Subject: [clisp-list] my FFI Lisp hacks toolbox #1

From: "Hoehle, Joerg-Cyril" <[email-masked]>
Date: Fri Apr 12 08:38:54 2002

Hi,

in order for people to experiment with many unexplored areas of the CLISP FFI, I thought it would be useful to release my FFI hacks file #1.

I hope to get some feedback. This would be nice for the future CLISP FFI.

+ foreign-address (c-pointer) <-> integer conversion
+ malloc
+ foreign-funcall using dynamic (variable) function type definition
  -> entry point to variable sized arrays and many more

The idea is to use FOREIGN-VARIABLE as typed pointer into foreign space.
Then, FFI::%OFFSET, FFI::%DEREF, FFI::%SLOT, FFI::%SIZEOF, FFI::FOREIGN-VALUE,
FFI::SET-FOREIGN-VALUE etc. become usable and extremely valuable.

FFI::PARSE-C-TYPE is required almost everywhere. This maps the USER visible
and well-documented foreign type (list based) to the internal one (vector based).

Don't be scared by the ::% prefix to all these functions. They are your friends now!

That shows part of the functionality. Naming and nice macros on top
of these etc. will be addressed in some future.

The dynload module or a tiny module with my clisp_ffi_redirector module
(see DEF-C-VARIABLE below) is required to get at the initial foreign
variable and function.

Enjoy,
	Jörg Höhle.

;; Save your life with the CLISP FFI
;; Jörg Höhle, March 2002

;; Most of this ought to become part of CLISP (rewritten as LISPFUN),
;; once I provide nice top-level interfaces on top of this.

(in-package "USER")

;; You all got these for free with the dynload module!
(eval-when (eval load)
(ffi:def-c-call-out c-self
  (:name "C_self")
  (:arguments (obj ffi:int))
  (:return-type ffi:int))
(ffi:def-c-var clisp-ffi-indirector (:type ffi:c-pointer)
   (:name "clisp_ffi_indirector"))
)

(defun describe-thing (o)
  (dotimes (i (sys::%record-length o) o)
    (format t "~&~D. ~S~%" i (sys::%record-ref o i))))

(setq f0 (or (GET 'CLISP-FFI-INDIRECTOR 'FFI:FOREIGN-VARIABLE)
  (error "clisp_ffi_indirector yet undeclared (unavailable?)")))

(setq f0-uint (load-time-value
   (ffi::%cast f0 (ffi::parse-c-type 'ffi:uint))))
(setq f0-c-pointer (load-time-value
   (ffi::%cast f0 (ffi::parse-c-type 'ffi:c-pointer))))

;; ffi::set-foreign-value is one key to convert_to_foreign
;; ffi::foreign-value is one key to convert_from_foreign

(defun foreign-address-unsigned (address)
  ; FOREIGN-ADDRESS-VALUE is a misnomer (bad abstraction level)
  ; since CLtL2, the value of an atom is itself.
  (ffi::foreign-address-value address)) ; is in CLISP-2.28
;(foreign-address-unsigned #'c-self)

(defun unsigned-foreign-address (n)
  (ffi::set-foreign-value f0-uint n)
  (ffi::foreign-value f0-c-pointer))
;(unsigned-foreign-address 3)

;;;###export
(defun foreign-address (foreign)
  (etypecase foreign
     (ffi:foreign-address foreign)
     ((or ffi:foreign-variable ffi:foreign-function)
      (sys::%record-ref foreign 1))))
;(foreign-address #'c-self)
;(foreign-address f0)

;;;###export
(defun update-foreign-address (foreign new-address)
  (check-type foreign (or ffi:foreign-function ffi:foreign-variable))
  (check-type new-address ffi:foreign-address)
  (setf (sys::%record-ref foreign 1) new-address))

;; already part of DYNLOAD module
;;;###export
(defun foreign-address-function (name address ctype)
  (check-type address ffi:foreign-address)
  (check-type name (or null string))
  (assert (and (simple-vector-p ctype)
	       (= (length ctype) 4) ; foreign.d does 1 more check
	       (eq (svref ctype 0) 'ffi:c-function)))
  (ffi::set-foreign-value f0-c-pointer address)
  (let ((ff (ffi::foreign-value (ffi::%cast f0 ctype))))
    (setf (sys::%record-ref ff 0) name)
    (update-foreign-address ff address) ; restore EQ address (needed for ff)
    ff))

(defun fcast (ffunction ctype)
  (check-type ffunction ffi:foreign-function)
  (foreign-address-function
   (sys::%record-ref ffunction 0) ; name
   (foreign-address ffunction) ctype))
;(fcast #'c-self (ffi::parse-c-type '(ffi:c-function (:arguments (obj ffi:c-string)) (:return-type ffi:c-string))))

;; gross hack, *not* to become part of CLISP!
(defun redefine-foreign-function (ffun ffi-type)
  ;;TODO check for incomplete type, e.g. (ffi:c-function)
  (unless
      ;; safety checks before hacking the internals
      ;; (0. c-name as string (possibly NIL?)
      ;;  1. foreign-address
      ;;  2. return type 3. argument types
      ;;  4. flags)
      (and (eq (type-of ffun) 'ffi:foreign-function)
	   (= (sys::%record-length ffun) 5)
	   (eq (type-of (sys::%record-ref ffun 1)) 'ffi:foreign-address)
	   (integerp (sys::%record-ref ffun 4))) ; flags
    ;;TODO type program-error or so?
    (error "Not a foreign function: ~S" ffun))
  (let ((new (ffi::parse-c-type ffi-type)))
    (unless
	(and (simple-vector-p new) (= (length new) 4)
	     (eq (svref new 0) 'ffi:c-function)
	     (integerp (svref new 3)))
      (error "Not a foreign function type specification: ~S" ffi-type))
    (setf (sys::%record-ref ffun 2) (svref new 1)) ;result type
    (setf (sys::%record-ref ffun 3) (svref new 2)) ;argument types
    (setf (sys::%record-ref ffun 4) (svref new 3)) ;flags
    ffun))

;; *Complex* malloc: allocates any nested structure, contrary to a
;; simple C malloc(). This does much more than you think!
;;;###export
(defun foreign-malloc (ffi-type initval)
  (let ((ft (ffi::parse-c-type ffi-type))
	;; allocate foreign-variable via replication
	(fv (ffi::%cast f0 'ffi:c-pointer)))
    (setf (sys::%record-ref fv 3) ft)	;foreign type
    (setf (sys::%record-ref fv 2) (ffi::%sizeof ft)) ;sizeof(type)
    (setf (sys::%record-ref fv 0) "via malloc")
    ;; TODO use fcast now that it exists
    (redefine-foreign-function #'c-self
     `(ffi:c-function (:arguments (obj (ffi:c-ptr ,ffi-type) :in :malloc-free))
		      (:return-type ffi:c-pointer)
		      (:language :stdc)))
    (setf (sys::%record-ref fv 1) (c-self initval)) ;foreign-address
    fv))
;(foreign-malloc 'ffi:int -123456789)

;; no idea for foreign-free() in Lisp.
;; malloc() is enough for experiments

;; Using the redirector and #'c-self, even stack-allocated foreigns are
;; implementable (using a Lisp function as "callback", not shown).
;; Writing them in C has advantages:
;;  + not executing within context of a callback
;;  + can return any Lisp values