X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=d9545758a3ee251f39753c02ebcec66852e7ff00;hb=75b52379bdc2269961af6a1308eca63610f38ac3;hp=0bd616168f100ee663b98e004fadf55bcb0630a1;hpb=de66d0244088badaf0898195d3112b62e11727ea;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 0bd6161..d954575 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -255,6 +255,8 @@ (compiler-style-warn "duplicate definitions in ~S" definitions)) (let* ((processed-definitions (mapcar definitionize-fun definitions)) (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) + ;; I wonder how much of an compiler performance penalty this + ;; non-constant keyword is. (funcall fun definitionize-keyword processed-definitions))) ;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then @@ -278,6 +280,9 @@ (destructuring-bind (name arglist &body body) definition (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) + (when (fboundp name) + (compiler-assert-symbol-home-package-unlocked + name "binding ~A as a local macro")) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -326,10 +331,14 @@ (destructuring-bind (name expansion) definition (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) + (when (or (boundp name) (eq (info :variable :kind name) :macro)) + (compiler-assert-symbol-home-package-unlocked + name "binding ~A as a local symbol-macro")) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) + ;; A magical cons that MACROEXPAND-1 understands. `(,name . (MACRO . ,expansion)))))) (defun funcall-in-symbol-macrolet-lexenv (definitions fun context) @@ -430,7 +439,7 @@ '(lambda named-lambda instance-lambda lambda-with-lexenv)) (ir1-convert-lambdalike thing - :debug-name (debug-namify "#'~S" thing) + :debug-name (debug-namify "#'" thing) :allow-debug-catch-tag t)) ((legal-fun-name-p thing) (find-lexically-apparent-fun @@ -479,8 +488,7 @@ `(%funcall ,function ,@args) (values nil t))) -(deftransform %coerce-callable-to-fun ((thing) (function) * - :important t) +(deftransform %coerce-callable-to-fun ((thing) (function) *) "optimize away possible call to FDEFINITION at runtime" 'thing) @@ -524,7 +532,10 @@ (vars var) (names name) (vals (second spec))))))) - + (dolist (name (names)) + (when (eq (info :variable :kind name) :macro) + (compiler-assert-symbol-home-package-unlocked + name "lexically binding symbol-macro ~A"))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) @@ -543,8 +554,9 @@ ((next result) (processing-decls (decls vars nil next result) (let ((fun (ir1-convert-lambda-body - forms vars - :debug-name (debug-namify "LET ~S" + forms + vars + :debug-name (debug-namify "LET S" bindings)))) (reference-leaf start ctran fun-lvar fun)) (values next result)))) @@ -560,7 +572,12 @@ (parse-body body :doc-string-allowed nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) (processing-decls (decls vars nil start next) - (ir1-convert-aux-bindings start next result forms vars values))))) + (ir1-convert-aux-bindings start + next + result + forms + vars + values))))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET @@ -602,6 +619,9 @@ (let ((name (first def))) (check-fun-name name) + (when (fboundp name) + (compiler-assert-symbol-home-package-unlocked + name "binding ~A as a local function")) (names name) (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) @@ -620,17 +640,20 @@ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-vars definitions 'flet) + (extract-flet-vars definitions 'flet) (let ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n :debug-name (debug-namify - "FLET ~S" n) + "FLET " n) :allow-debug-catch-tag t)) names defs))) (processing-decls (decls nil fvars next result) (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) - (ir1-convert-progn-body start next result forms))))))) + (ir1-convert-progn-body start + next + result + forms))))))) (def-ir1-translator labels ((definitions &body body) start next result) #!+sb-doc @@ -640,46 +663,50 @@ each other." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-vars definitions 'labels) - (let* ( ;; dummy LABELS functions, to be used as placeholders + (extract-flet-vars definitions 'labels) + (let* (;; dummy LABELS functions, to be used as placeholders ;; during construction of real LABELS functions - (placeholder-funs (mapcar (lambda (name) - (make-functional - :%source-name name - :%debug-name (debug-namify - "LABELS placeholder ~S" - name))) - names)) - ;; (like PAIRLIS but guaranteed to preserve ordering:) - (placeholder-fenv (mapcar #'cons names placeholder-funs)) + (placeholder-funs (mapcar (lambda (name) + (make-functional + :%source-name name + :%debug-name (debug-namify + "LABELS placeholder " + name))) + names)) + ;; (like PAIRLIS but guaranteed to preserve ordering:) + (placeholder-fenv (mapcar #'cons names placeholder-funs)) ;; the real LABELS functions, compiled in a LEXENV which ;; includes the dummy LABELS functions - (real-funs - (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) - (mapcar (lambda (name def) - (ir1-convert-lambda def - :source-name name - :debug-name (debug-namify - "LABELS ~S" name) - :allow-debug-catch-tag t)) - names defs)))) - + (real-funs + (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) + (mapcar (lambda (name def) + (ir1-convert-lambda def + :source-name name + :debug-name (debug-namify + "LABELS " name) + :allow-debug-catch-tag t)) + names defs)))) + ;; Modify all the references to the dummy function leaves so ;; that they point to the real function leaves. - (loop for real-fun in real-funs and - placeholder-cons in placeholder-fenv do - (substitute-leaf real-fun (cdr placeholder-cons)) - (setf (cdr placeholder-cons) real-fun)) - + (loop for real-fun in real-funs and + placeholder-cons in placeholder-fenv do + (substitute-leaf real-fun (cdr placeholder-cons)) + (setf (cdr placeholder-cons) real-fun)) + ;; Voila. - (processing-decls (decls nil real-funs next result) + (processing-decls (decls nil real-funs next result) (let ((*lexenv* (make-lexenv ;; Use a proper FENV here (not the ;; placeholder used earlier) so that if the ;; lexical environment is used for inline ;; expansion we'll get the right functions. :funs (pairlis names real-funs)))) - (ir1-convert-progn-body start next result forms))))))) + (ir1-convert-progn-body start + next + result + forms))))))) + ;;;; the THE special operator, and friends @@ -833,7 +860,7 @@ (let ((fun (ir1-convert-lambda `(lambda () (return-from ,tag (%unknown-values))) - :debug-name (debug-namify "escape function for ~S" tag)))) + :debug-name (debug-namify "escape function for " tag)))) (setf (functional-kind fun) :escape) (reference-leaf start next result fun))) @@ -861,9 +888,8 @@ (with-unique-names (exit-block) `(block ,exit-block (%within-cleanup - :catch - (%catch (%escape-fun ,exit-block) ,tag) - ,@body))))) + :catch (%catch (%escape-fun ,exit-block) ,tag) + ,@body))))) (def-ir1-translator unwind-protect ((protected &body cleanup) start next result)