Skip to content
Snippets Groups Projects
Commit b6359115 authored by csr21's avatar csr21
Browse files

Fix typesafety bugs in DEFINE-GCONTEXT-ACCESSOR

darcs-hash:20030625115504-ed5a3-8e1a89af106f69f94588df641457e22d23501f3f.gz
parent 68903efd
No related branches found
No related tags found
No related merge requests found
...@@ -95,14 +95,16 @@ ...@@ -95,14 +95,16 @@
(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named (defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
(name nil :type symbol :read-only t) (name nil :type symbol :read-only t)
(default nil :type t :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) (set-function #'(lambda (gcontext value)
(declare (ignore gcontext)) (declare (ignore gcontext))
value) value)
:type (function (gcontext t) t) :read-only t) :type (or function symbol) :read-only t)
(copy-function #'(lambda (from-gc to-gc value) (copy-function #'(lambda (from-gc to-gc value)
(declare (ignore from-gc to-gc)) (declare (ignore from-gc to-gc))
value) 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 (defvar *gcontext-extensions* nil) ;; list of gcontext-extension
...@@ -904,7 +906,7 @@ ...@@ -904,7 +906,7 @@
(declare (type symbol name) (declare (type symbol name)
(type t default) (type t default)
(type symbol set-function) ;; required (type symbol set-function) ;; required
(type symbol copy-function)) (type (or symbol list) copy-function))
(let* ((gc-name (intern (concatenate 'string (let* ((gc-name (intern (concatenate 'string
(string 'gcontext-) (string 'gcontext-)
(string name)))) ;; in current package (string name)))) ;; in current package
...@@ -957,8 +959,8 @@ ...@@ -957,8 +959,8 @@
(defun add-gcontext-extension (name default-value set-function copy-function) (defun add-gcontext-extension (name default-value set-function copy-function)
(declare (type symbol name) (declare (type symbol name)
(type t default-value) (type t default-value)
(type (function (gcontext t) t) set-function) (type (or function symbol) set-function)
(type (function (gcontext gcontext t) t) copy-function)) (type (or function symbol) copy-function))
(let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
(prog1 (length *gcontext-extensions*) (prog1 (length *gcontext-extensions*)
(push nil *gcontext-extensions*))))) (push nil *gcontext-extensions*)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment