projects / hyperobject.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (from parent 1: da95022)
r3614: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 13 Dec 2002 07:34:20 +0000 (07:34 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 13 Dec 2002 07:34:20 +0000 (07:34 +0000)
package.lisp patch | blob | history
views.lisp patch | blob | history
wrapper.lisp patch | blob | history

diff --git a/package.lisp b/package.lisp
index 9da628eec9b19a8dcdd59c42528cf750af26c478..d0d3957144c16042ea11a4d2d839af65ffceaf0f 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.18 2002/12/09 19:37:54 kevin Exp $
+;;;; $Id: package.lisp,v 1.19 2002/12/13 07:33:54 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -47,14 +47,15 @@
      clos:direct-slot-definition-class clos:compute-effective-slot-definition
      clos::compute-effective-slot-definition-initargs)
    #+sbcl 
-   `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class
+   `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl:find-class
+     sb-pcl::standard-class
      sb-pcl::slot-definition-name sb-pcl:finalize-inheritance
      sb-pcl::standard-direct-slot-definition
      sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
      sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition
      sb-pcl::compute-effective-slot-definition-initargs)
    #+cmu
-   `(pcl:class-of  pcl:class-name pcl:class-slots pcl::standard-class
+   `(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
      pcl::slot-definition-name pcl:finalize-inheritance
      pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
      pcl::validate-superclass pcl:direct-slot-definition-class
diff --git a/views.lisp b/views.lisp
index e30b0eb072b83d0611d0537eae930412850fc922..c30c0a8cfd1b24c9753bb16f6b31a70fefebab8d 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.12 2002/12/13 05:44:19 kevin Exp $
+;;;; $Id: views.lisp,v 1.13 2002/12/13 07:33:54 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -264,45 +264,46 @@
   (setf (slot-value view 'list-start-value-func) #'text-list-start-value-func)
   (setf (slot-value view 'list-start-indent) t)
   (setf (slot-value view 'obj-data-indent) t)
-  (setf (slot-value view 'obj-data-end-fmtstr) "~%"))
+  (setf (slot-value view 'obj-data-end-fmtstr) (format nil "~%"))
+  )
 
 (defun initialize-html-view (view)
   (initialize-text-view view)
-  (setf (slot-value view 'file-start-str) "<html><body>~%")
-  (setf (slot-value view 'file-end-str) "</body><html>~%")
+  (setf (slot-value view 'file-start-str) (format nil "<html><body>~%"))
+  (setf (slot-value view 'file-end-str) (format nil "</body><html>~%"))
   (setf (slot-value view 'list-start-indent) t)
   (setf (slot-value view 'list-start-fmtstr)
        "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%")
   (setf (slot-value view 'list-start-value-func)
        #'htmlformat-list-start-value-func)
-  (setf (slot-value view 'list-end-fmtstr) "</ul></div>~%")
+  (setf (slot-value view 'list-end-fmtstr) (format nil "</ul></div>~%"))
   (setf (slot-value view 'list-end-indent) t)
   (setf (slot-value view 'list-end-value-func) nil)
   (setf (slot-value view 'obj-start-indent) t)
   (setf (slot-value view 'obj-start-fmtstr) "<li>")
   (setf (slot-value view 'obj-start-value-func) nil)
   (setf (slot-value view 'obj-end-indent)  t)
-  (setf (slot-value view 'obj-end-fmtstr)  "</li>~%")
+  (setf (slot-value view 'obj-end-fmtstr)  (format nil "</li>~%"))
   (setf (slot-value view 'obj-end-value-func) nil)
   (setf (slot-value view 'obj-data-indent) t))
 
 (defun initialize-xhtml-view (view)
   (initialize-text-view view)
-  (setf (slot-value view 'file-start-str) "<html><body>~%")
-  (setf (slot-value view 'file-end-str) "</body><html>~%")
+  (setf (slot-value view 'file-start-str) (format nil "<html><body>~%"))
+  (setf (slot-value view 'file-end-str) (format nil "</body><html>~%"))
   (setf (slot-value view 'list-start-indent) t)
   (setf (slot-value view 'list-start-fmtstr)
        "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%")
   (setf (slot-value view 'list-start-value-func)
                    #'htmlformat-list-start-value-func)
-  (setf (slot-value view 'list-end-fmtstr) "</ul></div>~%")
+  (setf (slot-value view 'list-end-fmtstr) (format nil "</ul></div>~%"))
   (setf (slot-value view 'list-end-indent) t)
   (setf (slot-value view 'list-end-value-func) nil)
   (setf (slot-value view 'obj-start-indent) t)
   (setf (slot-value view 'obj-start-fmtstr) "<li>")
   (setf (slot-value view 'obj-start-value-func) nil)
   (setf (slot-value view 'obj-end-indent)  t)
-  (setf (slot-value view 'obj-end-fmtstr) "</li>~%")
+  (setf (slot-value view 'obj-end-fmtstr) (format nil "</li>~%"))
   (setf (slot-value view 'obj-end-value-func) nil)
   (setf (slot-value view 'obj-data-indent) t))
 
@@ -322,11 +323,9 @@
   (setf (slot-value view 'list-end-indent) t)
   (setf (slot-value view 'list-end-fmtstr) "</~a>~%")
   (setf (slot-value view 'list-end-value-func) #'xmlformat-list-end-value-func)
-  (setf (slot-value view 'obj-start-fmtstr) "<~a>")
-  (setf (slot-value view 'obj-start-value-func) #'class-name-of)
+  (setf (slot-value view 'obj-start-fmtstr) (format nil "<~(~a~)>" (slot-value view 'object-class)))
   (setf (slot-value view 'obj-start-indent) t)
-  (setf (slot-value view 'obj-end-fmtstr) "</~a>~%")
-  (setf (slot-value view 'obj-end-value-func) #'class-name-of)
+  (setf (slot-value view 'obj-end-fmtstr) (format nil "</~(~a~)>~%" (slot-value view 'object-class)))
   (setf (slot-value view 'obj-end-indent) nil)
   (setf (slot-value view 'obj-data-indent) nil))
 
@@ -335,11 +334,11 @@
 
 (defun fmt-file-start (view strm)
   (awhen (slot-value view 'file-start-str)
-        (format strm it)))
+        (write-string it strm)))
 
 (defun fmt-file-end (view strm)
   (awhen (slot-value view 'file-end-str)
-        (format strm it)))
+        (write-string it strm)))
 
 ;;; List Start and Ends
 
@@ -351,7 +350,7 @@
                    (apply #'format strm fmtstr
                           (multiple-value-list (funcall value-func
                                                         obj num-items)))
-                   (format strm fmtstr))))
+                   (write-string fmtstr strm))))
 
 (defun fmt-list-end (obj view strm indent num-items)
   (declare (ignore num-items))
@@ -361,7 +360,7 @@
            (let-if (value-func (slot-value view 'list-end-value-func))
                    (apply #'format strm fmtstr (multiple-value-list
                                                 (funcall value-func obj)))
-                   (format strm fmtstr))))
+                   (write-string fmtstr strm))))
 
 ;;; Object Start and Ends
 
@@ -372,7 +371,7 @@
            (let-if (value-func (slot-value view 'obj-start-value-func))
                    (apply #'format strm fmtstr (multiple-value-list
                                                 (funcall value-func obj)))
-                   (format strm fmtstr))))
+                   (write-string fmtstr strm))))
 
 (defun fmt-obj-end (obj view strm indent)
   (when (slot-value view 'obj-end-indent)
@@ -381,7 +380,7 @@
            (let-if (value-func (slot-value view 'obj-end-value-func))
                    (apply #'format strm fmtstr (multiple-value-list
                                                 (funcall value-func obj)))
-                   (format strm fmtstr))))
+                   (write-string fmtstr strm))))
   
 ;;; Object Data 
 
@@ -460,7 +459,13 @@
                         subobjects refvars)
   "Display a single or list of hyperobject-class instances and their subobjects"
   (let-when (objlist (mklist objs))
-    (let ((nobjs (length objlist)))
+    (let ((nobjs (length objlist))
+         (*print-pretty* nil)
+         (*print-circle* nil)
+         (*print-escape* nil)
+         (*print-readably* nil)
+         (*print-length* nil)
+         (*print-level* nil))
       (fmt-list-start (car objlist) view strm indent nobjs)
       (dolist (obj objlist)
         (unless (and filter (not (funcall filter obj)))
diff --git a/wrapper.lisp b/wrapper.lisp
index 6e67805fc8bf061838da35527e5a0b84403c8a83..e1c497c18894319b544a926abb6d02940857356f 100644 (file)
--- a/wrapper.lisp
+++ b/wrapper.lisp
@@ -7,10 +7,60 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: wrapper.lisp,v 1.2 2002/12/13 05:44:19 kevin Exp $
+;;;; $Id: wrapper.lisp,v 1.3 2002/12/13 07:33:54 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (in-package :hyperobject)
 
+(eval-when (:compile-toplevel :execute)
+  (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+
+#||
+(defmacro define-hyperobject (name parents fields &rest meta-fields)
+  (let* ((meta-fields (process-meta-fields fields meta-fields))
+        (cl-fields (process-hyper-fields fields meta-fields)))
+    `(progn
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+        (defclass ,name ,(append parents (list 'hyperobject)) ,cl-fields
+          ,@meta-fields))(and documentation (list (list :documentation documentation)))))
+       (let ((,value-func (compile nil (eval (slot-value ,meta 'value-func))))
+            (,xml-value-func (compile nil (eval (slot-value ,meta 'xml-value-func)))))
+        (defmethod ho-title ((obj ,name))
+          ,title)
+        (defmethod ho-name ((obj ,name))
+          ,(string-downcase (symbol-name name)))
+        (defmethod ho-fields ((obj ,name))
+          ',(slot-value meta 'fields))
+        (defmethod ho-references ((obj ,name))
+          ',(slot-value meta 'references))
+        (defmethod ho-subobjects ((obj ,name))
+          ',(slot-value meta 'subobjects))
+        (defmethod ho-value-func ((obj ,name))
+          ,value-func)
+        (defmethod ho-xml-value-func ((obj ,name))
+          ,xml-value-func)
+        (defmethod ho-fmtstr-text ((obj ,name))
+          ,(slot-value meta 'fmtstr-text))
+        (defmethod ho-fmtstr-html ((obj ,name))
+          ,(slot-value meta 'fmtstr-html))
+        (defmethod ho-fmtstr-xml ((obj ,name))
+          ,(slot-value meta 'fmtstr-xml))
+        (defmethod ho-fmtstr-text-labels ((obj ,name))
+          ,(slot-value meta 'fmtstr-text-labels))
+        (defmethod ho-fmtstr-html-labels ((obj ,name))
+          ,(slot-value meta 'fmtstr-html-labels))
+        (defmethod ho-fmtstr-xml-labels ((obj ,name))
+          ,(slot-value meta 'fmtstr-xml-labels))
+        (defmethod ho-fmtstr-html-ref ((obj ,name))
+          ,(slot-value meta 'fmtstr-html-ref))
+        (defmethod ho-fmtstr-xml-ref ((obj ,name))
+          ,(slot-value meta 'fmtstr-xml-ref))
+        (defmethod ho-fmtstr-html-ref-labels ((obj ,name))
+          ,(slot-value meta 'fmtstr-html-ref-labels))
+        (defmethod ho-fmtstr-xml-ref-labels ((obj ,name))
+          ,(slot-value meta 'fmtstr-xml-ref-labels))
+        ))))
+
+||#
Common Lisp library providing Smart, linked objects using metaobject protocol