X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffunction-names.lisp;h=822ab8c23ec6f7f1b90134052db6fb369a08b504;hb=04a651e749befd65ffd8bf49f689b6e7d55607e2;hp=405916db5b77c05194c948f4689c8ed81f99d6f3;hpb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;p=sbcl.git

diff --git a/src/code/function-names.lisp b/src/code/function-names.lisp
index 405916d..822ab8c 100644
--- a/src/code/function-names.lisp
+++ b/src/code/function-names.lisp
@@ -6,9 +6,9 @@
 (defun %define-fun-name-syntax (symbol checker)
   (let ((found (assoc symbol *valid-fun-names-alist* :test #'eq)))
     (if found
-	(setf (cdr found) checker)
-	(setq *valid-fun-names-alist*
-	      (acons symbol checker *valid-fun-names-alist*)))))
+        (setf (cdr found) checker)
+        (setq *valid-fun-names-alist*
+              (acons symbol checker *valid-fun-names-alist*)))))
 
 (defmacro define-function-name-syntax (symbol (var) &body body)
   #!+sb-doc
@@ -44,16 +44,35 @@ use as a BLOCK name in the function in question."
     (otherwise nil)))
 
 (define-function-name-syntax setf (name)
-  (when (cdr name)
+  (when (and (cdr name)
+             (consp (cdr name)))
     (destructuring-bind (fun &rest rest) (cdr name)
       (when (null rest)
-	(typecase fun
-	  ;; ordinary (SETF FOO) case
-	  (symbol (values t fun))
-	  ;; reasonable (SETF (QUUX BAZ)) case [but not (SETF (SETF
-	  ;; FOO))]
-	  (cons (unless (eq (car fun) 'setf)
-		  (valid-function-name-p fun))))))))
+        (typecase fun
+          ;; ordinary (SETF FOO) case
+          (symbol (values t fun))
+          ;; reasonable (SETF (QUUX BAZ)) case [but not (SETF (SETF
+          ;; FOO))]
+          (cons (unless (eq (car fun) 'setf)
+                  (valid-function-name-p fun))))))))
+
+(defun macro-function-name (name)
+  (when (and (cdr name)
+             (consp (cdr name)))
+    (destructuring-bind (fun &rest rest) (cdr name)
+      (when (null rest)
+        (typecase fun
+          ;; (DEFMACRO FOO)
+          (symbol (values t fun))
+          ;; (DEFMACRO (SETF FOO))
+          (cons (when (eq (car fun) 'setf)
+                  (valid-function-name-p fun))))))))
+
+(define-function-name-syntax defmacro (name)
+  (macro-function-name name))
+
+(define-function-name-syntax macrolet (name)
+  (macro-function-name name))
 
 #-sb-xc-host
 (defun !function-names-cold-init ()