Changeset 5792

Timestamp:

Jan 25, 2007, 3:32:10 AM (18 years ago)

Author:

Gary Byers

Message:

More plausible callback-bindings callback.

File:

• trunk/ccl/lib/ffi-linuxppc32.lisp (modified) (5 diffs)

trunk/ccl/lib/ffi-linuxppc32.lisp

@@ -103 +103 @@
             (setq argvars (cons struct-result-name argvars)
                   argspecs (cons :address argspecs)
-                  rtype *void-foreign-type))))
+                  rtype *void-foreign-type*))))
           (let* ((offset  96)
                  (gpr 0)
@@ -110 +110 @@
                   (argspecs argspecs (cdr argspecs)))
                  ((null argvars)
-                  (values (rlets) (lets) (dynamic-extent-names) (inits) rtype))
+                  (values (rlets) (lets) (dynamic-extent-names) nil rtype))
               (let* ((name (car argvars))
                      (spec (car argspecs))
@@ -120 +120 @@
                      (argtype (parse-foreign-type spec)))
                 (if (typep argtype 'foreign-record-type)
-                  (setq spec :address))
+                  (setq argtype (parse-foreign-type :address)))
                 (let* ((access-form
-                        `(,(case spec
-                                 (:single-float
-                                   (incf nextfpr 8)
-                                   (if (< fpr 96)
-                                     (setq target fpr)
-                                     (setq target (+ offset (logand offset 4))
-                                           nextoffset (+ target 8)))
-                                   '%get-single-float-from-double-ptr)
-                                  (:double-float
-                                   (incf nextfpr 8)
-                                   (if (< fpr 96)
-                                     (setq target fpr)
-                                     (setq target (+ offset (logand offset 4))
-                                           nextoffset (+ target 8)))
-                                   '%get-double-float)
-                                  (:signed-doubleword
-                                   (if (< gpr 56)
+                        `(,(cond
+                            ((typep argtype 'foreign-single-float-type)
+                             (incf nextfpr 8)
+                             (if (< fpr 96)
+                               (setq target fpr)
+                               (setq target (+ offset (logand offset 4))
+                                     nextoffset (+ target 8)))
+                             '%get-single-float-from-double-ptr)
+                            ((typep argtype 'foreign-double-float-type)
+                             (incf nextfpr 8)
+                             (if (< fpr 96)
+                               (setq target fpr)
+                               (setq target (+ offset (logand offset 4))
+                                     nextoffset (+ target 8)))
+                             '%get-double-float)
+                            ((and (typep argtype 'foreign-integer-type)
+                                  (= (foreign-integer-type-bits argtype) 64)
+                                  (foreign-integer-type-signed argtype))
+                             (if (< gpr 56)
                                      (setq target (+ gpr (logand gpr 4))
                                            nextgpr (+ 8 target))
@@ -144 +146 @@
                                            nextoffset (+ 8 offset)))
                                    '%%get-signed-longlong)
-                                  (:unsigned-doubleword
-                                   (if (< gpr 56)
-                                     (setq target (+ gpr (logand gpr 4))
-                                           nextgpr (+ 8 target))
-                                     (setq target (+ offset (logand offset 4))
-                                           nextoffset (+ 8 offset)))
-                                   '%%get-unsigned-longlong)
-                                  (t
-                                   (incf nextgpr 4)
-                                   (if (< gpr 64)
-                                     (setq target gpr)
-                                     (setq target offset nextoffset (+ offset 4)))
-                                   (ecase type
-                                     (:signed-fullword '%get-signed-long)
-                                     (:signed-halfword (setq bias 2) '%get-signed-word)
-                                     (:signed-byte (setq bias 3) '%get-signed-byte)
-                                     (:unsigned-fullword '%get-unsigned-long)
-                                     (:unsigned-halfword (setq bias 2) '%get-unsigned-word)
-                                     (:unsigned-byte (setq bias 3) '%get-unsigned-byte)
-                                     (:address '%get-ptr))))
+                            ((and (typep argtype 'foreign-integer-type)
+                                  (= (foreign-integer-type-bits argtype) 64)
+                                  (not (foreign-integer-type-signed argtype)))
+                             (if (< gpr 56)
+                               (setq target (+ gpr (logand gpr 4))
+                                     nextgpr (+ 8 target))
+                               (setq target (+ offset (logand offset 4))
+                                     nextoffset (+ 8 offset)))
+                             '%%get-unsigned-longlong)
+                            (t
+                             (incf nextgpr 4)
+                             (if (< gpr 64)
+                               (setq target gpr)
+                               (setq target offset nextoffset (+ offset 4)))
+                             (cond ((typep argtype 'foreign-pointer-type) '%get-ptr)
+                                   ((typep argtype 'foreign-integer-type)
+                                    (let* ((bits (foreign-integer-type-bits argtype))
+                                           (signed (foreign-integer-type-signed argtype)))
+                                      (cond ((<= bits 8)
+                                             (setq bias 3)
+                                             (if signed
+                                               '%get-signed-byte '
+                                               '%get-unsigned-byte))
+                                            ((<= bits 16)
+                                             (setq bias 2)
+                                             (if signed
+                                               '%get-signed-word '
+                                               '%get-unsigned-word))
+                                            ((<= bits 32)
+                                             (if signed
+                                               '%get-signed-long '
+                                               '%get-unsigned-long))
+                                            (t
+                                             (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
+                                   (t
+                                    (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
                           ,stack-ptr
                           ,(+ target bias))))
@@ -169 +187 @@
                   (when (eq spec :address)
                     (dynamic-extent-names name))
-                  (setq gpr nextgpr fpr nextfpr offset nextoffset)))))
-          (values (rlets)
-                  (lets)
-                  (dynamic-extent-names)
-                  nil
-                  rtype))))
+                  (setq gpr nextgpr fpr nextfpr offset nextoffset))))))))