src/code/function-names.lisp

   1 (in-package "SB!IMPL")
   2
   3 ;;;; generalized function names
   4 (defvar *valid-fun-names-alist* nil)
   5
   6 (defun %define-fun-name-syntax (symbol checker)
   7   (let ((found (assoc symbol *valid-fun-names-alist* :test #'eq)))
   8     (if found
   9         (setf (cdr found) checker)
  10         (setq *valid-fun-names-alist*
  11               (acons symbol checker *valid-fun-names-alist*)))))
  12
  13 (defmacro define-function-name-syntax (symbol (var) &body body)
  14   #!+sb-doc
  15   "Define function names of the form of a list headed by SYMBOL to be
  16 a legal function name, subject to restrictions imposed by BODY.  BODY
  17 is evaluated with VAR bound to the form required to check, and should
  18 return two values: the first value is a generalized boolean indicating
  19 legality, and the second a symbol for use as a BLOCK name or similar
  20 situations."
  21   (declare (type symbol symbol))
  22   (let ((syntax-checker (symbolicate '%check- symbol '-fun-name)))
  23     `(progn
  24        (defun ,syntax-checker (,var) ,@body)
  25        (%define-fun-name-syntax ',symbol #',syntax-checker))))
  26
  27 ;;; FIXME: this is a really lame name for something that has two
  28 ;;; return values.
  29 ;;; See CSR's log comment in bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c
  30 ;;; I would think that after 11 years of we're entitled to rename it.
  31 ;;; VALIDATE-FUNCTION-NAME would be apt.
  32 (defun valid-function-name-p (name)
  33   #!+sb-doc
  34   "The primary return value indicates whether NAME is a valid function
  35 name; if it is, the second return value will be a symbol suitable for
  36 use as a BLOCK name in the function in question."
  37   (typecase name
  38     (cons
  39      (when (symbolp (car name))
  40        (let ((syntax-checker (cdr (assoc (car name) *valid-fun-names-alist*
  41                                          :test #'eq))))
  42          (when syntax-checker
  43            (funcall syntax-checker name)))))
  44     (symbol (values t name))
  45     (otherwise nil)))
  46
  47 (define-function-name-syntax setf (name)
  48   (let ((tail (cdr name)))
  49     (when (and (consp tail) (null (cdr tail)))
  50       (let ((fun (car tail)))
  51         (typecase fun
  52           ;; ordinary (SETF FOO) case
  53           (symbol (values t fun))
  54           ;; reasonable (SETF (QUUX BAZ)) case [but not (SETF (SETF
  55           ;; FOO))]
  56           (cons (unless (member (car fun) '(cas setf))
  57                   (valid-function-name-p fun))))))))
  58
  59 ;; CAS and SETF names should have in common the aspect that
  60 ;; (CAS (CAS BAZ)), (SETF (CAS BAZ)), (CAS (SETF BAZ)) are not reasonable.
  61 ;; 'cas.lisp' doesn't need to know this technique for sharing the parser,
  62 ;; so the name syntax is defined here instead of there.
  63 (%define-fun-name-syntax 'cas #'%check-setf-fun-name)
  64
  65 (defun macro-function-name (name)
  66   (when (and (cdr name)
  67              (consp (cdr name)))
  68     (destructuring-bind (fun &rest rest) (cdr name)
  69       (when (null rest)
  70         (typecase fun
  71           ;; (DEFMACRO FOO)
  72           (symbol (values t fun))
  73           ;; (DEFMACRO (SETF FOO))
  74           (cons (when (eq (car fun) 'setf)
  75                   (valid-function-name-p fun))))))))
  76
  77 (define-function-name-syntax defmacro (name)
  78   (macro-function-name name))
  79
  80 (define-function-name-syntax macrolet (name)
  81   (macro-function-name name))