February 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2532 - in branches/trunk-reorg/projects: eboy gpn raw-data saugnapf unmaintained unmaintained/eboy unmaintained/gpn unmaintained/raw-data unmaintained/saugnapf
by hhubner＠common-lisp.net 18 Feb '08

18 Feb '08

Author: hhubner Date: Mon Feb 18 05:42:27 2008 New Revision: 2532 Added: branches/trunk-reorg/projects/unmaintained/ branches/trunk-reorg/projects/unmaintained/eboy/ - copied from r2514, branches/trunk-reorg/projects/eboy/ branches/trunk-reorg/projects/unmaintained/gpn/ - copied from r2514, branches/trunk-reorg/projects/gpn/ branches/trunk-reorg/projects/unmaintained/raw-data/ - copied from r2514, branches/trunk-reorg/projects/raw-data/ branches/trunk-reorg/projects/unmaintained/saugnapf/ - copied from r2514, branches/trunk-reorg/projects/saugnapf/ Removed: branches/trunk-reorg/projects/eboy/ branches/trunk-reorg/projects/gpn/ branches/trunk-reorg/projects/raw-data/ branches/trunk-reorg/projects/saugnapf/ Log: create "unmaintained" directory and move the historical projects there

1 0

[bknr-cvs] r2531 - branches/trunk-reorg/projects/lisp-ecoop/src
by hhubner＠common-lisp.net 18 Feb '08

18 Feb '08

Author: hhubner Date: Mon Feb 18 05:39:20 2008 New Revision: 2531 Modified: branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp Log: port to trunk-reorg Modified: branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp Mon Feb 18 05:39:20 2008 @@ -7,7 +7,11 @@ (when (probe-file "site.lisp") (load "site.lisp"))) -(defparameter *root-directory* (merge-pathnames #P"../" *load-pathname*)) +(defparameter *root-directory* (merge-pathnames #P"../" + (make-pathname :name nil + :type nil + :version nil + :defaults *load-pathname*))) (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*)) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp Mon Feb 18 05:39:20 2008 @@ -11,7 +11,7 @@ (unless (find-user "anonymous") (make-user "anonymous") ; used for all anonymous sessions (make-user "admin" :password "wispleb" :full-name "Administrator" :flags '(:admin)) - (import-image "bknr-logo.png" :keywords '(:banner :bknr))) + (import-image (probe-file #P"bknr-logo.png") :keywords '(:banner :bknr))) #+(or) (bknr.cron:start-cron) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp Mon Feb 18 05:39:20 2008 @@ -16,7 +16,7 @@ (with-slots (documents) submission (setf documents (remove document documents))))) -y(define-lisp-ecoop-class submission () +(define-lisp-ecoop-class submission () ((title :update :documentation "Title of the submission" :initform nil :attribute t) (abstract :update :documentation "Abstract or short description" :initform nil :element t) (submitters :update :documentation "List of participants who submitted this" :initform nil :element t :containment :+) Modified: branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp Mon Feb 18 05:39:20 2008 @@ -393,4 +393,4 @@ (pathname (find-template-pathname expander "toplevel")) (toplevel (bknr.web::get-cached-template pathname expander)) (bknr.web::*toplevel-children* bknr.web::*tag-children*)) - (emit-template-node toplevel))) \ No newline at end of file + (emit-template-node expander toplevel))) \ No newline at end of file Modified: branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp Mon Feb 18 05:39:20 2008 @@ -19,9 +19,9 @@ :name "LISP ECOOP CMS" :base-href base-href :template-base-directory (namestring (merge-pathnames #p"templates/" *website-directory*)) - :template-command-packages '((:lisp-ecoop . :lisp-ecoop.tags) - (:bknr . :bknr.web) - (:menu . :bknr.site-menu)) + :template-command-packages '(("http://lisp-ecoop07.bknr.net" . :lisp-ecoop.tags) + ("http://bknr.net" . :bknr.web) + ("http://bknr.net/menu" . :bknr.site-menu)) :handler-definitions `(user images #+(or) stats #+(or) mailinglist @@ -41,4 +41,5 @@ (when (and (boundp '*server*) *server*) (stop-server *server*)) (publish-lisp-ecoop) + (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (setq *server* (start-server :port port))) \ No newline at end of file

1 0

[bknr-cvs] r2530 - branches/trunk-reorg/bknr/datastore/src/xml-impex
by hhubner＠common-lisp.net 18 Feb '08

18 Feb '08

Author: hhubner Date: Mon Feb 18 05:36:28 2008 New Revision: 2530 Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp Log: refactor, remove warnings Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp Mon Feb 18 05:36:28 2008 @@ -12,43 +12,14 @@ (defmacro with-xml-export* ((&key output indentation canonical) &body body) `(let ((*objects-written* (make-hash-table :test #'equal)) (cxml::*current-element* nil) - (cxml::*sink* #+(or) (cxml:make-character-stream-sink ,output - :indentation ,indentation :canonical ,canonical))) + (cxml::*sink* (cxml:make-character-stream-sink ,output + :indentation ,indentation :canonical ,canonical))) ,@body)) (defmacro with-xml-export (nil &body body) `(with-xml-export* (:output *standard-output* :indentation 1 :canonical nil) ,@body)) -(defgeneric write-to-xml (object &key name no-recurse) - (:documentation "Write object to XML stream")) - -(defmethod write-to-xml ((object (eql nil)) &key name no-recurse) - (declare (ignore name))) - -(defmethod write-to-xml ((object list) &key (name (error "Can not serialize list to XML without an element name~%")) no-recurse) - (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) - (dolist (obj object) - (write-to-xml obj)) - (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) - -(defmethod write-to-xml ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object)) no-recurse) - (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) - (sax:characters cxml::*sink* (cxml::string-rod object)) - (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) - -(defmethod write-to-xml ((object standard-object) &key &allow-other-keys) - (cxml:with-element (string-downcase (class-name (class-of object))) - (dolist (slot (class-slots (class-of object))) - (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) - (let ((value (slot-value object (slot-definition-name slot)))) - (when value - (cxml:text (handler-case - (cxml::utf8-string-to-rod (princ-to-string value)) - (error (e) - (declare (ignore e)) - (cxml::utf8-string-to-rod "[unprintable]")))))))))) - (defun write-object-reference (class object unique-id-slot-name name) (let ((slotdef (find unique-id-slot-name (class-slots class) :key #'slot-definition-name))) (unless (xml-effective-slot-definition-attribute slotdef) @@ -58,65 +29,92 @@ :value (cxml::string-rod (slot-serialize-value slotdef (slot-value object unique-id-slot-name)))))) (sax:end-element cxml::*sink* nil nil name))) -(defmethod write-to-xml ((object xml-class) &key name no-recurse) - (xml-object-check-validity object) - (let* ((class (class-of object)) - (qname (cxml::string-rod (or name (xml-class-element class))))) - - ;; If this object has been serialized to the XML stream, - ;; write a reference to the object and return. - - (with-slots (unique-id-slot) class - (when unique-id-slot - (if (gethash (slot-value object (first unique-id-slot)) *objects-written*) - (progn - (write-object-reference class object (first unique-id-slot) qname) - (return-from write-to-xml)) - (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t)))) - - ;; Object has not been written to the XML file or no - ;; unique-id-slot is defined for this class. - - (let* ((attr-slots (xml-class-attribute-slots class)) - (elt-slots (xml-class-element-slots class)) - (body-slot (xml-class-body-slot class)) - ;; attributes - (attributes (loop for slot in attr-slots - for name = (slot-definition-name slot) - for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot)) - when (and (slot-boundp object name) - (slot-value object name)) - collect (sax:make-attribute - :qname attdef - :value - (cxml::string-rod - (slot-serialize-value slot (slot-value object name))))))) - (sax:start-element cxml::*sink* nil nil qname attributes) - - ;; elements - (dolist (slot elt-slots) - (let ((name (slot-definition-name slot)) - (element-name (xml-effective-slot-definition-element slot)) - (containment (xml-effective-slot-definition-containment slot))) - (when (slot-boundp object name) - (if (consp (slot-value object name)) - (dolist (child (slot-value object name)) - (if (typep (class-of child) 'xml-class) - (write-to-xml child) - (write-to-xml (slot-serialize-value slot child) :name element-name))) - (let ((child (slot-value object name))) - (if (typep (class-of child) 'xml-class) - (write-to-xml child) - (write-to-xml (slot-serialize-value slot child) :name element-name))))))) - - ;; body slot - (when body-slot - (let ((name (slot-definition-name body-slot))) - (when (slot-boundp object name) - (sax:characters - cxml::*sink* - (cxml::string-rod - (funcall (xml-effective-slot-definition-serializer body-slot) - (slot-value object name))))))) +(defgeneric write-to-xml (object &key) + (:documentation "Write OBJECT to XML stream") + + (:method ((object (eql nil)) &key)) + + (:method ((object list) &key (name (error "Can not serialize list to XML without an element name~%"))) + (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) + (dolist (obj object) + (write-to-xml obj)) + (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) + + (:method ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object))) + (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil) + (sax:characters cxml::*sink* (cxml::string-rod object)) + (sax:end-element cxml::*sink* nil nil (cxml::string-rod name))) + + (:method ((object standard-object) &key) + (cxml:with-element (string-downcase (class-name (class-of object))) + (dolist (slot (class-slots (class-of object))) + (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) + (let ((value (slot-value object (slot-definition-name slot)))) + (when value + (cxml:text (handler-case + (cxml::utf8-string-to-rod (princ-to-string value)) + (error (e) + (declare (ignore e)) + (cxml::utf8-string-to-rod "[unprintable]")))))))))) + + (:method ((object xml-class) &key name) + (xml-object-check-validity object) + (let* ((class (class-of object)) + (qname (cxml::string-rod (or name (xml-class-element class))))) + + ;; If this object has been serialized to the XML stream, + ;; write a reference to the object and return. + + (with-slots (unique-id-slot) class + (when unique-id-slot + (if (gethash (slot-value object (first unique-id-slot)) *objects-written*) + (progn + (write-object-reference class object (first unique-id-slot) qname) + (return-from write-to-xml)) + (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t)))) + + ;; Object has not been written to the XML file or no + ;; unique-id-slot is defined for this class. + + (let* ((attr-slots (xml-class-attribute-slots class)) + (elt-slots (xml-class-element-slots class)) + (body-slot (xml-class-body-slot class)) + ;; attributes + (attributes (loop for slot in attr-slots + for name = (slot-definition-name slot) + for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot)) + when (and (slot-boundp object name) + (slot-value object name)) + collect (sax:make-attribute + :qname attdef + :value + (cxml::string-rod + (slot-serialize-value slot (slot-value object name))))))) + (sax:start-element cxml::*sink* nil nil qname attributes) + + ;; elements + (dolist (slot elt-slots) + (let ((name (slot-definition-name slot)) + (element-name (xml-effective-slot-definition-element slot))) + (when (slot-boundp object name) + (if (consp (slot-value object name)) + (dolist (child (slot-value object name)) + (if (typep (class-of child) 'xml-class) + (write-to-xml child) + (write-to-xml (slot-serialize-value slot child) :name element-name))) + (let ((child (slot-value object name))) + (if (typep (class-of child) 'xml-class) + (write-to-xml child) + (write-to-xml (slot-serialize-value slot child) :name element-name))))))) + + ;; body slot + (when body-slot + (let ((name (slot-definition-name body-slot))) + (when (slot-boundp object name) + (sax:characters + cxml::*sink* + (cxml::string-rod + (funcall (xml-effective-slot-definition-serializer body-slot) + (slot-value object name))))))) - (sax:end-element cxml::*sink* nil nil qname)))) + (sax:end-element cxml::*sink* nil nil qname)))))

1 0

[bknr-cvs] r2529 - branches/trunk-reorg/bknr/datastore/src/indices
by hhubner＠common-lisp.net 18 Feb '08

18 Feb '08

Author: hhubner Date: Mon Feb 18 05:35:20 2008 New Revision: 2529 Modified: branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp Log: Fix warnings. Modified: branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp Mon Feb 18 05:35:20 2008 @@ -141,13 +141,11 @@ (when (and (not (slot-index-index-nil index)) (null key)) (return-from index-add)) - (multiple-value-bind (value presentp) - (gethash key hash-table) - (if presentp - (push object (gethash key hash-table)) - (progn - (tree-add-category tree key) - (setf (gethash key hash-table) (list object))))))) + (if (nth-value 1 (gethash key hash-table)) + (push object (gethash key hash-table)) + (progn + (tree-add-category tree key) + (setf (gethash key hash-table) (list object)))))) (defmethod index-remove ((index category-index) object) (let ((key (slot-value object (slot-index-slot-name index))) Modified: branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp Mon Feb 18 05:35:20 2008 @@ -135,11 +135,9 @@ (when (and (not (slot-index-index-nil index)) (null key)) (return-from index-add)) - (multiple-value-bind (value presentp) - (gethash key hash-table) - (if presentp - (push object (gethash key hash-table)) - (setf (gethash key hash-table) (list object)))))) + (if (nth-value 1 (gethash key hash-table)) + (push object (gethash key hash-table)) + (setf (gethash key hash-table) (list object))))) (defmethod index-remove ((index hash-index) object) (let ((key (slot-value object (slot-index-slot-name index))) @@ -172,11 +170,9 @@ (labels ((index-object (object class) (let ((key (class-name class)) (hash-table (slot-index-hash-table index))) - (multiple-value-bind (value presentp) - (gethash key hash-table) - (if presentp - (push object (gethash key hash-table)) - (setf (gethash key hash-table) (list object))))))) + (if (nth-value 1 (gethash key hash-table)) + (push object (gethash key hash-table)) + (setf (gethash key hash-table) (list object)))))) (if (class-index-index-superclasses index) (dolist (class (cons (class-of object) @@ -212,11 +208,9 @@ (let ((keys (slot-value object (slot-index-slot-name index))) (hash-table (slot-index-hash-table index))) (dolist (key keys) - (multiple-value-bind (value presentp) - (gethash key hash-table) - (if presentp - (push object (gethash key hash-table)) - (setf (gethash key hash-table) (list object))))))) + (if (nth-value 1 (gethash key hash-table)) + (push object (gethash key hash-table)) + (setf (gethash key hash-table) (list object)))))) (defmethod index-remove ((index hash-list-index) object) (let ((keys (slot-value object (slot-index-slot-name index))) @@ -406,7 +400,7 @@ the new skip-list." (let ((new-list (skip-list-index-skip-list new-index)) (old-list (skip-list-index-skip-list old-index))) - (setf (skip-list-index-skip-list new-index) old-list) + (setf (skip-list-index-skip-list new-list) old-list) new-index)) ;;;;;;;;;;;;;;;;;;;;;;;;; @@ -419,9 +413,8 @@ :accessor class-skip-index-slot-name) (hash-table :accessor class-skip-index-hash-table))) -(defmethod initialize-instance :after ((index class-skip-index) &key (type 'string) - (test #'eql) - slots index-superclasses &allow-other-keys) +(defmethod initialize-instance :after ((index class-skip-index) + &key (test #'eql) slots index-superclasses) (unless (<= (length slots) 1) (error "Can not create slot-index with more than one slot.")) (with-slots (hash-table slot-name) index

1 0

[bknr-cvs] r2528 - branches/trunk-reorg/bknr/datastore/src/data
by hhubner＠common-lisp.net 18 Feb '08

18 Feb '08

Author: hhubner Date: Mon Feb 18 05:34:38 2008 New Revision: 2528 Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp Log: Fix warnings Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/object.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp Mon Feb 18 05:34:38 2008 @@ -133,7 +133,7 @@ (:metaclass persistent-class) (:class-indices (all-class :index-type class-skip-index :index-subclasses t - :index-initargs (:type 'integer :index-superclasses t) + :index-initargs (:index-superclasses t) :index-keys all-store-classes :index-reader store-objects-with-class :slots (id)))) @@ -410,8 +410,7 @@ (progn #+nil (format t "read-slots for object ~A, id ~A~%" object object-id) (unless object - (error "READ-SLOTS form for unexistent object with ID ~A~%" object-id) - (return-from snapshot-read-slots)) + (error "READ-SLOTS form for unexistent object with ID ~A~%" object-id)) (%read-slots stream object (cdr (gethash layout-id layouts))) #+nil (when object

1 0

[bknr-cvs] r2527 - branches/trunk-reorg/thirdparty/hunchentoot-0.15.0
by hhubner＠common-lisp.net 18 Feb '08

18 Feb '08

Author: hhubner Date: Mon Feb 18 05:30:00 2008 New Revision: 2527 Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp Log: CCL 1.2 compatibility fix Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp (original) +++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp Mon Feb 18 05:30:00 2008 @@ -41,6 +41,7 @@ "Like INCF, but other threads can't interfer." `(ccl::atomic-incf-decf ,place ,delta)) +#-openmcl-native-threads (defun invoke-with-timeout (seconds bodyfn timeoutfn) "Executes the function \(with no arguments) BODY-FN and returns its results but stops execution after DURATION seconds and then @@ -54,6 +55,7 @@ (unwind-protect (funcall bodyfn) (ccl::dequeue-timer-request timer))))) +#-openmcl-native-threads (defmacro with-timeout ((seconds &body timeout-forms) &body body) "Executes the code BODY and returns the results of the last form but stops execution after SECONDS seconds and then instead @@ -63,6 +65,14 @@ #'(lambda () ,@body) #'(lambda () ,@timeout-forms))) +#+openmcl-native-threads +(defmacro with-timeout ((seconds &body timeout-forms) &body body) + "Compatibility stub, CCL with native threads does not support +support asynchronous timeouts." + (declare (ignore seconds timeout-forms)) + `(progn + ,@body)) + (defun process-run-function (name function &rest args) "See OpenMCL documentation for CCL:PROCESS-RUN-FUNCTION." (apply #'ccl:process-run-function name function args))

1 0

[bknr-cvs] r2526 - branches/trunk-reorg/thirdparty/uffi-1.6.0/src
by hhubner＠common-lisp.net 18 Feb '08

18 Feb '08

Author: hhubner Date: Mon Feb 18 03:38:51 2008 New Revision: 2526 Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp Log: fix :pointer-self for unions Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp (original) +++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp Mon Feb 18 03:38:51 2008 @@ -67,40 +67,48 @@ `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array))) ) -(defun process-struct-fields (name fields &optional (variant nil)) +(defun process-aggregate-fields (name fields &key (variant nil) (aggregate-type :struct)) (let (processed) (dolist (field fields) (let* ((field-name (car field)) (type (cadr field)) (def (append (list field-name) - (if (eq type :pointer-self) - #+(or cmu scl) `((* (alien:struct ,name))) - #+sbcl `((* (sb-alien:struct ,name))) - #+(or openmcl digitool) `((:* (:struct ,name))) - #+lispworks `((:pointer ,name)) - #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name)) - `(,(convert-from-uffi-type type :struct)))))) + (if (eq type :pointer-self) + (ecase aggregate-type + (:struct + #+(or cmu scl) `((* (alien:struct ,name))) + #+sbcl `((* (sb-alien:struct ,name))) + #+(or openmcl digitool) `((:* (:struct ,name))) + #+lispworks `((:pointer ,name)) + #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))) + (:union + #+(or cmu scl) `((* (alien:union ,name))) + #+sbcl `((* (sb-alien:union ,name))) + #+(or openmcl digitool) `((:* (:union ,name))) + #+lispworks `((:pointer ,name)) + #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name)))) + `(,(convert-from-uffi-type type aggregate-type)))))) (if variant (push (list def) processed) - (push def processed)))) + (push def processed)))) (nreverse processed))) (defmacro def-struct (name &rest fields) #+(or cmu scl) - `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) + `(alien:def-alien-type ,name (alien:struct ,name ,@(process-aggregate-fields name fields))) #+sbcl - `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields))) + `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-aggregate-fields name fields))) #+allegro - `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) + `(ff:def-foreign-type ,name (:struct ,@(process-aggregate-fields name fields))) #+lispworks - `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) + `(fli:define-c-struct ,name ,@(process-aggregate-fields name fields)) #+digitool - `(ccl:defrecord ,name ,@(process-struct-fields name fields)) + `(ccl:defrecord ,name ,@(process-aggregate-fields name fields)) #+openmcl `(ccl::def-foreign-type nil - (:struct ,name ,@(process-struct-fields name fields))) + (:struct ,name ,@(process-aggregate-fields name fields))) ) @@ -192,19 +200,26 @@ (defmacro def-union (name &rest fields) #+allegro - `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) + `(ff:def-foreign-type ,name (:union ,@(process-aggregate-fields name fields + :aggregate-type :union))) #+lispworks - `(fli:define-c-union ,name ,@(process-struct-fields name fields)) + `(fli:define-c-union ,name ,@(process-aggregate-fields name fields + :aggregate-type :union)) #+(or cmu scl) - `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields))) + `(alien:def-alien-type ,name (alien:union ,name ,@(process-aggregate-fields name fields + :aggregate-type :union))) #+sbcl - `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields))) + `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-aggregate-fields name fields + :aggregate-type :union))) #+digitool - `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))) + `(ccl:defrecord ,name (:variant ,@(process-aggregate-fields name fields + :variant t + :aggregate-type :union))) #+openmcl `(ccl::def-foreign-type nil - (:union ,name ,@(process-struct-fields name fields))) -) + (:union ,name ,@(process-aggregate-fields name fields + :aggregate-type :union))) + ) #-(or sbcl cmu)

1 0

[bknr-cvs] r2525 - in branches/trunk-reorg/bknr: datastore/src/data modules/mail web/src/rss
by hhubner＠common-lisp.net 17 Feb '08

17 Feb '08

Author: hhubner Date: Sun Feb 17 16:39:28 2008 New Revision: 2525 Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp branches/trunk-reorg/bknr/datastore/src/data/txn.lisp branches/trunk-reorg/bknr/modules/mail/mail.lisp branches/trunk-reorg/bknr/web/src/rss/rss.lisp Log: Docstring fixes, add another missing defgeneric. Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/object.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp Sun Feb 17 16:39:28 2008 @@ -647,7 +647,7 @@ (defun find-store-object (id-or-name &key (class 'store-object) query-function key-slot-name) - "mock up implementation of find-store-object api as in the old datastore" + "Mock up implementation of find-store-object API as in the old datastore" (unless id-or-name (error "can't search a store object with null key")) (when (stringp id-or-name) Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp Sun Feb 17 16:39:28 2008 @@ -223,12 +223,11 @@ ;;; itself or, in the case of a nested transaction, the parent ;;; transaction. Named transactions do not explicitly log the nested ;;; transactions as the nesting is implicit, meaning that any repeated -;;; execution of the transactions triggered by rolling forward the -;;; transaction log will automatically repeat the sequence of -;;; executing nested transactions by the program code executed. -;;; Contrasted to that, an anonymous transaction has no implicit -;;; nesting, so any nested transactions which are called are -;;; explicitly logged. +;;; execution of the transactions while rolling forward the +;;; transaction log will automatically repeat the sequence of nested +;;; transaction executions by the program code executed. Contrasted +;;; to that, an anonymous transaction has no implicit nesting, so any +;;; nested transactions which are called are explicitly logged. (defgeneric execute-transaction (executor transaction) (:documentation "Execute TRANSACTION on EXECUTOR (which may be a store or a transaction scope).")) @@ -299,9 +298,10 @@ (defmacro deftransaction (name (&rest args) &rest body) "Define a transaction function tx-NAME and a function NAME executing tx-NAME in the context of the current store. The arguments to NAME -will be serialized to the transaction-log, and should must be -supported by the binary encoder. tx-NAME will be called during a -roll-forward." +will be serialized to the transaction-log, and must be supported by +the binary encoder. tx-NAME will be called during a roll-forward to +repeat any effects that the transaction function had on the persistent +store." (let ((name name) (args args) (body body)) Modified: branches/trunk-reorg/bknr/modules/mail/mail.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mail.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mail.lisp Sun Feb 17 16:39:28 2008 @@ -92,12 +92,14 @@ :subject (header :subject) :id (regex-replace-all *message-id-re* - (header :message-id) #?/\1/) -#| :in-reply (regex-replace-all + (header :message-id) + #?/\1/) + :in-reply (regex-replace-all *message-id-re* (first (if (header :in-reply-to) (split #?/\s+/ (header :in-reply-to)) - (last (split #?/\s+/ (header :references)))))) |# + (last (split #?/\s+/ (header :references))))) + #?/\1/) :headers headers :body body))))) Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/rss.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp Sun Feb 17 16:39:28 2008 @@ -64,6 +64,9 @@ class RSS-CHANNEL for an overview.")) (defun make-rss-channel (name title description link &rest args) + "Create an RSS channel with the given NAME, TITLE, DESCRIPTION and +LINK (all strings) which are the mandatory fields in an RSS channel. +Returns the persistent RSS-CHANNEL object that has been created." (apply #'make-object 'rss-channel :name name :title title :description description :link link args)) (defun render-mandatory-element (channel element) @@ -73,20 +76,23 @@ it (format nil "(channel ~(~A~) not defined)" element))))) -(defmethod rss-channel-xml ((channel rss-channel) stream) - (with-xml-output (make-character-stream-sink stream) - (with-element "rss" - (attribute "version" "2.0") - (attribute* "xmlns" "content" "http://purl.org/rss/1.0/modules/content/") - (with-element "channel" - (dolist (slot '(title link description)) - (render-mandatory-element channel slot)) +(defgeneric rss-channel-xml (channel stream) + (:documentation "Generate XML for the current state of RSS channel +CHANNEL to STREAM.") + (:method ((channel rss-channel) stream) + (with-xml-output (make-character-stream-sink stream) + (with-element "rss" + (attribute "version" "2.0") + (attribute* "xmlns" "content" "http://purl.org/rss/1.0/modules/content/") + (with-element "channel" + (dolist (slot '(title link description)) + (render-mandatory-element channel slot)) - (dolist (item (remove-if-not #'(lambda (item) - (and (not (object-destroyed-p item)) - (rss-item-published item))) - (rss-channel-items channel))) - (rss-item-xml item)))))) + (dolist (item (remove-if-not #'(lambda (item) + (and (not (object-destroyed-p item)) + (rss-item-published item))) + (rss-channel-items channel))) + (rss-item-xml item))))))) (defgeneric rss-channel-items (channel) (:documentation "Return all non-expired items in channel.")

1 0

[bknr-cvs] r2524 - in branches/trunk-reorg/projects/quickhoney: src website/templates
by hhubner＠common-lisp.net 17 Feb '08

17 Feb '08

Author: hhubner Date: Sun Feb 17 16:38:17 2008 New Revision: 2524 Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp branches/trunk-reorg/projects/quickhoney/website/templates/index.xml Log: remove testing code. Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/tags.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp Sun Feb 17 16:38:17 2008 @@ -1,6 +1,6 @@ (in-package :quickhoney.tags) -(define-bknr-tag version-and-last-change (&rest args) +(define-bknr-tag version-and-last-change () (html "v1.1 | updated " (:princ-safe (string-downcase (substitute #\Space #\- Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml (original) +++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml Sun Feb 17 16:38:17 2008 @@ -35,7 +35,7 @@ </a> <p id="path" class="text"> </p> - <p id="version" class="text"><quickhoney:version-and-last-change foo="1" bar="2" /></p> + <p id="version" class="text"><quickhoney:version-and-last-change /></p> <div id="elements"> <div id="quickhoney">

1 0

[bknr-cvs] r2523 - branches/trunk-reorg/bknr/datastore/src/data
by hhubner＠common-lisp.net 17 Feb '08

17 Feb '08

Author: hhubner Date: Sun Feb 17 16:27:25 2008 New Revision: 2523 Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp Log: Improve DEFTRANSACTION: Define wrapper function with docstring, if supplied. Use lambda list specified in DEFTRANSACTION for the wrapper function. Handle docstrings correctly. Insert IN-TRANSACTION-P check after declarations and docstring in generated function. Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp Sun Feb 17 16:27:25 2008 @@ -240,26 +240,90 @@ (defmethod execute-transaction ((executor transaction) transaction) (execute-unlogged transaction)) +(defun find-doc (body) + "Given a function definition BODY, extract the docstring, if any. +Skips over any declarations that precede the docstring. See also CLHS +3.4.11" + (do ((body body (cdr body))) + ((or (not (listp (car body))) + (not (eq 'declare (caar body)))) + (when (and (stringp (car body)) + (cdr body)) + (car body))))) + +(defun insert-after-declarations (body forms-to-insert) + "Given a function definition body, insert FORMS-TO-INSERT after all +declarations and documentation in BODY." + (loop for rest on body + for form = (car rest) + with decls + with doc + while (or (and (listp form) (eq 'declare (car form))) + (and (not doc) (cdr rest) (stringp form))) + when (stringp form) + do (setf doc form) + do (push form decls) + finally (return-from insert-after-declarations (append (nreverse decls) forms-to-insert rest)))) + +(defun make-args (args) + "Parse the lambda list ARGS, returning a list that contains the +arguments in the lambda list prepared so that the list can be applied +to a function accepting that lambda list. + +For example: + + (MAKE-ARGS '(A B &OPTIONAL C &REST D &KEY E F)) => (A B C :E E :F F) + +It is used to forward arguments to a transaction wrapper generated by +DEFTRANSACTION to the actual transaction so that the wrapper function +can be declared with the lambda list of the transaction function +itself," + (do ((args args (cdr args)) + result + in-keywords-p) + ((not args) + (nreverse result)) + (let ((arg (funcall (if (listp (car args)) #'caar #'car) args))) + (cond + ((eql #\& (aref (symbol-name arg) 0)) + (case arg + (&optional) + (&rest (setf args (cdr args))) ; skip argument, too + (&key (setf in-keywords-p t)) + (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg)))) + (t + (when in-keywords-p + (push (intern (symbol-name arg) :keyword) result)) + (push arg result)))))) + (defmacro deftransaction (name (&rest args) &rest body) - "Define a transaction function tx-NAME and a function NAME executing tx-NAME in the context -of the current store. The arguments to NAME will be serialized to the transaction-log, and -should must be supported by the binary encoder. tx-NAME will be called during a roll-forward." - (dolist (arg args) - (when (listp arg) - (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) - (let ((args-name (gensym)) - (tx-name (intern (string-upcase (concatenate 'string "tx-" (symbol-name name))) - (symbol-package name)))) - `(progn - (defun ,tx-name ,args - (unless (in-transaction-p) - (error 'not-in-transaction)) - ,@body) - (defun ,name (&rest ,args-name) - (execute (make-instance 'transaction - :function-symbol ',tx-name - :timestamp (get-universal-time) - :args ,args-name)))))) + "Define a transaction function tx-NAME and a function NAME executing +tx-NAME in the context of the current store. The arguments to NAME +will be serialized to the transaction-log, and should must be +supported by the binary encoder. tx-NAME will be called during a +roll-forward." + (let ((name name) + (args args) + (body body)) + (dolist (arg args) + (when (listp arg) + (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) + (let ((tx-name (intern (format nil "TX-~A" name) + (symbol-package name)))) + `(progn + (defun ,tx-name ,args + ,@(insert-after-declarations body + '((unless (in-transaction-p) + (error 'not-in-transaction))))) + (defun ,name ,args + ,@(let ((doc (find-doc body))) + (when doc (list (format nil "[Transaction function wrapper ~A invokes a store transaction]~%~A" name doc)))) + ,@(let ((rest (member '&rest args))) + (when rest `((declare (ignore ,(second rest)))))) + (execute (make-instance 'transaction + :function-symbol ',tx-name + :timestamp (get-universal-time) + :args (list ,@(make-args args))))))))) (defmethod encode-object ((object transaction) stream) (%write-char #\T stream)

1 0