X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=e315843aecc11282fdca3291278f10290f80a8e7;hb=8c743e4dea6fe52c62c1cdf02a75839654e1427c;hp=327c76bd259c8f995ec5953ee2d58795898274df;hpb=ab3efcb8339f5af488db39118a62d8236fa20e35;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index 327c76b..e315843 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: mop.lisp,v 1.8 2002/12/09 10:39:38 kevin Exp $
+;;;; $Id: mop.lisp,v 1.9 2002/12/09 19:37:54 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -155,12 +155,25 @@
 			:initform nil))
 		  (append *slot-options* *slot-options-no-initarg*)))))
   ) ;; eval-when
-  
+
+(defun intern-in-keyword (obj)
+  (cond
+    ((null obj)
+     nil)
+    ((eq t obj)
+     t)
+    ((atom obj)
+     (intern (symbol-name obj) (find-package 'keyword)))
+    ((consp obj)
+     (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj))))
+    (t
+     obj)))
+
 (defmethod compute-effective-slot-definition :around
     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
   #+allergo (declare (ignore name))
   (let* ((dsd (car dsds))
-	 (ho-type (slot-value dsd 'type))
+	 (ho-type (intern-in-keyword (slot-value dsd 'type)))
 	 (sql-type (ho-type-to-sql-type ho-type))
 	 (length (when (consp ho-type) (cadr ho-type))))
     (setf (slot-value dsd 'ho-type) ho-type)
@@ -186,7 +199,7 @@
   (when (consp ho-type)
     (setq ho-type (car ho-type)))
   (check-type ho-type symbol)
-  (case (intern (symbol-name ho-type) (symbol-name :keyword))
+  (case ho-type
     ((or :string :cdata :varchar :char)
      'string)
     (:character
@@ -201,7 +214,7 @@
      'single-float)
     (:double-float
      'double-float)
-    (:nil
+    (nil
      t)
     (otherwise
      ho-type)))
@@ -210,7 +223,7 @@
   (when (consp ho-type)
     (setq ho-type (car ho-type)))
   (check-type ho-type symbol)
-  (case (intern (symbol-name ho-type) (symbol-name :keyword))
+  (case ho-type
     ((or :string :cdata)
      'string)
     (:fixnum
@@ -223,7 +236,7 @@
      'single-float)
     (:double-float
      'double-float)
-    (:nil
+    (nil
      t)
     (otherwise
      ho-type)))
@@ -336,13 +349,11 @@
 (defun hyperobject-class-xmlvalue-func (obj)
   (slot-value (class-of obj) 'xmlvalue-func))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  
-  (defun hyperobject-class-user-name (obj)
-    (awhen (slot-value (class-of obj) 'user-name)
-	   (if (consp it)
-	       (car it)
-	       it))))
+(defun hyperobject-class-user-name (obj)
+  (awhen (slot-value (class-of obj) 'user-name)
+	 (if (consp it)
+	     (car it)
+	     it)))
 
 (defun hyperobject-class-subobjects (obj)
   (slot-value (class-of obj) 'subobjects))