static void syntax_error (const char* const msg, const SCM form, const SCM expr) { SCM msg_string = scm_from_locale_string (msg); SCM filename = SCM_BOOL_F; SCM linenr = SCM_BOOL_F; const char *format; SCM args; if (scm_is_pair (form)) { filename = scm_source_property (form, scm_sym_filename); linenr = scm_source_property (form, scm_sym_line); } if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr)) { filename = scm_source_property (expr, scm_sym_filename); linenr = scm_source_property (expr, scm_sym_line); } if (!SCM_UNBNDP (expr)) { if (scm_is_true (filename)) { format = "In file ~S, line ~S: ~A ~S in expression ~S."; args = scm_list_5 (filename, linenr, msg_string, form, expr); } else if (scm_is_true (linenr)) { format = "In line ~S: ~A ~S in expression ~S."; args = scm_list_4 (linenr, msg_string, form, expr); } else { format = "~A ~S in expression ~S."; args = scm_list_3 (msg_string, form, expr); } } else { if (scm_is_true (filename)) { format = "In file ~S, line ~S: ~A ~S."; args = scm_list_4 (filename, linenr, msg_string, form); } else if (scm_is_true (linenr)) { format = "In line ~S: ~A ~S."; args = scm_list_3 (linenr, msg_string, form); } else { format = "~A ~S."; args = scm_list_2 (msg_string, form); } } scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F); }
bool mouseAreaMouseMove(guihckContext* ctx, guihckElementId id, void* data, float sx, float sy, float dx, float dy) { (void) data; (void) sx; (void) sy; (void) dx; (void) dy; bool handled = false; SCM handler = guihckElementGetProperty(ctx, id, "on-mouse-move"); if(scm_to_bool(scm_procedure_p(handler))) { guihckStackPushElement(ctx, id); SCM expression = scm_list_5(handler, scm_from_double(sx), scm_from_double(sy), scm_from_double(dx), scm_from_double(dy)); SCM result = guihckContextExecuteExpression(ctx, expression); handled = scm_is_eq(result, SCM_BOOL_T); guihckStackPopElement(ctx); } return handled; }
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 MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)); else return MAKMEMO_MOD_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_MOD_REF (REF (exp, MODULE_REF, MOD), REF (exp, MODULE_REF, NAME), REF (exp, MODULE_REF, PUBLIC)); case SCM_EXPANDED_MODULE_SET: return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env), REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, PUBLIC)); case SCM_EXPANDED_TOPLEVEL_REF: return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)); case SCM_EXPANDED_TOPLEVEL_SET: return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME), memoize (REF (exp, TOPLEVEL_SET, EXP), env)); case SCM_EXPANDED_TOPLEVEL_DEFINE: return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME), memoize (REF (exp, TOPLEVEL_DEFINE, EXP), 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), scm_ilength (args), 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 == 2 && scm_is_eq (name, scm_from_latin1_symbol ("wind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL); else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args); else return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name, SCM_BOOL_F), nargs, 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 or #f. */ { SCM meta, docstring, body, proc; meta = REF (exp, LAMBDA, META); docstring = scm_assoc_ref (meta, scm_sym_documentation); body = REF (exp, LAMBDA, BODY); if (scm_is_false (body)) /* Give a body to case-lambda with no clauses. */ proc = MAKMEMO_LAMBDA (MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, scm_from_latin1_symbol ("throw"), SCM_BOOL_F), 5, scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key), MAKMEMO_QUOTE (SCM_BOOL_F), MAKMEMO_QUOTE (scm_from_latin1_string ("Wrong number of arguments")), MAKMEMO_QUOTE (SCM_EOL), MAKMEMO_QUOTE (SCM_BOOL_F))), FIXED_ARITY (0), SCM_BOOL_F /* docstring */); else proc = memoize (body, env); if (scm_is_string (docstring)) { SCM args = SCM_MEMOIZED_ARGS (proc); SCM_SETCAR (SCM_CDR (args), docstring); } return proc; } case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; SCM walk, minits, arity, new_env; int nreq, nopt, ntotal; 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; ntotal = scm_ilength (vars); /* The vars are the gensyms, according to the divine plan. But we need to memoize the inits within their appropriate environment, complicating things. */ new_env = env; for (walk = req; scm_is_pair (walk); walk = CDR (walk), vars = CDR (vars)) new_env = scm_cons (CAR (vars), new_env); minits = SCM_EOL; for (walk = opt; scm_is_pair (walk); walk = CDR (walk), vars = CDR (vars), inits = CDR (inits)) { minits = scm_cons (memoize (CAR (inits), new_env), minits); new_env = scm_cons (CAR (vars), new_env); } if (scm_is_true (rest)) { new_env = scm_cons (CAR (vars), new_env); vars = CDR (vars); } for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits)) { minits = scm_cons (memoize (CAR (inits), new_env), minits); new_env = scm_cons (CAR (vars), new_env); } if (!scm_is_null (vars)) abort (); minits = scm_reverse_x (minits, SCM_UNDEFINED); 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 = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env); 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, minits, SCM_MEMOIZED_ARGS (memoize (alt, env))); else arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, SCM_BOOL_F /* docstring */); } case SCM_EXPANDED_LET: { SCM vars, exps, body, inits, new_env; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); inits = SCM_EOL; new_env = env; for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps)) { new_env = scm_cons (CAR (vars), new_env); inits = scm_cons (memoize (CAR (exps), env), inits); } return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED), memoize (body, new_env)); } case SCM_EXPANDED_LETREC: { SCM vars, exps, body, undefs, new_env; int i, nvars, in_order_p; vars = REF (exp, LETREC, GENSYMS); exps = REF (exp, LETREC, VALS); body = REF (exp, LETREC, BODY); in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P)); nvars = i = scm_ilength (vars); undefs = SCM_EOL; new_env = env; for (; scm_is_pair (vars); vars = CDR (vars)) { new_env = scm_cons (CAR (vars), new_env); undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs); } if (in_order_p) { SCM body_exps = SCM_EOL, seq; for (; scm_is_pair (exps); exps = CDR (exps), i--) body_exps = scm_cons (MAKMEMO_LEX_SET (i-1, memoize (CAR (exps), new_env)), body_exps); seq = memoize (body, new_env); for (; scm_is_pair (body_exps); body_exps = CDR (body_exps)) seq = MAKMEMO_SEQ (CAR (body_exps), seq); return MAKMEMO_LET (undefs, seq); } else { SCM sets = SCM_EOL, inits = SCM_EOL, set_seq; for (; scm_is_pair (exps); exps = CDR (exps), i--) { sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars, MAKMEMO_LEX_REF (i-1)), sets); inits = scm_cons (memoize (CAR (exps), new_env), inits); } inits = scm_reverse_x (inits, SCM_UNDEFINED); sets = scm_reverse_x (sets, SCM_UNDEFINED); if (scm_is_null (sets)) return memoize (body, env); for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets); sets = CDR (sets)) set_seq = MAKMEMO_SEQ (CAR (sets), set_seq); return MAKMEMO_LET (undefs, MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq), memoize (body, new_env))); } } default: abort (); } }