From: Kevin M. Rosenberg Date: Thu, 17 Aug 2006 18:31:29 +0000 (+0000) Subject: r11037: changes for sbcl mop / whitespace canonicalization X-Git-Tag: debian-2.11.0-2~16 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=920865199d81789ced3a9e0a24f4c95b3ec6fa7f r11037: changes for sbcl mop / whitespace canonicalization --- diff --git a/debian/changelog b/debian/changelog index 091a094..0f8819e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-hyperobject (2.9.1-1) unstable; urgency=low + + * Support change in SBCL MOP + + -- Kevin M. Rosenberg Thu, 17 Aug 2006 12:12:58 -0600 + cl-hyperobject (2.9.0-1) unstable; urgency=low * New upstream URI diff --git a/debian/control b/debian/control index 45e825d..86ee061 100644 --- a/debian/control +++ b/debian/control @@ -2,8 +2,8 @@ Source: cl-hyperobject Section: devel Priority: optional Maintainer: Kevin M. Rosenberg -Build-Depends-Indep: debhelper (>= 4.0.0) -Standards-Version: 3.6.2.1 +Build-Depends: debhelper (>= 4.0.0) +Standards-Version: 3.7.2.1 Package: cl-hyperobject Architecture: all diff --git a/mop.lisp b/mop.lisp index 5307f3e..7d6a77b 100644 --- a/mop.lisp +++ b/mop.lisp @@ -15,7 +15,7 @@ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) ;; Main class @@ -47,7 +47,7 @@ ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. - + (subobjects :initform nil :accessor subobjects :documentation "List of fields that contain a list of subobjects objects.") @@ -66,7 +66,7 @@ :documentation "The default view for a class") (documementation :initform nil :initarg :documentation :documentation "Documentation string for hyperclass.") - + ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) (create-indices-cmds :initform nil :reader create-index-cmds) @@ -116,7 +116,7 @@ #+ignore (unless (find-class (class-name cl)) (setf (find-class (class-name cl)) cl)) - + (init-hyperobject-class cl) ) @@ -126,13 +126,13 @@ 'compute-effective-slot-definition))) 3) (pushnew :ho-normal-cesd cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew :ho-normal-dsdc cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'effective-slot-definition-class))) @@ -144,7 +144,7 @@ #+ho-normal-dsdc &rest iargs) (find-class 'hyperobject-dsd)) -(defmethod effective-slot-definition-class ((cl hyperobject-class) +(defmethod effective-slot-definition-class ((cl hyperobject-class) #+ho-normal-esdc &rest iargs) (find-class 'hyperobject-esd)) @@ -175,7 +175,7 @@ #-lispworks (declare (ignore slot-name)) ) - + (dolist (option *class-options*) (eval `(process-class-option ,option))) (dolist (option *slot-options*) @@ -245,11 +245,13 @@ (defun compute-hyperobject-esd (esd dsds) (let* ((dsd (car dsds)) (value-type (canonicalize-value-type (slot-value dsd 'value-type)))) - (multiple-value-bind (sql-type sql-length) + (multiple-value-bind (sql-type sql-length) (value-type-to-sql-type value-type) (setf (esd-sql-type esd) sql-type) (setf (esd-sql-length esd) sql-length)) - (setf (slot-value esd 'type) (value-type-to-lisp-type value-type)) + (setf (slot-value esd #-sbcl 'type + #+sbcl 'sb-pcl::%type) + (value-type-to-lisp-type value-type)) (setf (esd-value-type esd) value-type) (setf (esd-user-name esd) (aif (dsd-user-name dsd) @@ -379,7 +381,7 @@ SQL name" ;; The reader is a function and the reader-keys are slot names. The slot is lazily set to ;; the result of applying the function to the slot-values of those slots, and that value ;; is also returned. -(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader +(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader &rest reader-keys) (setf (getf (gethash cl *lazy-readers*) slot-name) (aif subobj-class @@ -425,7 +427,7 @@ SQL name" "Make sure all class slots have an expected value" (unless (user-name cl) (setf (user-name cl) (format nil "~:(~A~)" (class-name cl)))) - + (setf (user-name-plural cl) (if (and (consp (user-name cl)) (cadr (user-name cl))) (cadr (user-name cl)) @@ -440,7 +442,7 @@ SQL name" (if (listp it) (car it) it)))) - + (unless (sql-name cl) (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl)))) ) diff --git a/views.lisp b/views.lisp index 8d43e69..b9274aa 100644 --- a/views.lisp +++ b/views.lisp @@ -11,7 +11,7 @@ ;;;; ;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) @@ -23,7 +23,7 @@ :documentation "List of effective slots for object to be viewed.") (id :initform nil :initarg :id :accessor id :documentation "id for this view.") - (source-code :initform nil :initarg :source-code :accessor source-code + (source-code :initform nil :initarg :source-code :accessor source-code :documentation "Source code for generating view.") (country-language :initform :en :initarg :country-language :documentation "Country's Language for this view.") @@ -111,8 +111,8 @@ (make-instance (class-name obj-cl)) (setq cpl (class-precedence-list obj-cl)))) (find-view-id-in-class-precedence (second cpl) vid))))) - - + + (defun get-view-id (obj vid &optional slots) "Find or make a category view for an object" (let ((obj-cl (class-of obj))) @@ -147,7 +147,7 @@ ((typep view-def 'object-view) view-def) ((eq view-def :default) - (make-instance 'object-view + (make-instance 'object-view :object-class (class-name cl) :id :compact-text)) ((consp view-def) @@ -160,11 +160,11 @@ (error "Invalid parameter to make-object-view: ~S" view-def)))) (defmethod initialize-instance :after ((self object-view) - &rest initargs + &rest initargs &key &allow-other-keys) (initialize-view self)) - + (defun initialize-view (view) "Calculate all view slots for a hyperobject class" (let ((obj-cl (find-class (object-class view)))) @@ -183,20 +183,20 @@ "Initialize a view based upon a source code" (let* ((source-code (source-code view)) (printer `(lambda - (,(intern (symbol-name '#:self) + (,(intern (symbol-name '#:self) (symbol-package (object-class view))) - ,(intern (symbol-name '#:s) + ,(intern (symbol-name '#:s) (symbol-package (object-class view)))) - (declare (ignorable - ,(intern (symbol-name '#:self) + (declare (ignorable + ,(intern (symbol-name '#:self) (symbol-package (object-class view))) - ,(intern (symbol-name '#:s) + ,(intern (symbol-name '#:s) (symbol-package (object-class view))))) - (with-slots ,(slots view) - ,(intern (symbol-name '#:self) + (with-slots ,(slots view) + ,(intern (symbol-name '#:self) (symbol-package (object-class view))) ,@source-code)))) - (setf (printer view) + (setf (printer view) (compile nil (eval printer))))) (defmacro write-simple (v s) @@ -240,7 +240,7 @@ (vector-push-extend '(write-string "" s) print-func) (ppfc-html title name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func)) - + (defun ppfc-html-labels (label name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) (vector-push-extend `(write-string ,label s) print-func) @@ -262,11 +262,11 @@ (defun ppfc-html-link (name type formatter cdata nlink print-func) (declare (fixnum nlink)) (vector-push-extend '(write-char #\< s) print-func) - (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func) + (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func) (vector-push-extend '(write-char #\> s) print-func) (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) (vector-push-extend '(write-string " s) print-func)) (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func) @@ -281,7 +281,8 @@ (user-name (esd-user-name slot)) (xml-user-name (escape-xml-string user-name)) (xml-tag (escape-xml-string user-name)) - (type (slot-value slot 'type)) + (type (slot-value slot #-sbcl 'type + #+sbcl 'sb-pcl::%type)) (cdata (not (null (and (in vid :xml :xhtml :xml-link :xhtml-link :xml-labels :ie-xml-labels @@ -290,7 +291,7 @@ (or formatter (lisp-type-is-a-string type)))))) (hyperlink (esd-hyperlink slot))) - + (case vid (:compact-text (vector-push-extend @@ -359,7 +360,7 @@ "Initialize a view based upon a preset vid" (unless (creatable-view-id-p obj-cl (id view)) (error "Unable to automatically create view id ~A" (id view))) - + (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) (let ((links '()) @@ -372,7 +373,7 @@ ((null slots)) (unless slot (error "Slot ~A is not found in class ~S" slot-name obj-cl)) - + (push-print-fun-code (id view) slot (length links) print-func) (when (> (length slots) 1) (vector-push-extend '(write-char #\space s) print-func)) @@ -386,7 +387,7 @@ ,@(map 'list #'identity print-func))) (setf (obj-data-printer view) (compile nil (eval (obj-data-print-code view)))) - + (setf (link-slots view) (nreverse links))) (finalize-view-by-id view) @@ -641,7 +642,7 @@ (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (obj-end-printer view) (if (stringp it) (write-string it strm) @@ -659,13 +660,13 @@ (defun fmt-subobj-end (obj view strm indent) (when (subobj-end-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (subobj-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) - -;;; Object Data + +;;; Object Data (defun make-link-start (view fieldfunc fieldvalue refvars link-printer) @@ -689,7 +690,7 @@ (link-printer (funcall link-printer link-page fieldfunc fieldvalue refvars s)))) (write-char #\" s))) - + (defun make-link-end (obj view fieldname) (declare (ignore obj fieldname)) (link-href-end view)) @@ -752,7 +753,7 @@ strm vid (1+ indent) filter subobjects refvars link-printer))))) - + (defun view-hyperobject (objs view strm &optional vid (indent 0) filter subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" @@ -772,7 +773,7 @@ (fmt-obj-start obj view strm indent) (fmt-obj-data obj view strm (1+ indent) refvars link-printer) (fmt-obj-end obj view strm indent) - (if subobjects + (if subobjects (progn (fmt-subobj-start obj view strm indent) (view-subobjects obj strm vid indent filter subobjects