home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-2.LHA / CLISP960530-di.lha / fd / foreign-emu.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-06-18  |  3.8 KB  |  117 lines
  1. #|
  2. (in-package "FFI")
  3. (defun ffi::lookup-foreign-function (name description)
  4.   (let ((args (list name description)))
  5.     (format *trace-output* "~&Calling Lookup with ~S.~%" args)
  6.     #'(lambda (&rest rest)
  7.     (format *trace-output* "~&Calling Looked-up(~S) with ~S.~%" args rest)
  8.     nil)))
  9. (defconstant ffi::ff-flag-alloca (ash 1 0))
  10. (defconstant ffi::ff-language-c  (ash 1 9))
  11. (defconstant ffi::ff-flag-out    (ash 1 4))
  12. (def-call-out OpenLibrary
  13.   (:name "OpenLibrary")
  14.   (:language :c)            ;every integral converted to (U)LONG
  15.   ;;(:library "exec.library")
  16.   (:arguments
  17.    (libname c-string :in :alloca :a0)
  18.    (version uint32   :in :none   :d0))
  19.   (:return-type c-pointer :none  :d0))
  20. (def-call-out ReadDOS
  21.   (:name "Read")
  22.   (:language :c)
  23.   (:arguments
  24.    (file c-pointer   :in :none   :d0)
  25.    (buffer c-string  :out :none :d1)    ;inexpressible
  26.    (length sint32    :in :none   :d2))
  27.   (:return-type sint32 :none :d0))
  28. |#
  29.  
  30. (in-package "AFFI")
  31. #|
  32. (macroexpand-1 '
  33. (def-affi-call-out OpenLibrary
  34.   (:name "OpenLibrary")
  35.   (:language :c)            ;every integral converted to (U)LONG
  36.   (:library "exec.library") (:offset -552)
  37.   (:arguments
  38.    (libname :c-string :in :alloca :a1)
  39.    (version :ulong     :in :none :d0))
  40.   (:return-type :c-pointer :none :d0))
  41. )
  42. (defflibfun 'OPENLIBRARY 'SYSBASE -552 #x1A '* 'string 4)
  43. ;; Read        :io     c-pointer :none   :out
  44. ;; OpenLibrary string  c-string  :alloca :in
  45. ;; Write       :io     c-pointer :none   :in    ; :io to avoid copying
  46. ;; OpenWindow  *       c-pointer :none   :in    ; disable string arg?
  47. |#
  48.  
  49. (defun error-bad-spec (whole &optional reason)
  50.   (error "Bad FFI specification: ~S" whole))
  51.  
  52. (defun parse-ffi-type (argspec whole)
  53.   (unless (and (consp argspec)
  54.            (symbolp (first argspec)))
  55.     (error-bad-spec whole))
  56.   (or
  57.    (case (second argspec)        ; c-type
  58.      (:boolean  0)            ; not implemented in AFFI.D as argument
  59.      (:sint8   -1)            ;add :char ?
  60.      ((:uint8 :uchar)   1)
  61.      ((:sint16 :short) -2)
  62.      ((:uint16 :ushort) 2)
  63.      ((:sint32 :long)  -4)
  64.      ((:uint32 :ulong)  4)
  65.      ((:c-pointer :c-string)        ;TODO revisit (dependency on allocation?)
  66.       (if (eq :return-type (first argspec))
  67.       (if (eq (second argspec) :c-string) 'string '*)
  68.       (case (third argspec)        ; param-mode
  69.         (:none          '*)
  70.         (:in            (if (eq (second argspec) :c-string) 'string '*))
  71.         ((:out :in-out) :io))))
  72.      ((:io string *) (second argspec)))    ; special pass-through
  73.    (error-bad-spec whole)))
  74.  
  75. (defun parse-options (options keywords whole)
  76.   (reverse options))
  77.  
  78. (defun calc-reg-mask (regs mask)
  79.   (if (null regs) mask
  80.       (calc-reg-mask
  81.        (rest regs)
  82.        (logior
  83.         (ash mask 4)
  84.         (1+ (position
  85.              (first regs)
  86.              '(:D0 :D1 :D2 :D3 :D4 :D5 :D6 :D7
  87.                :A0 :A1 :A2 :A3 :A4 :A5 :A6)
  88.              :test #'eq))))))
  89.  
  90. (defun calc-register-mask (regs)
  91.   (labels
  92.       ((calc (regs accu)
  93.      (if (null regs) accu
  94.          (calc (rest regs)
  95.            (logior
  96.             (ash accu 4)
  97.             (1+ (let ((reg (first regs))
  98.                   (list '(:D0 :D1 :D2 :D3 :D4 :D5 :D6 :D7
  99.                       :A0 :A1 :A2 :A3 :A4 :A5 :A6)))
  100.               (if (keywordp reg)
  101.                   (position reg list :test #'eq)
  102.                   (position (symbol-name reg) list :test #'string-equal :key #'symbol-name)))))))))
  103.     (calc (reverse regs) 0)))
  104.  
  105. (defmacro def-affi-call-out (&whole whole name &rest options)
  106.   (let* ((alist (parse-options options '(:name :library :offset :language :arguments :return-type) whole))
  107.      (library (first (check-library-name (second (assoc :library alist)))))
  108.      (offset (second (assoc :offset alist)))
  109.      (mask (calc-reg-mask (reverse (mapcar #'fifth (rest (assoc :arguments alist)))) 0))
  110.      (rtype (parse-ffi-type (assoc :return-type alist) whole))
  111.      (c-args (mapcar #'(lambda (spec) (list 'quote (parse-ffi-type spec whole)))
  112.              (rest (assoc :arguments alist))))
  113.      )
  114.     ;; declaim special?
  115.     `(defflibfun ',name ',library ,offset ,mask ',rtype ,@c-args)))
  116.  
  117.