home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-2.LHA / CLISP960530-ki.lha / fd / asl-ffi.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-08-23  |  7.5 KB  |  207 lines
  1. ;;; FFI demos and "how to" for the Amiga
  2. #-FFI(error "Foreign Function Interface (FFI) no available")
  3.  
  4. (in-package "FFI-DEMOS")
  5. (use-package "FFI")
  6.  
  7. #|
  8. ;;; What I've added to FOREIGN1.LSP
  9. #+AMIGA
  10. (defmacro DEF-LIB-CALL-OUT (&whole whole name library &rest options)
  11.   (check-symbol whole)
  12.   (let* ((alist (parse-options options '(:name :offset :arguments :return-type) whole))
  13.          (c-name (foreign-name name (assoc ':name alist)))
  14.          (offset (second (assoc ':offset alist))))
  15.     `(LET ()
  16.        (SYSTEM::REMOVE-OLD-DEFINITIONS ',name)
  17.        (EVAL-WHEN (COMPILE) (COMPILER::C-DEFUN ',name))
  18.        (SYSTEM::%PUTD ',name
  19.          (FFI::FOREIGN-LIBRARY-FUNCTION ',c-name
  20.           (FFI::FOREIGN-LIBRARY ',library)
  21.           ',offset
  22.           (PARSE-C-FUNCTION ',(remove (assoc ':name alist) alist) ',whole)))
  23.        ',name
  24. ) )  )
  25. |#
  26.  
  27. ;; I think what's missing is a C-POINTER-NULL type
  28. ;; (C-ARRAY-PTR uint32) might help but would not work with AllocateTagItems
  29. (def-lib-call-out AllocAslRequest "asl.library"
  30.   (:name "AllocAslRequest")
  31.   (:offset -48)
  32.   (:arguments
  33.    (reqType uint32 :in :none :d0)
  34.    (taglist uint32 :in :alloca :a0)) ; don't use c-pointer as we couldn't pass a NULL in!
  35.   (:return-type c-pointer :none))
  36.  
  37. (def-lib-call-out FreeAslRequest "asl.library"
  38.   (:name "FreeAslRequest")
  39.   (:offset -54)
  40.   (:arguments
  41.    (requester c-pointer :in :none :a0))
  42.   (:return-type nil :none))
  43.  
  44. (def-lib-call-out AslRequest "asl.library"
  45.   (:name "RequestFile")
  46.   (:offset -60)
  47.   (:arguments
  48.    (requester c-pointer :in :none :a0)
  49.    (taglist uint32 :in :alloca :a1)) ; don't use c-pointer as we couldn't pass a NULL in!
  50.   (:return-type boolean :none))
  51.  
  52. (defun AddPart2 (dir file)
  53.   (declare (type string dir file))
  54.   ;; pretend we don't know dos.library/AddPart()
  55.   (concatenate
  56.    'string
  57.    dir
  58.    (unless (zerop (length dir))
  59.            (unless (find (char dir (1- (length dir))) ":/") "/"))
  60.    file))
  61.  
  62.  
  63. ;; DEF-C-STRUCT costs a lot as accessors, constructor and copier are defined
  64. (def-c-struct FR-File-Drawer
  65.   ;; at offset 4 of FileRequester structure
  66.   (File      c-string)
  67.   (Drawer    c-string)
  68. )
  69.  
  70.  
  71. ;; roughly the level of the AFFI
  72. (defun aslfilerequest2 ()
  73.   (let ((fr (allocaslrequest 0 0)))
  74.     (when t                             ;null-pointer test?
  75.       (unwind-protect
  76.            (when (aslrequest fr 0)
  77.              (let ((file (ffi::foreign-value (ffi::foreign-address-variable "file" fr 4 'c-string)))
  78.                    (dir  (ffi::foreign-value (ffi::foreign-address-variable "drawer" fr 8 'c-string))))
  79.                (addpart2 dir file)))
  80.         (FreeAslRequest fr)))))
  81. ; Space: 142 Bytes
  82.  
  83. ;; a FOREIGN-ADDRESS can only be tested for NULL with EQUALP against a known
  84. ;; NULL address. Where to get this first one?
  85.  
  86. ;; a FOREIGN-ADDRESS-VARIABLE is a typed reference to an external object
  87. ;; (SLOT (FFI::FOREIGN-VALUE ...)) only dereferences given slot
  88. (defun aslfilerequest3 ()
  89.   (let ((fr (allocaslrequest 0 0)))
  90.     (when t                             ;null-pointer test?
  91.       (unwind-protect
  92.            (when (aslrequest fr 0)
  93.              (let* ((frvar (ffi::foreign-address-variable
  94.                             "f+d"       ; name could be NIL (not needed)
  95.                             fr          ; convert object to Lisp now
  96.                             4 (ffi::parse-c-type 'FR-File-Drawer)))
  97.                     (file (slot (ffi::foreign-value frvar) 'File))
  98.                     (dir  (slot (ffi::foreign-value frvar) 'Drawer)))
  99.                (addpart2 dir file)))
  100.         (FreeAslRequest fr)))))
  101. ; Space: 182 Bytes
  102.  
  103. ;; drawback is that the whole FR-File-Drawer is dereferenced and converted
  104. ;; but here it's an advantage as all slots are used
  105. (defun aslfilerequest5 ()
  106.   (let ((fr (allocaslrequest 0 0)))
  107.     (when t                             ;null-pointer test?
  108.       (unwind-protect
  109.            (when (aslrequest fr 0)
  110.              (let* ((frvar (ffi::foreign-value
  111.                             (ffi::foreign-address-variable
  112.                              "f+d" fr
  113.                              4 (ffi::parse-c-type 'FR-File-Drawer))))
  114.                     (file (FR-File-Drawer-File   frvar))
  115.                     (dir  (FR-File-Drawer-Drawer frvar)))
  116.                (addpart2 dir file)))
  117.         (FreeAslRequest fr)))))
  118. ; Space: 122 Bytes
  119.  
  120. ;; a local foreign structure should be set at compile-time, otherwise it conses a lot
  121. (defun aslfilerequest7 ()
  122.   (let ((fr (allocaslrequest 0 0)))
  123.     (when t                             ;null-pointer test?
  124.       (unwind-protect
  125.            (when (aslrequest fr 0)
  126.              (let* ((frvar (ffi::foreign-address-variable
  127.                             "f+d" fr
  128.                             4 '#.(ffi::parse-c-type
  129.                                   '(c-struct nil ;an attempt at local structures
  130.                                     (file c-string)
  131.                                     (drawer c-string)))))
  132.                     ;;<==>(slot (ffi::foreign-value frvar) 'file)
  133.                     (file (ffi::foreign-value (ffi::%slot frvar 'file)))
  134.                     (dir  (ffi::foreign-value (ffi::%slot frvar 'drawer))))
  135.                (addpart2 dir file)))
  136.         (FreeAslRequest fr)))))
  137. ; Space: 182 Bytes
  138. ;; I don't like the (slot (foreign-value ..)) syntax much, as it makes
  139. ;; me think it dereferences the complete object where it does not
  140.  
  141.  
  142.  
  143. ;; ffi::parse-c-type at macroexpansion-time so a constant value is compiled in
  144. #|
  145. (defmacro WITH-FOREIGN-VALUE ((var object type &optional (offset 0)) &body body)
  146.   (let ((fvar (gensym)))
  147.     `(LET ((,fvar (FFI::FOREIGN-ADDRESS-VARIABLE
  148.                   "unnamed" ,object ,offset ',(ffi::parse-c-type type))))
  149.        (SYMBOL-MACROLET ((,var (FFI::FOREIGN-VALUE ,fvar)))
  150.          ,@body))))
  151. |#
  152. (defmacro WITH-FOREIGN-VALUE ((var object type &optional (offset 0)) &body body)
  153.   (let ((fvar (gensym)))
  154.     `(LET ((,fvar (FFI::FOREIGN-ADDRESS-VARIABLE
  155.                   "unnamed" ,object ,offset
  156.                   ,(if (consp type)
  157.                        (list 'QUOTE (ffi::parse-c-type type)) ; assume a (STRUCT ...)
  158.                        ;; don't deparse DEF-C-STRUCT types at macroexpansion time
  159.                        `(FFI::PARSE-C-TYPE ',type)))))
  160.        (SYMBOL-MACROLET ((,var (FFI::FOREIGN-VALUE ,fvar)))
  161.          ,@body))))
  162.  
  163.  
  164. ;; that's beginning to get close to what I like
  165. ;; oh, it looks a lot like CMU
  166. (defun aslfilerequest8 ()
  167.   (let ((fr (allocaslrequest 0 0)))
  168.     (when t                             ;null-pointer test?
  169.       (unwind-protect
  170.            (when (aslrequest fr 0)
  171.              (with-foreign-value
  172.               (frvar fr (c-struct nil (file c-string) (drawer c-string)) 4)
  173.               (addpart2 (slot frvar 'drawer)
  174.                         (slot frvar 'file))))
  175.         (FreeAslRequest fr)))))
  176. ; Space: 182 Bytes
  177.  
  178. ;; or this, but it requires the overhead of DEF-C-STRUCT
  179. (defun aslfilerequest9 ()
  180.   (let ((fr (allocaslrequest 0 0)))
  181.     (when t                             ;null-pointer test?
  182.       (unwind-protect
  183.            (when (aslrequest fr 0)
  184.              (with-foreign-value
  185.               (frvar fr FR-File-Drawer 4)
  186.               (addpart2 (slot frvar 'drawer)
  187.                         (slot frvar 'file))))
  188.         (FreeAslRequest fr)))))
  189. ; Space: 182 Bytes
  190.  
  191. ;; Finally I prefer ASLFILEREQUEST8
  192. ;; With local structures you can avoid a lot, but not all of CLOS overhead,
  193. ;; but you can't get around DEF-C-STRUCT without local structures.
  194.  
  195.  
  196. #|
  197. (def-lib-call-out FindTask "exec.library"
  198.   (:name "FindTask")
  199.   (:offset -294)
  200.   (:arguments
  201.    (name    c-string :in :alloca :a1))
  202.   (:return-type c-pointer :none))
  203. ;; how can I tell whether the call succeeded?
  204. ;; the result could be either (c-ptr-null my-library), c-pointer or uint32.
  205. |#
  206.  
  207.