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        ;; FIXME: is it too expensive to go through a runtime call to
  26        ;; FDEFINITION each time we want to check a name's syntax?
  27        (%define-fun-name-syntax ',symbol ',syntax-checker))))
  28
  29 ;;; FIXME: this is a really lame name for something that has two
  30 ;;; return values.
  31 (defun valid-function-name-p (name)
  32   #!+sb-doc
  33   "The primary return value indicates whether NAME is a valid function
  34 name; if it is, the second return value will be a symbol suitable for
  35 use as a BLOCK name in the function in question."
  36   (typecase name
  37     (cons
  38      (when (symbolp (car name))
  39        (let ((syntax-checker (cdr (assoc (car name) *valid-fun-names-alist*
  40                                          :test #'eq))))
  41          (when syntax-checker
  42            (funcall syntax-checker name)))))
  43     (symbol (values t name))
  44     (otherwise nil)))
  45
  46 (define-function-name-syntax setf (name)
  47   (when (and (cdr name)
  48              (consp (cdr name)))
  49     (destructuring-bind (fun &rest rest) (cdr name)
  50       (when (null rest)
  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 (eq (car fun) 'setf)
  57                   (valid-function-name-p fun))))))))
  58
  59 #-sb-xc-host
  60 (defun !function-names-cold-init ()
  61   (setf *valid-fun-names-alist* '#.*valid-fun-names-alist*))