From d3e620a34711eaaadde4069d8d8eb46ffbe4151b Mon Sep 17 00:00:00 2001
From: pmai <pmai>
Date: Sat, 24 Aug 2002 13:46:52 +0000
Subject: [PATCH] Patch by Gerd Moellmann to remove PCL's variant of once-only,
 replacing it by the version already present in CMUCL.

---
 pcl/extensions.lisp |  6 +++---
 pcl/macros.lisp     | 35 +++--------------------------------
 2 files changed, 6 insertions(+), 35 deletions(-)

diff --git a/pcl/extensions.lisp b/pcl/extensions.lisp
index f92f46b79..524470cf5 100644
--- a/pcl/extensions.lisp
+++ b/pcl/extensions.lisp
@@ -18,7 +18,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/extensions.lisp,v 1.3 1999/05/30 23:13:58 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/extensions.lisp,v 1.4 2002/08/24 13:46:52 pmai Exp $")
 ;;;
 
 (in-package 'pcl)
@@ -83,7 +83,7 @@
 
 (defmacro slot-value-from-index (instance wrapper slot-name slots index)
   "Returns instance's slot-value given slot-name's index."
-  (once-only (index)
+  (ext:once-only ((index index))
     `(if ,index
          (let ((val (%svref ,slots ,index)))
            (if (eq val ',*slot-unbound*)
@@ -96,7 +96,7 @@
 (defmacro set-slot-value-from-index
           (instance wrapper slot-name slots index new-value)
   "Sets instance's slot-value to new-value given slot-name's index."
-  (once-only (index)
+  (ext:once-only ((index index))
     `(if ,index
           (setf (%svref ,slots ,index) ,new-value)
           (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
diff --git a/pcl/macros.lisp b/pcl/macros.lisp
index 3de2e8d84..f19dafd9d 100644
--- a/pcl/macros.lisp
+++ b/pcl/macros.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.16 2002/08/19 16:52:09 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.17 2002/08/24 13:46:52 pmai Exp $")
 ;;;
 ;;; Macros global variable definitions, and other random support stuff used
 ;;; by the rest of the system.
@@ -98,35 +98,6 @@
 (defun remtail (list tail)
   (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
 
-;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just
-;;; lifted it from there but I am honest.  Not only that but this one is
-;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more
-;;; like rebuilding Rome.
-(defmacro once-only (vars &body body)
-  (let ((gensym-var (gensym))
-        (run-time-vars (gensym))
-        (run-time-vals (gensym))
-        (expand-time-val-forms ()))
-    (dolist (var vars)
-      (push `(if (or (symbolp ,var)
-                     (numberp ,var)
-                     (and (listp ,var)
-			  (member (car ,var) '(quote function))))
-                 ,var
-                 (let ((,gensym-var (gensym)))
-                   (push ,gensym-var ,run-time-vars)
-                   (push ,var ,run-time-vals)
-                   ,gensym-var))
-            expand-time-val-forms))    
-    `(let* (,run-time-vars
-            ,run-time-vals
-            (wrapped-body
-	      (let ,(mapcar #'list vars (reverse expand-time-val-forms))
-		,@body)))
-       `(let ,(mapcar #'list (reverse ,run-time-vars)
-			     (reverse ,run-time-vals))
-	  ,wrapped-body))))
-
 (eval-when (compile load eval)
 (defun extract-declarations (body &optional environment)
   ;;(declare (values documentation declarations body))
@@ -184,13 +155,13 @@
   (intern (string-append sym1 sym2) package))
 
 (defmacro check-member (place list &key (test #'eql) (pretty-name place))
-  (once-only (place list)
+  (ext:once-only ((place place) (list list))
     `(or (member ,place ,list :test ,test)
          (error "The value of ~A, ~S is not one of ~S."
                 ',pretty-name ,place ,list))))
 
 (defmacro alist-entry (alist key make-entry-fn)
-  (once-only (alist key)
+  (ext:once-only ((alist alist) (key key))
     `(or (assq ,key ,alist)
 	 (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
 		(car ,alist)))))
-- 
GitLab