lispworks conditionalization

classes.lisp

@@ -224,15 +224,18 @@
   (:method ((identifier string))
     identifier))
 
-
-(defmethod c2mop:direct-slot-definition-class ((class thrift-class) &key identifier (identifier-name identifier))
+;;; 20110402 : lw does not allow for standard argument keys, thus the &allow-other-keys here
+(defmethod c2mop:direct-slot-definition-class ((class thrift-class) &key
+                                               identifier (identifier-name identifier)
+                                               &allow-other-keys)
   "If an id is present in the definition, the slot is included to pr included when de/serializing"
   (cond (identifier-name
          (find-class 'direct-field-definition))
         (t
          (call-next-method))))
 
-(defmethod c2mop:effective-slot-definition-class ((class thrift-class) &key name)
+(defmethod c2mop:effective-slot-definition-class ((class thrift-class) &key name
+                                                  &allow-other-keys)
   "If some direct lost definition indicates thrift support, them carry that over to the effective definition"
   (if (some #'(lambda (class)
                 (typep (find name (c2mop:class-direct-slots class) :key #'field-definition-name)
@@ -313,7 +316,26 @@
     ;; for use in macros
     (getf (cddr fd) :type))
   (:method ((sd c2mop:slot-definition))
-    (c2mop:slot-definition-type sd)))
+    (let ((literal-type (c2mop:slot-definition-type sd)))
+      ;; clozure rewrites the types specified in a slot definition
+      (etypecase literal-type
+        (symbol (case literal-type
+                  (boolean 'bool)
+                  (double-float 'thrift:double)
+                  (single-float 'thrift:float)
+                  (base-string 'string)
+                  (t literal-type)))
+        (cons (case (first literal-type)
+                (member (if (or (equal '(member nil t) literal-type) (equal '(member t nil) literal-type))
+                          'bool
+                          literal-type))
+                (signed-byte (ecase (second literal-type)
+                               (8 'i08)
+                               (16 'i16)
+                               (32 'i32)
+                               (64 'i64)))
+                ((array vector) 'binary)
+                (t literal-type)))))))
 
 
 (defgeneric class-field-definitions (class)

package.lisp

@@ -41,7 +41,9 @@
   #+sbcl
   (:import-from :sb-gray
                 :stream-write-string)
-
+  #+lispworks
+  (:import-from :stream
+                :stream-write-string)
   (:export 
    :*binary-transport-element-type*
    :application-error
@@ -195,28 +197,33 @@
  stream operators.")
 
   (:shadowing-import-from :common-lisp :byte :set :list :map :type-of :float)
-
+
+  (:import-from :de.setf.utility
+                :stream-reader
+                :stream-writer
+                )
   #+ccl
   (:import-from :ccl
                 :stream-write-byte :stream-read-byte
-                :stream-close :stream-direction
+                :stream-direction
                 :stream-position
-                :stream-read-sequence :stream-write-sequence
                 :stream-force-output :stream-finish-output)
-
+  #+mcl
+  (:import-from :ccl
+                :stream-close
+                :stream-read-sequence :stream-write-sequence
+                :stream-tyi :stream-tyo :stream-untyi)
   #+clozure
   (:import-from :ccl
                 :double-float-positive-infinity
                 :double-float-negative-infinity
                 #+ccl-1.4 :double-float-nan)
-
   #+sbcl
   (:import-from :sb-ext
                 :double-float-positive-infinity
                 :double-float-negative-infinity
                 :single-float-positive-infinity
                 :single-float-negative-infinity)
-
   #+sbcl
   (:import-from :sb-gray
                 :stream-write-byte :stream-read-byte

parameters.lisp

@@ -185,3 +185,14 @@
       (eval '(+ single-float-positive-infinity single-float-negative-infinity)))
     (defconstant double-float-nan
       (eval '(+ double-float-positive-infinity double-float-negative-infinity)))))
+
+#+lispworks
+(progn
+  (defconstant double-float-positive-infinity system::*plus-infinity-double*)
+  (defconstant double-float-negative-infinity system::*minus-infinity-double*)
+  (defconstant single-float-positive-infinity (coerce system::*plus-infinity-double* 'single-float))
+  (defconstant single-float-negative-infinity (coerce system::*minus-infinity-double* 'single-float))
+
+  (defconstant single-float-nan (+ single-float-positive-infinity single-float-negative-infinity))
+  (defconstant double-float-nan (+ double-float-positive-infinity double-float-negative-infinity))
+  )

types.lisp

@@ -63,7 +63,9 @@
   'list)
 
 
-(deftype base-type () '(member bool thrift:byte i08 i16 i32 i64 double thrift:float string binary))
+(deftype base-type ()
+  "Indicates the union of thrift base (atomic) types."
+  '(member bool thrift:byte i08 i16 i32 i64 double thrift:float string binary))
 
 (defun base-type-p (type)
   (typep type 'base-type))

vector-protocol.lisp

@@ -154,7 +154,7 @@
         (incf position)
         byte))))
 
-#+ccl
+#+mcl
 (defmethod ccl:stream-tyi ((stream vector-input-stream))
   (stream-read-byte stream))
 
@@ -198,7 +198,7 @@
     (setf position next)))
 
 
-#+ccl
+#+mcl
 (defmethod ccl:stream-tyo ((stream vector-output-stream) byte)
   (stream-write-byte stream byte))