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