Don't warn when #'(setf fun) is used in the presence of a setf-macro.

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

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 48af2fb..59de9b0 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -469,12 +469,16 @@
 ;;; 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))
 
@@ -510,21 +514,28 @@
 (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
 
@@ -681,17 +692,25 @@
     (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