dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Evaluator sets same procedure properties as compiler

Browse source 
* libguile/memoize.c (MAKMEMO_LAMBDA, memoize): Instead of passing the
  docstring in the memoized lambda, pass the meta as-is.  That way we
  get all procedure properties, including "name".
* module/ice-9/eval.scm (primitive-eval): Set procedure properties when
  making lambdas.  Don't set the name when defining toplevel variables
  -- before we did so only if the procedure didn't have a name
  property, but I would like to avoid calls to procedure-property in
  eval, because getting the name for an RTL function requires loading up
  other modules.
This commit is contained in:
Andy Wingo 2013-10-26 13:10:43 +02:00
commit 27ecfd3649
2 changed files with 17 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

22
libguile/memoize.c
View file

@ -122,9 +122,9 @@ scm_t_bits scm_tc16_memoized;
#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
alt, SCM_UNDEFINED)
#define MAKMEMO_LAMBDA(body, arity, docstring) \
#define MAKMEMO_LAMBDA(body, arity, meta) \
MAKMEMO (SCM_M_LAMBDA, \
scm_cons (body, scm_cons (docstring, arity)))
scm_cons (body, scm_cons (meta, arity)))
#define MAKMEMO_LET(inits, body) \
MAKMEMO (SCM_M_LET, scm_cons (inits, body))
#define MAKMEMO_QUOTE(exp) \
@ -367,10 +367,9 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case or #f. */
{
SCM meta, docstring, body, proc;
SCM meta, 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))
@ -388,15 +387,12 @@ memoize (SCM exp, SCM env)
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
SCM_BOOL_F /* docstring */);
meta);
else
proc = memoize (body, env);
if (scm_is_string (docstring))
{
SCM args = SCM_MEMOIZED_ARGS (proc);
SCM_SETCAR (SCM_CDR (args), docstring);
}
{
proc = memoize (body, env);
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
}
return proc;
}
@ -460,7 +456,7 @@ memoize (SCM exp, SCM env)
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_BOOL_F /* docstring */);
SCM_BOOL_F /* meta, filled in later */);
}
case SCM_EXPANDED_LET:

16
module/ice-9/eval.scm
View file

@ -308,7 +308,7 @@
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(define alt-proc
(and alt ; (body docstring nreq ...)
(and alt ; (body meta nreq ...)
(let* ((body (car alt))
(spec (cddr alt))
(nreq (car spec))
@ -479,7 +479,7 @@
(lp (1+ i))))
(eval body new-env)))
(('lambda (body docstring nreq . tail))
(('lambda (body meta nreq . tail))
(let ((proc
(if (null? tail)
(make-fixed-closure eval nreq body (capture-env env))
@ -487,8 +487,10 @@
(make-rest-closure eval nreq body (capture-env env))
(apply make-general-closure (capture-env env)
body nreq tail)))))
(when docstring
(set-procedure-property! proc 'documentation docstring))
(let lp ((meta meta))
(unless (null? meta)
(set-procedure-property! proc (caar meta) (cdar meta))
(lp (cdr meta))))
proc))
(('seq (head . tail))
@ -513,10 +515,8 @@
(memoize-variable-access! exp #f))))
(('define (name . x))
(let ((x (eval x env)))
(if (and (procedure? x) (not (procedure-property x 'name)))
(set-procedure-property! x 'name name))
(define! name x)
(begin
(define! name (eval x env))
(if #f #f)))
(('toplevel-set! (var-or-sym . x))