r3596: *** empty log message ***

diff --git a/mop.lisp b/mop.lisp
index 327c76bd259c8f995ec5953ee2d58795898274df..e315843aecc11282fdca3291278f10290f80a8e7 100644 (file)
--- 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))

diff --git a/package.lisp b/package.lisp
index ecda605e53bb4a0cf30a4d4bc2f6b3326f126779..9da628eec9b19a8dcdd59c42528cf750af26c478 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.17 2002/12/09 10:36:15 kevin Exp $
+;;;; $Id: package.lisp,v 1.18 2002/12/09 19:37:54 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -24,7 +24,7 @@
    #:package
    #:hyperobject
    #:hyperobject-class
-   #:hyperobject-class-title
+   #:hyperobject-class-user-name
    #:load-all-subobjects
    #:view
    #:fmt-comma-integer