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