X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=c5f7b4184d7edb1aa2a1f78b9a0697486ff09a09;hb=b0642df835dc2fca3e4cf47aff978ecdc88799d5;hp=e6f917fbdc05484e420593ffc3a3232660b0004a;hpb=9ce73d3eeef7ed9dda2f8029c5f42cc17798ad51;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index e6f917f..c5f7b41 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -903,7 +903,7 @@ (declare (list decl vars) (type lexenv res)) (let ((type (compiler-specifier-type (first decl)))) (collect ((restr nil cons) - (new-vars nil cons)) + (new-vars nil cons)) (dolist (var-name (rest decl)) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var @@ -911,26 +911,31 @@ (find-free-var var-name)))) (etypecase var (leaf - (let* ((old-type (or (lexenv-find var type-restrictions) - (leaf-type var))) - (int (if (or (fun-type-p type) - (fun-type-p old-type)) - type - (type-approx-intersection2 old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy *lexenv* (= inhibit-warnings 3)) - (compiler-warn - "The type declarations ~S and ~S for ~S conflict." - (type-specifier old-type) (type-specifier type) - var-name))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (restr (cons var int)))))) + (flet ((process-var (var bound-var) + (let* ((old-type (or (lexenv-find var type-restrictions) + (leaf-type var))) + (int (if (or (fun-type-p type) + (fun-type-p old-type)) + type + (type-approx-intersection2 old-type type)))) + (cond ((eq int *empty-type*) + (unless (policy *lexenv* (= inhibit-warnings 3)) + (compiler-warn + "The type declarations ~S and ~S for ~S conflict." + (type-specifier old-type) (type-specifier type) + var-name))) + (bound-var (setf (leaf-type bound-var) int)) + (t + (restr (cons var int))))))) + (process-var var bound-var) + (awhen (and (lambda-var-p var) + (lambda-var-specvar var)) + (process-var it nil)))) (cons ;; FIXME: non-ANSI weirdness (aver (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl) - ,(cdr var)))))) + ,(cdr var)))))) (heap-alien-info (compiler-error "~S is an alien variable, so its type can't be declared." @@ -1437,7 +1442,8 @@ aux-vals result (source-name '.anonymous.) - debug-name) + debug-name + (note-lexical-bindings t)) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) @@ -1473,7 +1479,8 @@ (svars var) (new-venv (cons (leaf-source-name specvar) specvar))) (t - (note-lexical-binding (leaf-source-name var)) + (when note-lexical-bindings + (note-lexical-binding (leaf-source-name var))) (new-venv (cons (leaf-source-name var) var)))))) (let ((*lexenv* (make-lexenv :vars (new-venv) @@ -1481,7 +1488,7 @@ :cleanup nil))) (setf (bind-lambda bind) lambda) (setf (node-lexenv bind) *lexenv*) - + (let ((cont1 (make-continuation)) (cont2 (make-continuation))) (continuation-starts-block cont1) @@ -1522,19 +1529,27 @@ (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) (arg-vars (mapcar (lambda (var) - (unless (lambda-var-specvar var) - (note-lexical-binding (leaf-source-name var))) (make-lambda-var :%source-name (leaf-source-name var) :type (leaf-type var) :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (fun (ir1-convert-lambda-body `((%funcall ,fun - ,@(reverse vals) - ,@defaults)) - arg-vars - :debug-name "&OPTIONAL processor"))) + (fun (collect ((default-bindings) + (default-vals)) + (dolist (default defaults) + (if (constantp default) + (default-vals default) + (let ((var (gensym))) + (default-bindings `(,var ,default)) + (default-vals var)))) + (ir1-convert-lambda-body `((let (,@(default-bindings)) + (%funcall ,fun + ,@(reverse vals) + ,@(default-vals)))) + arg-vars + :debug-name "&OPTIONAL processor" + :note-lexical-bindings nil)))) (mapc (lambda (var arg-var) (when (cdr (leaf-refs arg-var)) (setf (leaf-ever-used var) t))) @@ -1703,9 +1718,10 @@ `((let ,(temps) ,@(body) (%funcall ,(optional-dispatch-main-entry res) - . ,(arg-vals)))) ; FIXME: What is the '.'? ,@? + ,@(arg-vals)))) (arg-vars) - :debug-name (debug-namify "~S processing" '&more)))) + :debug-name (debug-namify "~S processing" '&more) + :note-lexical-bindings nil))) (setf (optional-dispatch-more-entry res) ep)))) (values)) @@ -1993,6 +2009,37 @@ (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) res))))) + +;;; helper for LAMBDA-like things, to massage them into a form +;;; suitable for IR1-CONVERT-LAMBDA. +;;; +;;; KLUDGE: We cons up a &REST list here, maybe for no particularly +;;; good reason. It's probably lost in the noise of all the other +;;; consing, but it's still inelegant. And we force our called +;;; functions to do full runtime keyword parsing, ugh. -- CSR, +;;; 2003-01-25 +(defun ir1-convert-lambdalike (thing &rest args + &key (source-name '.anonymous.) + debug-name allow-debug-catch-tag) + (ecase (car thing) + ((lambda) (apply #'ir1-convert-lambda thing args)) + ((instance-lambda) + (let ((res (apply #'ir1-convert-lambda + `(lambda ,@(cdr thing)) args))) + (setf (getf (functional-plist res) :fin-function) t) + res)) + ((named-lambda) + (let ((name (cadr thing))) + (if (legal-fun-name-p name) + (let ((res (apply #'ir1-convert-lambda `(lambda ,@(cddr thing)) + :source-name name + :debug-name nil + args))) + (assert-global-function-definition-type name res) + res) + (apply #'ir1-convert-lambda `(lambda ,@(cddr thing)) + :debug-name name args)))) + ((lambda-with-lexenv) (apply #'ir1-convert-inline-lambda thing args)))) ;;;; defining global functions @@ -2002,7 +2049,8 @@ ;;; reflect the state at the definition site. (defun ir1-convert-inline-lambda (fun &key (source-name '.anonymous.) - debug-name) + debug-name + allow-debug-catch-tag) (destructuring-bind (decls macros symbol-macros &rest body) (if (eq (car fun) 'lambda-with-lexenv) (cdr fun) @@ -2019,7 +2067,8 @@ :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) :source-name source-name - :debug-name debug-name)))) + :debug-name debug-name + :allow-debug-catch-tag nil)))) ;;; Get a DEFINED-FUN object for a function we are about to define. If ;;; the function has been forward referenced, then substitute for the