From 18558405db4d6d5ca2a47aac32fb13958430b189 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 25 Nov 2002 02:10:38 +0000 Subject: [PATCH] r3471: *** empty log message *** --- base-class.lisp | 30 ++++++++ hyperobject-no-mop.lisp | 3 +- hyperobject.asd | 10 +-- hyperobject.lisp | 148 +++++++++++++++++++++------------------- package.lisp | 3 +- 5 files changed, 115 insertions(+), 79 deletions(-) create mode 100644 base-class.lisp diff --git a/base-class.lisp b/base-class.lisp new file mode 100644 index 0000000..4c03156 --- /dev/null +++ b/base-class.lisp @@ -0,0 +1,30 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: base-class.lisp +;;;; Purpose: Definition of basic hyperobject class +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id: base-class.lisp,v 1.1 2002/11/25 02:10:38 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package :hyperobject) + +(defclass hyperobject () + () + (:metaclass hyperobject-class) + (:description "Basic hyperobject class")) + + +(defmethod print-object ((obj hyperobject) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (let ((fmt (make-instance 'hyperobject::textformat))) + (apply #'format + s (funcall (obj-data-fmtstr fmt) obj) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) obj) obj)))))) + diff --git a/hyperobject-no-mop.lisp b/hyperobject-no-mop.lisp index e315706..af75982 100644 --- a/hyperobject-no-mop.lisp +++ b/hyperobject-no-mop.lisp @@ -9,7 +9,7 @@ ;;;; ;;;; This is a rewrite of hyperobjec't to avoid using metaclasses. ;;;; -;;;; $Id: hyperobject-no-mop.lisp,v 1.4 2002/11/23 22:19:17 kevin Exp $ +;;;; $Id: hyperobject-no-mop.lisp,v 1.5 2002/11/25 02:10:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -214,7 +214,6 @@ (xml-value-func '()) (package (symbol-package name))) (dolist (field (slot-value meta 'fields)) - (declare (ignore rest)) (let* ((name (name field)) (print-formatter (print-formatter field)) (type (ho-type field)) diff --git a/hyperobject.asd b/hyperobject.asd index 8057acd..7e33ad1 100644 --- a/hyperobject.asd +++ b/hyperobject.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: hyperobject.asd,v 1.6 2002/11/22 15:43:22 kevin Exp $ +;;;; $Id: hyperobject.asd,v 1.7 2002/11/25 02:10:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -19,9 +19,11 @@ (pushnew :hyperobject cl:*features*)) :components ((:file "package") - #+(or allegro lispworks sbcl cmucl scl) + #+(or allegro lispworks sbcl cmu scl) (:file "hyperobject" :depends-on ("package")) - (:file "hyperobject-no-mop" :depends-on ("package"))) - :depends-on (:kmrcl)) + (:file "base-class" :depends-on ("hyperobject")) + (:file "hyperobject-no-mop" :depends-on ("package")) + ) + :depends-on (:kmrcl)) diff --git a/hyperobject.lisp b/hyperobject.lisp index 34a60a9..2479712 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.12 2002/11/24 17:47:50 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.13 2002/11/25 02:10:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -22,33 +22,35 @@ (eval-when (:compile-toplevel :execute) (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + #+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) + #+cmu + `(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)) -(shadowing-import - #+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) -`(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 @@ -58,7 +60,7 @@ (print-formatter :initarg :print-formatter :initform nil) (subobject :initarg :subobject :initform nil) (reference :initarg :reference :initform nil) - (description :initarg :reference :initform nil) + (description :initarg :description :initform nil) )) (defclass hyperobject-esd (standard-effective-slot-definition) @@ -66,7 +68,7 @@ (print-formatter :initarg :print-formatter :initform nil :accessor esd-print-formatter) (subobject :initarg :subobject :initform nil :accessor esd-subobject) (reference :initarg :reference :initform nil :accessor esd-reference) - (description :initarg :reference :initform nil :accessor esd-description) + (description :initarg :description :initform nil :accessor esd-description) )) ;; Main class @@ -130,20 +132,22 @@ ;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) - &rest iargs) + #+allegro &rest + iargs) (find-class 'hyperobject-dsd)) - (defmacro define-class-slot (slot-name &optional required) #+lispworks - (defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql ,slot-name)) - value) - (when (and ,required (null value)) - (error "hyperobject class slot ~A must have a value" name)) - (if (null (cdr value)) - (list name (car value)) - (list name `',value))) + `(defmethod clos:process-a-class-option ((class hyperobject-class) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "hyperobject class slot ~A must have a value" name)) + (if (null (cdr value)) + (list name (car value)) + (list name `',value))) + #+(or allegro sbcl cmu scl) + (declare (ignore slot-name required)) ) (define-class-slot :title) @@ -152,14 +156,14 @@ (defmethod compute-effective-slot-definition :around - ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) - (declare (ignorable slot)) + ((cl hyperobject-class) #+(or allegro lispworks) name dsds) + #+allergo (declare (ignore name)) (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 (compute-effective-slot-definition-initargs - cl #+lispworks slot dsds))) + cl #+lispworks name dsds))) (apply #'make-instance 'hyperobject-esd :ho-type ho-type @@ -196,21 +200,36 @@ (defun process-subobjects (cl) "Process class subobjects slot" - (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)) + (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 (esd-subobject slot)) + (slot-definition-name slot) + (esd-subobject slot))) + subobjects))) + subobjects))) (defun process-documentation (cl) "Calculate class documentation slot" - (setf (slot-value cl 'documentation) - (format nil "Hyperobject class: ~A" (slot-value cl 'description))) - ) - + (awhen (slot-value cl 'title) + (setf (slot-value cl 'title) (car it))) + (awhen (slot-value cl 'description) + (setf (slot-value cl 'description) (car it))) + + (let ((*print-circle* nil)) + (setf (documentation (class-name cl) 'class) + (format nil "Hyperobject~A~A~A~A" + (aif (slot-value cl 'title) + (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)) "") + (aif (slot-value cl 'print-slots) + (format nil "~%Print-slots:~{ ~A~}" it) "") + )))) (defun process-views (cl) "Calculate all view slots for a hyperobject class" @@ -229,8 +248,7 @@ (xmlvalue-func '()) (classname (class-name cl)) (package (symbol-package (class-name cl))) - (references nil) - (subobjects nil)) + (references nil)) (declare (ignore classname)) (dolist (slot-name (slot-value cl 'print-slots)) (let ((slot (find-slot-by-name cl slot-name))) @@ -332,8 +350,8 @@ (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" (process-subobjects cl) - (process-documentation cl) - (process-views cl)) + (process-views cl) + (process-documentation cl)) (defun hyperobject-class-fmtstr-text (obj) (slot-value (class-of obj) 'fmtstr-text)) @@ -820,17 +838,3 @@ (fmt-file-end fmt os))) objs) - -(defclass hyperobject () - () - (:metaclass hyperobject-class)) - - -(defmethod print-object ((obj hyperobject) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (let ((fmt (make-instance 'hyperobject::textformat))) - (apply #'format - s (funcall (obj-data-fmtstr fmt) obj) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) obj) obj)))))) - diff --git a/package.lisp b/package.lisp index dac580d..a0d8a3b 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.9 2002/11/23 22:19:17 kevin Exp $ +;;;; $Id: package.lisp,v 1.10 2002/11/25 02:10:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -20,6 +20,7 @@ (:nicknames #:ho) (:use #:common-lisp #:kmrcl) (:export + #:package #:hyperobject #:hyperobject-class #:hyperobject-base-url! -- 2.34.1