Moving Hello-c (my UFFI fork) to its own module (under Cello)

# CVS default ignores begin

tags

TAGS

.make.state

.nse_depinfo

*~

#*

.#*

,*

_$*

*$

*.old

*.bak

*.BAK

*.orig

*.rej

.del-*

*.a

*.olb

*.o

*.obj

*.so

*.exe

*.Z

*.elc

*.ln

core

# CVS default ignores end

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: hic -*-

;;;; *************************************************************************

;;;; FILE IDENTIFICATION

;;;;

;;;; Name:          aggregates.lisp

;;;; Purpose:       hic source to handle aggregate types

;;;; Programmer:    Kevin M. Rosenberg

;;;; Date Started:  Feb 2002

;;;;

;;;; $Id: aggregates.lisp,v 1.1 2004/12/14 03:58:48 ktilton Exp $

;;;;

;;;; This file, part of hic, is Copyright (c) 2002 by Kevin M. Rosenberg

;;;;

;;;; hic users are granted the rights to distribute and use this software

;;;; as governed by the terms of the Lisp Lesser GNU Public License

;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

;;;; *************************************************************************

(in-package #:hic)

(defmacro def-enum (enum-name args &key (separator-string "#"))

  "Creates a constants for a C type enum list, symbols are created

in the created in the current package. The symbol is the concatenation

of the enum-name name, separator-string, and field-name"

  (let ((counter 0)

	(cmds nil)

	(constants nil))

    (declare (fixnum counter))

    (dolist (arg args)

      (let ((name (if (listp arg) (car arg) arg))

	    (value (if (listp arg) 

		       (prog1

			   (setq counter (cadr arg))

			 (incf counter))

		     (prog1 

			 counter

		       (incf counter)))))

	(setq name (intern (concatenate 'string

			     (symbol-name enum-name)

			     separator-string

			     (symbol-name name))))

	(push `(ffx:def-constant ,name ,value) constants)))

    (setf cmds (append '(progn)

		       #+allegro `((ff:def-foreign-type ,enum-name :int))

		       #+lispworks `((fli:define-c-typedef ,enum-name :int))

		       #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))

		       #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))

                       #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))

                       #+openmcl `((ccl::def-foreign-type ,enum-name :int))

		       (nreverse constants)))

    cmds))

(defmacro def-array-pointer (name-array type)

  #+allegro

  `(ff:def-foreign-type ,name-array 

    (:array ,(convert-from-uffi-type type :array)))

  #+lispworks

  `(fli:define-c-typedef ,name-array

    (:c-array ,(convert-from-uffi-type type :array)))

  #+(or cmu scl)

  `(alien:def-alien-type ,name-array 

    (* ,(convert-from-uffi-type type :array)))

  #+sbcl

  `(sb-alien:define-alien-type ,name-array 

    (* ,(convert-from-uffi-type type :array)))

  #+(and mcl (not openmcl))

  `(def-mcl-type ,name-array '(:array ,type))

  #+openmcl

  `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))

  )

(defun process-struct-fields (name fields &optional (variant nil))

  (let (processed)

    (dolist (field fields)

      (let* ((field-name (car field))

	     (type (cadr field))

	     (def (append (list field-name)

			  (if (eq type :pointer-self)

			      #+(or cmu scl) `((* (alien:struct ,name)))

			      #+sbcl `((* (sb-alien:struct ,name)))

			      #+mcl `((:* (:struct ,name)))

			      #+lispworks `((:pointer ,name))

			      #-(or cmu sbcl scl mcl lispworks) `((* ,name))

			      `(,(convert-from-uffi-type type :struct))))))

	(if variant

	    (push (list def) processed)

	  (push def processed))))

    (nreverse processed)))

(defmacro def-struct (name &rest fields)

  #+(or cmu scl)

  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))

  #+sbcl

  `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))

  #+allegro

  `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))

  #+lispworks

  `(fli:define-c-struct ,name ,@(process-struct-fields name fields))

  #+(and mcl (not openmcl))

  `(ccl:defrecord ,name ,@(process-struct-fields name fields))

  #+openmcl

  `(ccl::def-foreign-type

    nil 

    (:struct ,name ,@(process-struct-fields name fields)))

  )

(defmacro get-slot-value (obj type slot)

  #+(or lispworks cmu sbcl scl) (declare (ignore type))

  #+allegro

  `(ff:fslot-value-typed ,type :c ,obj ,slot)

  #+lispworks

  `(fli:foreign-slot-value ,obj ,slot)

  #+(or cmu scl)

  `(alien:slot ,obj ,slot)

  #+sbcl

  `(sb-alien:slot ,obj ,slot)

  #+mcl

  `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))

  )

#+mcl

(defmacro set-slot-value (obj type slot value) ;use setf to set values

  `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))

#+mcl

(defsetf get-slot-value set-slot-value)

(defmacro get-slot-pointer (obj type slot)

  #+(or lispworks cmu sbcl scl) (declare (ignore type))

  #+allegro

  `(ff:fslot-value-typed ,type :c ,obj ,slot)

  #+lispworks

  `(fli:foreign-slot-pointer ,obj ,slot)

  #+(or cmu scl)

  `(alien:slot ,obj ,slot)

  #+sbcl

  `(sb-alien:slot ,obj ,slot)

  #+(and mcl (not openmcl))

  `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))

  #+openmcl

  `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))

     (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))  

)

;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8

;; below

(eval-when (:compile-toplevel :load-toplevel :execute)

  ;; so we could allow '(:array :long) or deref with other type like :long only

  #+mcl

  (defun array-type (type)

    (let ((result type))

      (when (listp type)

	(let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))

	  (when (and (listp type-list) (eq (car type-list) :array))

	    (setf result (cadr type-list)))))

      result))

  (defmacro deref-array (obj type i)

    "Returns a field from a row"

    #+(or lispworks cmu sbcl scl) (declare (ignore type))

    #+(or cmu scl)  `(alien:deref ,obj ,i)

    #+sbcl `(sb-alien:deref ,obj ,i)

    #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)

    #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)

    #+openmcl

    (let* ((array-type (array-type type))

	   (local-type (convert-from-uffi-type array-type :allocation))

	   (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))

      (ccl::%foreign-access-form

       obj

       (ccl::%foreign-type-or-record local-type)

       `(* ,i ,element-size-in-bits)

       nil))

    #+(and mcl (not openmcl))

    (let* ((array-type (array-type type))

	   (local-type (convert-from-uffi-type array-type :allocation))

	   (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))

      `(,accessor

	,obj

	(* (the fixnum ,i) ,(size-of-foreign-type local-type))))

    ))

; this expands to the %set-xx functions which has different params than %put-xx

#+(and mcl (not openmcl))

(defmacro deref-array-set (obj type i value)

  (let* ((array-type (array-type type))

         (local-type (convert-from-uffi-type array-type :allocation))

         (accessor (first (macroexpand `(ccl:pref obj ,local-type))))

         (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))

    `(,settor 

      ,obj

      (* (the fixnum ,i) ,(size-of-foreign-type local-type)) 

      ,value)))

#+(and mcl (not openmcl))

(defsetf deref-array deref-array-set)

(defmacro def-union (name &rest fields)

  #+allegro

  `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))

  #+lispworks

  `(fli:define-c-union ,name ,@(process-struct-fields name fields))

  #+(or cmu scl)

  `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))

  #+sbcl

  `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))

  #+(and mcl (not openmcl))

  `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))

  #+openmcl

  `(ccl::def-foreign-type nil 

			  (:union ,name ,@(process-struct-fields name fields)))

)

#-(or sbcl cmu)

(defun convert-from-foreign-usb8 (s len)

  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))

	   (fixnum len))

  (let ((a (make-array len :element-type '(unsigned-byte 8))))

    (dotimes (i len a)

      (declare (fixnum i))

      (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))

#+sbcl

(defun convert-from-foreign-usb8 (s len)

  (let ((sap (sb-alien:alien-sap s)))

    (declare (type sb-sys:system-area-pointer sap))

    (locally

	(declare (optimize (speed 3) (safety 0)))

      (let ((result (make-array len :element-type '(unsigned-byte 8))))

	(sb-kernel:copy-from-system-area sap 0

					 result (* sb-vm:vector-data-offset

						   sb-vm:n-word-bits)

					 (* len sb-vm:n-byte-bits))

	result))))

#+cmu

(defun convert-from-foreign-usb8 (s len)

  (let ((sap (alien:alien-sap s)))

    (declare (type system:system-area-pointer sap))

    (locally

	(declare (optimize (speed 3) (safety 0)))

      (let ((result (make-array len :element-type '(unsigned-byte 8))))

	(kernel:copy-from-system-area sap 0

				      result (* vm:vector-data-offset

						vm:word-bits)

				      (* len vm:byte-bits))

	result))))

;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*-

;;;

;;; Copyright  1995,2003 by Kenneth William Tilton.

;;;

;;; Permission is hereby granted, free of charge, to any person obtaining a copy 

;;; of this software and associated documentation files (the "Software"), to deal 

;;; in the Software without restriction, including without limitation the rights 

;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 

;;; copies of the Software, and to permit persons to whom the Software is furnished 

;;; to do so, subject to the following conditions:

;;;

;;; The above copyright notice and this permission notice shall be included in 

;;; all copies or substantial portions of the Software.

;;;

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 

;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 

;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 

;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 

;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 

;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 

;;; IN THE SOFTWARE.

(in-package :hello-c)

(defparameter *gl-rsrc* nil)

(defparameter *fgn-mem* nil)

(defun fgn-dump ()

  (print (length *fgn-mem*))

  (loop for fgn in *fgn-mem*

        do (print fgn)

        summing (fgn-amt fgn)))

#+check

(fgn-dump)

(defun ffx-reset (&optional force)

  (hic-reset force))

(defun hic-reset (&optional force)

  (if force

      (progn

        (loop for fgn in *fgn-mem*

            do (print fgn)

              (fgn-free (fgn-ptr fgn))

            finally (setf *fgn-mem* nil))

        (loop for fgn in *gl-rsrc*

            do (print fgn)

              (glfree (fgn-type fgn)(fgn-ptr fgn))

            finally (setf *gl-rsrc* nil))

    (progn

      (when *fgn-mem*

        (loop for fgn in *fgn-mem*

            do (print fgn)

            finally (break "above fgn-mem not freed")))

      (when *gl-rsrc*

        (loop for fgn in *gl-rsrc*

            do (print fgn)

            finally (break "above *gl-rsrc* not freed")))))))

(defstruct fgn ptr id type amt)

(defmethod print-object ((fgn fgn) s)

  (format s "fgnmem ~a :amt ~a :type ~a"

    (fgn-id fgn)(fgn-amt fgn)(fgn-type fgn)))

(defmacro fgn-alloc (type amt-form &rest keys)

  (let ((amt (gensym))

        (ptr (gensym)))

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

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

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

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

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

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

                        :type type

                        :amt amt

                        :ptr ptr)

                  *fgn-mem*))))

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

  (loop for fgn-ptr in fgn-ptrs 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))))

(defun gllog (type resource amt &rest keys)

  (push (make-fgn :id keys

          :type type

          :amt amt

          :ptr resource)

    *gl-rsrc*))

(defun glfree (type resource)

  (let ((fgn (find (cons type resource) *gl-rsrc*

               :test 'equal

               :key (lambda (g)

                      (cons (fgn-type g)(fgn-ptr g))))))

    (if fgn

        (setf *gl-rsrc* (delete fgn *gl-rsrc*))

      (format t "~&Freeing unknown GL resource ~a" (cons type resource)))

    #+nonono (ecase type

      (:texture (ogl:ogl-texture-delete resource)))))

(defmacro make-ff-array (type &rest values)

  (let ((fv (gensym))(n (gensym))(vs (gensym)))

    `(let ((,fv (fgn-alloc ',type ,(length values) :make-ff-array))

           (,vs (list ,@values)))

       (dotimes (,n ,(length values) ,fv)

         (setf (ff-elt ,fv ,type ,n)

           (coerce (nth ,n ,vs) ',(if (keywordp type)

                                     (intern (symbol-name type))

                                   (get type 'ffi-cast))))))))

(defmacro ff-list (array type count)

  (let ((a (gensym))(n (gensym)))

  `(loop with ,a = ,array

       for ,n below ,count

       collecting (ff-elt ,a ,type ,n))))

(defun make-floatv (&rest floats)

  (let* ((co (fgn-alloc :float (length floats) :make-floatv))

         )

    (apply 'ff-floatv-setf co floats)))

(defmacro ff-floatv-ensure (place &rest values)

  `(if ,place

       (ff-floatv-setf ,place ,@values)

     (setf ,place (make-floatv ,@values))))

(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)))

  array)

;--------- with-ff-array-elements ------------------------------------------

(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))))

             refs))

     ,@body))

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

(defmacro ff-elt-p (v n)

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

(defmacro ff-elt (v type n)

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

(defun elti (v n)

  (ff-elt v :int n))

(defun (setf elti) (value v n)

  (setf (ff-elt v :int n) (coerce value 'integer)))

(defun eltf (v n)

  (ff-elt v :float n))

(defun (setf eltf) (value v n)

  (setf (ff-elt v :float n) (coerce value 'float)))

(defun elt$ (v n)

  (ff-elt v :cstring n))

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

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

(defun eltd (v n)

  (ff-elt v :double n))

(defun (setf eltd) (value v n)

  (setf (ff-elt v :double n) (coerce value 'double-float)))

(defmacro fgn-pa (pa n)

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

(eval-when (compile load eval)

  (export '(ffx-reset

           ff-elt ff-list

           eltf eltd elti fgn-pa

           with-ff-array-elements

           make-ff-array

           make-floatv ff-floatv-ensure

           hic-reset fgn-alloc fgn-free gllog glfree)))

 No newline at end of file

;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*-

;;;

;;; Copyright © 1995,2003 by Kenneth William Tilton.

;;;

;;; Permission is hereby granted, free of charge, to any person obtaining a copy 

;;; of this software and associated documentation files (the "Software"), to deal 

;;; in the Software without restriction, including without limitation the rights 

;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 

;;; copies of the Software, and to permit persons to whom the Software is furnished 

;;; to do so, subject to the following conditions:

;;;

;;; The above copyright notice and this permission notice shall be included in 

;;; all copies or substantial portions of the Software.

;;;

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 

;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 

;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 

;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 

;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 

;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 

;;; IN THE SOFTWARE.

(in-package :hello-c)

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

  #+allegro

  (ff:register-foreign-callable callback-name)

  #+lispworks

  (let ((cb (progn ;; fli:pointer-address

              (fli:make-pointer :symbol-name (symbol-name callback-name) ;; leak?

                :functionp t))))

    (print (list :ff-register-callable-returns cb))

    cb))

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

  (declare (ignorable result-type))

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

                       (process-function-args args))))

    #+lispworks

    `(fli:define-foreign-callable

      (,(symbol-name name) :result-type ,result-type :calling-convention ,call-convention)

      (,@native-args)

      ,@body)

    #+allegro

    `(ff:defun-foreign-callable ,name ,native-args

       (declare (:convention ,(ecase call-convention

                                (:cdecl :c)

                                (:stdcall :stdcall))))

       ,@body)))

#+test

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

  (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)