From b635911519cd9b752015d0f31e178af5d549f9fc Mon Sep 17 00:00:00 2001
From: csr21 <unknown>
Date: Wed, 25 Jun 2003 07:55:04 -0400
Subject: [PATCH] Fix typesafety bugs in DEFINE-GCONTEXT-ACCESSOR

darcs-hash:20030625115504-ed5a3-8e1a89af106f69f94588df641457e22d23501f3f.gz
---
 gcontext.lisp | 12 +++++++-----
 1 file changed, 7 insertions(+), 5 deletions(-)

diff --git a/gcontext.lisp b/gcontext.lisp
index d1f6308..23d6a22 100644
--- a/gcontext.lisp
+++ b/gcontext.lisp
@@ -95,14 +95,16 @@
 (defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
   (name nil :type symbol :read-only t)
   (default nil :type t :read-only t)
+  ;; FIXME: these used to have glorious, but wrong, type declarations.
+  ;; See if we can't return them to their former glory.
   (set-function #'(lambda (gcontext value)
 		    (declare (ignore gcontext))
 		    value)
-		:type (function (gcontext t) t) :read-only t)
+		:type (or function symbol) :read-only t)
   (copy-function #'(lambda (from-gc to-gc value)
 		     (declare (ignore from-gc to-gc))
 		     value)
-		 :type (function (gcontext gcontext t) t) :read-only t))
+		 :type (or function symbol) :read-only t))
 
 (defvar *gcontext-extensions* nil) ;; list of gcontext-extension
 
@@ -904,7 +906,7 @@
   (declare (type symbol name)
 	   (type t default)
 	   (type symbol set-function) ;; required
-	   (type symbol copy-function))
+	   (type (or symbol list) copy-function))
   (let* ((gc-name (intern (concatenate 'string
 				       (string 'gcontext-)
 				       (string name)))) ;; in current package
@@ -957,8 +959,8 @@
 (defun add-gcontext-extension (name default-value set-function copy-function)
   (declare (type symbol name)
 	   (type t default-value)
-	   (type (function (gcontext t) t) set-function)
-	   (type (function (gcontext gcontext t) t) copy-function))
+	   (type (or function symbol) set-function)
+	   (type (or function symbol) copy-function))
   (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
 		    (prog1 (length *gcontext-extensions*)
 			   (push nil *gcontext-extensions*)))))
-- 
GitLab