From: Alastair Bridgewater <lisphacker@users.sourceforge.net>
Date: Sat, 11 Apr 2009 18:19:08 +0000 (+0000)
Subject: 1.0.27.6: Make alien-type-class definition work from outside sb-alien.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bda733c26c2555335d355e4bc453e443c2e5741c;p=sbcl.git

1.0.27.6: Make alien-type-class definition work from outside sb-alien.

  Added a slot to the alien-type-class structure to hold the name of
the structure for the class.

  Added the class structure name as a parameter to
create-alien-type-class-if-necessary in order to populate the slot in
the new alien-type-class structure.

  Changed define-alien-type-class to look up included alien type
defstruct names in the alien-type-class for the included type rather
than construct it via SYMBOLICATE (thus breaking the requirement that
all uses of define-alien-type-class be in the sb-alien package).
---

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 267a652..db3baad 100644
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -34,6 +34,7 @@
 
 (defstruct (alien-type-class (:copier nil))
   (name nil :type symbol)
+  (defstruct-name nil :type symbol)
   (include nil :type (or null alien-type-class))
   (unparse nil :type (or null function))
   (type= nil :type (or null function))
@@ -57,13 +58,15 @@
   (or (gethash name *alien-type-classes*)
       (error "no alien type class ~S" name)))
 
-(defun create-alien-type-class-if-necessary (name include)
+(defun create-alien-type-class-if-necessary (name defstruct-name include)
   (let ((old (gethash name *alien-type-classes*))
         (include (and include (alien-type-class-or-lose include))))
     (if old
         (setf (alien-type-class-include old) include)
         (setf (gethash name *alien-type-classes*)
-              (make-alien-type-class :name name :include include)))))
+              (make-alien-type-class :name name
+                                     :defstruct-name defstruct-name
+                                     :include include)))))
 
 (defparameter *method-slot-alist*
   '((:unparse . alien-type-class-unparse)
@@ -99,16 +102,19 @@
           (symbol
            (values
             include
-            (symbolicate "ALIEN-" include "-TYPE")
+            (alien-type-class-defstruct-name
+             (alien-type-class-or-lose include))
             nil))
           (list
            (values
             (car include)
-            (symbolicate "ALIEN-" (car include) "-TYPE")
+            (alien-type-class-defstruct-name
+             (alien-type-class-or-lose (car include)))
             (cdr include))))
       `(progn
          (eval-when (:compile-toplevel :load-toplevel :execute)
-           (create-alien-type-class-if-necessary ',name ',(or include 'root)))
+           (create-alien-type-class-if-necessary ',name ',defstruct-name
+                                                 ',(or include 'root)))
          (def!struct (,defstruct-name
                         (:include ,include-defstruct
                                   (class ',name)
@@ -329,7 +335,7 @@
 ;;;; the root alien type
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (create-alien-type-class-if-necessary 'root nil))
+  (create-alien-type-class-if-necessary 'root 'alien-type nil))
 
 (def!struct (alien-type
              (:make-load-form-fun sb!kernel:just-dump-it-normally)
diff --git a/version.lisp-expr b/version.lisp-expr
index 3466198..abd0218 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.27.5"
+"1.0.27.6"