0.9.1.38:

[sbcl.git] / src / compiler / macros.lisp

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index dbb41f9..7016312 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -26,17 +26,6 @@
 \f
 ;;;; 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.
 ;;;
@@ -53,16 +42,17 @@
     (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
@@ -269,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)
@@ -513,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)))))))
 \f
@@ -952,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)))