From 6f682746787779a2475eec53d7d46efab891b392 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 15 Apr 2004 10:43:01 +0000 Subject: [PATCH] r9012: add make-pointer and pointer-address --- ChangeLog | 6 +++++- debian/changelog | 6 ++++++ src/functions.lisp | 5 ----- src/objects.lisp | 16 ++++++++++++++++ src/package.lisp | 2 ++ src/primitives.lisp | 12 +++++++++--- src/strings.lisp | 22 ++++++++++++++-------- 7 files changed, 52 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4c50f90..4c0ea2e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ +2004-04-15 Kevin Rosenberg (kevin@rosenberg.net) + * src/objects.lisp: Add new functions: + MAKE-POINTER and POINTER-ADDRESS + 2004-04-13 Kevin Rosenberg (kevin@rosenberg.net) - * str/string.lisp: Add new FOREIGN-STRING-LENGTH + * src/string.lisp: Add new FOREIGN-STRING-LENGTH 2003-08-15 Kevin Rosenberg (kevin@rosenberg.net) * Added with-cast-pointer and def-foreign-var (patches submitted diff --git a/debian/changelog b/debian/changelog index 4edda68..2994cb6 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (1.4.10-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Thu, 15 Apr 2004 01:59:37 -0600 + cl-uffi (1.4.9-1) unstable; urgency=low * New upstream diff --git a/src/functions.lisp b/src/functions.lisp index 7f0939d..1b6b325 100644 --- a/src/functions.lisp +++ b/src/functions.lisp @@ -117,10 +117,5 @@ )) -(defun make-lisp-name (name) - (let ((converted (substitute #\- #\_ name))) - (intern - #+case-sensitive converted - #-case-sensitive (string-upcase converted)))) diff --git a/src/objects.lisp b/src/objects.lisp index dc382f5..82a9d0e 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -92,6 +92,22 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+mcl `(ccl:%null-ptr) ) +(defmacro make-pointer (addr type) + #+(or allegro mcl) (declare (ignore type)) + #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) + #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) + #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type))) + #+allegro addr + #+mcl `(ccl:%int-to-ptr addr) + ) + +(defmacro pointer-address (ptr) + #+allegro ptr + #+(or cmu scl) `(system:sap-int (alien:alien-sap ,ptr)) + #+sbcl `(sb-sys:sap-int (sb-alien:alien-sap ,ptr)) + #+lispworks `(fli:pointer-address ,ptr) + #+mcl `(ccl:%ptr-to-int ,ptr)) + (defmacro char-array-to-pointer (obj) #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8))) #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8))) diff --git a/src/package.lisp b/src/package.lisp index 05f7e4f..4744635 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -47,6 +47,8 @@ #:ensure-char-integer #:null-pointer-p #:make-null-pointer + #:make-pointer + #:pointer-address #:+null-cstring-pointer+ #:char-array-to-pointer #:with-cast-pointer diff --git a/src/primitives.lisp b/src/primitives.lisp index 007355c..c430894 100644 --- a/src/primitives.lisp +++ b/src/primitives.lisp @@ -87,9 +87,6 @@ supports takes advantage of this optimization." (make-hash-table :size 20 :test #'eq)) ) -#+(or cmu sbcl scl) -(defvar *cmu-sbcl-def-type-list* nil) - #+(or cmu scl) (defvar *cmu-sbcl-def-type-list* '((:char . (alien:signed 8)) @@ -104,8 +101,10 @@ supports takes advantage of this optimization." (:unsigned-long . (alien:unsigned 32)) (:float . alien:single-float) (:double . alien:double-float) + (:void . t) ) "Conversions in CMUCL for def-foreign-type are different than in def-function") + #+sbcl (defvar *cmu-sbcl-def-type-list* '((:char . (sb-alien:signed 8)) @@ -120,6 +119,7 @@ supports takes advantage of this optimization." (:unsigned-long . (sb-alien:unsigned 32)) (:float . sb-alien:single-float) (:double . sb-alien:double-float) + (:void . t) ) "Conversions in SBCL for def-foreign-type are different than in def-function") @@ -286,3 +286,9 @@ supports takes advantage of this optimization." ((and (eq (car result) :pointer) (eq context :allocation) :pointer)) (t result)))) + +(defun make-lisp-name (name) + (let ((converted (substitute #\- #\_ name))) + (intern + #+case-sensitive converted + #-case-sensitive (string-upcase converted)))) diff --git a/src/strings.lisp b/src/strings.lisp index 4671925..6e7292c 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -193,20 +193,26 @@ that LW/CMU automatically converts strings from c-calls." (defmacro allocate-foreign-string (size &key (unsigned t)) - #+(or cmu scl) + #+ignore (let ((array-def (gensym))) `(let ((,array-def (list 'alien:array 'c-call:char ,size))) (eval `(alien:cast (alien:make-alien ,,array-def) ,(if ,unsigned '(* (alien:unsigned 8)) '(* (alien:signed 8))))))) + + #+(or cmu scl) + `(alien:make-alien ,(if unsigned + '(alien:unsigned 8) + '(alien:signed 8)) + ,size) + #+sbcl - (let ((array-def (gensym))) - `(let ((,array-def (list 'sb-alien:array 'char ,size))) - (eval `(sb-alien:cast (sb-alien:make-alien ,,array-def) - ,(if ,unsigned - '(* (sb-alien:unsigned 8)) - '(* (sb-alien:signed 8))))))) + `(sb-alien:make-alien ,(if unsigned + '(sb-alien:unsigned 8) + '(sb-alien:signed 8)) + ,size) + #+lispworks `(fli:allocate-foreign-object :type ,(if unsigned @@ -227,7 +233,7 @@ that LW/CMU automatically converts strings from c-calls." #+allegro `(ff:foreign-strlen ,foreign-string) #-allegro `(loop with size = 0 - until (char= (deref-array ,ptr '(:array :unsigned-char) size) #\Null) + until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null) do (incf size) finally return size)) -- 2.34.1