X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=e188acbbcff1cbe88f35bfbfdf540f0b004d06e5;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=ec672382ced5f804ee2fd37da83cc83e960b699c;hpb=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index ec67238..e188acb 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -261,40 +261,38 @@ ;;; shared by the special-case top level MACROLET processing code, and ;;; further split so that the special-case MACROLET processing code in ;;; EVAL can likewise make use of it. -(defmacro macrolet-definitionize-fun (context lexenv) - (flet ((make-error-form (control &rest args) +(defun macrolet-definitionize-fun (context lexenv) + (flet ((fail (control &rest args) (ecase context - (:compile `(compiler-error ,control ,@args)) - (:eval `(error 'simple-program-error - :format-control ,control - :format-arguments (list ,@args)))))) - `(lambda (definition) + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error + :format-control control + :format-arguments 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)) + (fail "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)) - (with-unique-names (whole environment) - (multiple-value-bind (body local-decls) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - `(,name macro . - ,(compile-in-lexenv - nil - `(lambda (,whole ,environment) - ,@local-decls - (block ,name ,body)) - ,lexenv)))))))) - -(defun funcall-in-macrolet-lexenv (definitions fun) + (unless (symbolp name) + (fail "The local macro name ~S is not a symbol." name)) + (unless (listp arglist) + (fail "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) + `(,name macro . + ,(compile-in-lexenv + nil + `(lambda (,whole ,environment) + ,@local-decls + ,body) + lexenv)))))))) + +(defun funcall-in-macrolet-lexenv (definitions fun context) (%funcall-in-foomacrolet-lexenv - (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*)) + (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*)) :funs definitions fun)) @@ -309,33 +307,31 @@ definitions (lambda (&key funs) (declare (ignore funs)) - (ir1-translate-locally body start cont)))) + (ir1-translate-locally body start cont)) + :compile)) -(defmacro symbol-macrolet-definitionize-fun (context) - (flet ((make-error-form (control &rest args) +(defun symbol-macrolet-definitionize-fun (context) + (flet ((fail (control &rest args) (ecase context - (:compile `(compiler-error ,control ,@args)) - (:eval `(error 'simple-program-error - :format-control ,control - :format-arguments (list ,@args)))))) - `(lambda (definition) + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error + :format-control control + :format-arguments args))))) + (lambda (definition) (unless (proper-list-of-length-p definition 2) - ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition)) - (destructuring-bind (name expansion) definition - (unless (symbolp name) - ,(make-error-form - "The local symbol macro name ~S is not a symbol." - 'name)) - (let ((kind (info :variable :kind name))) - (when (member kind '(:special :constant)) - ,(make-error-form - "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" - 'kind 'name))) - `(,name . (MACRO . ,expansion))))))1 - -(defun funcall-in-symbol-macrolet-lexenv (definitions fun) + (fail "malformed symbol/expansion pair: ~S" definition)) + (destructuring-bind (name expansion) definition + (unless (symbolp name) + (fail "The local symbol macro name ~S is not a symbol." name)) + (let ((kind (info :variable :kind name))) + (when (member kind '(:special :constant)) + (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" + kind name))) + `(,name . (MACRO . ,expansion)))))) + +(defun funcall-in-symbol-macrolet-lexenv (definitions fun context) (%funcall-in-foomacrolet-lexenv - (symbol-macrolet-definitionize-fun :compile) + (symbol-macrolet-definitionize-fun context) :vars definitions fun)) @@ -348,7 +344,8 @@ (funcall-in-symbol-macrolet-lexenv macrobindings (lambda (&key vars) - (ir1-translate-locally body start cont :vars vars)))) + (ir1-translate-locally body start cont :vars vars)) + :compile)) ;;;; %PRIMITIVE ;;;; @@ -525,8 +522,7 @@ (values (vars) (vals)))) -(def-ir1-translator let ((bindings &body body) - start cont) +(def-ir1-translator let ((bindings &body body) start cont) #!+sb-doc "LET ({(Var [Value]) | Var}*) Declaration* Form* During evaluation of the Forms, bind the Vars to the result of evaluating the @@ -534,14 +530,17 @@ evaluated." (if (null bindings) (ir1-translate-locally body start cont) - (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed 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)) + (let* ((fun-cont (make-continuation)) + (cont (processing-decls (decls vars nil cont) + (let ((fun (ir1-convert-lambda-body + forms vars + :debug-name (debug-namify "LET ~S" + bindings)))) + (reference-leaf start fun-cont fun)) + cont))) (ir1-convert-combination-args fun-cont cont values)))))) (def-ir1-translator let* ((bindings &body body) @@ -550,10 +549,11 @@ "LET* ({(Var [Value]) | Var}*) Declaration* Form* Similar to LET, but the variables are bound sequentially, allowing each Value form to reference any of the previous Vars." - (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) - (let ((*lexenv* (process-decls decls vars nil cont))) - (ir1-convert-aux-bindings start cont forms vars values))))) + (processing-decls (decls vars nil cont) + (ir1-convert-aux-bindings start cont forms vars values))))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET @@ -564,8 +564,8 @@ ;;; forms before we hit the IR1 transform level. (defun ir1-translate-locally (body start cont &key vars funs) (declare (type list body) (type continuation start cont)) - (multiple-value-bind (forms decls) (parse-body body nil) - (let ((*lexenv* (process-decls decls vars funs cont))) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) + (processing-decls (decls vars funs cont) (ir1-convert-progn-body start cont forms)))) (def-ir1-translator locally ((&body body) start cont) @@ -609,20 +609,20 @@ Evaluate the Body-Forms with some local function definitions. The bindings do not enclose the definitions; any use of Name in the Forms will refer to the lexically apparent function definition in the enclosing environment." - (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) (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) - :allow-debug-catch-tag t)) - names defs)) - (*lexenv* (make-lexenv - :default (process-decls decls nil fvars cont) - :funs (pairlis names fvars)))) - (ir1-convert-progn-body start cont forms))))) + (let ((fvars (mapcar (lambda (n d) + (ir1-convert-lambda d + :source-name n + :debug-name (debug-namify + "FLET ~S" n) + :allow-debug-catch-tag t)) + names defs))) + (processing-decls (decls nil fvars cont) + (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) + (ir1-convert-progn-body start cont forms))))))) (def-ir1-translator labels ((definitions &body body) start cont) #!+sb-doc @@ -630,10 +630,10 @@ Evaluate the Body-Forms with some local function definitions. The bindings enclose the new definitions, so the defined functions can call themselves or each other." - (multiple-value-bind (forms decls) (parse-body body nil) + (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 + (let* ( ;; dummy LABELS functions, to be used as placeholders ;; during construction of real LABELS functions (placeholder-funs (mapcar (lambda (name) (make-functional @@ -664,14 +664,14 @@ (setf (cdr placeholder-cons) real-fun)) ;; Voila. - (let ((*lexenv* (make-lexenv - :default (process-decls decls nil real-funs cont) - ;; 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 cont forms)))))) + (processing-decls (decls nil real-funs cont) + (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 cont forms))))))) ;;;; the THE special operator, and friends @@ -697,10 +697,6 @@ ;;; Assert that FORM evaluates to the specified type (which may be a ;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE. -;;; -;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101, -;;; this didn't seem to expand into an assertion, at least for ALIEN -;;; values. Check that SBCL doesn't have this problem. (def-ir1-translator the ((type value) start cont) (the-in-policy type value (lexenv-policy *lexenv*) start cont))