TEST(vector, vector__empty) { ScmObj actual = SCM_OBJ_INIT, expected = SCM_OBJ_INIT; SCM_REFSTK_INIT_REG(&actual, &expected); expected = ut_read_cstr("#()"); actual = scm_vector(0); TEST_ASSERT_SCM_EQUAL(expected, actual); }
TEST(vector, vector__return_ERROR) { ScmObj elm[3] = { SCM_OBJ_INIT, SCM_OBJ_INIT, SCM_OBJ_INIT }; SCM_REFSTK_INIT; SCM_REFSTK_REG_ARY(elm, sizeof(elm)/sizeof(elm[0])); elm[0] = ut_read_cstr("a"); elm[1] = SCM_OBJ_NULL;; elm[2] = ut_read_cstr("c"); TEST_ASSERT_SCM_NULL(scm_vector(3, elm[0], elm[1], elm[2])); }
TEST(vector, vector) { ScmObj actual = SCM_OBJ_INIT, expected = SCM_OBJ_INIT; ScmObj elm[3] = { SCM_OBJ_INIT, SCM_OBJ_INIT, SCM_OBJ_INIT }; SCM_REFSTK_INIT_REG(&actual, &expected); SCM_REFSTK_REG_ARY(elm, sizeof(elm)/sizeof(elm[0])); elm[0] = ut_read_cstr("a"); elm[1] = ut_read_cstr("b"); elm[2] = ut_read_cstr("c"); expected = ut_read_cstr("#(a b c)"); actual = scm_vector(3, elm[0], elm[1], elm[2]); TEST_ASSERT_SCM_EQUAL(expected, actual); }
static SCM memoize (SCM exp, SCM env) { if (!SCM_EXPANDED_P (exp)) abort (); switch (SCM_EXPANDED_TYPE (exp)) { case SCM_EXPANDED_VOID: return MAKMEMO_QUOTE (SCM_UNSPECIFIED); case SCM_EXPANDED_CONST: return MAKMEMO_QUOTE (REF (exp, CONST, EXP)); case SCM_EXPANDED_PRIMITIVE_REF: if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, REF (exp, PRIMITIVE_REF, NAME))), env); else return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, list_of_guile, REF (exp, PRIMITIVE_REF, NAME), SCM_BOOL_F)); case SCM_EXPANDED_LEXICAL_REF: return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env)); case SCM_EXPANDED_LEXICAL_SET: return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env), memoize (REF (exp, LEXICAL_SET, EXP), env)); case SCM_EXPANDED_MODULE_REF: return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, REF (exp, MODULE_REF, MOD), REF (exp, MODULE_REF, NAME), REF (exp, MODULE_REF, PUBLIC))); case SCM_EXPANDED_MODULE_SET: return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_SET, REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, PUBLIC)), memoize (REF (exp, MODULE_SET, EXP), env)); case SCM_EXPANDED_TOPLEVEL_REF: return maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, REF (exp, TOPLEVEL_REF, NAME))), env); case SCM_EXPANDED_TOPLEVEL_SET: return maybe_makmemo_capture_module (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET, REF (exp, TOPLEVEL_SET, NAME)), memoize (REF (exp, TOPLEVEL_SET, EXP), capture_env (env))), env); case SCM_EXPANDED_TOPLEVEL_DEFINE: return maybe_makmemo_capture_module (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE, REF (exp, TOPLEVEL_DEFINE, NAME)), memoize (REF (exp, TOPLEVEL_DEFINE, EXP), capture_env (env))), env); case SCM_EXPANDED_CONDITIONAL: return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env), memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); case SCM_EXPANDED_CALL: { SCM proc, args; proc = REF (exp, CALL, PROC); args = memoize_exps (REF (exp, CALL, ARGS), env); return MAKMEMO_CALL (memoize (proc, env), args); } case SCM_EXPANDED_PRIMCALL: { SCM name, args; int nargs; name = REF (exp, PRIMCALL, NAME); args = memoize_exps (REF (exp, PRIMCALL, ARGS), env); nargs = scm_ilength (args); if (nargs == 3 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt"))) return MAKMEMO_CALL_WITH_PROMPT (CAR (args), CADR (args), CADDR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("apply"))) return MAKMEMO_APPLY (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-current-continuation"))) return MAKMEMO_CONT (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-values"))) return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("variable-ref"))) return MAKMEMO_BOX_REF (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("variable-set!"))) return MAKMEMO_BOX_SET (CAR (args), CADR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("wind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("push-dynamic-state"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-dynamic-state"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL); else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_CALL (maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, name)), env), args); else return MAKMEMO_CALL (MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, list_of_guile, name, SCM_BOOL_F)), args); } case SCM_EXPANDED_SEQ: return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env), memoize (REF (exp, SEQ, TAIL), env)); case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case. */ { SCM meta, body, proc, new_env; meta = REF (exp, LAMBDA, META); body = REF (exp, LAMBDA, BODY); new_env = push_flat_link (capture_env (env)); proc = memoize (body, new_env); SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta); return maybe_makmemo_capture_module (capture_flat_env (proc, new_env), env); } case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; SCM unbound, arity, rib, new_env; int nreq, nopt, ninits; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); opt = REF (exp, LAMBDA_CASE, OPT); kw = REF (exp, LAMBDA_CASE, KW); inits = REF (exp, LAMBDA_CASE, INITS); vars = REF (exp, LAMBDA_CASE, GENSYMS); body = REF (exp, LAMBDA_CASE, BODY); alt = REF (exp, LAMBDA_CASE, ALTERNATE); nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; ninits = scm_ilength (inits); /* This relies on assignment conversion turning inits into a sequence of CONST expressions whose values are a unique "unbound" token. */ unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F; rib = scm_vector (vars); new_env = push_nested_link (rib, env); if (scm_is_true (kw)) { /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */ SCM aok = CAR (kw), indices = SCM_EOL; for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw)) { SCM k; int idx; k = CAR (CAR (kw)); idx = lookup_rib (CADDR (CAR (kw)), rib); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); } kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); } if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt)) { if (scm_is_false (rest)) arity = FIXED_ARITY (nreq); else arity = REST_ARITY (nreq, SCM_BOOL_T); } else if (scm_is_true (alt)) arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, SCM_MEMOIZED_ARGS (memoize (alt, env))); else arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, SCM_EOL /* meta, filled in later */); } case SCM_EXPANDED_LET: { SCM vars, exps, body, varsv, inits, new_env; int i; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); varsv = scm_vector (vars); inits = scm_c_make_vector (VECTOR_LENGTH (varsv), SCM_BOOL_F); new_env = push_nested_link (varsv, capture_env (env)); for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++) VECTOR_SET (inits, i, memoize (CAR (exps), env)); return maybe_makmemo_capture_module (MAKMEMO_LET (inits, memoize (body, new_env)), env); } default: abort (); } }