From: Kevin M. Rosenberg Date: Mon, 9 Dec 2002 10:39:38 +0000 (+0000) Subject: r3587: *** empty log message *** X-Git-Tag: debian-2.11.0-2~240 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=9e616a490d6d4f03682a7bd7e9ea6587fecf2015 r3587: *** empty log message *** --- diff --git a/.cvsignore b/.cvsignore index 6b8599c..6aed28e 100644 --- a/.cvsignore +++ b/.cvsignore @@ -1,4 +1,8 @@ -*~ -*.cfsl -*.dfsl -*.fasl* +uffi.pdf +uffi.ps +uffi.tex +uffi.dvi +uffi.aux +uffi.log +uffi.out +html diff --git a/metaclass.lisp b/metaclass.lisp index 9c85450..2a632b5 100644 --- a/metaclass.lisp +++ b/metaclass.lisp @@ -8,7 +8,7 @@ ;;;; Date Started: Apr 2000 ;;;; ;;;; -;;;; $Id: metaclass.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $ +;;;; $Id: metaclass.lisp,v 1.3 2002/12/09 10:37:58 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -21,14 +21,14 @@ (defparameter *class-options* - '(:title :print-slots :description :version :sql-name) + '(:user-name :print-slots :description :version :sql-name) "List of class options for hyperobjects.") (defparameter *slot-options* - '(:print-formatter :description + '(:print-formatter :description :user-name :subobject :hyperlink :hyperlink-parameters - :stored :indexed :inverse :unique :sql-name) + :index :inverse :unique :sql-name) "Slot options that can appear as an initarg") (defparameter *slot-options-no-initarg* - '(:ho-type :sql-type) + '(:ho-type :sql-type :length) "Slot options that do not have an initarg") diff --git a/mop.lisp b/mop.lisp index 45e704a..327c76b 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.7 2002/12/06 16:18:49 kevin Exp $ +;;;; $Id: mop.lisp,v 1.8 2002/12/09 10:39:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -26,15 +26,15 @@ (defclass hyperobject-class (standard-class) ( ;; slots initialized in defclass - (title :initarg :title :type string :initform nil - :documentation "Print Title for class") + (user-name :initarg :user-name :type string :initform nil + :documentation "User name for class") (print-slots :initarg :print-slots :type list :initform nil :documentation "List of slots to print") (description :initarg :description :initform nil :documentation "Class description") (version :initarg :version :initform nil :documentation "Version number for class") - (sql-name :initarg :table-name :initform nil :reader sql-name) + (sql-name :initarg :table-name :initform nil) ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. @@ -66,8 +66,13 @@ (:documentation "Metaclass for Markup Language classes.")) (defclass subobject () - ((name :type symbol :initform nil :initarg :name :reader name) - (reader :type function :initform nil :initarg :reader :reader reader))) + ((name-class :type symbol :initform nil :initarg :name-class :reader name-class) + (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot) + (lookup :type symbol :initform nil :initarg :lookup :reader lookup) + (lookup-keys :type list :initform nil :initarg :lookup-keys + :reader lookup-keys)) + (:documentation "Contains subobject information")) + (defmethod print-object ((obj subobject) (s stream)) (print-unreadable-object (obj s :type t :identity t) @@ -156,7 +161,8 @@ #+allergo (declare (ignore name)) (let* ((dsd (car dsds)) (ho-type (slot-value dsd 'type)) - (sql-type (ho-type-to-sql-type ho-type))) + (sql-type (ho-type-to-sql-type ho-type)) + (length (when (consp ho-type) (cadr ho-type)))) (setf (slot-value dsd 'ho-type) ho-type) (setf (slot-value dsd 'sql-type) sql-type) (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type)) @@ -166,37 +172,46 @@ #'make-instance 'hyperobject-esd :ho-type ho-type :sql-type sql-type + :length length :print-formatter (slot-value dsd 'print-formatter) :subobject (slot-value dsd 'subobject) :hyperlink (slot-value dsd 'hyperlink) :hyperlink-parameters (slot-value dsd 'hyperlink-parameters) :description (slot-value dsd 'description) + :user-name (slot-value dsd 'user-name) + :index (slot-value dsd 'index) ia)))) (defun ho-type-to-lisp-type (ho-type) + (when (consp ho-type) + (setq ho-type (car ho-type))) (check-type ho-type symbol) (case (intern (symbol-name ho-type) (symbol-name :keyword)) - (:string + ((or :string :cdata :varchar :char) 'string) + (:character + 'character) (:fixnum 'fixnum) (:boolean 'boolean) (:integer 'integer) - (:cdata - 'string) - (:float - 'float) + ((or :float :single-float) + 'single-float) + (:double-float + 'double-float) (:nil t) (otherwise ho-type))) (defun ho-type-to-sql-type (ho-type) + (when (consp ho-type) + (setq ho-type (car ho-type))) (check-type ho-type symbol) (case (intern (symbol-name ho-type) (symbol-name :keyword)) - (:string + ((or :string :cdata) 'string) (:fixnum 'integer) @@ -204,10 +219,10 @@ 'boolean) (:integer 'integer) - (:cdata - 'string) - (:float - 'float) + ((or :float :single-float) + 'single-float) + (:double-float + 'double-float) (:nil t) (otherwise @@ -216,24 +231,50 @@ ;;;; Class initialization function +;; defines a slot-unbound method for class and slot-name, fills +;; the slot by calling reader function with the slot values of +;; the instance's reader-keys +(defmacro def-lazy-reader (class slot-name reader &rest reader-keys) + (let* ((the-slot-name (gensym)) + (the-class (gensym)) + (the-instance (gensym)) + (keys '())) + (dolist (key reader-keys) + (push (list 'slot-value the-instance (list 'quote key)) keys)) + (setq keys (nreverse keys)) + `(defmethod slot-unbound (,the-class (,the-instance ,class) + (,the-slot-name (eql ',slot-name))) + (declare (ignore ,the-class)) + (setf (slot-value ,the-instance ,the-slot-name) + (,reader ,@keys))))) + (defun finalize-subobjects (cl) "Process class subobjects slot" (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 (slot-value slot 'subobject)) - (slot-definition-name slot) - (slot-value slot 'subobject))) - subobjects))) + (let-when (subobj-def (slot-value slot 'subobject)) + (let ((subobject (make-instance 'subobject + :name-class (class-name cl) + :name-slot (slot-definition-name slot) + :lookup (if (atom subobj-def) + subobj-def + (car subobj-def)) + :lookup-keys (if (atom subobj-def) + nil + (cdr subobj-def))))) + (unless (eq (lookup subobject) t) + (eval `(def-lazy-reader ,(name-class subobject) + ,(name-slot subobject) ,(lookup subobject) + ,@(lookup-keys subobject)))) + (push subobject subobjects)))) subobjects))) (defun finalize-documentation (cl) "Calculate class documentation slot" - (awhen (slot-value cl 'title) - (setf (slot-value cl 'title) - (etypecase (slot-value cl 'title) + (awhen (slot-value cl 'user-name) + (setf (slot-value cl 'user-name) + (etypecase (slot-value cl 'user-name) (cons (car it)) ((or string symbol) it)))) (awhen (slot-value cl 'description) @@ -245,12 +286,12 @@ (let ((*print-circle* nil)) (setf (documentation (class-name cl) 'class) (format nil "Hyperobject~A~A~A~A" - (aif (slot-value cl 'title) + (aif (slot-value cl 'user-name) (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)) "") + (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") (aif (slot-value cl 'print-slots) (format nil "~%Print-slots:~{ ~A~}" it) "") )))) @@ -297,8 +338,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) - (defun hyperobject-class-title (obj) - (awhen (slot-value (class-of obj) 'title) + (defun hyperobject-class-user-name (obj) + (awhen (slot-value (class-of obj) 'user-name) (if (consp it) (car it) it)))) diff --git a/package.lisp b/package.lisp index daf4a32..ecda605 100644 --- a/package.lisp +++ b/package.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.16 2002/12/05 18:15:23 kevin Exp $ +;;;; $Id: package.lisp,v 1.17 2002/12/09 10:36:15 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* diff --git a/views.lisp b/views.lisp index f1016a1..a80c1e9 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.10 2002/12/06 20:46:51 kevin Exp $ +;;;; $Id: views.lisp,v 1.11 2002/12/09 10:39:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -218,11 +218,15 @@ (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) (link-ref :initarg :link-ref :reader link-ref)) - (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil - :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil - :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil - :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil - :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil + (:default-initargs :file-start-str nil :file-end-str nil + :list-start-fmtstr nil :list-start-value-func nil + :list-start-indent nil :list-end-fmtstr nil + :list-end-value-func nil :list-end-indent nil + :obj-start-fmtstr nil :obj-start-value-func nil + :obj-start-indent nil :obj-end-fmtstr nil + :obj-end-value-func nil :obj-end-indent nil + :obj-data-indent nil :obj-data-fmtstr nil + :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil :obj-data-value-func nil :link-ref nil) (:documentation "Parent for all dataformat objects")) @@ -233,7 +237,7 @@ ()) (defun text-list-start-value-func (obj nitems) - (values (hyperobject-class-title obj) nitems)) + (values (hyperobject-class-user-name obj) nitems)) (defclass textformat (dataformat) () @@ -251,7 +255,7 @@ (string-downcase (class-name (class-of obj)))) (defun htmlformat-list-start-value-func (x nitems) - (values (hyperobject-class-title x) nitems (class-name-of x))) + (values (hyperobject-class-user-name x) nitems (class-name-of x))) (defclass htmlformat (textformat) () @@ -300,7 +304,7 @@ (format nil "~alist" (class-name-of x))) (defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems)) + (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name x) nitems)) (defclass xmlformat (textformat) () @@ -530,7 +534,7 @@ (dolist (obj objlist) (awhen (hyperobject-class-subobjects obj) ;; access list of functions (dolist (child-obj it) ;; for each child function - (awhen (funcall (reader child-obj) obj) + (awhen (slot-value obj (name-slot child-obj)) (load-all-subobjects it)))))) objs)) @@ -556,10 +560,10 @@ (if subobjects (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 - (view-hyperobject it fmt strm label - (1+ indent) english-only-function - subobjects refvars))))) + (awhen (slot-value obj (name-slot child-obj)) ;; access set of child objects + (view-hyperobject it fmt strm label + (1+ indent) english-only-function + subobjects refvars))))) (fmt-obj-end obj fmt strm indent))) (fmt-list-end (car objs) fmt strm indent nobjs)) t))