home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / affi1.lsp < prev    next >
Lisp/Scheme  |  1996-08-12  |  11KB  |  290 lines
  1. ;;;; Simple Foreign Function Interface support
  2. ;;;; Jörg Höhle 7.8.1996
  3.  
  4. (in-package "AFFI")
  5.  
  6. (eval-when (eval load compile)
  7.   (dolist (symbol '("MEM-READ" "MEM-WRITE" "MEM-WRITE-VECTOR" "NZERO-POINTER-P"))
  8.     (import (intern symbol "SYS"))))
  9. (export '(declare-library-base require-library-functions
  10.           open-library close-library with-open-library
  11.           defflibfun declare-library-function flibcall mlibcall
  12.           nzero-pointer-p mem-read mem-write mem-write-vector))
  13.  
  14. ;; The libraries a-list associates the symbol used to denote the library
  15. ;; (e.g. SysBase for exec.library) with an opencount and the OS name (as a
  16. ;; string). The symbol's value field contains the library address.
  17.  
  18. (defvar *libraries-alist* '((SysBase 0 "exec.library")))
  19.  
  20. (defun reset-libraries-at-init ()
  21.   ;; reset all libray base pointers when starting a new Lisp
  22.   (dolist (library *libraries-alist*)
  23.     (makunbound (first library))))
  24. (pushnew 'reset-libraries-at-init sys::*init-hooks*)
  25.  
  26. (defun declare-library-base (symbol name)
  27.   "Associate the SYMBOL referencing library NAME and import it."
  28.   (unless (and (keywordp symbol) (stringp name))
  29.     (error
  30.       #L{
  31.       DEUTSCH "Base ~S kein Schlüsselwort oder Libraryname ~S kein String"
  32.       ENGLISH "Basename ~S not a keyword or libraryname ~S not a string"
  33.       FRANCAIS "La base ~S n'est pas un mot-clé ou alors le nom de librairie ~S n'est pas une chaîne"
  34.       }
  35.       symbol name))
  36.   (setq symbol (intern (symbol-name symbol) '#.*package*)) ;intern into AFFI
  37.   (let ((found (assoc symbol *libraries-alist* :test #'eq)))
  38.     (cond (found
  39.            (unless (string-equal name (third found))
  40.              ;; how possibly continue with cerror?
  41.              (error
  42.                #L{
  43.                DEUTSCH "Libraryredefinition: alt ~S, neu ~S"
  44.                ENGLISH "Library redefinition: old ~S, new ~S"
  45.                FRANCAIS "Redéfinition d'une librarie : avant ~S, maintenant ~S"
  46.                }
  47.                (third found) name)))
  48.           (t (push (list symbol 0 name) *libraries-alist*))))
  49.   (proclaim `(special ,symbol))
  50.   (import symbol)
  51.   symbol)
  52.  
  53.  
  54. (defun check-library-base (symbol)
  55.   (or (assoc symbol *libraries-alist* :test #'eq)
  56.       (error
  57.         #L{
  58.         DEUTSCH "Unbekannte Library: ~S"
  59.         ENGLISH "Unknown library: ~S"
  60.         FRANCAIS "Librairie inconnue : ~S"
  61.         }
  62.         symbol)))
  63.  
  64. ;;TODO? library version
  65. (defun open-library (symbol)
  66.   "Returns library address or NIL if it failed. The library must be known."
  67.   ;;CLISP won't close libraries for you...
  68.   (let ((found (check-library-base symbol)))
  69.     (cond
  70.       ((boundp symbol)
  71.        (incf (second found))            ;open count
  72.        (symbol-value symbol))
  73.       (t                                ;first open
  74.        (let ((base
  75.               (sys::%libcall
  76.                (locally (declare (special SysBase))
  77.                  (if (boundp 'SysBase) SysBase (sys::mem-read 4 '*)))
  78.                '#((-552 . #x1A) * string 2)
  79.                (third found) 0)))
  80.          (when (nzero-pointer-p base)
  81.            (prog1 (set (first found) base)
  82.              (setf (second found) 1)))))))) ; field might have been invalid
  83.  
  84. (defun close-library (symbol)
  85.   (let ((found (check-library-base symbol)))
  86.     (cond
  87.       ((not (boundp symbol))
  88.        (error
  89.          #L{
  90.          DEUTSCH "Library ~S ist gar nicht geöffnet"
  91.          ENGLISH "Library ~S is not open"
  92.          FRANCAIS "La librairie ~S n'est pas ouverte"
  93.          }
  94.          symbol))
  95.       ;;TODO? count<0 Test
  96.       ((zerop (decf (second found)))
  97.        (sys::%libcall
  98.         (locally (declare (special SysBase))
  99.           (if (boundp 'SysBase) SysBase (sys::mem-read 4 '*)))
  100.         '#((-414 . #xA) () *)
  101.         (symbol-value symbol))
  102.        (makunbound symbol))))
  103.   t)
  104.  
  105. (defun check-library-name (name)
  106.   ;; same as above, but allows base symbol or library name
  107.   (cond ((when (stringp name)
  108.            (rassoc name *libraries-alist* :key #'second
  109.                    :test #'string-equal))) ;case-sensitive like Exec
  110.         (t (check-library-base name)))) ;find it or error
  111.  
  112. (defmacro with-open-library ((name) &body body)
  113.   "If necessary opens library NAME, and executes BODY, finally closing it.
  114. Returns NIL if the library can't be opened.  Unlike OPEN-LIBRARY, NAME may
  115. be a string, which must be the name of a known library."
  116.   (when (stringp name) ; name must be known at compile-time
  117.     (setq name (car (check-library-name name))))
  118.   `(when (open-library ',name)
  119.     (unwind-protect (multiple-value-prog1 (progn ,@body))
  120.       (close-library ',name))))
  121.  
  122.  
  123. ;; All known functions symbols are stored in a single hash-table. Each
  124. ;; function is associated with its library and call information in a cons
  125. ;; pair: <function> -> ( <library> . <call information> )
  126.  
  127. (defvar *library-functions* (make-hash-table :test 'eq))
  128.  
  129. (defun import-or-loose (symbol)
  130.   (let ((new (find-symbol (symbol-name symbol))))
  131.     (when (and new (not (eq new symbol)))
  132.       (error "Another symbol ~A already exists" symbol))
  133.     (cond (new)
  134.       (t (import symbol) symbol))))
  135.  
  136. (defun require-library-functions (name &key (import t))
  137.   "Loads foreign function definitions for library NAME if necessary."
  138.   (let* ((entry (check-library-name name))
  139.          (base (first entry))
  140.          (name (third entry)))
  141.     (require name (make-pathname :type "affi" :defaults name)) ;"exec.affi"
  142.     ;; If require worked, name must be correct, now export symbols
  143.     (typecase import
  144.       (LIST                             ; import only requested functions
  145.        (values
  146.         base
  147.         (loop for fname in import
  148.               collect
  149.           (etypecase fname
  150.             (STRING
  151.              (let* ((common (intern (string-upcase fname) '#.*package*)) ;TODO? match *fd-readtable* case
  152.                     (info (gethash common *library-functions*)))
  153.                (if (and info (eq (car info) base))
  154.                    (import-or-loose common)
  155.                    (error
  156.                      #L{
  157.                      DEUTSCH "Funktion in Library ~S unbekannt: ~S"
  158.                      ENGLISH "Unknown function of library ~S: ~S"
  159.                      FRANCAIS "Fonction inconnue dans la librarie ~S : ~S"
  160.                      }
  161.                      name common))))))))
  162.       ((EQL T)
  163.        ;; as we don't store functions on a per-library basis, walk over all
  164.        (maphash
  165.         #'(lambda (function info)
  166.             (when (and (eq (car info) base)
  167.                        ;; Assume we only need to import AFFI symbols (others are imported from Lisp)
  168.                        ;; possible problem with "LISP" vs. "COMMON-LISP"
  169.                        (eq (symbol-package function) '#.*package*))
  170.               (import-or-loose function)))
  171.         *library-functions*)
  172.        base))))
  173.  
  174.  
  175. ;; The function call information is used by the C part. It's a simple-
  176. ;; vector of n+2 elements for an n-ary function. The first element may be
  177. ;; nil or a cons of a library offset and a mask indicating a
  178. ;; register-based call. The second element indicates the function return
  179. ;; type. The other elements indicate the argument types.
  180.  
  181. ;; ATTENTION: AFFI.D depends on this format!
  182.  
  183. (defun defflibfun (name library offset mask result-type &rest arg-types)
  184.   (check-library-base library)
  185.   (unless (typep offset 'fixnum)        ;TODO not only reg calls
  186.     (error
  187.       #L{
  188.       DEUTSCH "Offset ist kein FIXNUM: ~S"
  189.       ENGLISH "Offset must be a fixnum: ~S"
  190.       FRANCAIS "Le déplacement ~S n'est pas de type FIXNUM"
  191.       }
  192.       offset))
  193.   (let ((old (gethash name *library-functions*))
  194.         (new (cons library
  195.                    (concatenate
  196.                     'simple-vector
  197.                     (list (cons offset mask) result-type)
  198.                     arg-types))))
  199.     (unless (equalp old new)
  200.       (when old
  201.         (format *error-output*
  202.                 #L{
  203.                 DEUTSCH "~&;; Definitionsänderung der foreign-library Funktion ~S~%;;  von ~S nach ~S.~%"
  204.                 ENGLISH "~&;; redefining foreign library function ~S~%;;  from ~S to ~S~%"
  205.                 FRANCAIS "~&;; Redéfinition de la fonction étrangère ~S~%;;  de ~S en ~S~%"
  206.                 }
  207.                 name old new))
  208.       ;; TODO check types
  209.       (setf (gethash name *library-functions*) new)))
  210.   name)
  211.  
  212.  
  213. (defun calc-register-mask (regs test)
  214.   (labels
  215.       ((calc (regs accu)
  216.          (if (null regs) accu
  217.              (calc (rest regs)
  218.                    (logior
  219.                     (ash accu 4)
  220.                     (1+ (or (position
  221.                              (first regs)
  222.                              '(:D0 :D1 :D2 :D3 :D4 :D5 :D6 :D7
  223.                                :A0 :A1 :A2 :A3 :A4 :A5 :A6)
  224.                              :test test)
  225.                             (error
  226.                               #L{
  227.                               DEUTSCH "Unbekanntes Register: ~S"
  228.                               ENGLISH "Unknown register: ~S"
  229.                               FRANCAIS "Registre inconnu : ~S"
  230.                               }
  231.                               (first regs)))))))))
  232.     (calc (reverse regs) 0)))
  233.  
  234. ;; better-looking definitions (closer to FFI)
  235. (defmacro declare-library-function (name library &rest options)
  236.   (let ((base (first (check-library-name library)))
  237.         (arguments (rest (assoc :arguments options))))
  238.     (dolist (arg arguments)
  239.       (unless (and (symbolp (first arg))  ; variable name
  240.                    #+AMIGA (keywordp (third arg)) ; register
  241.                    (null (nthcdr 3 arg))) ; nothing more
  242.         (error
  243.           #L{
  244.           DEUTSCH "Ungültige Parameterspezifikation ~S in ~S"
  245.           ENGLISH "Invalid parameter specification ~S in function ~S"
  246.           FRANCAIS "Spécification invalide d'argument ~S pour la fonction ~S"
  247.           }
  248.           arg name)))
  249.     `(defflibfun ',name ',base
  250.       ',(second (assoc :offset options))
  251.       ',(calc-register-mask (mapcar #'third arguments) #'eq)
  252.       ',(second (assoc :return-type options))
  253.       ,.(mapcar #'(lambda (arg) (list 'quote (second arg))) arguments))))
  254.  
  255.  
  256. (flet
  257.     ((function-info (name)
  258.        (or (gethash name *library-functions*)
  259.            (error
  260.              #L{
  261.              DEUTSCH "Unbekannte Libraryfunktion: ~S"
  262.              ENGLISH "Unknown library function: ~S"
  263.              FRANCAIS "Fonction d'une librairie inconnue : ~S"
  264.              }
  265.              name))))
  266.  
  267. (defun flibcall (name &rest args)
  268.   "Call library function NAME with any number of ARGS."
  269.   (let ((info (function-info name)))
  270.     (apply #'sys::%libcall
  271.            (symbol-value (car info))    ; library
  272.            (cdr info)
  273.            args)))
  274.  
  275. (defmacro mlibcall (name &rest args)
  276.   "Call library function NAME with ARGS."
  277.   (let ((info (function-info name)))
  278.     (if (= (length args) (- (length (cdr info)) 2))
  279.         `(sys::%libcall ,(car info) ',(cdr info) . ,args)
  280.         (sys::error-of-type 'program-error
  281.           #L{
  282.           DEUTSCH "Falsche anzahl an Argumenten für ~S: ~S"
  283.           ENGLISH "Bad number of arguments for ~S: ~S"
  284.           FRANCAIS "Mauvais nombre d'arguments pour ~S : ~S"
  285.           }
  286.           name (length args)))))
  287.  
  288. ) ; flet
  289.  
  290.