From 9ccad91c1ec86cd90e8b591c29ec85aff9c89268 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 13 Dec 2002 07:34:20 +0000 Subject: [PATCH] r3614: *** empty log message *** --- package.lisp | 7 ++++--- views.lisp | 47 ++++++++++++++++++++++++++--------------------- wrapper.lisp | 52 +++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 81 insertions(+), 25 deletions(-) diff --git a/package.lisp b/package.lisp index 9da628e..d0d3957 100644 --- 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 e30b0eb..c30c0a8 100644 --- 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) "~%") - (setf (slot-value view 'file-end-str) "~%") + (setf (slot-value view 'file-start-str) (format nil "~%")) + (setf (slot-value view 'file-end-str) (format nil "~%")) (setf (slot-value view 'list-start-indent) t) (setf (slot-value view 'list-start-fmtstr) "

~a~p:

~%") (setf (slot-value view 'list-start-value-func) #'htmlformat-list-start-value-func) - (setf (slot-value view 'list-end-fmtstr) "

~%") + (setf (slot-value view 'list-end-fmtstr) (format nil "~%")) (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) "

") (setf (slot-value view 'obj-start-value-func) nil) (setf (slot-value view 'obj-end-indent) t) - (setf (slot-value view 'obj-end-fmtstr) "

~%") + (setf (slot-value view 'obj-end-fmtstr) (format nil "~%")) (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) "~%") - (setf (slot-value view 'file-end-str) "~%") + (setf (slot-value view 'file-start-str) (format nil "~%")) + (setf (slot-value view 'file-end-str) (format nil "~%")) (setf (slot-value view 'list-start-indent) t) (setf (slot-value view 'list-start-fmtstr) "

~a~p:

~%") (setf (slot-value view 'list-start-value-func) #'htmlformat-list-start-value-func) - (setf (slot-value view 'list-end-fmtstr) "

") (setf (slot-value view 'obj-start-value-func) nil) (setf (slot-value view 'obj-end-indent) t) - (setf (slot-value view 'obj-end-fmtstr) "

~%") + (setf (slot-value view 'obj-end-fmtstr) (format nil "~%")) (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) "~%") (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) "~%") - (setf (slot-value view 'obj-end-value-func) #'class-name-of) + (setf (slot-value view 'obj-end-fmtstr) (format nil "~%" (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 6e67805..e1c497c 100644 --- 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)) + )))) + +||# -- 2.34.1