static void validate_structure_layout(size_t slots, lref_t layout) { if (!CONSP(layout)) vmerror_wrong_type_n(2, layout); size_t len = (size_t) get_c_long(llength(layout)); if (len != 2) vmerror_arg_out_of_range(layout, _T("bad structure layout, length<>2")); lref_t slot_layout = CAR(CDR(layout)); if (get_c_long(llength(slot_layout)) != (long) slots) vmerror_arg_out_of_range(lcons(slot_layout, fixcons(slots)), _T("bad structure layout, wrong number of slots")); for (; CONSP(slot_layout); slot_layout = CDR(slot_layout)) { if (!CONSP(CAR(slot_layout))) vmerror_arg_out_of_range(lcons(slot_layout, layout), _T("bad structure layout, bad slot layout")); if (!SYMBOLP(CAR(CAR(slot_layout)))) vmerror_arg_out_of_range(layout, _T("bad structure layout, missing slot name")); } }
lref_t lenvlookup(lref_t var, lref_t env) { lref_t frame; for (frame = env; CONSP(frame); frame = CDR(frame)) { lref_t tmp = CAR(frame); if (!CONSP(tmp)) panic("damaged frame"); lref_t al, fl; for (fl = CAR(tmp), al = CDR(tmp); CONSP(fl); fl = CDR(fl), al = CDR(al)) { if (!CONSP(al)) vmerror_arg_out_of_range(NIL, _T("too few arguments")); if (EQ(CAR(fl), var)) return al; } if (SYMBOLP(fl) && EQ(fl, var)) return lcons(al, NIL); } if (!NULLP(frame)) panic("damaged env"); return NIL; }
void lenvlookup_set_by_index(fixnum_t frame_index, fixnum_t var_index, lref_t env, lref_t val) { lref_t binding_cell = binding_cell_by_index(frame_index, var_index, env); if (NULLP(binding_cell)) { vmerror_arg_out_of_range(NIL, _T("too few arguments (no binding cell)")); } SET_CAR(binding_cell, val); }
lref_t lenvlookup_by_index(fixnum_t frame_index, fixnum_t var_index, lref_t env) { lref_t binding_cell = binding_cell_by_index(frame_index, var_index, env); if (NULLP(binding_cell)) { vmerror_arg_out_of_range(NIL, _T("too few arguments")); } return CAR(binding_cell); }
static size_t get_trap_id(lref_t trap_id) { if (!FIXNUMP(trap_id)) vmerror_wrong_type_n(1, trap_id); size_t id = (size_t)FIXNM(trap_id); if (id > TRAP_LAST) vmerror_arg_out_of_range(trap_id, _T("[0,TRAP_LAST]")); return id; }
lref_t lread_binary_string(lref_t l, lref_t port) { _TCHAR buf[STACK_STRBUF_LEN]; if (!BINARY_PORTP(port)) vmerror_wrong_type_n(2, port); if (!NUMBERP(l)) vmerror_wrong_type_n(1, l); fixnum_t remaining_length = get_c_fixnum(l); if (remaining_length <= 0) vmerror_arg_out_of_range(l, _T(">0")); lref_t new_str = strcons(); size_t total_read = 0; while (remaining_length > 0) { fixnum_t to_read = remaining_length; if (to_read > STACK_STRBUF_LEN) to_read = STACK_STRBUF_LEN; size_t actual_read = read_bytes(port, buf, (size_t)(remaining_length * sizeof(_TCHAR))); if (actual_read <= 0) break; string_appendd(new_str, buf, actual_read); remaining_length -= actual_read; total_read += actual_read; } if (total_read == 0) return lmake_eof(); return new_str; }
lref_t lapply(size_t argc, lref_t argv[]) { size_t fn_argc = 0; lref_t fn_argv[ARG_BUF_LEN]; lref_t fn = (argc > 0) ? argv[0] : NIL; if (!PROCEDUREP(fn)) vmerror_wrong_type_n(1, fn); for (size_t ii = 1; ii < argc - 1; ii++) { if (fn_argc >= ARG_BUF_LEN) break; fn_argv[fn_argc] = argv[ii]; fn_argc++; } lref_t args = (argc > 1) ? argv[argc - 1] : NIL; while (CONSP(args)) { if (fn_argc >= ARG_BUF_LEN) break; fn_argv[fn_argc] = CAR(args); fn_argc++; args = CDR(args); } if (fn_argc >= ARG_BUF_LEN) vmerror_unsupported(_T("too many actual arguments in call to apply")); if (!NULLP(args)) vmerror_arg_out_of_range(args, _T("bad formal argument list")); return apply1(fn, fn_argc, fn_argv); }
static lref_t execute_fast_op(lref_t fop, lref_t env) { lref_t retval = NIL; lref_t sym; lref_t binding; lref_t fn; lref_t args; size_t argc; lref_t argv[ARG_BUF_LEN]; lref_t after; lref_t tag; lref_t cell; lref_t escape_retval; jmp_buf *jmpbuf; STACK_CHECK(&fop); _process_interrupts(); fstack_enter_eval_frame(&fop, fop, env); while(!NULLP(fop)) { switch(fop->header.opcode) { case FOP_LITERAL: retval = fop->as.fast_op.arg1; fop = fop->as.fast_op.next; break; case FOP_GLOBAL_REF: sym = fop->as.fast_op.arg1; binding = SYMBOL_VCELL(sym); if (UNBOUND_MARKER_P(binding)) vmerror_unbound(sym); retval = binding; fop = fop->as.fast_op.next; break; case FOP_GLOBAL_SET: sym = fop->as.fast_op.arg1; binding = SYMBOL_VCELL(sym); if (UNBOUND_MARKER_P(binding)) vmerror_unbound(sym); SET_SYMBOL_VCELL(sym, retval); fop = fop->as.fast_op.next; break; case FOP_APPLY_GLOBAL: sym = fop->as.fast_op.arg1; fn = SYMBOL_VCELL(sym); if (UNBOUND_MARKER_P(fn)) vmerror_unbound(sym); argc = 0; args = fop->as.fast_op.arg2; while (CONSP(args)) { if (argc >= ARG_BUF_LEN) { vmerror_unsupported(_T("too many actual arguments")); break; } argv[argc] = execute_fast_op(CAR(args), env); args = CDR(args); argc++; } if (!NULLP(args)) vmerror_arg_out_of_range(fop->as.fast_op.arg2, _T("bad formal argument list")); fop = apply(fn, argc, argv, &env, &retval); break; case FOP_APPLY: argc = 0; fn = execute_fast_op(fop->as.fast_op.arg1, env); args = fop->as.fast_op.arg2; while (CONSP(args)) { if (argc >= ARG_BUF_LEN) { vmerror_unsupported(_T("too many actual arguments")); break; } argv[argc] = execute_fast_op(CAR(args), env); args = CDR(args); argc++; } if (!NULLP(args)) vmerror_arg_out_of_range(fop->as.fast_op.arg2, _T("bad formal argument list")); fop = apply(fn, argc, argv, &env, &retval); break; case FOP_IF_TRUE: if (TRUEP(retval)) fop = fop->as.fast_op.arg1; else fop = fop->as.fast_op.arg2; break; case FOP_RETVAL: fop = fop->as.fast_op.next; break; case FOP_SEQUENCE: retval = execute_fast_op(fop->as.fast_op.arg1, env); fop = fop->as.fast_op.arg2; break; case FOP_THROW: tag = execute_fast_op(fop->as.fast_op.arg1, env); escape_retval = execute_fast_op(fop->as.fast_op.arg2, env); dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a, retval = ~a\n"), tag, escape_retval)); CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag); CURRENT_TIB()->escape_value = escape_retval; if (CURRENT_TIB()->escape_frame == NULL) { /* If we don't find a matching catch for the throw, we have a * problem and need to invoke a trap. */ vmtrap(TRAP_UNCAUGHT_THROW, (enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE), 2, tag, escape_retval); } unwind_stack_for_throw(); fop = fop->as.fast_op.next; break; case FOP_CATCH: tag = execute_fast_op(fop->as.fast_op.arg1, env); jmpbuf = fstack_enter_catch_frame(tag, CURRENT_TIB()->frame); dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp tag: ~a, frame: ~c&, jmpbuf: ~c&\n"), tag, CURRENT_TIB()->frame, jmpbuf)); if (setjmp(*jmpbuf) == 0) { retval = execute_fast_op(fop->as.fast_op.arg2, env); } else { dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch, retval = ~a\n"), CURRENT_TIB()->escape_value)); retval = CURRENT_TIB()->escape_value; CURRENT_TIB()->escape_value = NIL; } fstack_leave_frame(); fop = fop->as.fast_op.next; break; case FOP_WITH_UNWIND_FN: fstack_enter_unwind_frame(execute_fast_op(fop->as.fast_op.arg1, env)); retval = execute_fast_op(fop->as.fast_op.arg2, env); after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER]; fstack_leave_frame(); apply1(after, 0, NULL); fop = fop->as.fast_op.next; break; case FOP_CLOSURE: retval = lclosurecons(env, lcons(lcar(fop->as.fast_op.arg1), fop->as.fast_op.arg2), lcdr(fop->as.fast_op.arg1)); fop = fop->as.fast_op.next; break; case FOP_CAR: retval = lcar(retval); fop = fop->as.fast_op.next; break; case FOP_CDR: retval = lcdr(retval); fop = fop->as.fast_op.next; break; case FOP_NOT: retval = boolcons(!TRUEP(retval)); fop = fop->as.fast_op.next; break; case FOP_NULLP: retval = boolcons(NULLP(retval)); fop = fop->as.fast_op.next; break; case FOP_EQP: retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env), execute_fast_op(fop->as.fast_op.arg2, env))); fop = fop->as.fast_op.next; break; case FOP_GET_ENV: retval = env; fop = fop->as.fast_op.next; break; case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2); fop = fop->as.fast_op.next; break; case FOP_GET_FSP: retval = fixcons((fixnum_t)CURRENT_TIB()->fsp); fop = fop->as.fast_op.next; break; case FOP_GET_FRAME: retval = fixcons((fixnum_t)CURRENT_TIB()->frame); fop = fop->as.fast_op.next; break; case FOP_GET_HFRAMES: retval = CURRENT_TIB()->handler_frames; fop = fop->as.fast_op.next; break; case FOP_SET_HFRAMES: CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env); fop = fop->as.fast_op.next; break; case FOP_GLOBAL_PRESERVE_FRAME: sym = fop->as.fast_op.arg1; binding = SYMBOL_VCELL(sym); if (UNBOUND_MARKER_P(binding)) vmerror_unbound(sym); SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame)); retval = execute_fast_op(fop->as.fast_op.arg2, env); fop = fop->as.fast_op.next; break; case FOP_STACK_BOUNDARY: sym = execute_fast_op(fop->as.fast_op.arg1, env); fstack_enter_boundary_frame(sym); retval = execute_fast_op(fop->as.fast_op.arg2, env); fstack_leave_frame(); fop = fop->as.fast_op.next; break; case FOP_FAST_ENQUEUE_CELL: retval = execute_fast_op(fop->as.fast_op.arg2, env); cell = execute_fast_op(fop->as.fast_op.arg1, env); SET_CDR(CAR(retval), cell); SET_CAR(retval, cell); fop = fop->as.fast_op.next; break; case FOP_WHILE_TRUE: while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) { retval = execute_fast_op(fop->as.fast_op.arg2, env); } fop = fop->as.fast_op.next; break; case FOP_LOCAL_REF_BY_INDEX: retval = lenvlookup_by_index(FIXNM(fop->as.fast_op.arg1), FIXNM(fop->as.fast_op.arg2), env); fop = fop->as.fast_op.next; break; case FOP_LOCAL_REF_RESTARG: retval = lenvlookup_restarg_by_index(FIXNM(fop->as.fast_op.arg1), FIXNM(fop->as.fast_op.arg2), env); fop = fop->as.fast_op.next; break; case FOP_LOCAL_SET_BY_INDEX: lenvlookup_set_by_index(FIXNM(fop->as.fast_op.arg1), FIXNM(fop->as.fast_op.arg2), env, retval); fop = fop->as.fast_op.next; break; default: panic("Unsupported fast-op"); } } fstack_leave_frame(); return retval; }