From c8d88e5de0e83a50c4a5f64ee198c3efdca550f2 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Sat, 15 Feb 2003 22:08:31 +0000 Subject: [PATCH] Added bootstrap file to make compilation of current CVS with a lisp without the extended function name functionality work. --- bootfiles/18d/boot9.lisp | 54 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 bootfiles/18d/boot9.lisp diff --git a/bootfiles/18d/boot9.lisp b/bootfiles/18d/boot9.lisp new file mode 100644 index 000000000..2d1c37f02 --- /dev/null +++ b/bootfiles/18d/boot9.lisp @@ -0,0 +1,54 @@ +(in-package "EXTENSIONS") + +(export '(define-function-name-syntax valid-function-name-p)) + +(in-package "LISP") + +;;;; Function names. + +(defvar *valid-function-names* ()) + +(defun %define-function-name-syntax (name syntax-checker) + (let ((found (assoc name *valid-function-names* :test #'eq))) + (if found + (setf (cdr found) syntax-checker) + (setq *valid-function-names* + (acons name syntax-checker *valid-function-names*))))) + +(defmacro define-function-name-syntax (name (var) &body body) + "Define (NAME ...) to be a valid function name whose syntax is checked + by BODY. In BODY, VAR is bound to an actual function name of the + form (NAME ...) to check. BODY should return two values. + First value true means the function name is valid. Second value + is the name, a symbol, of the function for use in the BLOCK of DEFUNs + and in similar situations." + (let ((syntax-checker (symbolicate '%check- name '-function-name))) + `(progn + (defun ,syntax-checker (,var) ,@body) + (%define-function-name-syntax ',name #',syntax-checker)))) + +(defun valid-function-name-p (name) + "First value is true if NAME has valid function name syntax. + Second value is the name, a symbol, to use as a block name in DEFUNs + and in similar situations." + (typecase name + (cons + (when (and (symbolp (car name)) + (consp (cdr name))) + (let ((syntax-checker (cdr (assoc (car name) *valid-function-names* + :test #'eq)))) + (when syntax-checker + (funcall syntax-checker name))))) + (symbol (values t name)) + (otherwise nil))) + +(define-function-name-syntax setf (name) + (destructuring-bind (setf fn &rest rest) name + (declare (ignore setf)) + (when (null rest) + (typecase fn + (symbol + (values t fn)) + (cons + (unless (eq 'setf (car fn)) + (valid-function-name-p fn))))))) -- GitLab