From: Kevin M. Rosenberg Date: Mon, 25 Nov 2002 07:45:36 +0000 (+0000) Subject: r3474: *** empty log message *** X-Git-Tag: debian-2.11.0-2~258 X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=a922259ecd7b9d02cccb8cc735e06ed8483f270a;hp=a332fc23291a68f46d2e973df7c28ec07a4abcfe;p=hyperobject.git r3474: *** empty log message *** --- diff --git a/hyperobject-no-mop.lisp b/hyperobject-no-mop.lisp index af75982..bb104d3 100644 --- a/hyperobject-no-mop.lisp +++ b/hyperobject-no-mop.lisp @@ -9,12 +9,28 @@ ;;;; ;;;; This is a rewrite of hyperobjec't to avoid using metaclasses. ;;;; -;;;; $Id: hyperobject-no-mop.lisp,v 1.5 2002/11/25 02:10:38 kevin Exp $ +;;;; $Id: hyperobject-no-mop.lisp,v 1.6 2002/11/25 07:45:35 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* - + + +(defpackage #:hyperobject-no-mop + (:nicknames #:ho-no-mop) + (:use #:common-lisp #:kmrcl) + (:export + #:define-hyperobject + #:hyperobject + #:hyperobject-base-url! + #:load-all-subobjects + #:print-hyperobject + )) + +(defpackage #:hyperobject-no-mop-user + (:nicknames #:ho-no-mop-user) + (:use #:hyperobject-no-mop #:cl #:cl-user)) + (in-package :hyperobject-no-mop) diff --git a/hyperobject.lisp b/hyperobject.lisp index f6ad52c..574d1b6 100644 --- a/hyperobject.lisp +++ b/hyperobject.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: hyperobject.lisp,v 1.15 2002/11/25 04:49:22 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.16 2002/11/25 07:45:35 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -48,6 +48,13 @@ pcl::validate-superclass pcl:direct-slot-definition-class pcl:compute-effective-slot-definition pcl::compute-effective-slot-definition-initargs) + #+scl + `(class-of class-name clos:class-slots clos::standard-class + clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos::validate-superclass clos:direct-slot-definition-class + clos:compute-effective-slot-definition + clos::compute-effective-slot-definition-initargs) :hyperobject)) @@ -124,9 +131,7 @@ value) (when (and ,required (null value)) (error "hyperobject class slot ~A must have a value" name)) - (if (null (cdr value)) - `(name ,(car value)) - `(name (quote value)))) + (list name `',value)) #+(or allegro sbcl cmu scl) (declare (ignore slot-name required)) ) @@ -138,7 +143,7 @@ value already-processed-other-options slot) - (list option value)) + (list option `',value)) #-lispworks (declare (ignore slot-name)) ) @@ -155,23 +160,23 @@ ;; Slot definitions (defclass hyperobject-dsd (standard-direct-slot-definition) - ((ho-type :initarg :ho-type) - (print-formatter :initarg :print-formatter) - (subobject :initarg :subobject :initarg nil) - (reference :initarg :reference :initarg nil) - (description :initarg :description :initarg nil) + ((ho-type :initarg :ho-type :initform nil) + (print-formatter :initarg :print-formatter :initform nil) + (subobject :initarg :subobject :initform nil) + (reference :initarg :reference :initform nil) + (description :initarg :description :initform nil) )) (defclass hyperobject-esd (standard-effective-slot-definition) - ((ho-type :initarg :ho-type :accessor esd-ho-type) - (print-formatter :initarg :print-formatter :accessor esd-print-formatter) - (subobject :initarg :subobject :accessor esd-subobject) - (reference :initarg :reference :accessor esd-reference) - (description :initarg :description :accessor esd-description) + ((ho-type :initarg :ho-type :accessor esd-ho-type :initform nil) + (print-formatter :initarg :print-formatter :accessor esd-print-formatter + :initform nil) + (subobject :initarg :subobject :accessor esd-subobject :initform nil) + (reference :initarg :reference :accessor esd-reference :initform nil) + (description :initarg :description :accessor esd-description :initform nil) )) - (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+(or allegro lispworks) name dsds) #+allergo (declare (ignore name)) @@ -206,6 +211,8 @@ 'string) (:float 'float) + (:nil + t) (otherwise ho-type))) @@ -267,6 +274,7 @@ (package (symbol-package (class-name cl))) (references nil)) (declare (ignore classname)) + (check-type (slot-value cl 'print-slots) list) (dolist (slot-name (slot-value cl 'print-slots)) (let ((slot (find-slot-by-name cl slot-name))) (unless slot @@ -328,9 +336,9 @@ (if print-formatter (setq plain-value-func - (list `(,print-formatter (,(intern namestr package) x)))) + (list `(,print-formatter (slot-value x ',(intern namestr package))))) (setq plain-value-func - (list `(,(intern namestr package) x)))) + (list `(slot-value x ',(intern namestr package))))) (setq value-func (append value-func plain-value-func)) (if (eql type :cdata) diff --git a/package.lisp b/package.lisp index 0a2be50..3cccf37 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.11 2002/11/25 04:49:22 kevin Exp $ +;;;; $Id: package.lisp,v 1.12 2002/11/25 07:45:35 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -25,27 +25,11 @@ #:hyperobject-class #:hyperobject-class-title #:load-all-subobjects - #:print-hyperobject - )) - -(defpackage #:hyperobject-no-mop - (:nicknames #:ho-no-mop) - (:use #:common-lisp #:kmrcl) - (:export - #:define-hyperobject - #:hyperobject - #:hyperobject-base-url! - #:load-all-subobjects - #:print-hyperobject + #:view )) (defpackage #:hyperobject-user (:nicknames #:ho-user) (:use #:hyperobject #:cl #:cl-user)) -(defpackage #:hyperobject-no-mop-user - (:nicknames #:ho-no-mop-user) - (:use #:hyperobject-no-mop #:cl #:cl-user)) - - diff --git a/views.lisp b/views.lisp index cf92ed0..e9a89e3 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.1 2002/11/25 04:47:23 kevin Exp $ +;;;; $Id: views.lisp,v 1.2 2002/11/25 07:45:35 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -404,11 +404,11 @@ (load-all-subobjects it)))))) objs)) -(defgeneric print-hyperobject-class (objs fmt strm +(defgeneric view-hyperobject (objs fmt strm &optional label english-only-function indent subobjects refvars)) -(defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream) +(defmethod view-hyperobject (objs (fmt dataformat) (strm stream) &optional (label nil) (indent 0) (english-only-function nil) (subobjects nil) (refvars nil)) @@ -427,7 +427,7 @@ (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 - (print-hyperobject-class it fmt strm label + (view-hyperobject it fmt strm label (1+ indent) english-only-function subobjects refvars))))) (fmt-obj-end obj fmt strm indent))) @@ -435,16 +435,15 @@ t)) - -(defun print-hyperobject (objs &key (os *standard-output*) (format :text) +(defun view (objs &key (os *standard-output*) (format :text) (label nil) (english-only-function nil) (subobjects nil) (file-wrapper t) (refvars nil)) - "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class" + "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject" (let ((fmt (make-format-instance format))) (if file-wrapper (fmt-file-start fmt os)) (when objs - (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars)) + (view-hyperobject objs fmt os label 0 english-only-function subobjects refvars)) (if file-wrapper (fmt-file-end fmt os))) objs)