Ejemplo n.º 1
0
lref_t lstructurep(lref_t st, lref_t expected_layout)
{
     if (!STRUCTUREP(st))
          return boolcons(false);

     if (!NULLP(expected_layout) && (expected_layout != STRUCTURE_LAYOUT(st)))
          return boolcons(false);

     return boolcons(true);
}
Ejemplo n.º 2
0
Archivo: io.c Proyecto: mschaef/vcsh
lref_t linput_portp(lref_t obj)
{
     if (PORTP(obj) && PORT_INPUTP(obj))
          return obj;

     return boolcons(false);
}
Ejemplo n.º 3
0
Archivo: io.c Proyecto: mschaef/vcsh
lref_t loutput_portp(lref_t obj)
{
     if (PORTP(obj) && PORT_OUTPUTP(obj))
          return obj;

     return boolcons(false);
}
Ejemplo n.º 4
0
lref_t lport_translate_mode(lref_t port)
{
     if (!TEXT_PORTP(port))
          vmerror_wrong_type_n(1, port);

     return boolcons(PORT_TEXT_INFO(port)->translate);
}
Ejemplo n.º 5
0
Archivo: io.c Proyecto: mschaef/vcsh
lref_t lbinary_portp(lref_t obj)
{
     if (BINARY_PORTP(obj))
          return obj;

     return boolcons(false);
}
Ejemplo n.º 6
0
Archivo: io.c Proyecto: mschaef/vcsh
lref_t lport_openp(lref_t obj)
{
     if (!PORTP(obj))
          vmerror_wrong_type_n(1, obj);

     return boolcons(!PORT_CLOSEDP(obj));
}
Ejemplo n.º 7
0
Archivo: io.c Proyecto: mschaef/vcsh
lref_t leof_objectp(lref_t obj)
{
     if (EOFP(obj))
          return obj;

     return boolcons(false);
}
Ejemplo n.º 8
0
lref_t lifoplog_enable(lref_t enablep)
{
     lref_t prev = boolcons(CURRENT_TIB()->foplog_enable);

     CURRENT_TIB()->foplog_enable = TRUEP(enablep);

     return prev;
}
Ejemplo n.º 9
0
lref_t lset_interrupt_mask(lref_t new_mask)
{
     bool previous_mask = interp.intr_masked;

     interp.intr_masked = TRUEP(new_mask);

     return boolcons(previous_mask);
}
Ejemplo n.º 10
0
lref_t lfresh_line(lref_t port)
{
     if (NULLP(port))
          port = CURRENT_OUTPUT_PORT();

     if (!TEXT_PORTP(port))
          vmerror_wrong_type_n(1, port);

     if (PORT_INPUTP(port))
          vmerror_unsupported(_T("cannot fresh-line to input ports"));

     if ((PORT_TEXT_INFO(port)->col != 0) && !PORT_TEXT_INFO(port)->needs_lf) {
          lnewline(port);
          return boolcons(true);
     }

     return boolcons(false);
}
Ejemplo n.º 11
0
lref_t lrich_write(lref_t obj, lref_t machine_readable, lref_t port)
{
     if (NULLP(port))
          port = CURRENT_OUTPUT_PORT();

     if (!PORTP(port))
          vmerror_wrong_type_n(3, port);

     if (PORT_INPUTP(port))
          vmerror_unsupported(_T("cannot rich-write to input ports"));

     if (PORT_CLASS(port)->rich_write == NULL)
          return boolcons(false);

     if (PORT_CLASS(port)->rich_write(port, obj, TRUEP(machine_readable)))
          return port;

     return boolcons(false);
}
Ejemplo n.º 12
0
lref_t lport_set_translate_mode(lref_t port, lref_t mode)
{
     if (!TEXT_PORTP(port))
          vmerror_wrong_type_n(1, port);

     if (!BOOLP(mode))
          vmerror_wrong_type_n(2, mode);

     lflush_port(port);

     bool old_translate_mode = PORT_TEXT_INFO(port)->translate;

     PORT_TEXT_INFO(port)->translate = TRUEP(mode);

     return boolcons(old_translate_mode);
}
Ejemplo n.º 13
0
Archivo: fasl.c Proyecto: mschaef/vcsh
static lref_t find_package(lref_t name)
{
    _TCHAR *n = get_c_string(name);

    for (lref_t l = interp.fasl_package_list; CONSP(l); l = CDR(l))
    {
        lref_t p = CAR(l);

        if (!PACKAGEP(p))
            panic("damaged package list");

        if (_tcscmp(n, get_c_string(p->as.package.name)) == 0)
            return p;
    }

    return boolcons(false);
}
Ejemplo n.º 14
0
lref_t lset_stack_limit(lref_t amount)
{
     size_t new_size_limit = 0;
     if (!NULLP(amount) && !FALSEP(amount))
          new_size_limit = get_c_long(amount);

     void *new_limit_obj = sys_set_stack_limit(new_size_limit);

     if (!new_size_limit)
     {
          dscwritef(DF_SHOW_GC, ("stack limit disabled!"));

          return boolcons(false);
     }

     dscwritef(DF_SHOW_GC, ("stack_size = ~cd bytes, [~c&,~c&]\n", new_size_limit, new_limit_obj, sys_get_stack_start()));

     return fixcons(new_size_limit);
}
Ejemplo n.º 15
0
Archivo: fasl.c Proyecto: mschaef/vcsh
static void fast_read(lref_t reader, lref_t * retval, bool allow_loader_ops /* = false */ )
{
    lref_t *fasl_table_entry = NULL;

    *retval = NIL;

    if (!FASL_READER_P(reader))
        vmerror_wrong_type_n(1, reader);

    assert(NULLP(FASL_READER_STREAM(reader)->table) || VECTORP(FASL_READER_STREAM(reader)->table));

    /* The core of this function is wrapped in a giant while loop to remove
     * tail recursive calls. Some opcodes don't directly return anything:
     * they just tail recursively read the next opcode after performing their
     * action via side effect. */
    bool current_read_complete = false;
    while (!current_read_complete)
    {
        /*  Assume we're going to complete the read unless we find out otherwise.. */
        current_read_complete = true;

        size_t opcode_location = PORT_BYTES_READ(FASL_READER_PORT(reader));

        enum fasl_opcode_t opcode = fast_read_opcode(reader);
        fixnum_t index = 0;
        lref_t name;

        if (DEBUG_FLAG(DF_FASL_SHOW_OPCODES))
        {
            const _TCHAR *opcode_name = fasl_opcode_name(opcode);

            dscwritef(DF_FASL_SHOW_OPCODES,
                      (_T("; DEBUG: fasl-opcode@~cx :~cS\n"),
                       opcode_location, opcode_name ? opcode_name : _T("<INVALID>")));
        }

        switch (opcode)
        {
        case FASL_OP_NIL:
            *retval = NIL;
            break;

        case FASL_OP_TRUE:
            *retval = boolcons(true);
            break;

        case FASL_OP_FALSE:
            *retval = boolcons(false);
            break;

        case FASL_OP_CHARACTER:
            fast_read_character(reader, retval);
            break;

        case FASL_OP_LIST:
            fast_read_list(reader, false, retval);
            break;

        case FASL_OP_LISTD:
            fast_read_list(reader, true, retval);
            break;

        case FASL_OP_FIX8:
            fast_read_fixnum_int8(reader, retval);
            break;

        case FASL_OP_FIX16:
            fast_read_fixnum_int16(reader, retval);
            break;

        case FASL_OP_FIX32:
            fast_read_fixnum_int32(reader, retval);
            break;

        case FASL_OP_FIX64:
            fast_read_fixnum_int64(reader, retval);
            break;

        case FASL_OP_FLOAT:
            fast_read_flonum(reader, false, retval);
            break;

        case FASL_OP_COMPLEX:
            fast_read_flonum(reader, true, retval);
            break;

        case FASL_OP_STRING:
            fast_read_string(reader, retval);
            break;

        case FASL_OP_PACKAGE:
            fast_read_package(reader, retval);
            break;

        case FASL_OP_VECTOR:
            fast_read_vector(reader, retval);
            break;

        case FASL_OP_HASH:
            fast_read_hash(reader, retval);
            break;

        case FASL_OP_CLOSURE:
            fast_read_closure(reader, retval);
            break;

        case FASL_OP_MACRO:
            fast_read_macro(reader, retval);
            break;

        case FASL_OP_SYMBOL:
            fast_read_symbol(reader, retval);
            break;

        case FASL_OP_SUBR:
            fast_read_subr(reader, retval);
            break;

        case FASL_OP_STRUCTURE:
            fast_read_structure(reader, retval);
            break;

        case FASL_OP_STRUCTURE_LAYOUT:
            fast_read_structure_layout(reader, retval);
            break;

        case FASL_OP_FAST_OP_0:
            fast_read_fast_op(0, false, reader, retval);
            break;

        case FASL_OP_FAST_OP_1:
            fast_read_fast_op(1, false, reader, retval);
            break;

        case FASL_OP_FAST_OP_2:
            fast_read_fast_op(2, false, reader, retval);
            break;

        case FASL_OP_FAST_OP_0N:
            fast_read_fast_op(0, true, reader, retval);
            break;

        case FASL_OP_FAST_OP_1N:
            fast_read_fast_op(1, true, reader, retval);
            break;

        case FASL_OP_FAST_OP_2N:
            fast_read_fast_op(2, true, reader, retval);
            break;

        case FASL_OP_NOP_1:
        case FASL_OP_NOP_2:
        case FASL_OP_NOP_3:
            current_read_complete = false;
            break;

        case FASL_OP_COMMENT_1:
        case FASL_OP_COMMENT_2:
            fast_read_to_newline(reader);
            current_read_complete = false;
            break;

        case FASL_OP_RESET_READER_DEFS:
            FASL_READER_STREAM(reader)->table = NIL;
            current_read_complete = false;
            break;

        case FASL_OP_READER_DEFINITION:
            index = fast_read_table_index(reader);

            fasl_table_entry = &(FASL_READER_STREAM(reader)->table->as.vector.data[index]);

            fast_read(reader, fasl_table_entry, allow_loader_ops);

            /* This should throw if the FASL table was resized
             * during the call to read. */
            assert(fasl_table_entry == &(FASL_READER_STREAM(reader)->table->as.vector.data[index]));

            *retval = *fasl_table_entry;
            break;

        case FASL_OP_READER_REFERENCE:
            index = fast_read_table_index(reader);

            *retval = FASL_READER_STREAM(reader)->table->as.vector.data[index];
            break;

        case FASL_OP_EOF:
            *retval = lmake_eof();
            break;

        case FASL_OP_LOADER_DEFINEQ:
        case FASL_OP_LOADER_DEFINEA0:
            if (!allow_loader_ops)
                vmerror_fast_read(_T("loader definitions not allowed outside loader"), reader, NIL);

            fast_read_loader_definition(reader, opcode);
            current_read_complete = false;
            break;

        case FASL_OP_LOADER_APPLY0:
        case FASL_OP_LOADER_APPLYN:
            if (!allow_loader_ops)
                vmerror_fast_read(_T("loader function applications not allowed outside loader"), reader, NIL);

            fast_read_loader_application(reader, opcode);
            break;

        case FASL_OP_BEGIN_LOAD_UNIT:
            if (!allow_loader_ops)
                vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL);

            fast_read(reader, &name, allow_loader_ops);

            dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL entering unit ~s\n", name));
            break;

        case FASL_OP_END_LOAD_UNIT:
            if (!allow_loader_ops)
                vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL);

            fast_read(reader, &name, allow_loader_ops);

            dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL leaving unit ~s\n", name));
            break;

        case FASL_OP_LOADER_PUSH:
            fast_loader_stack_push(reader, FASL_READER_STREAM(reader)->accum);
            break;

        case FASL_OP_LOADER_DROP:
            fast_loader_stack_pop(reader);
            break;

        default:
            vmerror_fast_read("invalid opcode", reader, fixcons(opcode));
        }
    }
}
Ejemplo n.º 16
0
Archivo: io.c Proyecto: mschaef/vcsh
lref_t lportp(lref_t obj)
{
     return boolcons(PORTP(obj));
}
Ejemplo n.º 17
0
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;
}