diff --git a/libguile/eval.c b/libguile/eval.c index 2488ee272..d76fbd30d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -116,13 +116,13 @@ static scm_t_bits scm_tc16_boot_closure; #define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x)))) /* NB: One may only call the following accessors if the closure is not REST. */ #define BOOT_CLOSURE_IS_FULL(x) (1) -#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \ +#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \ do { SCM fu = fu_; \ body = CAR (fu); fu = CDDR (fu); \ \ rest = kw = alt = SCM_BOOL_F; \ - inits = SCM_EOL; \ - nopt = 0; \ + unbound = SCM_BOOL_F; \ + nopt = ninits = 0; \ \ nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \ if (scm_is_pair (fu)) \ @@ -132,7 +132,8 @@ static scm_t_bits scm_tc16_boot_closure; { \ nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \ kw = CAR (fu); fu = CDR (fu); \ - inits = CAR (fu); fu = CDR (fu); \ + ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \ + unbound = CAR (fu); fu = CDR (fu); \ alt = CAR (fu); \ } \ } \ @@ -196,14 +197,6 @@ env_set (SCM env, int depth, int width, SCM val) } -SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); - -static void error_used_before_defined (void) -{ - scm_error (scm_unbound_variable_key, NULL, - "Variable used before given a value", SCM_EOL, SCM_BOOL_F); -} - static void error_invalid_keyword (SCM proc, SCM obj) { scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, @@ -358,20 +351,14 @@ eval (SCM x, SCM env) case SCM_M_LEXICAL_REF: { - SCM pos, ret; + SCM pos; int depth, width; pos = mx; depth = SCM_I_INUM (CAR (pos)); width = SCM_I_INUM (CDR (pos)); - ret = env_ref (env, depth, width); - - if (SCM_UNLIKELY (SCM_UNBNDP (ret))) - /* we don't know what variable, though, because we don't have its - name */ - error_used_before_defined (); - return ret; + return env_ref (env, depth, width); } case SCM_M_LEXICAL_SET: @@ -764,12 +751,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, } else { - int i, argc, nreq, nopt, nenv; - SCM body, rest, kw, inits, alt; + int i, argc, nreq, nopt, ninits, nenv; + SCM body, rest, kw, unbound, alt; SCM mx = BOOT_CLOSURE_CODE (proc); loop: - BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt); + BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, + ninits, unbound, alt); argc = scm_ilength (args); if (argc < nreq) @@ -814,8 +802,8 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, } /* At this point we are committed to the chosen clause. */ - nenv = nreq + (scm_is_true (rest) ? 1 : 0) + scm_ilength (inits); - env = make_env (nenv, SCM_UNDEFINED, env); + nenv = nreq + (scm_is_true (rest) ? 1 : 0) + ninits; + env = make_env (nenv, unbound, env); for (i = 0; i < nreq; i++, args = CDR (args)) env_set (env, 0, i, CAR (args)); @@ -823,15 +811,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, if (scm_is_false (kw)) { /* Optional args (possibly), but no keyword args. */ - for (; i < argc && i < nreq + nopt; - i++, args = CDR (args), inits = CDR (inits)) + for (; i < argc && i < nreq + nopt; i++, args = CDR (args)) env_set (env, 0, i, CAR (args)); - - for (; i < nreq + nopt; i++, inits = CDR (inits)) - env_set (env, 0, i, EVAL1 (CAR (inits), env)); - if (scm_is_true (rest)) - env_set (env, 0, i++, args); + env_set (env, 0, nreq + nopt, args); } else { @@ -842,18 +825,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, /* Optional args. As before, but stop at the first keyword. */ for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args)); - i++, args = CDR (args), inits = CDR (inits)) + i++, args = CDR (args)) env_set (env, 0, i, CAR (args)); - - for (; i < nreq + nopt; i++, inits = CDR (inits)) - env_set (env, 0, i, EVAL1 (CAR (inits), env)); - if (scm_is_true (rest)) - env_set (env, 0, i++, args); + env_set (env, 0, nreq + nopt, args); /* Parse keyword args. */ { - int kw_start_idx = i; SCM walk; if (scm_is_pair (args) && scm_is_pair (CDR (args))) @@ -880,20 +858,9 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, } if (scm_is_pair (args) && scm_is_false (rest)) error_invalid_keyword (proc, CAR (args)); - - /* Now fill in unbound values, evaluating init expressions in their - appropriate environment. */ - for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits)) - if (SCM_UNBNDP (env_ref (env, 0, i))) - env_set (env, 0, i, EVAL1 (CAR (inits), env)); } } - if (!scm_is_null (inits)) - abort (); - if (i != nenv) - abort (); - *out_body = body; *out_env = env; } diff --git a/libguile/expand.c b/libguile/expand.c index 1d511e62d..e1c6c18a5 100644 --- a/libguile/expand.c +++ b/libguile/expand.c @@ -977,8 +977,8 @@ expand_named_let (const SCM expr, SCM env) scm_list_1 (name), scm_list_1 (name_sym), scm_list_1 (LAMBDA (SCM_BOOL_F, SCM_EOL, - LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F, - SCM_BOOL_F, SCM_BOOL_F, var_syms, + LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F, + SCM_BOOL_F, SCM_EOL, var_syms, expand_sequence (CDDDR (expr), inner_env), SCM_BOOL_F))), CALL (SCM_BOOL_F, @@ -1434,7 +1434,7 @@ convert_assignment (SCM exp, SCM assigned) alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned); new_inits = scm_make_list (scm_length (inits), const_unbound); - + seq = SCM_EOL, symwalk = syms; /* Required arguments may need boxing. */ @@ -1511,7 +1511,7 @@ convert_assignment (SCM exp, SCM assigned) case SCM_EXPANDED_LETREC: { - SCM src, names, syms, vals, unbound, boxes, body; + SCM src, names, syms, vals, empty_box, boxes, body; src = REF (exp, LETREC, SRC); names = REF (exp, LETREC, NAMES); @@ -1519,10 +1519,11 @@ convert_assignment (SCM exp, SCM assigned) vals = convert_assignment (REF (exp, LETREC, VALS), assigned); body = convert_assignment (REF (exp, LETREC, BODY), assigned); - unbound = PRIMCALL (SCM_BOOL_F, - scm_from_latin1_symbol ("make-undefined-variable"), - SCM_EOL); - boxes = scm_make_list (scm_length (names), unbound); + empty_box = + PRIMCALL (SCM_BOOL_F, + scm_from_latin1_symbol ("make-undefined-variable"), + SCM_EOL); + boxes = scm_make_list (scm_length (names), empty_box); if (scm_is_true (REF (exp, LETREC, IN_ORDER_P))) return LET diff --git a/libguile/memoize.c b/libguile/memoize.c index 36766e83e..9651cadc6 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -119,9 +119,9 @@ scm_t_bits scm_tc16_memoized; scm_list_1 (SCM_I_MAKINUM (nreq)) #define REST_ARITY(nreq, rest) \ scm_list_2 (SCM_I_MAKINUM (nreq), rest) -#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 FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \ + scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \ + SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED) #define MAKMEMO_LAMBDA(body, arity, meta) \ MAKMEMO (SCM_M_LAMBDA, \ scm_cons (body, scm_cons (meta, arity))) @@ -418,8 +418,8 @@ memoize (SCM exp, SCM env) case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; - SCM walk, minits, arity, rib, new_env; - int nreq, nopt; + SCM unbound, arity, rib; + int nreq, nopt, ninits; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); @@ -432,17 +432,12 @@ memoize (SCM exp, SCM env) nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; - - /* The vars are the gensyms, according to the divine plan. But we need - to memoize the inits within their appropriate environment, - complicating things. */ + 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 = scm_cons (rib, env); - - minits = SCM_EOL; - for (walk = inits; scm_is_pair (walk); walk = CDR (walk)) - minits = scm_cons (memoize (CAR (walk), new_env), minits); - minits = scm_reverse_x (minits, SCM_UNDEFINED); if (scm_is_true (kw)) { @@ -468,12 +463,13 @@ memoize (SCM exp, SCM env) arity = REST_ARITY (nreq, SCM_BOOL_T); } else if (scm_is_true (alt)) - arity = FULL_ARITY (nreq, rest, nopt, kw, minits, + arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, SCM_MEMOIZED_ARGS (memoize (alt, env))); else - arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F); + arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, + SCM_BOOL_F); - return MAKMEMO_LAMBDA (memoize (body, new_env), arity, + return MAKMEMO_LAMBDA (memoize (body, scm_cons (rib, env)), arity, SCM_BOOL_F /* meta, filled in later */); } @@ -497,64 +493,6 @@ memoize (SCM exp, SCM env) (MAKMEMO_LET (inits, memoize (body, new_env)), env); } - case SCM_EXPANDED_LETREC: - { - SCM vars, varsv, exps, expsv, 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)); - - varsv = scm_vector (vars); - nvars = VECTOR_LENGTH (varsv); - expsv = scm_vector (exps); - - undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED)); - new_env = scm_cons (varsv, capture_env (env)); - - if (in_order_p) - { - SCM body_exps = memoize (body, new_env); - for (i = nvars - 1; i >= 0; i--) - { - SCM init = memoize (VECTOR_REF (expsv, i), new_env); - body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init), - body_exps); - } - return maybe_makmemo_capture_module - (MAKMEMO_LET (undefs, body_exps), env); - } - else - { - SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F); - for (i = nvars - 1; i >= 0; i--) - { - SCM init, set; - - init = memoize (VECTOR_REF (expsv, i), new_env); - VECTOR_SET (inits, i, init); - - set = MAKMEMO_LEX_SET (make_pos (1, i), - MAKMEMO_LEX_REF (make_pos (0, i))); - if (scm_is_false (sets)) - sets = set; - else - sets = MAKMEMO_SEQ (set, sets); - } - - if (scm_is_false (sets)) - return memoize (body, env); - - return maybe_makmemo_capture_module - (MAKMEMO_LET (undefs, - MAKMEMO_SEQ (MAKMEMO_LET (inits, sets), - memoize (body, new_env))), - env); - } - } - default: abort (); } @@ -670,7 +608,7 @@ unmemoize (const SCM expr) { SCM alt, tail; - alt = CADDR (CDDDR (spec)); + alt = CADDDR (CDDDR (spec)); if (scm_is_true (alt)) tail = CDR (unmemoize (alt)); else @@ -682,7 +620,7 @@ unmemoize (const SCM expr) CADR (spec), CADDR (spec), CADDDR (spec), - unmemoize_exprs (CADR (CDDDR (spec)))), + CADR (CDDDR (spec))), unmemoize (body)), tail)); } diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 89d17cd91..98db033ea 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -329,16 +329,10 @@ ;; of arguments, and some rest arities; see make-fixed-closure and ;; make-rest-closure above. - ;; A unique marker for unbound keywords. NB: There should be no - ;; other instance of '(unbound-arg) in this compilation unit, so - ;; that this marker is indeed unique. It's a hack, but it allows - ;; the constant to propagate to inner closures, reducing free - ;; variable counts all around, so it is important for perf. - (define unbound-arg '(unbound-arg)) - ;; Procedures with rest, optional, or keyword arguments, potentially with ;; multiple arities, as with case-lambda. - (define (make-general-closure env body nreq rest? nopt kw inits alt) + (define (make-general-closure env body nreq rest? nopt kw ninits unbound + alt) (define alt-proc (and alt ; (body meta nreq ...) (let* ((body (car alt)) @@ -348,9 +342,11 @@ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) (nopt (if tail (car tail) 0)) (kw (and tail (cadr tail))) - (inits (if tail (caddr tail) '())) - (alt (and tail (cadddr tail)))) - (make-general-closure env body nreq rest nopt kw inits alt)))) + (ninits (if tail (caddr tail) 0)) + (unbound (and tail (cadddr tail))) + (alt (and tail (car (cddddr tail))))) + (make-general-closure env body nreq rest nopt kw ninits unbound + alt)))) (define (set-procedure-arity! proc) (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) (if (not alt) @@ -367,7 +363,7 @@ (rest?* (if (null? (cdr spec)) #f (cadr spec))) (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) (nopt* (if tail (car tail) 0)) - (alt* (and tail (cadddr tail)))) + (alt* (and tail (car (cddddr tail))))) (if (or (< nreq* nreq) (and (= nreq* nreq) (if rest? @@ -395,8 +391,8 @@ "eval" "Wrong number of arguments" '() #f)))) (else - (let* ((nvals (+ nreq (if rest? 1 0) (length inits))) - (env (make-env nvals unbound-arg env))) + (let* ((nvals (+ nreq (if rest? 1 0) ninits)) + (env (make-env nvals unbound env))) (let lp ((i 0) (args %args)) (cond ((< i nreq) @@ -405,39 +401,30 @@ (lp (1+ i) (cdr args))) ((not kw) ;; Optional args (possibly), but no keyword args. - (let lp ((i i) (args args) (inits inits)) + (let lp ((i i) (args args)) (cond - ((< i (+ nreq nopt)) - (cond - ((< i nargs) - (env-set! env 0 i (car args)) - (lp (1+ i) (cdr args) (cdr inits))) - (else - (env-set! env 0 i (eval (car inits) env)) - (lp (1+ i) args (cdr inits))))) + ((and (< i (+ nreq nopt)) (< i nargs)) + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args))) (else (when rest? - (env-set! env 0 i args)) + (env-set! env 0 (+ nreq nopt) args)) (eval body env))))) (else ;; Optional args. As before, but stop at the first ;; keyword. - (let lp ((i i) (args args) (inits inits)) + (let lp ((i i) (args args)) (cond - ((< i (+ nreq nopt)) - (cond - ((and (< i nargs) (not (keyword? (car args)))) - (env-set! env 0 i (car args)) - (lp (1+ i) (cdr args) (cdr inits))) - (else - (env-set! env 0 i (eval (car inits) env)) - (lp (1+ i) args (cdr inits))))) + ((and (< i (+ nreq nopt)) + (< i nargs) + (not (keyword? (car args)))) + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args))) (else (when rest? - (env-set! env 0 i args)) + (env-set! env 0 (+ nreq nopt) args)) (let ((aok (car kw)) - (kw (cdr kw)) - (kw-base (if rest? (1+ i) i))) + (kw (cdr kw))) ;; Now scan args for keywords. (let lp ((args args)) (cond @@ -463,19 +450,8 @@ "eval" "Invalid keyword" '() (list (car args)))))) (else - ;; Finished parsing keywords. Fill in - ;; uninitialized kwargs by evalling init - ;; expressions in their appropriate - ;; environment. - (let lp ((i kw-base) (inits inits)) - (cond - ((pair? inits) - (when (eq? (env-ref env 0 i) unbound-arg) - (env-set! env 0 i (eval (car inits) env))) - (lp (1+ i) (cdr inits))) - (else - ;; Finally, eval the body. - (eval body env))))))))))))))))))))) + ;; Finally, eval the body. + (eval body env)))))))))))))))))) ;; The "engine". EXP is a memoized expression. (define (eval exp env) @@ -513,9 +489,10 @@ (if (null? tail) (make-rest-closure eval nreq body env) (mx-bind - tail (nopt kw inits alt) + tail (nopt kw ninits unbound alt) (make-general-closure env body nreq rest? - nopt kw inits alt))))))) + nopt kw ninits unbound + alt))))))) (let lp ((meta meta)) (unless (null? meta) (set-procedure-property! proc (caar meta) (cdar meta))