\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.
;;;
;;; 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.)
;;; 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)
(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
(ctran-next it))
(t (return)))))
,@(when lvar-var
- `((,lvar-var #1=(when (valued-node-p ,node-var)
- (node-lvar ,node-var))
- #1#))))
+ `((,lvar-var (when (valued-node-p ,node-var)
+ (node-lvar ,node-var))
+ (when (valued-node-p ,node-var)
+ (node-lvar ,node-var))))))
(nil)
,@body
,@(when restart-p
;;; Like DO-NODES, only iterating in reverse order. Should be careful
;;; with block being split under us.
-(defmacro do-nodes-backwards ((node-var lvar block) &body body)
+(defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body)
(let ((n-block (gensym))
(n-prev (gensym)))
`(loop with ,n-block = ,block
- for ,node-var = (block-last ,n-block) then (ctran-use ,n-prev)
- while ,node-var ; FIXME: this is non-ANSI
- for ,n-prev = (node-prev ,node-var)
- and ,lvar = (when (valued-node-p ,node-var) (node-lvar ,node-var))
+ for ,node-var = (block-last ,n-block) then
+ ,(if restart-p
+ `(if (eq ,n-block (ctran-block ,n-prev))
+ (ctran-use ,n-prev)
+ (block-last ,n-block))
+ `(ctran-use ,n-prev))
+ for ,n-prev = (when ,node-var (node-prev ,node-var))
+ and ,lvar = (when (and ,node-var (valued-node-p ,node-var))
+ (node-lvar ,node-var))
+ while ,(if restart-p
+ `(and ,node-var (not (block-to-be-deleted-p ,n-block)))
+ node-var)
do (progn
,@body))))
(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)))