X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=701631231c0e2217bb29f0e39f3eada7f8d63117;hb=883b33b092472473b0dd559d64351b9436916af3;hp=c92c88a25f2594582889ff02a274b9bfd820b7fe;hpb=0c25cf1e8e49095969378ab356a5516f29d4c139;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index c92c88a..7016312 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -26,17 +26,6 @@ ;;;; source-hacking defining forms -;;; to be passed to PARSE-DEFMACRO when we want compiler errors -;;; instead of real errors -#!-sb-fluid (declaim (inline convert-condition-into-compiler-error)) -(defun convert-condition-into-compiler-error (datum &rest stuff) - (if (stringp datum) - (apply #'compiler-error datum stuff) - (compiler-error "~A" - (if (symbolp datum) - (apply #'make-condition datum stuff) - datum)))) - ;;; Parse a DEFMACRO-style lambda-list, setting things up so that a ;;; compiler error happens if the syntax is invalid. ;;; @@ -45,42 +34,44 @@ ;;; list. START-VAR, NEXT-VAR and RESULT-VAR are bound to the start and ;;; result continuations for the resulting IR1. KIND is the function ;;; kind to associate with NAME. -(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var - &key (kind :special-form)) - &body body) +(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var) + &body body) (let ((fn-name (symbolicate "IR1-CONVERT-" name)) (n-form (gensym)) (n-env (gensym))) (multiple-value-bind (body decls doc) (parse-defmacro lambda-list n-form body name "special form" :environment n-env - :error-fun 'convert-condition-into-compiler-error + :error-fun 'compiler-error :wrap-block nil) `(progn (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) ,fn-name)) - (defun ,fn-name (,start-var ,next-var ,result-var ,n-form) - (let ((,n-env *lexenv*)) - ,@decls - ,body - (values))) + (defun ,fn-name (,start-var ,next-var ,result-var ,n-form + &aux (,n-env *lexenv*)) + (declare (ignorable ,start-var ,next-var ,result-var)) + ,@decls + ,body + (values)) ,@(when doc `((setf (fdocumentation ',name 'function) ,doc))) ;; FIXME: Evidently "there can only be one!" -- we overwrite any ;; other :IR1-CONVERT value. This deserves a warning, I think. (setf (info :function :ir1-convert ',name) #',fn-name) - (setf (info :function :kind ',name) ,kind) + ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to + ;; the 1990s? + (setf (info :function :kind ',name) :special-form) ;; It's nice to do this for error checking in the target ;; SBCL, but it's not nice to do this when we're running in ;; the cross-compilation host Lisp, which owns the ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. #-sb-xc-host - ,@(when (eq kind :special-form) - `((setf (symbol-function ',name) - (lambda (&rest rest) - (declare (ignore rest)) - (error 'special-form-function - :name ',name))))))))) + (let ((fun (lambda (&rest rest) + (declare (ignore rest)) + (error 'special-form-function :name ',name)))) + (setf (%simple-fun-arglist fun) ',lambda-list) + (setf (symbol-function ',name) fun)) + ',name)))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the ;;; syntax is invalid.) @@ -268,14 +259,14 @@ ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses ;;; the arguments of a combination with respect to that -;;; lambda-list. BODY is the the list of forms which are to be +;;; lambda-list. BODY is the list of forms which are to be ;;; evaluated within the bindings. ARGS is the variable that holds ;;; list of argument lvars. ERROR-FORM is a form which is evaluated ;;; when the syntax of the supplied arguments is incorrect or a ;;; non-constant argument keyword is supplied. Defaults and other gunk ;;; are ignored. The second value is a list of all the arguments ;;; bound. We make the variables IGNORABLE so that we don't have to -;;; manually declare them Ignore if their only purpose is to make the +;;; manually declare them IGNORE if their only purpose is to make the ;;; syntax work. (defun parse-deftransform (lambda-list body args error-form) (multiple-value-bind (req opt restp rest keyp keys allowp) @@ -512,11 +503,13 @@ (let ((n-args (gensym))) `(progn (defun ,name (,n-node ,@vars) + (declare (ignorable ,@vars)) (let ((,n-args (basic-combination-args ,n-node))) ,(parse-deftransform lambda-list body n-args `(return-from ,name nil)))) ,@(when (consp what) - `((setf (,(symbolicate "FUN-INFO-" (second what)) + `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) + (symbolicate "FUN-INFO-" (second what))) (fun-info-or-lose ',(first what))) #',name))))))) @@ -951,3 +944,29 @@ (defmacro position-or-lose (&rest args) `(or (position ,@args) (error "shouldn't happen?"))) + +;;; user-definable compiler io syntax + +;;; We use WITH-SANE-IO-SYNTAX to provide safe defaults, and provide +;;; *COMPILER-PRINT-VARIABLE-ALIST* for user customization. +(defvar *compiler-print-variable-alist* nil + #!+sb-doc + "an association list describing new bindings for special variables +to be used by the compiler for error-reporting, etc. Eg. + + ((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL)) + +The variables in the CAR positions are bound to the values in the CDR +during the execution of some debug commands. When evaluating arbitrary +expressions in the debugger, the normal values of the printer control +variables are in effect. + +Initially empty, *COMPILER-PRINT-VARIABLE-ALIST* is Typically used to +specify bindings for printer control variables.") + +(defmacro with-compiler-io-syntax (&body forms) + `(with-sane-io-syntax + (progv + (nreverse (mapcar #'car *compiler-print-variable-alist*)) + (nreverse (mapcar #'cdr *compiler-print-variable-alist*)) + ,@forms)))