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