コード例 #1
0
ファイル: print.c プロジェクト: SatoHiroki/julia
static int print_circle_prefix(ios_t *f, value_t v)
{
    value_t label;
    char buf[64];
    char *str;
    if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
        (value_t)HT_NOTFOUND) {
        if (!ismarked(v)) {
            //HPOS+=ios_printf(f, "#%ld#", numval(label));
            outc('#', f);
            str = uint2str(buf, sizeof(buf)-1, numval(label), 10);
            outs(str, f);
            outc('#', f);
            return 1;
        }
        //HPOS+=ios_printf(f, "#%ld=", numval(label));
        outc('#', f);
        str = uint2str(buf, sizeof(buf)-1, numval(label), 10);
        outs(str, f);
        outc('=', f);
    }
    if (ismanaged(v))
        unmark_cons(v);
    return 0;
}
コード例 #2
0
static cell_t *read_bytevector(secd_parser_t *p) {
    secd_t *secd = p->secd;
    assert(p->token == '(', "read_bytevector: '(' expected");
    cell_t *tmplist = SECD_NIL;
    cell_t *cur;
    size_t len = 0;
    while (lexnext(p) == TOK_NUM) {
        assert((0 <= p->numtok) && (p->numtok < 256),
                "read_bytevector: out of range");

        cell_t *newc = new_cons(secd, new_number(secd, p->numtok), SECD_NIL);
        if (not_nil(tmplist)) {
            cur->as.cons.cdr = share_cell(secd, newc);
            cur = newc;
        } else {
            tmplist = cur = newc;
        }
        ++len;
    }

    cell_t *bvect = new_bytevector_of_size(secd, len);
    assert_cell(bvect, "read_bytevector: failed to allocate");
    unsigned char *mem = (unsigned char *)strmem(bvect);

    cur = tmplist;
    size_t i;
    for (i = 0; i < len; ++i) {
        mem[i] = (unsigned char)numval(list_head(cur));
        cur = list_next(secd, cur);
    }

    free_cell(secd, tmplist);
    return bvect;
}
コード例 #3
0
/* machine printing, (write) */
void sexp_pprint(secd_t* secd, cell_t *port, const cell_t *cell) {
    switch (cell_type(cell)) {
      case CELL_UNDEF:  secd_pprintf(secd, port, "#?"); break;
      case CELL_INT:    secd_pprintf(secd, port, "%d", cell->as.num); break;
      case CELL_CHAR:
        if (isprint(cell->as.num))
            secd_pprintf(secd, port, "#\\%c", (char)cell->as.num);
        else
            secd_pprintf(secd, port, "#\\x%x", numval(cell));
        break;
      case CELL_OP:     sexp_print_opcode(secd, port, cell->as.op); break;
      case CELL_FUNC:   secd_pprintf(secd, port, "##func*%p", cell->as.ptr); break;
      case CELL_FRAME:  secd_pprintf(secd, port,
                                "##frame@%ld ", cell_index(secd, cell)); break;
      case CELL_KONT:   secd_pprintf(secd, port,
                                "##kont@%ld ", cell_index(secd, cell)); break;
      case CELL_CONS:   sexp_print_list(secd, port, cell); break;
      case CELL_ARRAY:  sexp_print_array(secd, port, cell); break;
      case CELL_STR:    secd_pprintf(secd, port, "\"%s\"", strval(cell) + cell->as.str.offset); break;
      case CELL_SYM:    secd_pprintf(secd, port, "%s", symname(cell)); break;
      case CELL_BYTES:  sexp_print_bytes(secd, port, strval(cell), mem_size(cell)); break;
      case CELL_ERROR:  secd_pprintf(secd, port, "#!\"%s\"", errmsg(cell)); break;
      case CELL_PORT:   sexp_pprint_port(secd, port, cell); break;
      case CELL_REF:    sexp_pprint(secd, port, cell->as.ref);  break;
      default: errorf("sexp_print: unknown cell type %d", (int)cell_type(cell));
    }
}
コード例 #4
0
ファイル: equal.c プロジェクト: LiaoPengyu/femtolisp
static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
                                  int eq)
{
    size_t la = vector_size(a);
    size_t lb = vector_size(b);
    size_t m, i;
    value_t d, xa, xb, ca, cb;

    // first try to prove them different with no recursion
    if (eq && (la!=lb)) return fixnum(1);
    m = la < lb ? la : lb;
    for (i = 0; i < m; i++) {
        xa = vector_elt(a,i);
        xb = vector_elt(b,i);
        if (leafp(xa) || leafp(xb)) {
            d = bounded_compare(xa, xb, 1, eq);
            if (d!=NIL && numval(d)!=0) return d;
        }
        else if (tag(xa) < tag(xb)) {
            return fixnum(-1);
        }
        else if (tag(xa) > tag(xb)) {
            return fixnum(1);
        }
    }

    ca = eq_class(table, a);
    cb = eq_class(table, b);
    if (ca!=NIL && ca==cb)
        return fixnum(0);

    eq_union(table, a, b, ca, cb);

    for (i = 0; i < m; i++) {
        xa = vector_elt(a,i);
        xb = vector_elt(b,i);
        if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {
            d = cyc_compare(xa, xb, table, eq);
            if (numval(d)!=0)
                return d;
        }
    }

    if (la < lb) return fixnum(-1);
    if (la > lb) return fixnum(1);
    return fixnum(0);
}
コード例 #5
0
ファイル: ast.c プロジェクト: ararslan/julia
JL_DLLEXPORT int jl_operator_precedence(char *sym)
{
    jl_ast_context_t *ctx = jl_ast_ctx_enter();
    fl_context_t *fl_ctx = &ctx->fl;
    int res = numval(fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "operator-precedence")), symbol(fl_ctx, sym)));
    jl_ast_ctx_leave(ctx);
    return res;
}
コード例 #6
0
ファイル: ast.c プロジェクト: YellowApple/julia-lite
jl_value_t *jl_parse_next(void)
{
    value_t c = fl_applyn(0, symbol_value(symbol("jl-parser-next")));
    if (c == FL_EOF)
        return NULL;
    if (iscons(c)) {
        if (cdr_(c) == FL_EOF)
            return NULL;
        value_t a = car_(c);
        if (isfixnum(a)) {
            jl_lineno = numval(a);
            //jl_printf(JL_STDERR, "  on line %d\n", jl_lineno);
            c = cdr_(c);
        }
    }
    // for error, get most recent line number
    if (iscons(c) && car_(c) == fl_error_sym)
        jl_lineno = numval(fl_applyn(0, symbol_value(symbol("jl-parser-current-lineno"))));
    return scm_to_julia(c,0);
}
コード例 #7
0
ファイル: builtins.c プロジェクト: LiaoPengyu/femtolisp
static double todouble(value_t a, char *fname)
{
    if (isfixnum(a))
        return (double)numval(a);
    if (iscprim(a)) {
        cprim_t *cp = (cprim_t*)ptr(a);
        numerictype_t nt = cp_numtype(cp);
        return conv_to_double(cp_data(cp), nt);
    }
    type_error(fname, "number", a);
}
コード例 #8
0
ファイル: parser.c プロジェクト: drcz/drczlang
void _write_se(SE *e) {
  char numbuf[23];
  if(e==NIL) {
      c_out("()");
      return;
    }
  switch(type(e)) {
    case NUM: sprintf(numbuf,"%d",numval(e));
              c_out(numbuf); break;
    case SYM: c_out(symval(e)); break;
    case CONS: c_out("("); write_cdr(e); break;
    }
}
コード例 #9
0
ファイル: ast.c プロジェクト: rpruim/julia
jl_value_t *jl_parse_next(int *plineno)
{
    value_t c = fl_applyn(0, symbol_value(symbol("jl-parser-next")));
    if (c == FL_F)
        return NULL;
    if (iscons(c)) {
        value_t a = car_(c);
        if (isfixnum(a)) {
            *plineno = numval(a);
            return scm_to_julia(cdr_(c));
        }
    }
    return scm_to_julia(c);
}
コード例 #10
0
ファイル: ast.c プロジェクト: RZEWa60/julia
jl_value_t *jl_parse_next()
{
    value_t c = fl_applyn(0, symbol_value(symbol("jl-parser-next")));
    if (c == FL_F)
        return NULL;
    if (iscons(c)) {
        value_t a = car_(c);
        if (isfixnum(a)) {
            jl_lineno = numval(a);
            //jl_printf(JL_STDERR, "  on line %d\n", jl_lineno);
            return scm_to_julia(cdr_(c));
        }
    }
    return scm_to_julia(c);
}
コード例 #11
0
ファイル: equal.c プロジェクト: LiaoPengyu/femtolisp
static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
{
    size_t la = vector_size(a);
    size_t lb = vector_size(b);
    size_t m, i;
    if (eq && (la!=lb)) return fixnum(1);
    m = la < lb ? la : lb;
    for (i = 0; i < m; i++) {
        value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i),
                                    bound-1, eq);
        if (d==NIL || numval(d)!=0) return d;
    }
    if (la < lb) return fixnum(-1);
    if (la > lb) return fixnum(1);
    return fixnum(0);
}
コード例 #12
0
nsresult txResultNumberComparator::createSortableValue(Expr* aExpr,
                                                       txIEvalContext* aContext,
                                                       txObject*& aResult) {
  nsAutoPtr<NumberValue> numval(new NumberValue);
  if (!numval) {
    return NS_ERROR_OUT_OF_MEMORY;
  }

  RefPtr<txAExprResult> exprRes;
  nsresult rv = aExpr->evaluate(aContext, getter_AddRefs(exprRes));
  NS_ENSURE_SUCCESS(rv, rv);

  numval->mVal = exprRes->numberValue();

  aResult = numval.forget();

  return NS_OK;
}
コード例 #13
0
ファイル: scm.c プロジェクト: denrusio/vak-opensource
void putatom (LISP p, FILE *fd)
{
	if (p == NIL) {
		fputs ("()", fd);
		return;
	}
	switch (mem[p].type) {
	case TSYMBOL:  fputs (symname (p), fd);                         break;
	case TBOOL:    fputs ("#t", fd);                                break;
	case TINTEGER: fprintf (fd, "%ld", numval (p));                 break;
	case TREAL:    fprintf (fd, "%#g", realval (p));                break;
	case TSTRING:  putstring (p, fd);                               break;
	case TVECTOR:  putvector (p, fd);                               break;
	case TCHAR:    putchr (charval (p), fd);                        break;
	case THARDW:   fprintf (fd, "<builtin-%lx>", (long) hardwval (p)); break;
	case TCLOSURE: fprintf (fd, "<closure-%lx>", p);                break;
	default:       fputs ("<?>", fd);                               break;
	}
}
コード例 #14
0
ファイル: ast.c プロジェクト: ararslan/julia
value_t fl_julia_logmsg(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
{
    int kwargs_len = (int)nargs - 6;
    if (nargs < 6 || kwargs_len % 2 != 0) {
        lerror(fl_ctx, fl_ctx->ArgError, "julia-logmsg: bad argument list - expected "
               "level (symbol) group (symbol) id file line msg . kwargs");
    }
    value_t arg_level = args[0];
    value_t arg_group = args[1];
    value_t arg_id    = args[2];
    value_t arg_file  = args[3];
    value_t arg_line  = args[4];
    value_t arg_msg   = args[5];
    value_t *arg_kwargs = args + 6;
    if (!isfixnum(arg_level) || !issymbol(arg_group) || !issymbol(arg_id) ||
        !issymbol(arg_file) || !isfixnum(arg_line) || !fl_isstring(fl_ctx, arg_msg)) {
        lerror(fl_ctx, fl_ctx->ArgError,
               "julia-logmsg: Unexpected type in argument list");
    }

    // Abuse scm_to_julia here to convert arguments.  This is meant for `Expr`s
    // but should be good enough provided we're only passing simple numbers,
    // symbols and strings.
    jl_value_t *group=NULL, *id=NULL, *file=NULL, *line=NULL, *msg=NULL;
    jl_array_t *kwargs=NULL;
    JL_GC_PUSH6(&group, &id, &file, &line, &msg, &kwargs);
    group = scm_to_julia(fl_ctx, arg_group, NULL);
    id    = scm_to_julia(fl_ctx, arg_id, NULL);
    file  = scm_to_julia(fl_ctx, arg_file, NULL);
    line  = scm_to_julia(fl_ctx, arg_line, NULL);
    msg   = scm_to_julia(fl_ctx, arg_msg, NULL);
    kwargs = jl_alloc_vec_any(kwargs_len);
    for (int i = 0; i < kwargs_len; ++i) {
        jl_array_ptr_set(kwargs, i, scm_to_julia(fl_ctx, arg_kwargs[i], NULL));
    }
    jl_log(numval(arg_level), NULL, group, id, file, line, (jl_value_t*)kwargs, msg);
    JL_GC_POP();
    return fl_ctx->T;
}
コード例 #15
0
ファイル: printf.c プロジェクト: ChunHungLiu/bos
static int
fmt_handling(uint32_t value, const char *fmt, int fmtlen, char *buf, int buflen)
{
	const char *t;
	uint8_t flen = 0;
	int fmttype = fmt[fmtlen-1];
	int upper = 1;

	if (fmttype - 'a' > 0) 
		upper = 0;

	t = itohex(value, buf, buflen+1, upper);
	if (*fmt != '0') { /* no leading zero char */
		return t - buf;
	}
	t = buf;
	if (is_num(fmt[1])) {
		flen = numval(fmt[1]);
		if (flen < buflen) {
			t+= buflen - flen;
		}
	}
	return t - buf;
}
コード例 #16
0
ファイル: ast.c プロジェクト: ararslan/julia
static jl_value_t *scm_to_julia_(fl_context_t *fl_ctx, value_t e, jl_module_t *mod)
{
    if (fl_isnumber(fl_ctx, e)) {
        int64_t i64;
        if (isfixnum(e)) {
            i64 = numval(e);
        }
        else {
            assert(iscprim(e));
            cprim_t *cp = (cprim_t*)ptr(e);
            numerictype_t nt = cp_numtype(cp);
            switch (nt) {
            case T_DOUBLE:
                return (jl_value_t*)jl_box_float64(*(double*)cp_data(cp));
            case T_FLOAT:
                return (jl_value_t*)jl_box_float32(*(float*)cp_data(cp));
            case T_UINT8:
                return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data(cp));
            case T_UINT16:
                return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data(cp));
            case T_UINT32:
                return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data(cp));
            case T_UINT64:
                return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data(cp));
            default:
                ;
            }
            i64 = conv_to_int64(cp_data(cp), nt);
        }
#ifdef _P64
        return (jl_value_t*)jl_box_int64(i64);
#else
        if (i64 > (int64_t)S32_MAX || i64 < (int64_t)S32_MIN)
            return (jl_value_t*)jl_box_int64(i64);
        else
            return (jl_value_t*)jl_box_int32((int32_t)i64);
#endif
    }
    if (issymbol(e)) {
        if (e == jl_ast_ctx(fl_ctx)->true_sym)
            return jl_true;
        else if (e == jl_ast_ctx(fl_ctx)->false_sym)
            return jl_false;
        return (jl_value_t*)scmsym_to_julia(fl_ctx, e);
    }
    if (fl_isstring(fl_ctx, e))
        return jl_pchar_to_string((char*)cvalue_data(e), cvalue_len(e));
    if (iscons(e) || e == fl_ctx->NIL) {
        value_t hd;
        jl_sym_t *sym;
        if (e == fl_ctx->NIL) {
            hd = e;
        }
        else {
            hd = car_(e);
            if (hd == jl_ast_ctx(fl_ctx)->ssavalue_sym)
                return jl_box_ssavalue(numval(car_(cdr_(e))));
            else if (hd == jl_ast_ctx(fl_ctx)->slot_sym)
                return jl_box_slotnumber(numval(car_(cdr_(e))));
            else if (hd == jl_ast_ctx(fl_ctx)->null_sym && llength(e) == 1)
                return jl_nothing;
        }
        if (issymbol(hd))
            sym = scmsym_to_julia(fl_ctx, hd);
        else
            sym = list_sym;
        size_t n = llength(e)-1;
        if (issymbol(hd))
            e = cdr_(e);
        else
            n++;
        // nodes with special representations
        jl_value_t *ex = NULL, *temp = NULL;
        if (sym == line_sym && (n == 1 || n == 2)) {
            jl_value_t *linenum = scm_to_julia_(fl_ctx, car_(e), mod);
            jl_value_t *file = jl_nothing;
            JL_GC_PUSH2(&linenum, &file);
            if (n == 2)
                file = scm_to_julia_(fl_ctx, car_(cdr_(e)), mod);
            temp = jl_new_struct(jl_linenumbernode_type, linenum, file);
            JL_GC_POP();
            return temp;
        }
        JL_GC_PUSH1(&ex);
        if (sym == label_sym) {
            ex = scm_to_julia_(fl_ctx, car_(e), mod);
            temp = jl_new_struct(jl_labelnode_type, ex);
        }
        else if (sym == goto_sym) {
            ex = scm_to_julia_(fl_ctx, car_(e), mod);
            temp = jl_new_struct(jl_gotonode_type, ex);
        }
        else if (sym == newvar_sym) {
            ex = scm_to_julia_(fl_ctx, car_(e), mod);
            temp = jl_new_struct(jl_newvarnode_type, ex);
        }
        else if (sym == globalref_sym) {
            ex = scm_to_julia_(fl_ctx, car_(e), mod);
            temp = scm_to_julia_(fl_ctx, car_(cdr_(e)), mod);
            assert(jl_is_module(ex));
            assert(jl_is_symbol(temp));
            temp = jl_module_globalref((jl_module_t*)ex, (jl_sym_t*)temp);
        }
        else if (sym == top_sym) {
            assert(mod && "top should not be generated by the parser");
            ex = scm_to_julia_(fl_ctx, car_(e), mod);
            assert(jl_is_symbol(ex));
            temp = jl_module_globalref(jl_base_relative_to(mod), (jl_sym_t*)ex);
        }
        else if (sym == core_sym) {
            ex = scm_to_julia_(fl_ctx, car_(e), mod);
            assert(jl_is_symbol(ex));
            temp = jl_module_globalref(jl_core_module, (jl_sym_t*)ex);
        }
        else if (sym == inert_sym || (sym == quote_sym && (!iscons(car_(e))))) {
            ex = scm_to_julia_(fl_ctx, car_(e), mod);
            temp = jl_new_struct(jl_quotenode_type, ex);
        }
        if (temp) {
            JL_GC_POP();
            return temp;
        }
        ex = (jl_value_t*)jl_exprn(sym, n);
        size_t i;
        for (i = 0; i < n; i++) {
            assert(iscons(e));
            jl_array_ptr_set(((jl_expr_t*)ex)->args, i, scm_to_julia_(fl_ctx, car_(e), mod));
            e = cdr_(e);
        }
        if (sym == lambda_sym)
            ex = (jl_value_t*)jl_new_code_info_from_ast((jl_expr_t*)ex);
        JL_GC_POP();
        if (sym == list_sym)
            return (jl_value_t*)((jl_expr_t*)ex)->args;
        return (jl_value_t*)ex;
    }
    if (iscprim(e) && cp_class((cprim_t*)ptr(e)) == fl_ctx->wchartype) {
        uint32_t c, u = *(uint32_t*)cp_data((cprim_t*)ptr(e));
        if (u < 0x80) {
            c = u << 24;
        } else {
            c = ((u << 0) & 0x0000003f) | ((u << 2) & 0x00003f00) |
                ((u << 4) & 0x003f0000) | ((u << 6) & 0x3f000000);
            c = u < 0x00000800 ? (c << 16) | 0xc0800000 :
                u < 0x00010000 ? (c <<  8) | 0xe0808000 :
                                 (c <<  0) | 0xf0808080 ;
        }
        return jl_box_char(c);
    }
    if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jl_ast_ctx(fl_ctx)->jvtype) {
        return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
    }
    jl_error("malformed tree");
}
コード例 #17
0
ファイル: print.c プロジェクト: SatoHiroki/julia
void fl_print_child(ios_t *f, value_t v)
{
    char *name, *str;
    char buf[64];
    if (print_level >= 0 && P_LEVEL >= print_level &&
        (iscons(v) || isvector(v) || isclosure(v))) {
        outc('#', f);
        return;
    }
    P_LEVEL++;

    switch (tag(v)) {
    case TAG_NUM :
    case TAG_NUM1: //HPOS+=ios_printf(f, "%ld", numval(v)); break;
        str = uint2str(&buf[1], sizeof(buf)-1, labs(numval(v)), 10);
        if (numval(v)<0)
            *(--str) = '-';
        outs(str, f);
        break;
    case TAG_SYM:
        name = symbol_name(v);
        if (print_princ)
            outs(name, f);
        else if (ismanaged(v)) {
            outsn("#:", f, 2);
            outs(name, f);
        }
        else
            print_symbol_name(f, name);
        break;
    case TAG_FUNCTION:
        if (v == FL_T) {
            outsn("#t", f, 2);
        }
        else if (v == FL_F) {
            outsn("#f", f, 2);
        }
        else if (v == FL_NIL) {
            outsn("()", f, 2);
        }
        else if (v == FL_EOF) {
            outsn("#<eof>", f, 6);
        }
        else if (isbuiltin(v)) {
            if (!print_princ)
                outsn("#.", f, 2);
            outs(builtin_names[uintval(v)], f);
        }
        else {
            assert(isclosure(v));
            if (!print_princ) {
                if (print_circle_prefix(f, v)) break;
                function_t *fn = (function_t*)ptr(v);
                outs("#fn(", f);
                char *data = cvalue_data(fn->bcode);
                size_t i, sz = cvalue_len(fn->bcode);
                for(i=0; i < sz; i++) data[i] += 48;
                fl_print_child(f, fn->bcode);
                for(i=0; i < sz; i++) data[i] -= 48;
                outc(' ', f);
                fl_print_child(f, fn->vals);
                if (fn->env != NIL) {
                    outc(' ', f);
                    fl_print_child(f, fn->env);
                }
                if (fn->name != LAMBDA) {
                    outc(' ', f);
                    fl_print_child(f, fn->name);
                }
                outc(')', f);
            }
            else {
                outs("#<function>", f);
            }
        }
        break;
    case TAG_CVALUE:
    case TAG_CPRIM:
        if (v == UNBOUND) { outs("#<undefined>", f); break; }
    case TAG_VECTOR:
    case TAG_CONS:
        if (print_circle_prefix(f, v)) break;
        if (isvector(v)) {
            outc('[', f);
            int newindent = HPOS, est;
            int i, sz = vector_size(v);
            for(i=0; i < sz; i++) {
                if (print_length >= 0 && i >= print_length && i < sz-1) {
                    outsn("...", f, 3);
                    break;
                }
                fl_print_child(f, vector_elt(v,i));
                if (i < sz-1) {
                    if (!print_pretty) {
                        outc(' ', f);
                    }
                    else {
                        est = lengthestimate(vector_elt(v,i+1));
                        if (HPOS > SCR_WIDTH-4 ||
                            (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
                            (HPOS > SCR_WIDTH/2 &&
                             !smallp(vector_elt(v,i+1)) &&
                             !tinyp(vector_elt(v,i))))
                            newindent = outindent(newindent, f);
                        else
                            outc(' ', f);
                    }
                }
            }
            outc(']', f);
            break;
        }
        if (iscvalue(v) || iscprim(v))
            cvalue_print(f, v);
        else
            print_pair(f, v);
        break;
    }
    P_LEVEL--;
}
コード例 #18
0
ファイル: main.c プロジェクト: drcz/drczlang
int main(int ac, char **av) {
  FILE *codefile=stdin;
  int  mempoolsize=1024*1024;
  int c;
  SE *prog,*result;

  silent=0;

  if(ac<2) {
    versioninfo(stderr,av[0]);
    helpinfo(stderr,av[0]);
    return 1;
  }

  while((c=getopt(ac,av,"svch?p:"))!=-1) {
    switch(c) {

    case 's':
      silent=1;
      break;

    case 'c':
      conscellinfo(stdout,av[0]);
      return 0;

    case 'v':
      versioninfo(stdout,av[0]);
      return 0;

    case '?':
    case 'h':
      versioninfo(stdout,av[0]);
      helpinfo(stdout,av[0]);
      return 0;

    case 'p':
      mempoolsize=atoi(optarg);
      break;

    default:      
      // versioninfo(stderr,av[0]);
      // helpinfo(stdout,av[0]);
      return 1;      
    }
  }

  if((codefile=fopen(av[optind],"r"))) {
    if(silent!=1) printf("Initializing mempool (%d cells)...\n",mempoolsize);
    init_mempool(mempoolsize);

    if(silent!=1) printf("Loading code from %s...\n",av[optind]);
    prog=read_se(codefile);

    if(silent!=1) printf("Allocating %d env-slot(s) for environments...\n",numval(car(prog)));
    Dreg=(SE **)malloc(sizeof(SE *)*numval(car(prog)));

    Rreg=NIL;
    Creg=NIL;

    C_push(cdr(prog));

    if(silent!=1) printf("Running the machine.\n");
    result=run();

    if(silent!=1) printf("Result: ");
    write_se(result,stdout);
    printf("\n"); // ?

    if(silent!=1) printf("\nAuf wiedersehen!\n");
    return 0;

  } else fprintf(stderr,"Could not open file %s.\n",av[optind]);

  return 1;
}
コード例 #19
0
ファイル: equal.c プロジェクト: LiaoPengyu/femtolisp
// strange comparisons are resolved arbitrarily but consistently.
// ordering: number < cprim < function < vector < cvalue < symbol < cons
static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
{
    value_t d;

 compare_top:
    if (a == b) return fixnum(0);
    if (bound <= 0)
        return NIL;
    int taga = tag(a);
    int tagb = cmptag(b);
    int c;
    switch (taga) {
    case TAG_NUM :
    case TAG_NUM1:
        if (isfixnum(b)) {
            return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
        }
        if (iscprim(b)) {
            if (cp_class((cprim_t*)ptr(b)) == wchartype)
                return fixnum(1);
            return fixnum(numeric_compare(a, b, eq, 1, NULL));
        }
        return fixnum(-1);
    case TAG_SYM:
        if (eq) return fixnum(1);
        if (tagb < TAG_SYM) return fixnum(1);
        if (tagb > TAG_SYM) return fixnum(-1);
        return fixnum(strcmp(symbol_name(a), symbol_name(b)));
    case TAG_VECTOR:
        if (isvector(b))
            return bounded_vector_compare(a, b, bound, eq);
        break;
    case TAG_CPRIM:
        if (cp_class((cprim_t*)ptr(a)) == wchartype) {
            if (!iscprim(b) || cp_class((cprim_t*)ptr(b)) != wchartype)
                return fixnum(-1);
        }
        else if (iscprim(b) && cp_class((cprim_t*)ptr(b)) == wchartype) {
            return fixnum(1);
        }
        c = numeric_compare(a, b, eq, 1, NULL);
        if (c != 2)
            return fixnum(c);
        break;
    case TAG_CVALUE:
        if (iscvalue(b)) {
            if (cv_isPOD((cvalue_t*)ptr(a)) && cv_isPOD((cvalue_t*)ptr(b)))
                return cvalue_compare(a, b);
            return fixnum(1);
        }
        break;
    case TAG_FUNCTION:
        if (tagb == TAG_FUNCTION) {
            if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) {
                function_t *fa = (function_t*)ptr(a);
                function_t *fb = (function_t*)ptr(b);
                d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
                if (d==NIL || numval(d) != 0) return d;
                d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
                if (d==NIL || numval(d) != 0) return d;
                d = bounded_compare(fa->env, fb->env, bound-1, eq);
                if (d==NIL || numval(d) != 0) return d;
                return fixnum(0);
            }
            return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
        }
        break;
    case TAG_CONS:
        if (tagb < TAG_CONS) return fixnum(1);
        d = bounded_compare(car_(a), car_(b), bound-1, eq);
        if (d==NIL || numval(d) != 0) return d;
        a = cdr_(a); b = cdr_(b);
        bound--;
        goto compare_top;
    }
    return (taga < tagb) ? fixnum(-1) : fixnum(1);
}
コード例 #20
0
ファイル: equal.c プロジェクト: LiaoPengyu/femtolisp
int equal_lispvalue(value_t a, value_t b)
{
    if (eq_comparable(a, b))
        return (a==b);
    return (numval(compare_(a,b,1))==0);
}
コード例 #21
0
ファイル: read.c プロジェクト: GlenHertz/julia
// label is the backreference we'd like to fix up with this read
static value_t do_read_sexpr(value_t label)
{
    value_t v, sym, oldtokval, *head;
    value_t *pv;
    u_int32_t t;
    char c;

    t = peek();
    take();
    switch (t) {
    case TOK_CLOSE:
        lerror(ParseError, "read: unexpected ')'");
    case TOK_CLOSEB:
        lerror(ParseError, "read: unexpected ']'");
    case TOK_DOT:
        lerror(ParseError, "read: unexpected '.'");
    case TOK_SYM:
    case TOK_NUM:
        return tokval;
    case TOK_COMMA:
        head = &COMMA; goto listwith;
    case TOK_COMMAAT:
        head = &COMMAAT; goto listwith;
    case TOK_COMMADOT:
        head = &COMMADOT; goto listwith;
    case TOK_BQ:
        head = &BACKQUOTE; goto listwith;
    case TOK_QUOTE:
        head = &QUOTE;
    listwith:
        v = cons_reserve(2);
        car_(v) = *head;
        cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
        car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
        PUSH(v);
        if (label != UNBOUND)
            ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
        v = do_read_sexpr(UNBOUND);
        car_(cdr_(Stack[SP-1])) = v;
        return POP();
    case TOK_SHARPQUOTE:
        // femtoLisp doesn't need symbol-function, so #' does nothing
        return do_read_sexpr(label);
    case TOK_OPEN:
        PUSH(NIL);
        read_list(&Stack[SP-1], label);
        return POP();
    case TOK_SHARPSYM:
        sym = tokval;
        if (sym == tsym || sym == Tsym)
            return FL_T;
        else if (sym == fsym || sym == Fsym)
            return FL_F;
        // constructor notation
        c = nextchar();
        if (c != '(') {
            take();
            lerrorf(ParseError, "read: expected argument list for %s",
                    symbol_name(tokval));
        }
        PUSH(NIL);
        read_list(&Stack[SP-1], UNBOUND);
        if (sym == vu8sym) {
            sym = arraysym;
            Stack[SP-1] = fl_cons(uint8sym, Stack[SP-1]);
        }
        else if (sym == fnsym) {
            sym = FUNCTION;
        }
        v = symbol_value(sym);
        if (v == UNBOUND)
            fl_raise(fl_list2(UnboundError, sym));
        return fl_apply(v, POP());
    case TOK_OPENB:
        return read_vector(label, TOK_CLOSEB);
    case TOK_SHARPOPEN:
        return read_vector(label, TOK_CLOSE);
    case TOK_SHARPDOT:
        // eval-when-read
        // evaluated expressions can refer to existing backreferences, but they
        // cannot see pending labels. in other words:
        // (... #2=#.#0# ... )    OK
        // (... #2=#.(#2#) ... )  DO NOT WANT
        sym = do_read_sexpr(UNBOUND);
        if (issymbol(sym)) {
            v = symbol_value(sym);
            if (v == UNBOUND)
                fl_raise(fl_list2(UnboundError, sym));
            return v;
        }
        return fl_toplevel_eval(sym);
    case TOK_LABEL:
        // create backreference label
        if (ptrhash_has(&readstate->backrefs, (void*)tokval))
            lerrorf(ParseError, "read: label %ld redefined", numval(tokval));
        oldtokval = tokval;
        v = do_read_sexpr(tokval);
        ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v);
        return v;
    case TOK_BACKREF:
        // look up backreference
        v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval);
        if (v == (value_t)HT_NOTFOUND)
            lerrorf(ParseError, "read: undefined label %ld", numval(tokval));
        return v;
    case TOK_GENSYM:
        pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
        if (*pv == (value_t)HT_NOTFOUND)
            *pv = fl_gensym(NULL, 0);
        return *pv;
    case TOK_DOUBLEQUOTE:
        return read_string();
    }
    return FL_UNSPECIFIED;
}
コード例 #22
0
ファイル: ast.c プロジェクト: YellowApple/julia-lite
static jl_value_t *scm_to_julia_(value_t e, int eo)
{
    if (fl_isnumber(e)) {
        int64_t i64;
        if (isfixnum(e)) {
            i64 = numval(e);
        }
        else {
            assert(iscprim(e));
            cprim_t *cp = (cprim_t*)ptr(e);
            numerictype_t nt = cp_numtype(cp);
            switch (nt) {
            case T_DOUBLE:
                return (jl_value_t*)jl_box_float64(*(double*)cp_data(cp));
            case T_FLOAT:
                return (jl_value_t*)jl_box_float32(*(float*)cp_data(cp));
            case T_UINT8:
                return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data(cp));
            case T_UINT16:
                return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data(cp));
            case T_UINT32:
                return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data(cp));
            case T_UINT64:
                return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data(cp));
            default:
                ;
            }
            i64 = conv_to_int64(cp_data(cp), nt);
        }
        if (
#ifdef _P64
            jl_compileropts.int_literals==32
#else
            jl_compileropts.int_literals!=64
#endif
            ) {
            if (i64 > (int64_t)S32_MAX || i64 < (int64_t)S32_MIN)
                return (jl_value_t*)jl_box_int64(i64);
            return (jl_value_t*)jl_box_int32((int32_t)i64);
        }
        else {
            return (jl_value_t*)jl_box_int64(i64);
        }
    }
    if (issymbol(e)) {
        if (e == true_sym)
            return jl_true;
        else if (e == false_sym)
            return jl_false;
        return (jl_value_t*)scmsym_to_julia(e);
    }
    if (fl_isstring(e)) {
        return jl_pchar_to_string((char*)cvalue_data(e), cvalue_len(e));
    }
    if (e == FL_F) {
        return jl_false;
    }
    if (e == FL_T) {
        return jl_true;
    }
    if (e == FL_NIL) {
        return (jl_value_t*)jl_null;
    }
    if (iscons(e)) {
        value_t hd = car_(e);
        if (issymbol(hd)) {
            jl_sym_t *sym = scmsym_to_julia(hd);
            /* tree node types:
               goto  gotoifnot  label  return
               lambda  call  =  quote
               null  top  method
               body  file new
               line  enter  leave
            */
            size_t n = llength(e)-1;
            size_t i;
            if (sym == null_sym && n == 0)
                return jl_nothing;
            if (sym == lambda_sym) {
                jl_expr_t *ex = jl_exprn(lambda_sym, n);
                e = cdr_(e);
                value_t largs = car_(e);
                jl_cellset(ex->args, 0, full_list(largs,eo));
                e = cdr_(e);
                
                value_t ee = car_(e);
                jl_array_t *vinf = jl_alloc_cell_1d(3);
                jl_cellset(vinf, 0, full_list(car_(ee),eo));
                ee = cdr_(ee);
                jl_cellset(vinf, 1, full_list_of_lists(car_(ee),eo));
                ee = cdr_(ee);
                jl_cellset(vinf, 2, full_list_of_lists(car_(ee),eo));
                assert(!iscons(cdr_(ee)));
                jl_cellset(ex->args, 1, vinf);
                e = cdr_(e);
                
                for(i=2; i < n; i++) {
                    assert(iscons(e));
                    jl_cellset(ex->args, i, scm_to_julia_(car_(e), eo));
                    e = cdr_(e);
                }
                return
                    (jl_value_t*)jl_new_lambda_info((jl_value_t*)ex, jl_null);
            }

            e = cdr_(e);
            if (!eo) {
                if (sym == line_sym && n==1) {
                    return jl_new_struct(jl_linenumbernode_type,
                                         scm_to_julia_(car_(e),0));
                }
                if (sym == label_sym) {
                    return jl_new_struct(jl_labelnode_type,
                                         scm_to_julia_(car_(e),0));
                }
                if (sym == goto_sym) {
                    return jl_new_struct(jl_gotonode_type,
                                         scm_to_julia_(car_(e),0));
                }
                if (sym == quote_sym) {
                    return jl_new_struct(jl_quotenode_type,
                                         scm_to_julia_(car_(e),0));
                }
                if (sym == top_sym) {
                    return jl_new_struct(jl_topnode_type,
                                         scm_to_julia_(car_(e),0));
                }
                if (sym == newvar_sym) {
                    return jl_new_struct(jl_newvarnode_type,
                                         scm_to_julia_(car_(e),0));
                }
            }
            jl_expr_t *ex = jl_exprn(sym, n);
            // allocate a fresh args array for empty exprs passed to macros
            if (eo && n == 0)
                ex->args = jl_alloc_cell_1d(0);
            for(i=0; i < n; i++) {
                assert(iscons(e));
                jl_cellset(ex->args, i, scm_to_julia_(car_(e),eo));
                e = cdr_(e);
            }
            return (jl_value_t*)ex;
        }
        else {
            jl_error("malformed tree");
        }
    }
    if (iscprim(e) && cp_class((cprim_t*)ptr(e))==wchartype) {
        jl_value_t *wc =
            jl_box32(jl_char_type, *(int32_t*)cp_data((cprim_t*)ptr(e)));
        return wc;
    }
    if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jvtype) {
        return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
    }
    jl_error("malformed tree");
    
    return (jl_value_t*)jl_null;
}
コード例 #23
0
ファイル: ast.c プロジェクト: YellowApple/julia-lite
DLLEXPORT int jl_operator_precedence(char *sym) {
     return numval(fl_applyn(1, symbol_value(symbol("operator-precedence")),
                             symbol(sym)));
}
コード例 #24
0
ファイル: ast.c プロジェクト: RZEWa60/julia
static jl_value_t *scm_to_julia_(value_t e)
{
    if (fl_isnumber(e)) {
        if (iscprim(e)) {
            numerictype_t nt = cp_numtype((cprim_t*)ptr(e));
            switch (nt) {
            case T_DOUBLE:
                return (jl_value_t*)jl_box_float64(*(double*)cp_data((cprim_t*)ptr(e)));
            case T_FLOAT:
                return (jl_value_t*)jl_box_float32(*(float*)cp_data((cprim_t*)ptr(e)));
            case T_INT64:
                return (jl_value_t*)jl_box_int64(*(int64_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT8:
                return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT16:
                return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT32:
                return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT64:
                return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data((cprim_t*)ptr(e)));
            default:
                ;
            }
        }
        if (isfixnum(e)) {
            int64_t ne = numval(e);
#ifdef __LP64__
            return (jl_value_t*)jl_box_int64(ne);
#else
            if (ne > S32_MAX || ne < S32_MIN)
                return (jl_value_t*)jl_box_int64(ne);
            return (jl_value_t*)jl_box_int32((int32_t)ne);
#endif
        }
        uint64_t n = toulong(e, "scm_to_julia");
#ifdef __LP64__
        return (jl_value_t*)jl_box_int64((int64_t)n);
#else
        if (n > S32_MAX)
            return (jl_value_t*)jl_box_int64((int64_t)n);
        return (jl_value_t*)jl_box_int32((int32_t)n);
#endif
    }
    if (issymbol(e)) {
        if (!fl_isgensym(e)) {
            char *sn = symbol_name(e);
            if (!strcmp(sn, "true"))
                return jl_true;
            else if (!strcmp(sn, "false"))
                return jl_false;
        }
        return (jl_value_t*)scmsym_to_julia(e);
    }
    if (fl_isstring(e)) {
        return jl_pchar_to_string(cvalue_data(e), cvalue_len(e));
    }
    if (e == FL_F) {
        return jl_false;
    }
    if (e == FL_T) {
        return jl_true;
    }
    if (e == FL_NIL) {
        return (jl_value_t*)jl_null;
    }
    if (iscons(e)) {
        value_t hd = car_(e);
        if (issymbol(hd)) {
            jl_sym_t *sym = scmsym_to_julia(hd);
            /* tree node types:
               goto  gotoifnot  label  return
               lambda  call  =  quote
               null  top  method
               body  file new
               line  enter  leave
            */
            size_t n = llength(e)-1;
            size_t i;
            if (sym == lambda_sym) {
                jl_expr_t *ex = jl_exprn(lambda_sym, n);
                e = cdr_(e);
                value_t largs = car_(e);
                jl_cellset(ex->args, 0, full_list(largs));
                e = cdr_(e);
                
                value_t ee = car_(e);
                jl_array_t *vinf = jl_alloc_cell_1d(3);
                jl_cellset(vinf, 0, full_list(car_(ee)));
                ee = cdr_(ee);
                jl_cellset(vinf, 1, full_list_of_lists(car_(ee)));
                ee = cdr_(ee);
                jl_cellset(vinf, 2, full_list_of_lists(car_(ee)));
                assert(!iscons(cdr_(ee)));
                jl_cellset(ex->args, 1, vinf);
                e = cdr_(e);
                
                for(i=2; i < n; i++) {
                    assert(iscons(e));
                    jl_cellset(ex->args, i, scm_to_julia_(car_(e)));
                    e = cdr_(e);
                }
                return
                    (jl_value_t*)jl_new_lambda_info((jl_value_t*)ex, jl_null);
            }

            e = cdr_(e);
            if (sym == line_sym && n==1) {
                return jl_new_struct(jl_linenumbernode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == label_sym) {
                return jl_new_struct(jl_labelnode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == goto_sym) {
                return jl_new_struct(jl_gotonode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == quote_sym) {
                return jl_new_struct(jl_quotenode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == top_sym) {
                return jl_new_struct(jl_topnode_type,
                                     scm_to_julia_(car_(e)));
            }
            jl_expr_t *ex = jl_exprn(sym, n);
            for(i=0; i < n; i++) {
                assert(iscons(e));
                jl_cellset(ex->args, i, scm_to_julia_(car_(e)));
                e = cdr_(e);
            }
            return (jl_value_t*)ex;
        }
        else {
            jl_error("malformed tree");
        }
    }
    if (iscprim(e) && cp_class((cprim_t*)ptr(e))==wchartype) {
        jl_value_t *wc =
            jl_box32(jl_char_type, *(int32_t*)cp_data((cprim_t*)ptr(e)));
        return wc;
    }
    if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jvtype) {
        return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
    }
    jl_error("malformed tree");
    
    return (jl_value_t*)jl_null;
}
コード例 #25
0
ファイル: equal.c プロジェクト: LiaoPengyu/femtolisp
static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
{
    value_t d, ca, cb;
 cyc_compare_top:
    if (a==b)
        return fixnum(0);
    if (iscons(a)) {
        if (iscons(b)) {
            value_t aa = car_(a); value_t da = cdr_(a);
            value_t ab = car_(b); value_t db = cdr_(b);
            int tagaa = tag(aa); int tagda = tag(da);
            int tagab = tag(ab); int tagdb = tag(db);
            if (leafp(aa) || leafp(ab)) {
                d = bounded_compare(aa, ab, 1, eq);
                if (d!=NIL && numval(d)!=0) return d;
            }
            else if (tagaa < tagab)
                return fixnum(-1);
            else if (tagaa > tagab)
                return fixnum(1);
            if (leafp(da) || leafp(db)) {
                d = bounded_compare(da, db, 1, eq);
                if (d!=NIL && numval(d)!=0) return d;
            }
            else if (tagda < tagdb)
                return fixnum(-1);
            else if (tagda > tagdb)
                return fixnum(1);

            ca = eq_class(table, a);
            cb = eq_class(table, b);
            if (ca!=NIL && ca==cb)
                return fixnum(0);

            eq_union(table, a, b, ca, cb);
            d = cyc_compare(aa, ab, table, eq);
            if (numval(d)!=0) return d;
            a = da;
            b = db;
            goto cyc_compare_top;
        }
        else {
            return fixnum(1);
        }
    }
    else if (isvector(a) && isvector(b)) {
        return cyc_vector_compare(a, b, table, eq);
    }
    else if (isclosure(a) && isclosure(b)) {
        function_t *fa = (function_t*)ptr(a);
        function_t *fb = (function_t*)ptr(b);
        d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
        if (numval(d) != 0) return d;
        
        ca = eq_class(table, a);
        cb = eq_class(table, b);
        if (ca!=NIL && ca==cb)
            return fixnum(0);
        
        eq_union(table, a, b, ca, cb);
        d = cyc_compare(fa->vals, fb->vals, table, eq);
        if (numval(d) != 0) return d;
        a = fa->env;
        b = fb->env;
        goto cyc_compare_top;
    }
    return bounded_compare(a, b, 1, eq);
}
コード例 #26
0
ファイル: read.c プロジェクト: GlenHertz/julia
static u_int32_t peek(void)
{
    char c, *end;
    fixnum_t x;
    int ch, base;

    if (toktype != TOK_NONE)
        return toktype;
    c = nextchar();
    if (ios_eof(F)) return TOK_NONE;
    if (c == '(') {
        toktype = TOK_OPEN;
    }
    else if (c == ')') {
        toktype = TOK_CLOSE;
    }
    else if (c == '[') {
        toktype = TOK_OPENB;
    }
    else if (c == ']') {
        toktype = TOK_CLOSEB;
    }
    else if (c == '\'') {
        toktype = TOK_QUOTE;
    }
    else if (c == '`') {
        toktype = TOK_BQ;
    }
    else if (c == '"') {
        toktype = TOK_DOUBLEQUOTE;
    }
    else if (c == '#') {
        ch = ios_getc(F); c = (char)ch;
        if (ch == IOS_EOF)
            lerror(ParseError, "read: invalid read macro");
        if (c == '.') {
            toktype = TOK_SHARPDOT;
        }
        else if (c == '\'') {
            toktype = TOK_SHARPQUOTE;
        }
        else if (c == '\\') {
            uint32_t cval;
            if (ios_getutf8(F, &cval) == IOS_EOF)
                lerror(ParseError, "read: end of input in character constant");
            if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
                cval == (uint32_t)'x') {
                read_token('u', 0);
                if (buf[1] != '\0') {  // not a solitary 'u','U','x'
                    if (!read_numtok(&buf[1], &tokval, 16))
                        lerror(ParseError,
                               "read: invalid hex character constant");
                    cval = numval(tokval);
                }
            }
            else if (cval >= 'a' && cval <= 'z') {
                read_token((char)cval, 0);
                tokval = symbol(buf);
                if (buf[1] == '\0')       /* one character */;
                else if (tokval == nulsym)        cval = 0x00;
                else if (tokval == alarmsym)      cval = 0x07;
                else if (tokval == backspacesym)  cval = 0x08;
                else if (tokval == tabsym)        cval = 0x09;
                else if (tokval == linefeedsym)   cval = 0x0A;
                else if (tokval == newlinesym)    cval = 0x0A;
                else if (tokval == vtabsym)       cval = 0x0B;
                else if (tokval == pagesym)       cval = 0x0C;
                else if (tokval == returnsym)     cval = 0x0D;
                else if (tokval == escsym)        cval = 0x1B;
                else if (tokval == spacesym)      cval = 0x20;
                else if (tokval == deletesym)     cval = 0x7F;
                else
                    lerrorf(ParseError, "read: unknown character #\\%s", buf);
            }
            toktype = TOK_NUM;
            tokval = mk_wchar(cval);
        }
        else if (c == '(') {
            toktype = TOK_SHARPOPEN;
        }
        else if (c == '<') {
            lerror(ParseError, "read: unreadable object");
        }
        else if (isdigit(c)) {
            read_token(c, 1);
            c = (char)ios_getc(F);
            if (c == '#')
                toktype = TOK_BACKREF;
            else if (c == '=')
                toktype = TOK_LABEL;
            else
                lerror(ParseError, "read: invalid label");
            errno = 0;
            x = strtol(buf, &end, 10);
            if (*end != '\0' || errno)
                lerror(ParseError, "read: invalid label");
            tokval = fixnum(x);
        }
        else if (c == '!') {
            // #! single line comment for shbang script support
            do {
                ch = ios_getc(F);
            } while (ch != IOS_EOF && (char)ch != '\n');
            return peek();
        }
        else if (c == '|') {
            // multiline comment
            int commentlevel=1;
            while (1) {
                ch = ios_getc(F);
            hashpipe_gotc:
                if (ch == IOS_EOF)
                    lerror(ParseError, "read: eof within comment");
                if ((char)ch == '|') {
                    ch = ios_getc(F);
                    if ((char)ch == '#') {
                        commentlevel--;
                        if (commentlevel == 0)
                            break;
                        else
                            continue;
                    }
                    goto hashpipe_gotc;
                }
                else if ((char)ch == '#') {
                    ch = ios_getc(F);
                    if ((char)ch == '|')
                        commentlevel++;
                    else
                        goto hashpipe_gotc;
                }
            }
            // this was whitespace, so keep peeking
            return peek();
        }
        else if (c == ';') {
            // datum comment
            (void)do_read_sexpr(UNBOUND); // skip
            return peek();
        }
        else if (c == ':') {
            // gensym
            ch = ios_getc(F);
            if ((char)ch == 'g')
                ch = ios_getc(F);
            read_token((char)ch, 0);
            errno = 0;
            x = strtol(buf, &end, 10);
            if (*end != '\0' || buf[0] == '\0' || errno)
                lerror(ParseError, "read: invalid gensym label");
            toktype = TOK_GENSYM;
            tokval = fixnum(x);
        }
        else if (symchar(c)) {
            read_token(ch, 0);

            if (((c == 'b' && (base= 2)) ||
                 (c == 'o' && (base= 8)) ||
                 (c == 'd' && (base=10)) ||
                 (c == 'x' && (base=16))) &&
                (isdigit_base(buf[1],base) ||
                 buf[1]=='-')) {
                if (!read_numtok(&buf[1], &tokval, base))
                    lerrorf(ParseError, "read: invalid base %d constant", base);
                return (toktype=TOK_NUM);
            }

            toktype = TOK_SHARPSYM;
            tokval = symbol(buf);
        }
        else {
            lerror(ParseError, "read: unknown read macro");
        }
    }
    else if (c == ',') {
        toktype = TOK_COMMA;
        ch = ios_getc(F);
        if (ch == IOS_EOF)
            return toktype;
        if ((char)ch == '@')
            toktype = TOK_COMMAAT;
        else if ((char)ch == '.')
            toktype = TOK_COMMADOT;
        else
            ios_ungetc((char)ch, F);
    }
    else {
        if (!read_token(c, 0)) {
            if (buf[0]=='.' && buf[1]=='\0') {
                return (toktype=TOK_DOT);
            }
            else {
                if (read_numtok(buf, &tokval, 0))
                    return (toktype=TOK_NUM);
            }
        }
        toktype = TOK_SYM;
        tokval = symbol(buf);
    }
    return toktype;
}
コード例 #27
0
ファイル: equal.c プロジェクト: LiaoPengyu/femtolisp
value_t fl_equal(value_t a, value_t b)
{
    if (eq_comparable(a, b))
        return (a == b) ? FL_T : FL_F;
    return (numval(compare_(a,b,1))==0 ? FL_T : FL_F);
}
コード例 #28
0
ファイル: equal.c プロジェクト: LiaoPengyu/femtolisp
// *oob: output argument, means we hit the limit specified by 'bound'
static uptrint_t bounded_hash(value_t a, int bound, int *oob)
{
    *oob = 0;
    union {
        double d;
        int64_t i64;
    } u;
    numerictype_t nt;
    size_t i, len;
    cvalue_t *cv;
    cprim_t *cp;
    void *data;
    uptrint_t h = 0;
    int oob2, tg = tag(a);
    switch(tg) {
    case TAG_NUM :
    case TAG_NUM1:
        u.d = (double)numval(a);
        return doublehash(u.i64);
    case TAG_FUNCTION:
        if (uintval(a) > N_BUILTINS)
            return bounded_hash(((function_t*)ptr(a))->bcode, bound, oob);
        return inthash(a);
    case TAG_SYM:
        return ((symbol_t*)ptr(a))->hash;
    case TAG_CPRIM:
        cp = (cprim_t*)ptr(a);
        data = cp_data(cp);
        if (cp_class(cp) == wchartype)
            return inthash(*(int32_t*)data);
        nt = cp_numtype(cp);
        u.d = conv_to_double(data, nt);
        return doublehash(u.i64);
    case TAG_CVALUE:
        cv = (cvalue_t*)ptr(a);
        data = cv_data(cv);
        return memhash(data, cv_len(cv));

    case TAG_VECTOR:
        if (bound <= 0) {
            *oob = 1;
            return 1;
        }
        len = vector_size(a);
        for(i=0; i < len; i++) {
            h = MIX(h, bounded_hash(vector_elt(a,i), bound/2, &oob2)^1);
            if (oob2)
                bound/=2;
            *oob = *oob || oob2;
        }
        return h;

    case TAG_CONS:
        do {
            if (bound <= 0) {
                *oob = 1;
                return h;
            }
            h = MIX(h, bounded_hash(car_(a), bound/2, &oob2));
            // bounds balancing: try to share the bounds efficiently
            // so we can hash better when a list is cdr-deep (a common case)
            if (oob2)
                bound/=2;
            else
                bound--;
            // recursive OOB propagation. otherwise this case is slow:
            // (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#))
            *oob = *oob || oob2;
            a = cdr_(a);
        } while (iscons(a));
        h = MIX(h, bounded_hash(a, bound-1, &oob2)^2);
        *oob = *oob || oob2;
        return h;
    }
    return 0;
}
コード例 #29
0
ファイル: ast.c プロジェクト: Dominick-A/julia
static jl_value_t *scm_to_julia_(fl_context_t *fl_ctx, value_t e, int eo)
{
    if (fl_isnumber(fl_ctx, e)) {
        int64_t i64;
        if (isfixnum(e)) {
            i64 = numval(e);
        }
        else {
            assert(iscprim(e));
            cprim_t *cp = (cprim_t*)ptr(e);
            numerictype_t nt = cp_numtype(cp);
            switch (nt) {
            case T_DOUBLE:
                return (jl_value_t*)jl_box_float64(*(double*)cp_data(cp));
            case T_FLOAT:
                return (jl_value_t*)jl_box_float32(*(float*)cp_data(cp));
            case T_UINT8:
                return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data(cp));
            case T_UINT16:
                return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data(cp));
            case T_UINT32:
                return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data(cp));
            case T_UINT64:
                return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data(cp));
            default:
                ;
            }
            i64 = conv_to_int64(cp_data(cp), nt);
        }
#ifdef _P64
        return (jl_value_t*)jl_box_int64(i64);
#else
        if (i64 > (int64_t)S32_MAX || i64 < (int64_t)S32_MIN)
            return (jl_value_t*)jl_box_int64(i64);
        else
            return (jl_value_t*)jl_box_int32((int32_t)i64);
#endif
    }
    if (issymbol(e)) {
        if (e == jl_ast_ctx(fl_ctx)->true_sym)
            return jl_true;
        else if (e == jl_ast_ctx(fl_ctx)->false_sym)
            return jl_false;
        return (jl_value_t*)scmsym_to_julia(fl_ctx, e);
    }
    if (fl_isstring(fl_ctx, e))
        return jl_pchar_to_string((char*)cvalue_data(e), cvalue_len(e));
    if (iscons(e) || e == fl_ctx->NIL) {
        value_t hd;
        jl_sym_t *sym;
        if (e == fl_ctx->NIL) {
            hd = e;
        }
        else {
            hd = car_(e);
            if (hd == jl_ast_ctx(fl_ctx)->ssavalue_sym)
                return jl_box_ssavalue(numval(car_(cdr_(e))));
            else if (hd == jl_ast_ctx(fl_ctx)->slot_sym)
                return jl_box_slotnumber(numval(car_(cdr_(e))));
            else if (hd == jl_ast_ctx(fl_ctx)->null_sym && llength(e) == 1)
                return jl_nothing;
        }
        if (issymbol(hd))
            sym = scmsym_to_julia(fl_ctx, hd);
        else
            sym = list_sym;
        size_t n = llength(e)-1;
        if (issymbol(hd))
            e = cdr_(e);
        else
            n++;
        if (!eo) {
            if (sym == line_sym && n==1) {
                jl_value_t *linenum = scm_to_julia_(fl_ctx, car_(e), 0);
                JL_GC_PUSH1(&linenum);
                jl_value_t *temp = jl_new_struct(jl_linenumbernode_type, linenum);
                JL_GC_POP();
                return temp;
            }
            jl_value_t *scmv = NULL, *temp = NULL;
            JL_GC_PUSH1(&scmv);
            if (sym == label_sym) {
                scmv = scm_to_julia_(fl_ctx,car_(e),0);
                temp = jl_new_struct(jl_labelnode_type, scmv);
                JL_GC_POP();
                return temp;
            }
            if (sym == goto_sym) {
                scmv = scm_to_julia_(fl_ctx,car_(e),0);
                temp = jl_new_struct(jl_gotonode_type, scmv);
                JL_GC_POP();
                return temp;
            }
            if (sym == inert_sym || (sym == quote_sym && (!iscons(car_(e))))) {
                scmv = scm_to_julia_(fl_ctx,car_(e),0);
                temp = jl_new_struct(jl_quotenode_type, scmv);
                JL_GC_POP();
                return temp;
            }
            if (sym == top_sym) {
                scmv = scm_to_julia_(fl_ctx,car_(e),0);
                assert(jl_is_symbol(scmv));
                temp = jl_module_globalref(jl_base_relative_to(jl_current_module), (jl_sym_t*)scmv);
                JL_GC_POP();
                return temp;
            }
            if (sym == core_sym) {
                scmv = scm_to_julia_(fl_ctx,car_(e),0);
                assert(jl_is_symbol(scmv));
                temp = jl_module_globalref(jl_core_module, (jl_sym_t*)scmv);
                JL_GC_POP();
                return temp;
            }
            if (sym == globalref_sym) {
                scmv = scm_to_julia_(fl_ctx,car_(e),0);
                temp = scm_to_julia_(fl_ctx,car_(cdr_(e)),0);
                assert(jl_is_module(scmv));
                assert(jl_is_symbol(temp));
                temp = jl_module_globalref((jl_module_t*)scmv, (jl_sym_t*)temp);
                JL_GC_POP();
                return temp;
            }
            if (sym == newvar_sym) {
                scmv = scm_to_julia_(fl_ctx,car_(e),0);
                temp = jl_new_struct(jl_newvarnode_type, scmv);
                JL_GC_POP();
                return temp;
            }
            JL_GC_POP();
        }
        else if (sym == inert_sym && !iscons(car_(e))) {
            sym = quote_sym;
        }
        jl_value_t *ex = (jl_value_t*)jl_exprn(sym, n);
        JL_GC_PUSH1(&ex);
        // allocate a fresh args array for empty exprs passed to macros
        if (eo && n == 0) {
            ((jl_expr_t*)ex)->args = jl_alloc_vec_any(0);
            jl_gc_wb(ex, ((jl_expr_t*)ex)->args);
        }
        size_t i;
        for(i=0; i < n; i++) {
            assert(iscons(e));
            jl_array_ptr_set(((jl_expr_t*)ex)->args, i, scm_to_julia_(fl_ctx, car_(e), eo));
            e = cdr_(e);
        }
        if (sym == lambda_sym)
            ex = (jl_value_t*)jl_new_lambda_info_from_ast((jl_expr_t*)ex);
        JL_GC_POP();
        if (sym == list_sym)
            return (jl_value_t*)((jl_expr_t*)ex)->args;
        return (jl_value_t*)ex;
    }
    if (iscprim(e) && cp_class((cprim_t*)ptr(e)) == fl_ctx->wchartype) {
        return jl_box32(jl_char_type, *(int32_t*)cp_data((cprim_t*)ptr(e)));
    }
    if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jl_ast_ctx(fl_ctx)->jvtype) {
        return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
    }
    jl_error("malformed tree");

    return jl_nothing;
}