(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
(define-function-name-syntax setf (name)
(when (and (cdr name)
- (consp (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 ()