From 52b71f23b37b79d9f23bd1ab1d8b39e42c7c18d9 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 22 Nov 2002 19:48:49 +0000 Subject: [PATCH] r3457: *** empty log message *** --- example.lisp | 4 +- hyperobject-no-mop.lisp | 4 +- hyperobject.lisp | 93 +++++++++++++++++++---------------------- no-mop-example.lisp | 4 +- package.lisp | 6 +-- 5 files changed, 51 insertions(+), 60 deletions(-) diff --git a/example.lisp b/example.lisp index cc9883d..75ef3f7 100644 --- a/example.lisp +++ b/example.lisp @@ -9,13 +9,13 @@ ;;;; ;;;; A simple example file for hyperobjects ;;;; -;;;; $Id: example.lisp,v 1.3 2002/11/22 19:14:17 kevin Exp $ +;;;; $Id: example.lisp,v 1.4 2002/11/22 19:48:49 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* -(in-package :hyperobject-mop-user) +(in-package :hyperobject-user) (defclass person (hyperobject) diff --git a/hyperobject-no-mop.lisp b/hyperobject-no-mop.lisp index d0be74c..d9f468b 100644 --- a/hyperobject-no-mop.lisp +++ b/hyperobject-no-mop.lisp @@ -9,13 +9,13 @@ ;;;; ;;;; This is a rewrite of hyperobjec't to avoid using metaclasses. ;;;; -;;;; $Id: hyperobject-no-mop.lisp,v 1.1 2002/11/22 15:43:22 kevin Exp $ +;;;; $Id: hyperobject-no-mop.lisp,v 1.2 2002/11/22 19:48:49 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* -(in-package :hyperobject) +(in-package :hyperobject-no-mop) (eval-when (:compile-toplevel :execute) diff --git a/hyperobject.lisp b/hyperobject.lisp index 70b67b1..cedfa5e 100644 --- a/hyperobject.lisp +++ b/hyperobject.lisp @@ -11,53 +11,44 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: hyperobject.lisp,v 1.8 2002/11/22 19:14:17 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.9 2002/11/22 19:48:49 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* -(in-package :hyperobject-mop) +(in-package :hyperobject) (eval-when (:compile-toplevel :execute) (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) -#+allegro (shadowing-import - mop:class-slots mop::slot-definition-name mop:finalize-inheritance - mop::standard-direct-slot-definition mop::standard-effective-slot-definition - mop:direct-slot-definition-class mop:compute-effective-slot-definition - excl::compute-effective-slot-definition-initargs -) - -#+lispworks -(shadowing-import - clos:class-slots clos::slot-definition-name clos:finalize-inheritance - clos::standard-direct-slot-definition clos::standard-effective-slot-definition - clos:direct-slot-definition-class clos:compute-effective-slot-definition - clos::compute-effective-slot-definition-initargs - ) - + #+allegro + `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance + mop::standard-direct-slot-definition mop::standard-effective-slot-definition + mop:direct-slot-definition-class mop:compute-effective-slot-definition + excl::compute-effective-slot-definition-initargs) + #+lispworks + `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + 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::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) #+(or cmu scl) -(shadowing-import - pcl:class-of pcl:class-name pcl:class-slots 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 - pcl:compute-effective-slot-definition - pcl::compute-effective-slot-definition-initargs -) - -#+sbcl -(shadowing-import - sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots 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 - ) +`(pcl:class-of pcl:class-name pcl:class-slots 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 + pcl:compute-effective-slot-definition + pcl::compute-effective-slot-definition-initargs) + :hyperobject) ;; Slot definitions @@ -159,14 +150,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (list name (car value)) (list name `',value))) -(defmethod (compute-effective-slot-definition) :around +(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) (declare (ignorable slot)) (let* ((dsd (car dsds)) (ho-type (slot-value dsd 'type))) (setf (slot-value dsd 'ho-type) ho-type) (setf (slot-value dsd 'type) (convert-ho-type ho-type)) - (let ((ia (computer-effective-slot-definition-initargs + (let ((ia (compute-effective-slot-definition-initargs cl #+lispworks slot dsds))) (apply #'make-instance 'hyperobject-esd @@ -219,20 +210,21 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (references nil) (subobjects nil)) (declare (ignore classname)) - + (dolist (slot (class-slots cl)) + (when (slot-value slot 'subobject) + (push (make-instance 'subobject :name (slot-definition-name slot) + :reader (if (eq t (esd-subobject slot)) + (slot-definition-name slot) + (esd-subobject slot))) + subobjects))) + (setf (slot-value cl 'subobjects) subobjects) (dolist (slot-name (slot-value cl 'print-slots)) (let ((slot (find-slot-by-name cl slot-name))) (unless slot (error "Slot ~A is not found in class ~S" slot-name cl)) - (if (slot-value slot 'subobject) - (push (make-instance 'subobject :name (slot-definition-name slot) - :reader (if (eq t (esd-subobject slot)) - (slot-definition-name slot) - (esd-subobject slot))) - subobjects) - (let ((name (slot-definition-name slot)) - (namestr (symbol-name (slot-definition-name slot))) - (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) + (let ((name (slot-definition-name slot)) + (namestr (symbol-name (slot-definition-name slot))) + (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) (type (slot-value slot 'ho-type)) (formatter (slot-value slot 'format-func)) (value-fmt "~a") @@ -298,10 +290,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (if (eql type :cdata) (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) (setq xmlvalue-func (append xmlvalue-func plain-value-func))) - )))) + ))) (setf (slot-value cl 'references) references) - (setf (slot-value cl 'subobjects) subobjects) (if value-func (setq value-func `(lambda (x) (values ,@value-func))) @@ -823,7 +814,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (print-unreadable-object (obj s :type t :identity t) (let ((fmt (make-instance 'hyperobject::textformat))) (apply #'format - s (funcall (hyperobject-mop::obj-data-fmtstr fmt) obj) + s (funcall (obj-data-fmtstr fmt) obj) (multiple-value-list - (funcall (funcall (hyperobject-mop::obj-data-value-func fmt) obj) obj)))))) + (funcall (funcall (obj-data-value-func fmt) obj) obj)))))) diff --git a/no-mop-example.lisp b/no-mop-example.lisp index c120c21..414acf1 100644 --- a/no-mop-example.lisp +++ b/no-mop-example.lisp @@ -11,13 +11,13 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: no-mop-example.lisp,v 1.1 2002/11/22 15:45:06 kevin Exp $ +;;;; $Id: no-mop-example.lisp,v 1.2 2002/11/22 19:48:49 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* -(in-package :hyperobject-user) +(in-package :hyperobject-no-mop-user) (define-hyperobject person () ((first-name :type string :reference find-person-by-last-name) diff --git a/package.lisp b/package.lisp index 61b19e9..d17b023 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.6 2002/11/22 15:43:22 kevin Exp $ +;;;; $Id: package.lisp,v 1.7 2002/11/22 19:48:49 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -41,11 +41,11 @@ )) (defpackage #:hyperobject-user - (:niceknames #:ho-user) + (:nicknames #:ho-user) (:use #:hyperobject #:cl #:cl-user)) (defpackage #:hyperobject-no-mop-user - (:niceknames #:ho-no-mop-user) + (:nicknames #:ho-no-mop-user) (:use #:hyperobject-no-mop #:cl #:cl-user)) -- 2.34.1