home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / cl-support / foreign.lisp < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.1 KB  |  145 lines  |  [TEXT/CCL2]
  1. ;;; foreign.lisp -- A C interface package for Common Lisp
  2. ;;;
  3. ;;; author :  John Peterson
  4. ;;;
  5. ;;; You must load cl-setup and cl-support before trying to compile this 
  6. ;;; file.
  7.  
  8. (in-package "MUMBLE-IMPLEMENTATION")
  9.  
  10. ;;; Since the foreign function interfaces are so different among the various
  11. ;;; lisps, all definitions are conditionalized at the very top level.
  12.  
  13. ;;; The following functions constitute the C interface:
  14.  
  15. ;;;  (load-foreign-file filename)  -- Loads a .o file
  16.  
  17. ;;; (define-c-function c-name lisp-name r-type type-1 type-2 ... type-n)
  18. ;;;   C types are:
  19. ;;;     :char
  20. ;;;     :short
  21. ;;;     :int
  22. ;;;     :long
  23. ;;;     :unsigned-char
  24. ;;;     :unsigned-short
  25. ;;;     :unsigned-int
  26. ;;;     :unsigned-long
  27. ;;;     :float
  28. ;;;     :double
  29. ;;;     :bool
  30. ;;;     :void
  31. ;;;     :c-string
  32. ;;;     (:* type)
  33. ;;;     
  34.  
  35. (defvar *ff-cache* '())
  36.  
  37. (define-mumble-function mumble::load-foreign-file/cached (file-name)
  38.   (let ((fname (expand-filename file-name)))
  39.     (if (probe-file fname)
  40.     (let ((wd (file-write-date fname))
  41.           (old-wd (assoc fname *ff-cache* :test #'string=)))
  42.       (if (and old-wd (equal wd (cdr old-wd)))
  43.           ':cached
  44.           (if old-wd
  45.           ':error
  46.           (load-foreign-file-aux fname)))))))
  47.  
  48. (define-mumble-function mumble::load-foreign-file (file-name)
  49.   (load-foreign-file-aux (expand-filename file-name)))
  50.             
  51.              
  52.  
  53. #+cmu
  54. (progn
  55.   (defun load-foreign-file-aux (file-name)
  56.     (if (probe-file file-name)
  57.     (progn (extensions:load-foreign file-name)
  58.            (setf *ff-cache* (cons (cons file-name
  59.                         (file-write-date file-name))
  60.                       *ff-cache*))
  61.            ':loaded)
  62.         ':not-found))
  63.  
  64.   (defun convert-c-type (ty)
  65.     (cond ((eq ty ':char) 'c-call:char)
  66.       ((eq ty ':short) 'c-call:short)       
  67.       ((eq ty ':int) 'c-call:int)
  68.       ((eq ty ':long) 'c-call:long)       
  69.       ((eq ty ':unsigned-char) 'c-call:unsigned-char)       
  70.       ((eq ty ':unsigned-short) 'c-call:unsigned-short)       
  71.       ((eq ty ':unsigned-int) 'c-call:unsigned-int)
  72.       ((eq ty ':unsigned-long) 'c-call:unsigned-long)       
  73.       ((eq ty ':float) 'c-call:float)       
  74.       ((eq ty ':double) 'c-call:double)
  75.       ((eq ty ':bool) 'alien:boolean)
  76.       ((eq ty ':void) 'c-call:void)
  77.       ((eq ty ':c-string) 'c-call:c-string)
  78.       ((and (listp ty)
  79.         (eq (car ty) ':*))
  80.        (list 'alien:* (convert-c-type (cadr ty))))
  81.       (t (error "C type ~s is not supported in this Lisp." ty))))
  82.  
  83.   (define-mumble-macro mumble::define-c-function
  84.                          (c-name lisp-name res-type &rest arg-types)
  85.     `(alien:def-alien-routine (,c-name ,lisp-name)
  86.        ,(convert-c-type res-type)
  87.        ,@(mapcar #'(lambda (ty)
  88.              (list (gensym "a") (convert-c-type ty)))
  89.          arg-types)))
  90.   )    
  91.  
  92. #+allegro
  93. (progn
  94.   (defun load-foreign-file-aux (file-name)
  95.     (if (probe-file file-name)
  96.     (progn (load file-name)
  97.            (setf *ff-cache* (cons (cons file-name
  98.                         (file-write-date file-name))
  99.                       *ff-cache*))
  100.            ':loaded)
  101.         ':not-found))
  102.  
  103.   (defun convert-c-type/in (ty)
  104.     (cond ((eq ty ':char) 'character)
  105. ;      ((eq ty ':short) 'c-call:short)       
  106.       ((eq ty ':int) 'fixnum)
  107. ;      ((eq ty ':long) 'c-call:long)       
  108. ;      ((eq ty ':unsigned-char) 'c-call:unsigned-char)       
  109. ;      ((eq ty ':unsigned-short) 'c-call:unsigned-short)       
  110. ;      ((eq ty ':unsigned-int) 'c-call:unsigned-int)
  111. ;      ((eq ty ':unsigned-long) 'c-call:unsigned-long)       
  112.       ((eq ty ':float) 'float)       
  113.       ((eq ty ':double) 'double-float)
  114. ;      ((eq ty ':bool) 'alien:boolean)
  115.       ((eq ty ':void) ':void)
  116.       ((eq ty ':c-string) 'string)
  117. ;      ((and (listp ty)
  118. ;        (eq (car ty) ':*))
  119. ;       (list 'alien:* (convert-c-type (cadr ty))))
  120.       (t (error "C type ~s is not supported in this Lisp." ty))))
  121.  
  122.   (defun convert-c-type/out (ty)
  123.     (cond ((eq ty ':char) :character)
  124. ;      ((eq ty ':short) 'c-call:short)       
  125.       ((eq ty ':int) :fixnum)
  126. ;      ((eq ty ':long) 'c-call:long)       
  127. ;      ((eq ty ':unsigned-char) 'c-call:unsigned-char)       
  128. ;      ((eq ty ':unsigned-short) 'c-call:unsigned-short)       
  129. ;      ((eq ty ':unsigned-int) 'c-call:unsigned-int)
  130. ;      ((eq ty ':unsigned-long) 'c-call:unsigned-long)       
  131.       ((eq ty ':float) ':single-float)       
  132.       ((eq ty ':double) ':double-float)
  133. ;      ((eq ty ':bool) 'alien:boolean)
  134.       ((eq ty ':void) ':void)
  135. ;      ((eq ty ':c-string) 'string)
  136. ;      ((and (listp ty)
  137. ;        (eq (car ty) ':*))
  138. ;       (list 'alien:* (convert-c-type (cadr ty))))
  139.       (t (error "C type ~s is not supported in this Lisp." ty))))
  140.  
  141.   (define-mumble-macro mumble::define-c-function
  142.                          (c-name lisp-name res-type &rest arg-types)
  143.     `(ff:defforeign ',lisp-name
  144.        :entry-point ',(concatenate 'string "_" c-name)
  145.        :return-type ',(convert-c-