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
