X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=c107a938282ab3f8e0c37e1405c5f5705e3792cf;hb=e73a30c901ab234291aefc9f1e73507650628892;hp=1f4b91dc7ae09b7303d71c8af10d102e62253403;hpb=f8c2f73dea06d9728cae4d2e8dc28c682ac2ecd2;p=sbcl.git diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 1f4b91d..c107a93 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -214,7 +214,7 @@ :aux-vars (rest aux-vars) :aux-vals (rest aux-vals) :debug-name (debug-namify - "&AUX bindings ~S" + "&AUX bindings " aux-vars)))) (reference-leaf start ctran fun-lvar fun) (ir1-convert-combination-args fun-lvar ctran next result @@ -255,6 +255,25 @@ (rest svars)))))) (values)) +;;; FIXME: this is the interface of the CMUCL WITH-DYNAMIC-EXTENT +;;; macro. It is slightly confusing, in that START and BODY-START are +;;; already-existing CTRANs (and FIXME: probably deserve a ONCE-ONLY), +;;; whereas NEXT is a variable naming a CTRAN in the body. -- CSR, +;;; 2004-03-30. +(defmacro with-dynamic-extent ((start body-start next kind) &body body) + (declare (ignore kind)) + (with-unique-names (cleanup next-ctran) + `(progn + (ctran-starts-block ,body-start) + (let ((,cleanup (make-cleanup :kind :dynamic-extent)) + (,next-ctran (make-ctran)) + (,next (make-ctran))) + (ir1-convert ,start ,next-ctran nil '(%dynamic-extent-start)) + (setf (cleanup-mess-up ,cleanup) (ctran-use ,next-ctran)) + (let ((*lexenv* (make-lexenv :cleanup ,cleanup))) + (ir1-convert ,next-ctran ,next nil '(%cleanup-point)) + (locally ,@body)))))) + ;;; Create a lambda node out of some code, returning the result. The ;;; bindings are specified by the list of VAR structures VARS. We deal ;;; with adding the names to the LEXENV-VARS for the conversion. The @@ -267,7 +286,7 @@ ;;; the special binding code. ;;; ;;; We ignore any ARG-INFO in the VARS, trusting that someone else is -;;; dealing with &nonsense. +;;; dealing with &NONSENSE, except for &REST vars with DYNAMIC-EXTENT. ;;; ;;; AUX-VARS is a list of VAR structures for variables that are to be ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated @@ -291,7 +310,8 @@ :%source-name source-name :%debug-name debug-name)) (result-ctran (make-ctran)) - (result-lvar (make-lvar))) + (result-lvar (make-lvar)) + (dx-rest nil)) (awhen (lexenv-lambda *lexenv*) (push lambda (lambda-children it)) @@ -321,7 +341,12 @@ (t (when note-lexical-bindings (note-lexical-binding (leaf-source-name var))) - (new-venv (cons (leaf-source-name var) var)))))) + (new-venv (cons (leaf-source-name var) var))))) + (let ((info (lambda-var-arg-info var))) + (when (and info + (eq (arg-info-kind info) :rest) + (leaf-dynamic-extent var)) + (setq dx-rest t)))) (let ((*lexenv* (make-lexenv :vars (new-venv) :lambda lambda @@ -346,9 +371,14 @@ (ctran-starts-block prebind-ctran) (link-node-to-previous-ctran bind prebind-ctran) (use-ctran bind postbind-ctran) - (ir1-convert-special-bindings postbind-ctran result-ctran result-lvar - body - aux-vars aux-vals (svars)))))) + (if dx-rest + (with-dynamic-extent (postbind-ctran result-ctran dx :rest) + (ir1-convert-special-bindings dx result-ctran result-lvar + body aux-vars aux-vals + (svars))) + (ir1-convert-special-bindings postbind-ctran result-ctran + result-lvar body + aux-vars aux-vals (svars))))))) (link-blocks (component-head *current-component*) (node-block bind)) (push lambda (component-new-functionals *current-component*)) @@ -397,8 +427,8 @@ ,@(default-vals)))) arg-vars :debug-name - (debug-namify "&OPTIONAL processor ~D" - (random 100)) + (debug-namify "&OPTIONAL processor " + (gensym)) :note-lexical-bindings nil)))) (mapc (lambda (var arg-var) (when (cdr (leaf-refs arg-var)) @@ -514,7 +544,8 @@ (arg-vars context-temp count-temp) (when rest - (arg-vals `(%listify-rest-args ,n-context ,n-count))) + (arg-vals `(%listify-rest-args + ,n-context ,n-count ,(leaf-dynamic-extent rest)))) (when morep (arg-vals n-context) (arg-vals n-count)) @@ -564,7 +595,7 @@ (tests `((eq ,n-key :allow-other-keys) (setq ,n-allowp ,n-value-temp)))) (tests `(t - (setq ,n-losep ,n-key)))) + (setq ,n-losep (list ,n-key))))) (body `(when (oddp ,n-count) @@ -583,7 +614,7 @@ (unless allowp (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-key-arg-error ,n-losep))))))) + (%unknown-key-arg-error (car ,n-losep)))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) @@ -591,7 +622,7 @@ (%funcall ,(optional-dispatch-main-entry res) ,@(arg-vals)))) (arg-vars) - :debug-name (debug-namify "~S processing" '&more) + :debug-name "&MORE processing" :note-lexical-bindings nil))) (setf (optional-dispatch-more-entry res) (register-entry-point ep res))))) @@ -677,9 +708,8 @@ body (main-vars) :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) - :debug-name (debug-namify "varargs entry for ~A" - (as-debug-name source-name - debug-name)))) + :debug-name (debug-namify + "varargs entry for " source-name debug-name))) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) @@ -747,9 +777,9 @@ :aux-vars aux-vars :aux-vals aux-vals :debug-name (debug-namify - "hairy arg processor for ~A" - (as-debug-name source-name - debug-name))))) + "hairy arg processor for " + source-name + debug-name)))) (setf (optional-dispatch-main-entry res) fun) (register-entry-point fun res) (push (if supplied-p-p @@ -816,7 +846,7 @@ &key (source-name '.anonymous.) (debug-name (debug-namify - "OPTIONAL-DISPATCH ~S" + "OPTIONAL-DISPATCH " vars))) (declare (list body vars aux-vars aux-vals)) (let ((res (make-optional-dispatch :arglist vars @@ -936,6 +966,7 @@ (source-name '.anonymous.) debug-name allow-debug-catch-tag) + (declare (ignore allow-debug-catch-tag)) (destructuring-bind (decls macros symbol-macros &rest body) (if (eq (car fun) 'lambda-with-lexenv) (cdr fun) @@ -1050,18 +1081,25 @@ ;;; ;;; The INLINE-EXPANSION is a LAMBDA-WITH-LEXENV, or NIL if there is ;;; no inline expansion. -(defun %compiler-defun (name lambda-with-lexenv) +(defun %compiler-defun (name lambda-with-lexenv compile-toplevel) (let ((defined-fun nil)) ; will be set below if we're in the compiler - (when (boundp '*lexenv*) ; when in the compiler + (when compile-toplevel + ;; better be in the compiler + (aver (boundp '*lexenv*)) (when sb!xc:*compile-print* (compiler-mumble "~&; recognizing DEFUN ~S~%" name)) (remhash name *free-funs*) - (setf defined-fun (get-defined-fun name))) + (setf defined-fun (get-defined-fun name)) - (become-defined-fun-name name) + (aver (fasl-output-p *compile-object*)) + (if (member name *fun-names-in-this-file* :test #'equal) + (warn 'duplicate-definition :name name) + (push name *fun-names-in-this-file*))) + (become-defined-fun-name name) + (cond (lambda-with-lexenv (setf (info :function :inline-expansion-designator name) lambda-with-lexenv)