Commit 8c0a5421 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

*** empty log message ***

parent f79d5e68

arrays.lisp

+19 −17
Original line number Diff line number Diff line
@@ -23,7 +23,7 @@ 




  

(in-package :hello-c)

(in-package :ffx)

  

(defparameter *gl-rsrc* nil)
@@ -46,7 +46,7 @@ 
      (progn

        (loop for fgn in *fgn-mem*

            do (print fgn)

              (fgn-free (fgn-ptr fgn))

              (foreign-free (fgn-ptr fgn))

            finally (setf *fgn-mem* nil))

        (loop for fgn in *gl-rsrc*

            do (print fgn)
@@ -72,11 +72,11 @@ 
  (let ((amt (gensym))

        (ptr (gensym)))

    `(let* ((,amt ,amt-form)

            (,ptr (allocate-foreign-object ,type ,amt)))

            (,ptr (falloc ,type ,amt)))

       (call-fgn-alloc ,type ,amt ,ptr (list ,@keys)))))



(defun call-fgn-alloc (type amt ptr keys)

  ;;(print `(fgnalloc ,type ,amt ,keys))

  ;;(print `(call-fgn-alloc ,type ,amt ,keys))

  (fgn-ptr (car (push (make-fgn :id keys

                        :type type

                        :amt amt
@@ -84,12 +84,14 @@ 
                  *fgn-mem*))))



(defun fgn-free (&rest fgn-ptrs)

  (loop for fgn-ptr in fgn-ptrs do

  ;; (print `(fgn-free freeing ,@fgn-ptrs))

  (let ((start (copy-list fgn-ptrs)))

    (loop for fgn-ptr in start do

          (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr)))

            (if fgn

                (setf *fgn-mem* (delete fgn *fgn-mem*))

              (format t "~&Freeing unknown FGN ~a" fgn-ptr))

          (free-foreign-object fgn-ptr))))

            (foreign-free fgn-ptr)))))



(defun gllog (type resource amt &rest keys)

  (push (make-fgn :id keys
@@ -138,7 +140,7 @@ 
(defun ff-floatv-setf (array &rest floats)

  (loop for f in floats

        and n upfrom 0

        do (setf (deref-array array '(:array :float) n) (* 1.0 f)))

        do (setf (mem-aref array :float n) (* 1.0 f)))

  array)



;--------- with-ff-array-elements ------------------------------------------
@@ -147,17 +149,17 @@ 
(defmacro with-ff-array-elements ((fa type &rest refs) &body body)

  `(let ,(let ((refn -1))

           (mapcar (lambda (ref)

                     `(,ref (deref-array ,fa '(:array ,type) ,(incf refn))))

                     `(,ref (mem-aref ,fa ,type) ,(incf refn)))

             refs))

     ,@body))



;-------- ff-elt ---------------------------------------



(defmacro ff-elt-p (v n)

  `(deref-array ,v '(:array (* :void)) ,n))

  `(mem-aref ,v :pointer ,n))



(defmacro ff-elt (v type n)

  `(deref-array ,v '(:array ,type) ,n))

  `(mem-aref ,v ',type ,n))



(defun elti (v n)

  (ff-elt v :int n))
@@ -172,10 +174,10 @@ 
  (setf (ff-elt v :float n) (coerce value 'float)))



(defun elt$ (v n)

  (ff-elt v :cstring n))

  (ff-elt v :string n))



(defun (setf elt$) (value v n)

  (setf (ff-elt v :cstring n) value))

  (setf (ff-elt v :string n) value))



(defun eltd (v n)

  (ff-elt v :double n))
@@ -184,7 +186,7 @@ 
  (setf (ff-elt v :double n) (coerce value 'double-float)))



(defmacro fgn-pa (pa n)

  `(deref-array ,pa '(:array (* :void)) ,n))

  `(mem-aref ,pa :pointer ,n))



(eval-when (compile load eval)

  (export '(ffx-reset

callbacks.lisp

+16 −26
Original line number Diff line number Diff line
@@ -21,8 +21,10 @@ 
;;; IN THE SOFTWARE.





(in-package :hello-c)

(in-package :ffx)





#+precffi

(defun ff-register-callable (callback-name)

  #+allegro

  (ff:register-foreign-callable callback-name)
@@ -33,8 +35,18 @@ 
    (print (list :ff-register-callable-returns cb))

    cb))



(defun ff-register-callable (callback-name)

  (let ((known-callback (cffi:get-callback callback-name)))

    (assert known-callback)

    known-callback))



(defmacro ff-defun-callable (call-convention result-type name args &body body)

  (declare (ignorable call-convention))

  `(defcallback ,name ,result-type ,args ,@body))



#+precffi

(defmacro ff-defun-callable (call-convention result-type name args &body body)

  (declare (ignorable result-type))

  (declare (ignorable call-convention result-type))

  (let ((native-args (when args ;; without this p-f-a returns '(:void) as if for declare

                       (process-function-args args))))

    #+lispworks
@@ -50,35 +62,13 @@ 
       ,@body)))





#+test

(ff-defun-callable :cdecl :int square ((arg-1 :int)(data (* :void)))

#+(or)

(ff-defun-callable :cdecl :int square ((arg-1 :int)(data :pointer))

  (list data (* arg-1 arg-1)))



(defmacro ff-def-call ((module iname ename) args)

  #+cormanlisp

  (assert module () "Module (dll name, in fact) required for Corman Lisp")

  #+cormanlisp

  `(ct:defun-dll ,iname ,args

     :return-type :short

     :library-name ,module ;; required according Corman doc

     :entry-name ,ename

     :linkage-type :c) ;; ??



  #+allegro (declare (ignorable module))

  #+allegro

  `(ff:def-foreign-call (,iname ,ename) ,args)

  #+lispworks

  `(fli:define-foreign-function (,iname ,ename)

     ,(mapcar (lambda (arg) (if (listp (cadr arg))

                                (list (car arg) (substitute :pointer '* (cadr arg)))

                              arg))

        args)

     :module ,module

     :result-type :int))





(eval-when (compile load eval)

  (export '(ff-register-callable

            ff-defun-callable

            ff-def-call

            ff-pointer-address)))
 
 No newline at end of file

definers.lisp

+50 −5
Original line number Diff line number Diff line
@@ -22,7 +22,7 @@ 


;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $



(in-package :hello-c)

(in-package :ffx)



(eval-when (compile load eval)

  (export '(
@@ -46,11 +46,56 @@ 
;;;  (fli:make-pointer :address n :pointer-type '(:pointer :void)))



(defun make-ff-pointer (n)

  #+allegro   (ff:make-foreign-pointer :address n :type '(* void))

  #+lispworks (fli:make-pointer :address n :pointer-type  '(:pointer :void))

  #-(or lispworks allegro) n

  #+clisp (ffi:unsigned-foreign-address n)

  #-(or clisp lispworks) n

  )



(defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing)

  (declare (ignore module$))

  (let* ((lisp-fn (lisp-fn name$))

         (lispfn (intern (string-upcase name$)))

         (var-types (let (args)

                      (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$)

                      (dotimes (n (floor (length type-args) 2) (nreverse args))

                        (let ((type (elt type-args (* 2 n)))

                              (var (elt type-args (1+ (* 2 n)))))

                          (when (eql #\* (elt (symbol-name var) 0))

                            ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1)))

                            (setf type :pointer))

                          (push (list var type) args)))))

         (cast-vars (mapcar (lambda (var-type)

                             (copy-symbol (car var-type))) var-types)))

    `(progn

       (cffi:defcfun (,name$ ,lispfn) ,(if (and (consp rtn) (eq '* (car rtn)))

                                           :pointer rtn)

         ,@var-types)

                     

       (defun ,lisp-fn ,(mapcar #'car var-types)

         (let ,(mapcar (lambda (cast-var var-type)

                         `(,cast-var ,(if (listp (cadr var-type))

                                         (car var-type)

                                       (case (cadr var-type)

                                         (:int `(coerce ,(car var-type) 'integer))

                                         (:long `(coerce ,(car var-type) 'integer))

                                         (:unsigned-long `(coerce ,(car var-type) 'integer))

                                         (:unsigned-int `(coerce ,(car var-type) 'integer))

                                         (:float `(coerce ,(car var-type) 'float))

                                         (:double `(coerce ,(car var-type) 'double-float))

                                         (:string (car var-type))

                                         (:pointer (car var-type))

                                         (otherwise

                                          (let ((ffc (get (cadr var-type) 'ffi-cast)))

                                            (assert ffc () "Don't know how to cast ~a" (cadr var-type))

                                            `(coerce ,(car var-type) ',ffc)))))))

                 cast-vars var-types)

           (prog1

               (,lispfn ,@cast-vars)

             ,@post-processing)))

       (eval-when (compile eval load)

         (export '(,lispfn ,lisp-fn))))))



#+precffi

(defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing)

  (let* ((lisp-fn (lisp-fn name$))

         (lispfn (intern (string-upcase name$)))
@@ -81,7 +126,7 @@ 
                                         (:unsigned-int `(coerce ,(car var-type) 'integer))

                                         (:float `(coerce ,(car var-type) 'float))

                                         (:double `(coerce ,(car var-type) 'double-float))

                                         (:cstring (car var-type))

                                         (:string (car var-type))

                                         (otherwise

                                          (let ((ffc (get (cadr var-type) 'ffi-cast)))

                                            (assert ffc () "Don't know how to cast ~a" (cadr var-type))
@@ -121,7 +166,7 @@ 
(defmacro dft (ctype ffi-type ffi-cast)

  `(progn

     (setf (get ',ctype 'ffi-cast) ',ffi-cast)

     (def-foreign-type ,ctype ,ffi-type)

     (defctype ,ctype ,ffi-type)

     (eval-when (compile eval load)

       (export ',ctype))))

ffi-extender.lisp

0 → 100644
+51 −0
Original line number Diff line number Diff line 
(in-package :cl-user)



(defpackage #:ffi-extender

  (:nicknames #:ffx)

  (:shadowing-import-from #:cffi #:with-foreign-object

    #:load-foreign-library #:with-foreign-string)

  (:use #:common-lisp #:cffi)

  (:export

   #:def-type

   #:def-foreign-type

   #:def-constant

   #:null-char-p

   #:def-enum

   #:def-struct

   #:get-slot-value

   #:get-slot-pointer

   #:def-array-pointer

   #:def-union

   #:allocate-foreign-object

   #:with-foreign-object

   #:with-foreign-objects

   #:size-of-foreign-type

   #:pointer-address

   #:deref-pointer

   #:ensure-char-character

   #:ensure-char-integer

   #:ensure-char-storable

   #:null-pointer-p

   #:+null-cstring-pointer+

   #:char-array-to-pointer

   #:with-cast-pointer

   #:def-foreign-var

   #:convert-from-cstring

   #:convert-to-cstring

   #:free-cstring

   #:with-cstring

   #:with-cstrings

   #:def-function

   #:find-foreign-library

   #:load-foreign-library

   #:default-foreign-library-type

   #:run-shell-command

   #:convert-from-foreign-string

   #:convert-to-foreign-string

   #:allocate-foreign-string

   #:with-foreign-string

   #:foreign-string-length              ; not implemented

   #:convert-from-foreign-usb8

   ))



(in-package :ffx)
 
 No newline at end of file

hello-cffi.asd

0 → 100644
+24 −0
Original line number Diff line number Diff line 
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-



;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1)))

(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))





#-(or openmcl sbcl cmu clisp lispworks ecl allegro cormanlisp)

(error "Sorry, this Lisp is not yet supported.  Patches welcome!")



(asdf:defsystem :hello-cffi

  :name "Hello CFFI"

  :author "Kenny Tilton <ktilton@nyc.rr.com>"

  :version "1.0.0"

  :maintainer "Kenny Tilton <ktilton@nyc.rr.com>"

  :licence "Lisp Lesser GNU Public License"

  :description "CFFI Add-ons"

  :long-description "Extensions and utilities for CFFI"

  :depends-on (:cffi :cffi-uffi-compat)

  :serial t

  :components ((:file "my-uffi-compat")

               (:file "ffi-extender")

               (:file "definers")

               (:file "arrays")

               (:file "callbacks")))