+scm_make_gloc (var, env)
+ SCM var;
+ SCM env;
+{
+#if 1 /* Unsafe */
+ if (SCM_NIMP (var) && SCM_CONSP (var))
+ var = scm_cons (SCM_BOOL_F, var);
+ else
+#endif
+ SCM_ASSERT (SCM_NIMP (var) && SCM_VARIABLEP (var),
+ var,
+ SCM_ARG1,
+ s_make_gloc);
+ if (SCM_UNBNDP (env))
+ env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
+ else
+ SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
+ env,
+ SCM_ARG2,
+ s_make_gloc);
+ return scm_make_memoized (SCM_VARVCELL (var) + 1, env);
+}
+
+SCM_PROC (s_gloc_p, "gloc?", 1, 0, 0, scm_gloc_p);
+
+SCM
+scm_gloc_p (obj)
+ SCM obj;
+{
+ return ((SCM_NIMP (obj)
+ && SCM_MEMOIZEDP (obj)
+ && (SCM_MEMOIZED_EXP (obj) & 7) == 1)
+ ? SCM_BOOL_T
+ : SCM_BOOL_F);
+}
+
+SCM_PROC (s_make_iloc, "make-iloc", 3, 0, 0, scm_make_iloc);
+
+SCM
+scm_make_iloc (frame, binding, cdrp)
+ SCM frame;
+ SCM binding;
+ SCM cdrp;
+{
+ SCM_ASSERT (SCM_INUMP (frame), frame, SCM_ARG1, s_make_iloc);
+ SCM_ASSERT (SCM_INUMP (binding), binding, SCM_ARG2, s_make_iloc);
+ return (SCM_ILOC00
+ + SCM_IFRINC * SCM_INUM (frame)
+ + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0)
+ + SCM_IDINC * SCM_INUM (binding));
+}
+
+SCM_PROC (s_iloc_p, "iloc?", 1, 0, 0, scm_iloc_p);
+
+SCM
+scm_iloc_p (obj)
+ SCM obj;
+{
+ return SCM_ILOCP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC (s_memcons, "memcons", 2, 1, 0, scm_memcons);
+
+SCM
+scm_memcons (car, cdr, env)
+ SCM car;
+ SCM cdr;
+ SCM env;
+{
+ if (SCM_NIMP (car) && SCM_MEMOIZEDP (car))
+ {
+ /*fixme* environments may be two different but equal top-level envs */
+ if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
+ scm_misc_error (s_memcons,
+ "environment mismatch arg1 <-> arg3",
+ scm_cons2 (car, env, SCM_EOL));
+ else
+ env = SCM_MEMOIZED_ENV (car);
+ car = SCM_MEMOIZED_EXP (car);
+ }
+ if (SCM_NIMP (cdr) && SCM_MEMOIZEDP (cdr))
+ {
+ if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
+ scm_misc_error (s_memcons,
+ "environment mismatch arg2 <-> arg3",
+ scm_cons2 (cdr, env, SCM_EOL));
+ else
+ env = SCM_MEMOIZED_ENV (cdr);
+ cdr = SCM_MEMOIZED_EXP (cdr);
+ }
+ if (SCM_UNBNDP (env))
+ env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
+ else
+ SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
+ env,
+ SCM_ARG3,
+ s_make_iloc);
+ return scm_make_memoized (scm_cons (car, cdr), env);
+}
+
+SCM_PROC (s_mem_to_proc, "mem->proc", 1, 0, 0, scm_mem_to_proc);
+
+SCM
+scm_mem_to_proc (obj)
+ SCM obj;
+{
+ SCM env;
+ SCM_ASSERT (SCM_NIMP (obj) && SCM_MEMOIZEDP (obj),
+ obj,
+ SCM_ARG1,
+ s_mem_to_proc);
+ env = SCM_MEMOIZED_ENV (obj);
+ obj = SCM_MEMOIZED_EXP (obj);
+ if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA))
+ scm_misc_error (s_mem_to_proc,
+ "expected lambda expression",
+ scm_cons (obj, SCM_EOL));
+ return scm_closure (SCM_CDR (obj), env);
+}
+
+SCM_PROC (s_proc_to_mem, "proc->mem", 1, 0, 0, scm_proc_to_mem);
+
+SCM
+scm_proc_to_mem (obj)
+ SCM obj;
+{
+ SCM_ASSERT (SCM_NIMP (obj) && SCM_CLOSUREP (obj),
+ obj,
+ SCM_ARG1,
+ s_proc_to_mem);
+ return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)),
+ SCM_ENV (obj));
+}
+
+#endif /* GUILE_DEBUG */
+
+SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize);
+