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
