X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=6bf18435ee1b80673d56a45581cce1eef070dff9;hb=f741a144c386acdb82cac2e3352abab7cff65f1d;hp=ab8bd8baaf31ea769bb7fc1bb0e44797d86d955b;hpb=f181ad9ffeeadf341b6a16c3591eadf0c1e3fa61;p=sbcl.git diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index ab8bd8b..6bf1843 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -1007,15 +1007,17 @@ :source-name source-name :debug-name debug-name)) ((instance-lambda) - (deprecation-warning 'instance-lambda 'lambda) - (ir1-convert-lambda `(lambda ,@(cdr thing)) + (deprecation-warning :final "0.9.3.32" 'instance-lambda 'lambda) + (ir1-convert-lambda `(lambda (&rest args) + (declare (ignore args)) + (deprecation-error "0.9.3.32" 'instance-lambda 'lambda)) :source-name source-name :debug-name debug-name)) ((named-lambda) (let ((name (cadr thing)) (lambda-expression `(lambda ,@(cddr thing)))) (if (and name (legal-fun-name-p name)) - (let ((defined-fun-res (get-defined-fun name)) + (let ((defined-fun-res (get-defined-fun name (second lambda-expression))) (res (ir1-convert-lambda lambda-expression :maybe-add-debug-catch t :source-name name))) @@ -1073,29 +1075,62 @@ (setf (functional-inline-expanded clambda) t) clambda))) +;;; Given a lambda-list, return a FUN-TYPE object representing the signature: +;;; return type is *, and each individual arguments type is T -- but we get +;;; the argument counts and keywords. +(defun ftype-from-lambda-list (lambda-list) + (multiple-value-bind (req opt restp rest-name keyp key-list allowp morep) + (parse-lambda-list lambda-list) + (declare (ignore rest-name)) + (flet ((t (list) + (mapcar (constantly t) list))) + (let ((reqs (t req)) + (opts (when opt (cons '&optional (t opt)))) + ;; When it comes to building a type, &REST means pretty much the + ;; same thing as &MORE. + (rest (when (or morep restp) (list '&rest t))) + (keys (when keyp + (cons '&key (mapcar (lambda (spec) + (let ((key/var (if (consp spec) + (car spec) + spec))) + (list (if (consp key/var) + (car key/var) + (keywordicate key/var)) + t))) + key-list)))) + (allow (when allowp (list '&allow-other-keys)))) + (specifier-type `(function (,@reqs ,@opts ,@rest ,@keys ,@allow) *)))))) + ;;; Get a DEFINED-FUN object for a function we are about to define. If ;;; the function has been forward referenced, then substitute for the ;;; previous references. -(defun get-defined-fun (name) +(defun get-defined-fun (name &optional (lambda-list nil lp)) (proclaim-as-fun-name name) - (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) - (note-name-defined name :function) - (cond ((not (defined-fun-p found)) - (aver (not (info :function :inlinep name))) - (let* ((where-from (leaf-where-from found)) - (res (make-defined-fun - :%source-name name - :where-from (if (eq where-from :declared) - :declared :defined) - :type (leaf-type found)))) - (substitute-leaf res found) - (setf (gethash name *free-funs*) res))) - ;; If *FREE-FUNS* has a previously converted definition - ;; for this name, then blow it away and try again. - ((defined-fun-functionals found) - (remhash name *free-funs*) - (get-defined-fun name)) - (t found)))) + (when (boundp '*free-funs*) + (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) + (note-name-defined name :function) + (cond ((not (defined-fun-p found)) + (aver (not (info :function :inlinep name))) + (let* ((where-from (leaf-where-from found)) + (res (make-defined-fun + :%source-name name + :where-from (if (eq where-from :declared) + :declared + :defined-here) + :type (if (eq :declared where-from) + (leaf-type found) + (if lp + (ftype-from-lambda-list lambda-list) + (specifier-type 'function)))))) + (substitute-leaf res found) + (setf (gethash name *free-funs*) res))) + ;; If *FREE-FUNS* has a previously converted definition + ;; for this name, then blow it away and try again. + ((defined-fun-functionals found) + (remhash name *free-funs*) + (get-defined-fun name lambda-list)) + (t found))))) ;;; Check a new global function definition for consistency with ;;; previous declaration or definition, and assert argument/result @@ -1146,6 +1181,27 @@ (setf (functional-inlinep fun) inlinep) (assert-new-definition var fun) (setf (defined-fun-inline-expansion var) expansion) + ;; Associate VAR with the FUN -- and in case of an optional dispatch + ;; with the various entry-points. This allows XREF to know where the + ;; inline CLAMBDA comes from. + (flet ((note-inlining (f) + (typecase f + (functional + (setf (functional-inline-expanded f) var)) + (cons + ;; Delayed entry-point. + (if (car f) + (setf (functional-inline-expanded (cdr f)) var) + (let ((old-thunk (cdr f))) + (setf (cdr f) (lambda () + (let ((g (funcall old-thunk))) + (setf (functional-inline-expanded g) var) + g))))))))) + (note-inlining fun) + (when (optional-dispatch-p fun) + (note-inlining (optional-dispatch-main-entry fun)) + (note-inlining (optional-dispatch-more-entry fun)) + (mapc #'note-inlining (optional-dispatch-entry-points fun)))) ;; substitute for any old references (unless (or (not *block-compile*) (and info @@ -1162,14 +1218,15 @@ (defun %compiler-defun (name lambda-with-lexenv compile-toplevel) (let ((defined-fun nil)) ; will be set below if we're in the compiler (when compile-toplevel - ;; better be in the compiler - (aver (boundp '*lexenv*)) - (remhash name *free-funs*) - (setf defined-fun (get-defined-fun 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*))) + (setf defined-fun (if lambda-with-lexenv + (get-defined-fun name (fifth lambda-with-lexenv)) + (get-defined-fun name))) + (when (boundp '*lexenv*) + (remhash name *free-funs*) + (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) @@ -1185,8 +1242,7 @@ ;; old CMU CL comment: ;; If there is a type from a previous definition, blast it, ;; since it is obsolete. - (when (and defined-fun - (eq (leaf-where-from defined-fun) :defined)) + (when (and defined-fun (neq :declared (leaf-where-from defined-fun))) (setf (leaf-type defined-fun) ;; FIXME: If this is a block compilation thing, shouldn't ;; we be setting the type to the full derived type for the