Update of /project/cello/cvsroot/hello-c In directory common-lisp.net:/tmp/cvs-serv3125

Modified Files: definers.lisp hello-c.lpr primitives.lisp strings.lisp Log Message: No comment Date: Sun Jul 10 23:35:01 2005 Author: ktilton

Index: hello-c/definers.lisp diff -u hello-c/definers.lisp:1.1 hello-c/definers.lisp:1.2 --- hello-c/definers.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/definers.lisp Sun Jul 10 23:35:01 2005 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.

-;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $

(in-package :hello-c)

@@ -39,11 +39,17 @@ #-lispworks ff-ptr #+lispworks (fli:pointer-address ff-ptr))

+;;;(defun make-ff-pointer (n) +;;; #-lispworks +;;; n +;;; #+lispworks +;;; (fli:make-pointer :address n :pointer-type '(:pointer :void))) + (defun make-ff-pointer (n) - #-lispworks - n - #+lispworks - (fli:make-pointer :address n :pointer-type '(:pointer :void))) + #+allegro (ff:make-foreign-pointer :address n :type '(* void)) + #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) + #-(or lispworks allegro) n + )

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

Index: hello-c/hello-c.lpr diff -u hello-c/hello-c.lpr:1.1 hello-c/hello-c.lpr:1.2 --- hello-c/hello-c.lpr:1.1 Tue May 24 01:51:57 2005 +++ hello-c/hello-c.lpr Sun Jul 10 23:35:01 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (May 6, 2005 8:25)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (Jun 10, 2005 13:34)"; cg: "1.54.2.17"; -*-

(in-package :cg-user)

Index: hello-c/primitives.lisp diff -u hello-c/primitives.lisp:1.1 hello-c/primitives.lisp:1.2 --- hello-c/primitives.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/primitives.lisp Sun Jul 10 23:35:01 2005 @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;;;; $Id: primitives.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ ;;;; ;;;; This file, part of hello-c, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -242,37 +242,37 @@ (cond #+(or allegro cormanlisp) ((and (or (eq context :routine) (eq context :return)) - (eq type :cstring)) - (setq type '((* :char) integer))) + (eq type :cstring)) + (setq type '((* :char) integer))) #+(or cmu sbcl scl) ((eq context :type) - (let ((cmu-type (gethash type *cmu-def-type-hash*))) - (if cmu-type - cmu-type - (basic-convert-from-uffi-type type)))) + (let ((cmu-type (gethash type *cmu-def-type-hash*))) + (if cmu-type + cmu-type + (basic-convert-from-uffi-type type)))) #+lispworks ((and (eq context :return) - (eq type :cstring)) - (basic-convert-from-uffi-type :cstring-returning)) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) #+(and mcl (not openmcl)) ((and (eq type :void) (eq context :return)) nil) (t - (basic-convert-from-uffi-type type))) + (basic-convert-from-uffi-type type))) (let ((sub-type (car type))) (case sub-type - (cl:quote - (convert-from-uffi-type (cadr type) context)) - (:struct-pointer - #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) - #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) - ) - (:struct - #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) - #-mcl (%convert-from-uffi-type (cadr type) :struct) - ) - (t - (cons (%convert-from-uffi-type (first type) context) - (%convert-from-uffi-type (rest type) context))))))) + (cl:quote + (convert-from-uffi-type (cadr type) context)) + (:struct-pointer + #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) + #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) + ) + (:struct + #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) + #-mcl (%convert-from-uffi-type (cadr type) :struct) + ) + (t + (cons (%convert-from-uffi-type (first type) context) + (%convert-from-uffi-type (rest type) context)))))))

#+test

Index: hello-c/strings.lisp diff -u hello-c/strings.lisp:1.1 hello-c/strings.lisp:1.2 --- hello-c/strings.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/strings.lisp Sun Jul 10 23:35:01 2005 @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strings.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;;;; $Id: strings.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ ;;;; ;;;; This file, part of hic, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -68,28 +68,31 @@ (dispose-ptr ,obj)) )

-(defmacro with-cstring ((cstring lisp-string) &body body) +(defmacro with-cstring ((cstring lisp$-form) &body body) #+(or cmu sbcl scl lispworks) - `(let ((,cstring ,lisp-string)) ,@body) + `(let ((,cstring ,lisp$-form)) ,@body) #+allegro (let ((acl-native (gensym))) - `(excl:with-native-string (,acl-native ,lisp-string) - (let ((,cstring (if ,lisp-string ,acl-native 0))) - ,@body))) + `(excl:with-native-string (,acl-native ,lisp$-form) + (let ((,cstring ,(if lisp$-form acl-native 0))) + ,@body))) #+mcl - `(if (stringp ,lisp-string) - (ccl:with-cstrs ((,cstring ,lisp-string)) - ,@body) - (let ((,cstring +null-cstring-pointer+)) - ,@body)) - ) + (let ((lisp$ (gensym))) + `(let ((,lisp$ (let ((,lisp$ ,lisp$-form)) + (typecase ,lisp$ + (null +null-cstring-pointer+) + (string ,lisp$) + (t (error "with-cstring asked to handle non-string ~a" ,lisp$)))))) + (ccl:with-cstrs ((,cstring ,lisp$)) + ,@body)))) +

(defmacro with-cstrings (bindings &rest body) (if bindings `(with-cstring ,(car bindings) - (with-cstrings ,(cdr bindings) - ,@body)) - `(progn ,@body))) + (with-cstrings ,(cdr bindings) + ,@body)) + `(progn ,@body)))

;;; Foreign string functions