From 86ec4d5f1d54cc100dec0882d5bf7ecaf8d39af7 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 26 Nov 2002 21:52:29 +0000 Subject: [PATCH] r3491: *** empty log message *** --- debian/changelog | 6 ++ examples/example.lisp | 6 +- hyperobject.lisp | 135 ++++++++++++++++++++++++------------------ 3 files changed, 85 insertions(+), 62 deletions(-) diff --git a/debian/changelog b/debian/changelog index e9639ec..b6e2503 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-hyperobject (2.0.1-1) unstable; urgency=low + + * Rework definition of class and slot options + + -- Kevin M. Rosenberg Tue, 26 Nov 2002 14:52:22 -0700 + cl-hyperobject (2.0.0-1) unstable; urgency=low * New version, incompatibe with version 1.x diff --git a/examples/example.lisp b/examples/example.lisp index 0e97b03..0d6b3d5 100644 --- a/examples/example.lisp +++ b/examples/example.lisp @@ -9,7 +9,7 @@ ;;;; ;;;; A simple example file for hyperobjects ;;;; -;;;; $Id: example.lisp,v 1.1 2002/11/25 04:47:23 kevin Exp $ +;;;; $Id: example.lisp,v 1.2 2002/11/26 21:51:10 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -84,7 +84,7 @@ (format t "~&Text Format~%") -(print-hyperobject mary :subobjects t) +(view mary :subobjects t) (format t "~&XML Format with field labels and hyperlinks~%") -(print-hyperobject mary :subobjects t :label t :format :xmlref) +(view mary :subobjects t :label t :format :xmlref) diff --git a/hyperobject.lisp b/hyperobject.lisp index 574d1b6..8f585f0 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.16 2002/11/25 07:45:35 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.17 2002/11/26 21:51:10 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -69,6 +69,8 @@ :documentation "List of slots to print") (description :initarg :description :initform nil :documentation "Class description") + (version :initarg :version :initform nil + :documentation "Version number for class") ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. @@ -77,6 +79,8 @@ "List of fields that contain a list of subobjects objects.") (references :type list :initform nil :documentation "List of fields that have references") + (class-id :type integer :initform nil :documentation + "Unique ID for the class") (value-func :initform nil :type function) (xmlvalue-func :initform nil :type function) @@ -124,59 +128,71 @@ iargs) (find-class 'hyperobject-dsd)) -(defmacro define-class-option (slot-name &optional required) - #+lispworks - `(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql ,slot-name)) - value) + +; Slot definitions + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro process-class-option (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)) (list name `',value)) - #+(or allegro sbcl cmu scl) - (declare (ignore slot-name required)) - ) - -(defmacro define-slot-option (slot-name) - #+lispworks - `(defmethod clos:process-a-slot-option ((class hyperobject-class) - (option (eql ,slot-name)) - value + #+(or allegro sbcl cmu scl) + (declare (ignore slot-name required)) + ) + + (defmacro process-slot-option (slot-name) + #+lispworks + `(defmethod clos:process-a-slot-option ((class hyperobject-class) + (option (eql ,slot-name)) + value already-processed-other-options - slot) - (list option `',value)) - #-lispworks - (declare (ignore slot-name)) - ) - -(define-class-option :title) -(define-class-option :print-slots) -(define-class-option :description) - -(define-slot-option :print-formatter) -(define-slot-option :subobject) -(define-slot-option :reference) -(define-slot-option :description) - -;; Slot definitions - -(defclass hyperobject-dsd (standard-direct-slot-definition) - ((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 :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) - )) - - + slot) + (list option `',value)) + #-lispworks + (declare (ignore slot-name)) + ) + + (defparameter *class-options* + '(:title :print-slots :description :version :sql-name) + "List of class options for hyperobjects.") + (defparameter *slot-options* + '(:print-formatter :subobject :reference :description :unique :sql-name) + "List of slot options that can appear as an initarg") + (defparameter *slot-options-no-initarg* + '(:ho-type) + "List of slot options that do not have an initarg") + + (dolist (option *class-options*) + (eval `(process-class-option ,option))) + (dolist (option *slot-options*) + (eval `(process-slot-option ,option))) + + (eval + `(defclass hyperobject-dsd (standard-direct-slot-definition) + (,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initform nil)) + *slot-options-no-initarg*) + ,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initarg + ,(intern (symbol-name x) (symbol-name :keyword)) + :initform nil)) + *slot-options*)))) + (eval + `(defclass hyperobject-esd (standard-effective-slot-definition) + (,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initarg + ,(intern (symbol-name x) (symbol-name :keyword)) + :initform nil)) + (append *slot-options* *slot-options-no-initarg*))))) + ) ;; eval-when + (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+(or allegro lispworks) name dsds) #+allergo (declare (ignore name)) @@ -229,9 +245,9 @@ (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)) + :reader (if (eq t (slot-value slot 'subobject)) (slot-definition-name slot) - (esd-subobject slot))) + (slot-value slot 'subobject))) subobjects))) subobjects))) @@ -320,13 +336,14 @@ (string-append fmtstr-html-labels html-label-str) (string-append fmtstr-xml-labels xml-label-str) - (if (esd-reference slot) + (if (slot-value slot 'reference) (progn (string-append fmtstr-html-ref "<~~a>" value-fmt "") (string-append fmtstr-xml-ref "<~~a>" value-fmt "") (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") - (push (make-instance 'reference :name name :lookup (esd-reference slot)) + (push (make-instance 'reference :name name + :lookup (slot-value slot 'reference)) references)) (progn (string-append fmtstr-html-ref html-str) @@ -403,11 +420,11 @@ (slot-value (class-of obj) 'xmlvalue-func)) (eval-when (:compile-toplevel :load-toplevel :execute) -(defun hyperobject-class-title (obj) - (awhen (slot-value (class-of obj) 'title) - (if (consp it) - (car it) - it)))) + (defun hyperobject-class-title (obj) + (awhen (slot-value (class-of obj) 'title) + (if (consp it) + (car it) + it)))) (defun hyperobject-class-subobjects (obj) (slot-value (class-of obj) 'subobjects)) -- 2.34.1