X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/7572ee5261f434cf9b8e58126eb6d87c085a596d..28d5d2537c0321643c3b511a2195cd491204e7f2:/module/ice-9/eval.scm diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index e6e5f1713..fdf16c8ae 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -1,7 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 2009, 2010 -;;;; Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -46,6 +45,9 @@ (eval-when (compile) (define-syntax capture-env (syntax-rules () + ((_ (exp ...)) + (let ((env (exp ...))) + (capture-env env))) ((_ env) (if (null? env) (current-module) @@ -62,7 +64,7 @@ (define (make-formals n) (map (lambda (i) (datum->syntax - x + x (string->symbol (string (integer->char (+ (char->integer #\a) i)))))) (iota n))) @@ -201,8 +203,6 @@ ;;; module-ref: 14468 ;;; define: 1259 ;;; toplevel-set: 328 -;;; dynwind: 162 -;;; with-fluids: 0 ;;; call/cc: 0 ;;; module-set: 0 ;;; @@ -222,121 +222,164 @@ ;; multiple arities, as with case-lambda. (define (make-general-closure env body nreq rest? nopt kw inits alt) (define alt-proc - (and alt - (apply make-general-closure env (memoized-expression-data alt)))) - (lambda %args - (let lp ((env env) - (nreq* nreq) - (args %args)) - (if (> nreq* 0) - ;; First, bind required arguments. - (if (null? args) - (if alt - (apply alt-proc %args) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f)) - (lp (cons (car args) env) - (1- nreq*) - (cdr args))) - ;; Move on to optional arguments. - (if (not kw) - ;; Without keywords, bind optionals from arguments. - (let lp ((env env) - (nopt nopt) - (args args) - (inits inits)) - (if (zero? nopt) - (if rest? - (eval body (cons args env)) - (if (null? args) - (eval body env) - (if alt - (apply alt-proc %args) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f)))) - (if (null? args) - (lp (cons (eval (car inits) env) env) - (1- nopt) args (cdr inits)) - (lp (cons (car args) env) - (1- nopt) (cdr args) (cdr inits))))) - ;; With keywords, we stop binding optionals at the first - ;; keyword. - (let lp ((env env) - (nopt* nopt) - (args args) - (inits inits)) - (if (> nopt* 0) - (if (or (null? args) (keyword? (car args))) - (lp (cons (eval (car inits) env) env) - (1- nopt*) args (cdr inits)) - (lp (cons (car args) env) - (1- nopt*) (cdr args) (cdr inits))) - ;; Finished with optionals. - (let* ((aok (car kw)) - (kw (cdr kw)) - (kw-base (+ nopt nreq (if rest? 1 0))) - (imax (let lp ((imax (1- kw-base)) (kw kw)) - (if (null? kw) - imax - (lp (max (cdar kw) imax) - (cdr kw))))) - ;; Fill in kwargs with "undefined" vals. - (env (let lp ((i kw-base) - ;; Also, here we bind the rest - ;; arg, if any. - (env (if rest? (cons args env) env))) - (if (<= i imax) - (lp (1+ i) (cons unbound-arg env)) - env)))) - ;; Now scan args for keywords. - (let lp ((args args)) - (if (and (pair? args) (pair? (cdr args)) - (keyword? (car args))) - (let ((kw-pair (assq (car args) kw)) - (v (cadr args))) - (if kw-pair - ;; Found a known keyword; set its value. - (list-set! env (- imax (cdr kw-pair)) v) - ;; Unknown keyword. - (if (not aok) - (scm-error 'keyword-argument-error - "eval" "Unrecognized keyword" - '() #f))) - (lp (cddr args))) - (if (pair? args) - (if rest? - ;; Be lenient parsing rest args. - (lp (cdr args)) - (scm-error 'keyword-argument-error - "eval" "Invalid keyword" - '() #f)) - ;; Finished parsing keywords. Fill in - ;; uninitialized kwargs by evalling init - ;; expressions in their appropriate - ;; environment. - (let lp ((i (- imax kw-base)) - (inits inits)) - (if (pair? inits) - (let ((tail (list-tail env i))) - (if (eq? (car tail) unbound-arg) - (set-car! tail - (eval (car inits) - (cdr tail)))) - (lp (1- i) (cdr inits))) - ;; Finally, eval the body. - (eval body env)))))))))))))) + (and alt ; (body docstring nreq ...) + (let* ((body (car alt)) + (spec (cddr alt)) + (nreq (car spec)) + (rest (if (null? (cdr spec)) #f (cadr spec))) + (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)))) + (define (set-procedure-arity! proc) + (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) + (if (not alt) + (begin + (set-procedure-property! proc 'arglist + (list nreq + nopt + (if kw (cdr kw) '()) + (and kw (car kw)) + (and rest? '_))) + (set-procedure-minimum-arity! proc nreq nopt rest?)) + (let* ((spec (cddr alt)) + (nreq* (car spec)) + (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)))) + (if (or (< nreq* nreq) + (and (= nreq* nreq) + (if rest? + (and rest?* (> nopt* nopt)) + (or rest?* (> nopt* nopt))))) + (lp alt* nreq* nopt* rest?*) + (lp alt* nreq nopt rest?))))) + proc) + (set-procedure-arity! + (lambda %args + (let lp ((env env) + (nreq* nreq) + (args %args)) + (if (> nreq* 0) + ;; First, bind required arguments. + (if (null? args) + (if alt + (apply alt-proc %args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (lp (cons (car args) env) + (1- nreq*) + (cdr args))) + ;; Move on to optional arguments. + (if (not kw) + ;; Without keywords, bind optionals from arguments. + (let lp ((env env) + (nopt nopt) + (args args) + (inits inits)) + (if (zero? nopt) + (if rest? + (eval body (cons args env)) + (if (null? args) + (eval body env) + (if alt + (apply alt-proc %args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)))) + (if (null? args) + (lp (cons (eval (car inits) env) env) + (1- nopt) args (cdr inits)) + (lp (cons (car args) env) + (1- nopt) (cdr args) (cdr inits))))) + (let lp ((env env) + (nopt* nopt) + (args args) + (inits inits)) + (cond + ;; With keywords, we stop binding optionals at the + ;; first keyword. + ((> nopt* 0) + (if (or (null? args) (keyword? (car args))) + (lp (cons (eval (car inits) env) env) + (1- nopt*) args (cdr inits)) + (lp (cons (car args) env) + (1- nopt*) (cdr args) (cdr inits)))) + ;; Finished with optionals. + ((and alt (pair? args) (not (keyword? (car args))) + (not rest?)) + ;; Too many positional args, no #:rest arg, + ;; and we have an alternate. + (apply alt-proc %args)) + (else + (let* ((aok (car kw)) + (kw (cdr kw)) + (kw-base (+ nopt nreq (if rest? 1 0))) + (imax (let lp ((imax (1- kw-base)) (kw kw)) + (if (null? kw) + imax + (lp (max (cdar kw) imax) + (cdr kw))))) + ;; Fill in kwargs with "undefined" vals. + (env (let lp ((i kw-base) + ;; Also, here we bind the rest + ;; arg, if any. + (env (if rest? + (cons args env) + env))) + (if (<= i imax) + (lp (1+ i) (cons unbound-arg env)) + env)))) + ;; Now scan args for keywords. + (let lp ((args args)) + (if (and (pair? args) (pair? (cdr args)) + (keyword? (car args))) + (let ((kw-pair (assq (car args) kw)) + (v (cadr args))) + (if kw-pair + ;; Found a known keyword; set its value. + (list-set! env + (- imax (cdr kw-pair)) v) + ;; Unknown keyword. + (if (not aok) + (scm-error + 'keyword-argument-error + "eval" "Unrecognized keyword" + '() (list (car args))))) + (lp (cddr args))) + (if (pair? args) + (if rest? + ;; Be lenient parsing rest args. + (lp (cdr args)) + (scm-error 'keyword-argument-error + "eval" "Invalid keyword" + '() (list (car args)))) + ;; Finished parsing keywords. Fill in + ;; uninitialized kwargs by evalling init + ;; expressions in their appropriate + ;; environment. + (let lp ((i (- imax kw-base)) + (inits inits)) + (if (pair? inits) + (let ((tail (list-tail env i))) + (if (eq? (car tail) unbound-arg) + (set-car! tail + (eval (car inits) + (cdr tail)))) + (lp (1- i) (cdr inits))) + ;; Finally, eval the body. + (eval body env)))))))))))))))) ;; The "engine". EXP is a memoized expression. (define (eval exp env) (memoized-expression-case exp (('lexical-ref n) - (let lp ((n n) (env env)) - (if (zero? n) - (car env) - (lp (1- n) (cdr env))))) - + (list-ref env n)) + (('call (f nargs . args)) (let ((proc (eval f env))) (call eval proc nargs args env))) @@ -345,10 +388,10 @@ (variable-ref (if (variable? var-or-sym) var-or-sym - (let lp ((env env)) - (if (pair? env) - (lp (cdr env)) - (memoize-variable-access! exp (capture-env env))))))) + (memoize-variable-access! exp + (capture-env (if (pair? env) + (cdr (last-pair env)) + env)))))) (('if (test consequent . alternate)) (if (eval test env) @@ -364,29 +407,29 @@ (eval body new-env) (lp (cdr inits) (cons (eval (car inits) env) new-env))))) - - (('lambda (body nreq . tail)) - (if (null? tail) - (make-fixed-closure eval nreq body (capture-env env)) - (if (null? (cdr tail)) - (make-general-closure (capture-env env) body nreq (car tail) - 0 #f '() #f) - (apply make-general-closure (capture-env env) body nreq tail)))) - (('begin (first . rest)) - (let lp ((first first) (rest rest)) - (if (null? rest) - (eval first env) - (begin - (eval first env) - (lp (car rest) (cdr rest)))))) - + (('lambda (body docstring nreq . tail)) + (let ((proc + (if (null? tail) + (make-fixed-closure eval nreq body (capture-env env)) + (if (null? (cdr tail)) + (make-general-closure (capture-env env) body + nreq (car tail) + 0 #f '() #f) + (apply make-general-closure (capture-env env) + body nreq tail))))) + (when docstring + (set-procedure-property! proc 'documentation docstring)) + proc)) + + (('seq (head . tail)) + (begin + (eval head env) + (eval tail env))) + (('lexical-set! (n . x)) (let ((val (eval x env))) - (let lp ((n n) (env env)) - (if (zero? n) - (set-car! env val) - (lp (1- n) (cdr env)))))) + (list-set! env n val))) (('call-with-values (producer . consumer)) (call-with-values (eval producer env) @@ -402,36 +445,27 @@ (memoize-variable-access! exp #f)))) (('define (name . x)) - (define! name (eval x env))) + (let ((x (eval x env))) + (if (and (procedure? x) (not (procedure-property x 'name))) + (set-procedure-property! x 'name name)) + (define! name x) + (if #f #f))) (('toplevel-set! (var-or-sym . x)) (variable-set! (if (variable? var-or-sym) var-or-sym - (let lp ((env env)) - (if (pair? env) - (lp (cdr env)) - (memoize-variable-access! exp (capture-env env))))) + (memoize-variable-access! exp + (capture-env (if (pair? env) + (cdr (last-pair env)) + env)))) (eval x env))) - (('dynwind (in exp . out)) - (dynamic-wind (eval in env) - (lambda () (eval exp env)) - (eval out env))) - - (('with-fluids (fluids vals . exp)) - (let* ((fluids (map (lambda (x) (eval x env)) fluids)) - (vals (map (lambda (x) (eval x env)) vals))) - (let lp ((fluids fluids) (vals vals)) - (if (null? fluids) - (eval exp env) - (with-fluids (((car fluids) (car vals))) - (lp (cdr fluids) (cdr vals))))))) - - (('prompt (tag exp . handler)) - (@prompt (eval tag env) - (eval exp env) - (eval handler env))) + (('call-with-prompt (tag thunk . handler)) + (call-with-prompt + (eval tag env) + (eval thunk env) + (eval handler env))) (('call/cc proc) (call/cc (eval proc env))) @@ -447,7 +481,8 @@ (lambda (exp) "Evaluate @var{exp} in the current module." (eval - (if (memoized? exp) - exp - ((module-transformer (current-module)) exp)) + (memoize-expression + (if (macroexpanded? exp) + exp + ((module-transformer (current-module)) exp))) '()))))