;;; kind to associate with NAME.
(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var)
&body body)
- (let ((fn-name (symbolicate "IR1-CONVERT-" name)))
+ (let ((fn-name (symbolicate "IR1-CONVERT-" name))
+ (guard-name (symbolicate name "-GUARD")))
(with-unique-names (whole-var n-env)
(multiple-value-bind (body decls doc)
(parse-defmacro lambda-list whole-var body name "special form"
,@decls
,body
(values))
- ,@(when doc
- `((setf (fdocumentation ',name 'function) ,doc)))
+ #-sb-xc-host
+ ;; 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. These guard
+ ;; functions also provide the documentation for special forms.
+ (progn
+ (defun ,guard-name (&rest args)
+ ,@(when doc (list doc))
+ (declare (ignore args))
+ (error 'special-form-function :name ',name))
+ (let ((fun #',guard-name))
+ (setf (%simple-fun-arglist fun) ',lambda-list
+ (%simple-fun-name fun) ',name
+ (symbol-function ',name) fun)
+ (fmakunbound ',guard-name)))
;; 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)
;; 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
- (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
;;; the function might have.
(defmacro defknown (name arg-types result-type &optional (attributes '(any))
&body keys)
+ #-sb-xc-host
+ (when (member 'unsafe attributes)
+ (style-warn "Ignoring legacy attribute UNSAFE. Replaced by its inverse: DX-SAFE.")
+ (setf attributes (remove 'unsafe attributes)))
(when (and (intersection attributes '(any call unwind))
(intersection attributes '(movable)))
(error "function cannot have both good and bad attributes: ~S" attributes))
(when (member 'any attributes)
- (setq attributes (union '(call unsafe unwind) attributes)))
+ (setq attributes (union '(call unwind) attributes)))
(when (member 'flushable attributes)
(pushnew 'unsafely-flushable attributes))
(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym))
&rest vars)
&body body)
- (let ((name (if (symbolp what) what
- (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
-
- (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 (,(let ((*package* (symbol-package 'sb!c::fun-info)))
- (symbolicate "FUN-INFO-" (second what)))
- (fun-info-or-lose ',(first what)))
- #',name)))))))
+ (flet ((function-name (name)
+ (etypecase name
+ (symbol name)
+ ((cons (eql setf) (cons symbol null))
+ (symbolicate (car name) "-" (cadr name))))))
+ (let ((name (if (symbolp what)
+ what
+ (symbolicate (function-name (first what))
+ "-" (second what) "-OPTIMIZER"))))
+
+ (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 (,(let ((*package* (symbol-package 'sb!c::fun-info)))
+ (symbolicate "FUN-INFO-" (second what)))
+ (fun-info-or-lose ',(first what)))
+ #',name))))))))
\f
;;;; IR groveling macros
(aver-live-component *current-component*)
(funcall fun)))
+(defmacro with-source-paths (&body forms)
+ (with-unique-names (source-paths)
+ `(let* ((,source-paths (make-hash-table :test 'eq))
+ (*source-paths* ,source-paths))
+ (unwind-protect
+ (progn ,@forms)
+ (clrhash ,source-paths)))))
+
;;; Bind the hashtables used for keeping track of global variables,
;;; functions, etc. Also establish condition handlers.
(defmacro with-ir1-namespace (&body forms)
`(let ((*free-vars* (make-hash-table :test 'eq))
(*free-funs* (make-hash-table :test 'equal))
- (*constants* (make-hash-table :test 'equal))
- (*source-paths* (make-hash-table :test 'eq)))
- (handler-bind ((compiler-error #'compiler-error-handler)
- (style-warning #'compiler-style-warning-handler)
- (warning #'compiler-warning-handler))
- ,@forms)))
+ (*constants* (make-hash-table :test 'equal)))
+ (unwind-protect
+ (progn ,@forms)
+ (clrhash *free-funs*)
+ (clrhash *free-vars*)
+ (clrhash *constants*))))
;;; Look up NAME in the lexical environment namespace designated by
;;; SLOT, returning the <value, T>, or <NIL, NIL> if no entry. The
(nreverse (mapcar #'car *compiler-print-variable-alist*))
(nreverse (mapcar #'cdr *compiler-print-variable-alist*))
,@forms)))
+
+;;; Like DESTRUCTURING-BIND, but generates a COMPILER-ERROR on failure
+(defmacro compiler-destructuring-bind (lambda-list thing context
+ &body body)
+ (let ((whole-name (gensym "WHOLE")))
+ (multiple-value-bind (body local-decls)
+ (parse-defmacro lambda-list whole-name body nil
+ context
+ :anonymousp t
+ :doc-string-allowed nil
+ :wrap-block nil
+ :error-fun 'compiler-error)
+ `(let ((,whole-name ,thing))
+ (declare (type list ,whole-name))
+ ,@local-decls
+ ,body))))
projects / sbcl.git / blobdiff