r3587: *** empty log message ***

diff --git a/.cvsignore b/.cvsignore
index 6b8599c2f4fa7b4f591b62de1bef851a141322a1..6aed28e83188a13431bdc23ceb59d57c4bc76683 100644 (file)
--- a/.cvsignore
+++ b/.cvsignore
@@ -1,4 +1,8 @@
-*~
-*.cfsl
-*.dfsl
-*.fasl*
+uffi.pdf
+uffi.ps
+uffi.tex
+uffi.dvi
+uffi.aux
+uffi.log
+uffi.out
+html

diff --git a/metaclass.lisp b/metaclass.lisp
index 9c854509286ffe211fa687389a005d67d547c710..2a632b50d766faba563699999eb0e6847fd6ca22 100644 (file)
--- a/metaclass.lisp
+++ b/metaclass.lisp
@@ -8,7 +8,7 @@
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;;
-;;;; $Id: metaclass.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
+;;;; $Id: metaclass.lisp,v 1.3 2002/12/09 10:37:58 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -21,14 +21,14 @@
 
   
 (defparameter *class-options*
-  '(:title :print-slots :description :version :sql-name)
+  '(:user-name :print-slots :description :version :sql-name)
   "List of class options for hyperobjects.")
 (defparameter *slot-options*
-  '(:print-formatter :description
+  '(:print-formatter :description :user-name
     :subobject :hyperlink :hyperlink-parameters
-    :stored :indexed :inverse :unique :sql-name)
+    :index :inverse :unique :sql-name)
   "Slot options that can appear as an initarg")
 (defparameter *slot-options-no-initarg*
-  '(:ho-type :sql-type)
+  '(:ho-type :sql-type :length)
   "Slot options that do not have an initarg")
 

diff --git a/mop.lisp b/mop.lisp
index 45e704aee09c17929079473bf4d0d99c7e7e2a62..327c76bd259c8f995ec5953ee2d58795898274df 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.7 2002/12/06 16:18:49 kevin Exp $
+;;;; $Id: mop.lisp,v 1.8 2002/12/09 10:39:38 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -26,15 +26,15 @@
 
 (defclass hyperobject-class (standard-class)
   ( ;; slots initialized in defclass
-   (title :initarg :title :type string :initform nil
-         :documentation "Print Title for class")
+   (user-name :initarg :user-name :type string :initform nil
+         :documentation "User name for class")
    (print-slots :initarg :print-slots :type list :initform nil
                :documentation "List of slots to print")
    (description :initarg :description :initform nil
                :documentation "Class description")
    (version :initarg :version :initform nil
                :documentation "Version number for class")
-   (sql-name :initarg :table-name :initform nil :reader sql-name)
+   (sql-name :initarg :table-name :initform nil)
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
@@ -66,8 +66,13 @@
   (:documentation "Metaclass for Markup Language classes."))
 
 (defclass subobject ()
-  ((name :type symbol :initform nil :initarg :name :reader name)
-   (reader :type function :initform nil :initarg :reader :reader reader)))
+  ((name-class :type symbol :initform nil :initarg :name-class :reader name-class)
+   (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)
+   (lookup :type symbol :initform nil :initarg :lookup :reader lookup)
+   (lookup-keys :type list :initform nil :initarg :lookup-keys
+               :reader lookup-keys))
+  (:documentation "Contains subobject information"))
+
 
 (defmethod print-object ((obj subobject) (s stream))
   (print-unreadable-object (obj s :type t :identity t)
@@ -156,7 +161,8 @@
   #+allergo (declare (ignore name))
   (let* ((dsd (car dsds))
         (ho-type (slot-value dsd 'type))
-        (sql-type (ho-type-to-sql-type ho-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)
     (setf (slot-value dsd 'sql-type) sql-type)
     (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
@@ -166,37 +172,46 @@
        #'make-instance 'hyperobject-esd 
        :ho-type ho-type
        :sql-type sql-type
+       :length length
        :print-formatter (slot-value dsd 'print-formatter)
        :subobject (slot-value dsd 'subobject)
        :hyperlink (slot-value dsd 'hyperlink)
        :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
        :description (slot-value dsd 'description)
+       :user-name (slot-value dsd 'user-name)
+       :index (slot-value dsd 'index)
        ia))))
 
 (defun ho-type-to-lisp-type (ho-type)
+  (when (consp ho-type)
+    (setq ho-type (car ho-type)))
   (check-type ho-type symbol)
   (case (intern (symbol-name ho-type) (symbol-name :keyword))
-    (:string
+    ((or :string :cdata :varchar :char)
      'string)
+    (:character
+     'character)
     (:fixnum
      'fixnum)
     (:boolean
      'boolean)
     (:integer
      'integer)
-    (:cdata
-     'string)
-    (:float
-     'float)
+    ((or :float :single-float)
+     'single-float)
+    (:double-float
+     'double-float)
     (:nil
      t)
     (otherwise
      ho-type)))
 
 (defun ho-type-to-sql-type (ho-type)
+  (when (consp ho-type)
+    (setq ho-type (car ho-type)))
   (check-type ho-type symbol)
   (case (intern (symbol-name ho-type) (symbol-name :keyword))
-    (:string
+    ((or :string :cdata)
      'string)
     (:fixnum
      'integer)
@@ -204,10 +219,10 @@
      'boolean)
     (:integer
      'integer)
-    (:cdata
-     'string)
-    (:float
-     'float)
+    ((or :float :single-float)
+     'single-float)
+    (:double-float
+     'double-float)
     (:nil
      t)
     (otherwise
@@ -216,24 +231,50 @@
 
 ;;;; Class initialization function
 
+;; defines a slot-unbound method for class and slot-name, fills
+;; the slot by calling reader function with the slot values of
+;; the instance's reader-keys
+(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
+  (let* ((the-slot-name (gensym))
+        (the-class (gensym))
+        (the-instance (gensym))
+        (keys '()))
+    (dolist (key reader-keys)
+      (push (list 'slot-value the-instance (list 'quote key)) keys))
+    (setq keys (nreverse keys))
+    `(defmethod slot-unbound (,the-class (,the-instance ,class)
+                                        (,the-slot-name (eql ',slot-name)))
+       (declare (ignore ,the-class))
+       (setf (slot-value ,the-instance ,the-slot-name)
+          (,reader ,@keys)))))
+
 (defun finalize-subobjects (cl)
   "Process class subobjects slot"
   (setf (slot-value cl 'subobjects)
     (let ((subobjects '()))
       (dolist (slot (class-slots cl))
-       (when (slot-value slot 'subobject)
-         (push (make-instance 'subobject :name (slot-definition-name slot)
-                              :reader (if (eq t (slot-value slot 'subobject))
-                                          (slot-definition-name slot)
-                                        (slot-value slot 'subobject)))
-               subobjects)))
+       (let-when (subobj-def (slot-value slot 'subobject))
+          (let ((subobject (make-instance 'subobject
+                                         :name-class (class-name cl)
+                                         :name-slot (slot-definition-name slot)
+                                         :lookup (if (atom subobj-def)
+                                                     subobj-def
+                                                     (car subobj-def))
+                                         :lookup-keys (if (atom subobj-def)
+                                                          nil
+                                                          (cdr subobj-def)))))
+           (unless (eq (lookup subobject) t)
+             (eval `(def-lazy-reader ,(name-class subobject)
+                        ,(name-slot subobject) ,(lookup subobject)
+                        ,@(lookup-keys subobject))))
+           (push subobject subobjects))))
       subobjects)))
 
 (defun finalize-documentation (cl)
   "Calculate class documentation slot"
-  (awhen (slot-value cl 'title)
-        (setf (slot-value cl 'title)
-              (etypecase (slot-value cl 'title)
+  (awhen (slot-value cl 'user-name)
+        (setf (slot-value cl 'user-name)
+              (etypecase (slot-value cl 'user-name)
                   (cons (car it))
                   ((or string symbol) it))))
   (awhen (slot-value cl 'description)
@@ -245,12 +286,12 @@
   (let ((*print-circle* nil))
     (setf (documentation (class-name cl) 'class)
       (format nil "Hyperobject~A~A~A~A"
-             (aif (slot-value cl 'title)
+             (aif (slot-value cl 'user-name)
                   (format nil ": ~A" it ""))
              (aif (slot-value cl 'description)
                   (format nil "~%Class description: ~A" it) "")
              (aif (slot-value cl 'subobjects)
-                  (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
+                  (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
              (aif (slot-value cl 'print-slots)
                   (format nil "~%Print-slots:~{ ~A~}" it) "")
              ))))
@@ -297,8 +338,8 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   
-  (defun hyperobject-class-title (obj)
-    (awhen (slot-value (class-of obj) 'title)
+  (defun hyperobject-class-user-name (obj)
+    (awhen (slot-value (class-of obj) 'user-name)
           (if (consp it)
               (car it)
               it))))

diff --git a/package.lisp b/package.lisp
index daf4a32dec7ceaf60f61f72d509deb94ad75a38f..ecda605e53bb4a0cf30a4d4bc2f6b3326f126779 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.16 2002/12/05 18:15:23 kevin Exp $
+;;;; $Id: package.lisp,v 1.17 2002/12/09 10:36:15 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************

diff --git a/views.lisp b/views.lisp
index f1016a14599de1f25f6d43dc62d4d98293e1854e..a80c1e9a58051331c17fae8530096be424fd0241 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.10 2002/12/06 20:46:51 kevin Exp $
+;;;; $Id: views.lisp,v 1.11 2002/12/09 10:39:38 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -218,11 +218,15 @@
    (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
    (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
    (link-ref :initarg :link-ref :reader link-ref))
-  (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
-                    :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
-                    :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
-                    :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
-                    :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
+  (:default-initargs :file-start-str nil :file-end-str nil
+                    :list-start-fmtstr nil :list-start-value-func nil
+                    :list-start-indent nil :list-end-fmtstr nil
+                    :list-end-value-func nil :list-end-indent nil
+                    :obj-start-fmtstr nil :obj-start-value-func nil
+                    :obj-start-indent nil :obj-end-fmtstr nil
+                    :obj-end-value-func nil :obj-end-indent nil
+                    :obj-data-indent nil :obj-data-fmtstr nil
+                    :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
                     :obj-data-value-func nil :link-ref nil)
   (:documentation "Parent for all dataformat objects"))
 
@@ -233,7 +237,7 @@
   ())
 
 (defun text-list-start-value-func (obj nitems)
-  (values (hyperobject-class-title obj) nitems))
+  (values (hyperobject-class-user-name obj) nitems))
 
 (defclass textformat (dataformat) 
   ()   
@@ -251,7 +255,7 @@
   (string-downcase (class-name (class-of obj))))
 
 (defun htmlformat-list-start-value-func (x nitems) 
-  (values (hyperobject-class-title x) nitems (class-name-of x)))
+  (values (hyperobject-class-user-name x) nitems (class-name-of x)))
 
 (defclass htmlformat (textformat) 
   ()
@@ -300,7 +304,7 @@
   (format nil "~alist" (class-name-of x)))
 
 (defun xmlformat-list-start-value-func (x nitems) 
-  (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
+  (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name x) nitems))
 
 (defclass xmlformat (textformat) 
   ()
@@ -530,7 +534,7 @@
       (dolist (obj objlist)
         (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
           (dolist (child-obj it)   ;; for each child function
-            (awhen (funcall (reader child-obj) obj)
+            (awhen (slot-value obj (name-slot child-obj))
               (load-all-subobjects it))))))
     objs))
 
@@ -556,10 +560,10 @@
           (if subobjects
               (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
                         (dolist (child-obj it)   ;; for each child function
-                          (awhen (funcall (reader child-obj) obj) ;; access set of child objects
-                                    (view-hyperobject it fmt strm label 
-                                                     (1+ indent) english-only-function
-                                                    subobjects refvars)))))
+                          (awhen (slot-value obj (name-slot child-obj)) ;; access set of child objects
+                                (view-hyperobject it fmt strm label 
+                                                  (1+ indent) english-only-function
+                                                  subobjects refvars)))))
           (fmt-obj-end obj fmt strm indent)))
       (fmt-list-end (car objs) fmt strm indent nobjs))
     t))