X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=ce061231bb4bbdeedfd62853ea72502c738439d3;hb=78164d7ec6e90551208719b0445286eccf35c451;hp=4c5a861faa30d3863016c7b28fb86075855263fc;hpb=e38cf29945f9ff0cfbf614c0c216be60e2515175;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 4c5a861..ce06123 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -270,14 +270,17 @@ :format-arguments (list ,@args)))))) `(lambda (definition) (unless (list-of-length-at-least-p definition 2) - ,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition)) + ,(make-error-form + "The list ~S is too short to be a legal local macro definition." + 'definition)) (destructuring-bind (name arglist &body body) definition (unless (symbolp name) ,(make-error-form "The local macro name ~S is not a symbol." 'name)) (unless (listp arglist) - ,(make-error-form "The local macro argument list ~S is not a list." 'arglist)) - (let ((whole (gensym "WHOLE")) - (environment (gensym "ENVIRONMENT"))) + ,(make-error-form + "The local macro argument list ~S is not a list." + 'arglist)) + (with-unique-names (whole environment) (multiple-value-bind (body local-decls) (parse-defmacro arglist whole body name 'macrolet :environment environment) @@ -346,15 +349,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 ;;;; @@ -444,7 +438,7 @@ thing :debug-name (debug-namify "#'~S" thing) :allow-debug-catch-tag t))) - ((setf sb!pcl::class-predicate) + ((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))) @@ -539,15 +533,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) @@ -714,7 +710,9 @@ ;;; many branches there are going to be. (defun ir1ize-the-or-values (type cont lexenv place) (declare (type continuation cont) (type lexenv lexenv)) - (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type))) + (let* ((atype (if (typep type 'ctype) + type + (compiler-values-specifier-type type))) (old-atype (or (lexenv-find cont type-restrictions) *wild-type*)) (old-ctype (or (lexenv-find cont weakend-type-restrictions) @@ -722,7 +720,8 @@ (intersects (values-types-equal-or-intersect old-atype atype)) (new-atype (values-type-intersection old-atype atype)) (new-ctype (values-type-intersection - old-ctype (maybe-weaken-check atype (lexenv-policy lexenv))))) + old-ctype + (maybe-weaken-check atype (lexenv-policy lexenv))))) (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new-atype) (setf (continuation-type-to-check cont) new-ctype)) @@ -885,45 +884,40 @@ (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) -;;; We represent the possibility of the control transfer by making an -;;; "escape function" that does a lexical exit, and instantiate the -;;; cleanup using %WITHIN-CLEANUP. (def-ir1-translator catch ((tag &body body) start cont) #!+sb-doc "Catch Tag Form* - Evaluates Tag and instantiates it as a catcher while the body forms are - evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic + Evaluate TAG and instantiate it as a catcher while the body forms are + evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic scope of the body, then control will be transferred to the end of the body and the thrown values will be returned." + ;; We represent the possibility of the control transfer by making an + ;; "escape function" that does a lexical exit, and instantiate the + ;; cleanup using %WITHIN-CLEANUP. (ir1-convert start cont - (let ((exit-block (gensym "EXIT-BLOCK-"))) + (with-unique-names (exit-block) `(block ,exit-block (%within-cleanup :catch (%catch (%escape-fun ,exit-block) ,tag) ,@body))))) -;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the -;;; cleanup forms into a local function so that they can be referenced -;;; both in the case where we are unwound and in any local exits. We -;;; use %CLEANUP-FUN on this to indicate that reference by -;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of -;;; an XEP. (def-ir1-translator unwind-protect ((protected &body cleanup) start cont) #!+sb-doc "Unwind-Protect Protected Cleanup* - Evaluate the form Protected, returning its values. The cleanup forms are - evaluated whenever the dynamic scope of the Protected form is exited (either + Evaluate the form PROTECTED, returning its values. The CLEANUP forms are + evaluated whenever the dynamic scope of the PROTECTED form is exited (either due to normal completion or a non-local exit such as THROW)." + ;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the + ;; cleanup forms into a local function so that they can be referenced + ;; both in the case where we are unwound and in any local exits. We + ;; use %CLEANUP-FUN on this to indicate that reference by + ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of + ;; an XEP. (ir1-convert start cont - (let ((cleanup-fun (gensym "CLEANUP-FUN-")) - (drop-thru-tag (gensym "DROP-THRU-TAG-")) - (exit-tag (gensym "EXIT-TAG-")) - (next (gensym "NEXT")) - (start (gensym "START")) - (count (gensym "COUNT"))) + (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count) `(flet ((,cleanup-fun () ,@cleanup nil)) ;; FIXME: If we ever get DYNAMIC-EXTENT working, then ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, @@ -942,21 +936,22 @@ ;;;; multiple-value stuff -;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an -;;; MV-COMBINATION. -;;; -;;; If there are no arguments, then we convert to a normal -;;; combination, ensuring that a MV-COMBINATION always has at least -;;; one argument. This can be regarded as an optimization, but it is -;;; more important for simplifying compilation of MV-COMBINATIONS. (def-ir1-translator multiple-value-call ((fun &rest args) start cont) #!+sb-doc "MULTIPLE-VALUE-CALL Function Values-Form* - Call Function, passing all the values of each Values-Form as arguments, - values from the first Values-Form making up the first argument, etc." + Call FUNCTION, passing all the values of each VALUES-FORM as arguments, + values from the first VALUES-FORM making up the first argument, etc." (let* ((fun-cont (make-continuation)) (node (if args + ;; If there are arguments, MULTIPLE-VALUE-CALL + ;; turns into an MV-COMBINATION. (make-mv-combination fun-cont) + ;; If there are no arguments, then we convert to a + ;; normal combination, ensuring that a MV-COMBINATION + ;; always has at least one argument. This can be + ;; regarded as an optimization, but it is more + ;; important for simplifying compilation of + ;; MV-COMBINATIONS. (make-combination fun-cont)))) (ir1-convert start fun-cont (if (and (consp fun) (eq (car fun) 'function))