X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=ab89de188e92d581f6f93bc5ce68d051ed2f2958;hb=65a01dae3d437a48e8dd0d051a446245f9e29929;hp=8eb3b485b18e0786503edc55cc41527b712c43dd;hpb=71985ecfdc880e6c11a191d799313de9b4e0c12b;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 8eb3b48..ab89de1 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -35,6 +35,8 @@ (node (make-if :test pred :consequent then-block :alternative else-block))) + ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the + ;; order of the following two forms is important (setf (continuation-dest pred) node) (ir1-convert start pred test) (link-node-to-previous-continuation node pred) @@ -344,15 +346,6 @@ macrobindings (lambda (&key vars) (ir1-translate-locally body start cont :vars vars)))) - -;;; not really a special form, but.. -(def-ir1-translator declare ((&rest stuff) start cont) - (declare (ignore stuff)) - ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to - ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR - ;; macro would put the DECLARE in the wrong place, so.. - start cont - (compiler-error "misplaced declaration")) ;;;; %PRIMITIVE ;;;; @@ -435,60 +428,22 @@ be a lambda expression." (if (consp thing) (case (car thing) - ((lambda) + ((lambda named-lambda instance-lambda lambda-with-lexenv) (reference-leaf start cont - (ir1-convert-lambda thing - :debug-name (debug-namify - "#'~S" thing)))) - ((setf) + (ir1-convert-lambdalike + thing + :debug-name (debug-namify "#'~S" thing) + :allow-debug-catch-tag t))) + ((setf sb!pcl::class-predicate sb!pcl::slot-accessor) (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) - ((instance-lambda) - (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) - :debug-name (debug-namify "#'~S" - thing)))) - (setf (getf (functional-plist res) :fin-function) t) - (reference-leaf start cont res))) (t (compiler-error "~S is not a legal function name." thing))) (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var)))) - -;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)), -;;; except that the value of NAME is passed to the compiler for use in -;;; creation of debug information for the resulting function. -;;; -;;; NAME can be a legal function name or some arbitrary other thing. -;;; -;;; If NAME is a legal function name, then the caller should be -;;; planning to set (FDEFINITION NAME) to the created function. -;;; (Otherwise the debug names will be inconsistent and thus -;;; unnecessarily confusing.) -;;; -;;; Arbitrary other things are appropriate for naming things which are -;;; not the FDEFINITION of NAME. E.g. -;;; NAME = (:FLET FOO BAR) -;;; for the FLET function in -;;; (DEFUN BAR (X) -;;; (FLET ((FOO (Y) (+ X Y))) -;;; FOO)) -;;; or -;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T)) -;;; for the function used to implement -;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...). -(def-ir1-translator named-lambda ((name &rest rest) start cont) - (let* ((fun (if (legal-fun-name-p name) - (ir1-convert-lambda `(lambda ,@rest) - :source-name name) - (ir1-convert-lambda `(lambda ,@rest) - :debug-name name))) - (leaf (reference-leaf start cont fun))) - (when (legal-fun-name-p name) - (assert-global-function-definition-type name fun)) - leaf)) ;;;; FUNCALL @@ -575,15 +530,17 @@ During evaluation of the Forms, bind the Vars to the result of evaluating the Value forms. The variables are bound in parallel after all of the Values are evaluated." - (multiple-value-bind (forms decls) (parse-body body nil) - (multiple-value-bind (vars values) (extract-let-vars bindings 'let) - (let ((fun-cont (make-continuation))) - (let* ((*lexenv* (process-decls decls vars nil cont)) - (fun (ir1-convert-lambda-body - forms vars - :debug-name (debug-namify "LET ~S" bindings)))) - (reference-leaf start fun-cont fun)) - (ir1-convert-combination-args fun-cont cont values))))) + (if (null bindings) + (ir1-translate-locally body start cont) + (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (vars values) (extract-let-vars bindings 'let) + (let ((fun-cont (make-continuation))) + (let* ((*lexenv* (process-decls decls vars nil cont)) + (fun (ir1-convert-lambda-body + forms vars + :debug-name (debug-namify "LET ~S" bindings)))) + (reference-leaf start fun-cont fun)) + (ir1-convert-combination-args fun-cont cont values)))))) (def-ir1-translator let* ((bindings &body body) start cont) @@ -657,7 +614,8 @@ (ir1-convert-lambda d :source-name n :debug-name (debug-namify - "FLET ~S" n))) + "FLET ~S" n) + :allow-debug-catch-tag t)) names defs)) (*lexenv* (make-lexenv :default (process-decls decls nil fvars cont) @@ -692,7 +650,8 @@ (ir1-convert-lambda def :source-name name :debug-name (debug-namify - "LABELS ~S" name))) + "LABELS ~S" name) + :allow-debug-catch-tag t)) names defs)))) ;; Modify all the references to the dummy function leaves so @@ -849,7 +808,10 @@ (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) (ir1-convert start dest value) - (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*)) + (assert-continuation-type dest + (or (lexenv-find var type-restrictions) + (leaf-type var)) + (lexenv-policy *lexenv*)) (let ((res (make-set :var var :value dest))) (setf (continuation-dest dest) res) (setf (leaf-ever-used var) t) @@ -994,9 +956,6 @@ fun `(%coerce-callable-to-fun ,fun))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol)) - (lexenv-policy *lexenv*)) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args)