Author: hhubner Date: 2006-02-06 12:36:30 -0600 (Mon, 06 Feb 2006) New Revision: 1824 Modified: trunk/bknr/src/bknr-datastore.asd trunk/bknr/src/bknr-utils.asd trunk/bknr/src/data/blob.lisp trunk/bknr/src/data/encoding.lisp trunk/bknr/src/data/object.lisp trunk/bknr/src/data/package.lisp trunk/bknr/src/data/txn.lisp trunk/bknr/src/indices/indexed-class.lisp trunk/bknr/src/indices/package.lisp trunk/bknr/src/utils/package.lisp trunk/bknr/src/utils/smbpasswd.lisp trunk/bknr/src/utils/utils.lisp Log: SBCL and OpenMCL compatibility changes by Hoan Ton-That. Modified: trunk/bknr/src/bknr-datastore.asd =================================================================== --- trunk/bknr/src/bknr-datastore.asd 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/bknr-datastore.asd 2006-02-06 18:36:30 UTC (rev 1824) @@ -16,8 +16,11 @@ :licence "BSD" :description "baikonour - launchpad for lisp satellites" - :depends-on (:cl-interpol :unit-test :bknr-utils :bknr-indices - :acl-compat) + :depends-on (:cl-interpol + :unit-test + :bknr-utils + :bknr-indices + #+(not allegro) :acl-compat) :components ((:module "data" :components ((:file "package") (:file "encoding" :depends-on ("package")) Modified: trunk/bknr/src/bknr-utils.asd =================================================================== --- trunk/bknr/src/bknr-utils.asd 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/bknr-utils.asd 2006-02-06 18:36:30 UTC (rev 1824) @@ -28,7 +28,7 @@ (:module "utils" :components ((:file "package") (:file "utils" :depends-on ("package")) (:file "class" :depends-on ("package" "utils")) - #+(or cmu allegro sbcl) + #+(or cmu allegro openmcl sbcl) (:file "smbpasswd" :depends-on ("utils")) (:file "actor" :depends-on ("utils")) (:file "reader" :depends-on ("utils")) Modified: trunk/bknr/src/data/blob.lisp =================================================================== --- trunk/bknr/src/data/blob.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/data/blob.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -154,13 +154,7 @@ blob)) (defmethod rename-file-to-blob ((blob blob) pathname) - ;; xxx fixme: hier sollte ggf. copy-file benutzt werden, damit das - ;; auch �ber Filesystemgrenzen hinweg funktioniert. - #+cmu - (unix:unix-rename (namestring pathname) - (namestring (blob-pathname blob))) - #+allegro - (rename-file pathname (blob-pathname blob))) + (move-file pathname (blob-pathname blob))) (defmethod restore-subsystem ((store store) (subsystem blob-subsystem) &key until) (declare (ignore until)) Modified: trunk/bknr/src/data/encoding.lisp =================================================================== --- trunk/bknr/src/data/encoding.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/data/encoding.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -120,6 +120,9 @@ (defun %write-char (char stream) (write-byte (char-code char) stream)) +(defun %write-string (string stream) + (dotimes (i (length string)) + (%write-char (char string i) stream))) ;;;; binary encoding @@ -168,10 +171,10 @@ (defun %encode-string (object stream) (%encode-integer (length object) stream) + #+allegro + (excl::stream-write-sequence stream object) #-allegro - (write-string object stream) - #+allegro - (excl::stream-write-sequence stream object)) + (%write-string object stream)) (defun encode-string (object stream) (%write-char #\s stream) @@ -196,26 +199,36 @@ object)) (defun %encode-single-float (object stream) - #+cmu - (%encode-int32 (kernel:single-float-bits object) stream) #+allegro (map nil #'(lambda (short) (%encode-int16 short stream)) - (multiple-value-list (excl::single-float-to-shorts object)))) + (multiple-value-list (excl::single-float-to-shorts object))) + #+cmu + (%encode-int32 (kernel:single-float-bits object) stream) + #+openmcl + (%encode-int32 (ccl::single-float-bits object) stream) + #+sbcl + (%encode-int32 (sb-kernel:single-float-bits object) stream)) (defun encode-single-float (object stream) (%write-char #\f stream) (%encode-single-float object stream)) (defun %encode-double-float (object stream) - #+cmu - (%encode-int32 (kernel:double-float-high-bits object) stream) - #+cmu - (%encode-int32 (kernel:double-float-low-bits object) stream) - #+allegro + #+cmucl (map nil #'(lambda (short) (%encode-int16 short stream)) - (multiple-value-list (excl::double-float-to-shorts object)))) + (multiple-value-list (excl::double-float-to-shorts object))) + #+cmu + (progn (%encode-int32 (kernel:double-float-high-bits object) stream) + (%encode-int32 (kernel:double-float-low-bits object) stream)) + #+openmcl + (multiple-value-bind (hi lo) (ccl::double-float-bits object) + (%encode-int32 hi stream) + (%encode-int32 lo stream)) + #+sbcl + (progn (%encode-int32 (sb-kernel:double-float-high-bits object) stream) + (%encode-int32 (sb-kernel:double-float-low-bits object) stream))) (defun encode-double-float (object stream) (%write-char #\d stream) @@ -327,21 +340,31 @@ result)) (defun %decode-single-float (stream) + #+allegro + (excl::shorts-to-single-float (%decode-uint16 stream) + (%decode-uint16 stream)) #+cmu (kernel:make-single-float (%decode-sint32 stream)) - #+allegro - (excl::shorts-to-single-float (%decode-uint16 stream) - (%decode-uint16 stream))) + #+openmcl + (make-single-float (%decode-sint32 stream)) + #+sbcl + (sb-kernel:make-single-float (%decode-sint32 stream))) (defun %decode-double-float (stream) - #+cmu - (kernel:make-double-float (%decode-sint32 stream) - (%decode-uint32 stream)) #+allegro (excl::shorts-to-double-float (%decode-uint16 stream) (%decode-uint16 stream) (%decode-uint16 stream) - (%decode-uint16 stream))) + (%decode-uint16 stream)) + #+cmu + (kernel:make-double-float (%decode-sint32 stream) + (%decode-uint32 stream)) + #+openmcl + (make-double-float (%decode-sint32 stream) + (%decode-uint32 stream)) + #+sbcl + (sb-kernel:make-double-float (%decode-sint32 stream) + (%decode-uint32 stream))) (defun %decode-array (stream) (let* ((element-type (%decode-symbol stream)) @@ -380,3 +403,44 @@ (t (decode-object tag stream))))) (defgeneric decode-object (tag stream)) + +;;;; OpenMCL does not have these functions +(defun make-single-float (bits) + (cond + ;; IEEE float special cases + ((zerop bits) 0.0) + ((= bits #x-80000000) -0.0) + (t (let* ((sign (ecase (ldb (byte 1 31) bits) + (0 1.0) + (1 -1.0))) + (iexpt (ldb (byte 8 23) bits)) + (expt (if (zerop iexpt) ; denormalized + -126 + (- iexpt 127))) + (mant (* (logior (ldb (byte 23 0) bits) + (if (zerop iexpt) + 0 + (ash 1 23))) + (expt 0.5 23)))) + (* sign (expt 2.0 expt) mant))))) + +#+openmcl +(defun make-double-float (hi lo) + (cond + ;; IEEE float special cases + ((and (zerop hi) (zerop lo)) 0.0d0) + ((and (= hi #x-80000000) (zerop lo)) -0.0d0) + (t (let* ((bits (logior (ash hi 32) lo)) + (sign (ecase (ldb (byte 1 63) bits) + (0 1.0d0) + (1 -1.0d0))) + (iexpt (ldb (byte 11 52) bits)) + (expt (if (zerop iexpt) ; denormalized + -1022 + (- iexpt 1023))) + (mant (* (logior (ldb (byte 52 0) bits) + (if (zerop iexpt) + 0 + (ash 1 52))) + (expt 0.5d0 52)))) + (* sign (expt 2.0d0 expt) mant))))) Modified: trunk/bknr/src/data/object.lisp =================================================================== --- trunk/bknr/src/data/object.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/data/object.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -211,6 +211,15 @@ (:metaclass persistent-class) ,@class-options))) +(defmacro defpersistent-class (class (&rest superclasses) slots &rest class-options) + (let ((superclasses (or superclasses '(store-object)))) + (when (member :metaclass class-options :key #'car) + (error "Can not define a persistent class with a metaclass.")) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass ,class ,superclasses ,slots + (:metaclass persistent-class) + ,@class-options)))) + #+nil (define-persistent-class foo () ((a :read))) Modified: trunk/bknr/src/data/package.lisp =================================================================== --- trunk/bknr/src/data/package.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/data/package.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -7,9 +7,10 @@ :mp #+(not allegro) :acl-compat.mp + #+allegro :aclmop #+cmu :pcl - #+sbcl :sb-mop - #+allegro :aclmop) + #+openmcl :openmcl-mop + #+sbcl :sb-mop) #+(not allegro) (:shadowing-import-from :acl-compat.mp process-kill process-wait) (:shadowing-import-from :cl-interpol quote-meta-chars) @@ -41,6 +42,7 @@ #:persistent-xml-class #:persistent-xml-class-importer #:define-persistent-class + #:defpersistent-class #:store-object #:store-object-store Modified: trunk/bknr/src/data/txn.lisp =================================================================== --- trunk/bknr/src/data/txn.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/data/txn.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -297,7 +297,9 @@ ;; dabei waere sync()-Semantik zu erwarten. (finish-output stream) #+cmu - (unix:unix-fsync (kernel::fd-stream-fd stream))) + (unix:unix-fsync (kernel::fd-stream-fd stream)) + #+sbcl + (sb-posix:fsync (sb-kernel::fd-stream-fd stream))) (defvar *disable-sync* nil) @@ -431,7 +433,7 @@ (close-transaction-log-stream store) ;; CMUCL will, dass das directory existiert, ACL nicht - #+cmu + #+(or cmu sbcl) (ensure-directories-exist backup-directory) (when *store-debug* @@ -490,7 +492,9 @@ (copy-stream s r)))) (format t "~&; truncating transaction log at position ~D.~%" p) #+cmu - (unix:unix-truncate (ext:unix-namestring pathname) p))))) + (unix:unix-truncate (ext:unix-namestring pathname) p) + #+sbcl + (sb-posix:truncate (namestring pathname) p))))) (defgeneric restore-subsystem (store subsystem &key until)) Modified: trunk/bknr/src/indices/indexed-class.lisp =================================================================== --- trunk/bknr/src/indices/indexed-class.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/indices/indexed-class.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -235,12 +235,12 @@ ;;; avoid late instantiation -#+(or allegro cmu sbcl) +#+(or allegro cmu openmcl sbcl) (defmethod initialize-instance :after ((class indexed-class) &key &allow-other-keys) (compute-class-indices class (indexed-class-index-definitions class)) (reinitialize-class-indices class)) -#+(or allegro cmu sbcl) +#+(or allegro cmu openmcl sbcl) (defmethod reinitialize-instance :after ((class indexed-class) &key &allow-other-keys) (compute-class-indices class (indexed-class-index-definitions class)) (reinitialize-class-indices class)) Modified: trunk/bknr/src/indices/package.lisp =================================================================== --- trunk/bknr/src/indices/package.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/indices/package.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -11,6 +11,7 @@ :bknr.skip-list #+allegro :aclmop #+cmu :pcl + #+openmcl :openmcl-mop #+sbcl :sb-pcl) (:export #:index-add #:index-get Modified: trunk/bknr/src/utils/package.lisp =================================================================== --- trunk/bknr/src/utils/package.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/utils/package.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -5,15 +5,11 @@ :cl-ppcre :cl-interpol :cxml-xmls - #+cmu - :extensions :md5 -; #+sbcl -; :sb-ext - #+(not allegro) - :acl-compat.mp - #+allegro - :mp) + #+cmu :extensions +; #+sbcl :sb-ext + #+(not allegro) :acl-compat.mp + #+allegro :mp) (:shadowing-import-from :cl-interpol quote-meta-chars) #+(not allegro) (:shadowing-import-from :acl-compat.mp process-kill process-wait) Modified: trunk/bknr/src/utils/smbpasswd.lisp =================================================================== --- trunk/bknr/src/utils/smbpasswd.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/utils/smbpasswd.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -32,6 +32,10 @@ (unless (zerop (process-exit-code process)) (error (make-condition 'smb-password-error :message (get-output-stream-string stream)))) (process-close process))) + #+openmcl + (ccl::run-program +smb-wrapper-program+ + args + :output stream) #+sbcl (let ((process (sb-ext:run-program +smb-wrapper-program+ args :output stream :error :output))) Modified: trunk/bknr/src/utils/utils.lisp =================================================================== --- trunk/bknr/src/utils/utils.lisp 2006-02-06 18:33:09 UTC (rev 1823) +++ trunk/bknr/src/utils/utils.lisp 2006-02-06 18:36:30 UTC (rev 1824) @@ -134,6 +134,7 @@ (let ((hostname #+allegro (sys:getenv "HOST") #+cmu (cdr (assoc :host ext:*environment-list*)) + #+openmcl (ccl::getenv "HOST") #+sbcl (sb-ext:posix-getenv "HOST"))) (unless hostname (error "HOST environment variable not set, can't continue")) @@ -169,7 +170,7 @@ (when (< read-count 4096) (return))))))) (defun move-file (file1 file2) - #+allegro + #+(or allegro openmcl) (rename-file file1 file2) #+cmu (unix:unix-rename (namestring file1) @@ -524,6 +525,8 @@ (aclmop:class-direct-subclasses class) #+cmu (pcl:class-direct-subclasses class) + #+openmcl + (openmcl-mop:class-direct-subclasses class) #+sbcl (sb-mop:class-direct-subclasses class))) (apply #'append subclasses