X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/dfadcf85cb3ae9133dece6bc39ed03dd25323d6e..28d5d2537c0321643c3b511a2195cd491204e7f2:/module/ice-9/eval.scm diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index d993db0c7..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, 2011 -;;;; 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 @@ -65,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))) @@ -204,8 +203,6 @@ ;;; module-ref: 14468 ;;; define: 1259 ;;; toplevel-set: 328 -;;; dynwind: 162 -;;; with-fluids: 0 ;;; call/cc: 0 ;;; module-set: 0 ;;; @@ -225,11 +222,12 @@ ;; multiple arities, as with case-lambda. (define (make-general-closure env body nreq rest? nopt kw inits alt) (define alt-proc - (and alt + (and alt ; (body docstring nreq ...) (let* ((body (car alt)) - (nreq (cadr alt)) - (rest (if (null? (cddr alt)) #f (caddr alt))) - (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr 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) '())) @@ -238,10 +236,18 @@ (define (set-procedure-arity! proc) (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?)) (if (not alt) - (set-procedure-minimum-arity! proc nreq nopt rest?) - (let* ((nreq* (cadr alt)) - (rest?* (if (null? (cddr alt)) #f (caddr alt))) - (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr 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) @@ -290,72 +296,83 @@ (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))))))))))))))) + (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) @@ -390,14 +407,20 @@ (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)))) + + (('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 @@ -438,24 +461,11 @@ 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)))