static value_t fl_length(value_t *args, u_int32_t nargs) { argcount("length", nargs, 1); value_t a = args[0]; cvalue_t *cv; if (isvector(a)) { return fixnum(vector_size(a)); } else if (iscprim(a)) { cv = (cvalue_t*)ptr(a); if (cp_class(cv) == bytetype) return fixnum(1); else if (cp_class(cv) == wchartype) return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv))); } else if (iscvalue(a)) { cv = (cvalue_t*)ptr(a); if (cv_class(cv)->eltype != NULL) return size_wrap(cvalue_arraylen(a)); } else if (a == FL_NIL) { return fixnum(0); } else if (iscons(a)) { return fixnum(llength(a)); } type_error("length", "sequence", a); }
void print_traverse(value_t v) { value_t *bp; while (iscons(v)) { if (ismarked(v)) { bp = (value_t*)ptrhash_bp(&printconses, (void*)v); if (*bp == (value_t)HT_NOTFOUND) *bp = fixnum(printlabel++); return; } mark_cons(v); print_traverse(car_(v)); v = cdr_(v); } if (!ismanaged(v) || issymbol(v)) return; if (ismarked(v)) { bp = (value_t*)ptrhash_bp(&printconses, (void*)v); if (*bp == (value_t)HT_NOTFOUND) *bp = fixnum(printlabel++); return; } if (isvector(v)) { if (vector_size(v) > 0) mark_cons(v); unsigned int i; for(i=0; i < vector_size(v); i++) print_traverse(vector_elt(v,i)); } else if (iscprim(v)) { mark_cons(v); } else if (isclosure(v)) { mark_cons(v); function_t *f = (function_t*)ptr(v); print_traverse(f->bcode); print_traverse(f->vals); print_traverse(f->env); } else { assert(iscvalue(v)); cvalue_t *cv = (cvalue_t*)ptr(v); // don't consider shared references to "" if (!cv_isstr(cv) || cv_len(cv)!=0) mark_cons(v); fltype_t *t = cv_class(cv); if (t->vtable != NULL && t->vtable->print_traverse != NULL) t->vtable->print_traverse(v); } }
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; }
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"); }
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; }
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; }