diff --git a/doc/Makefile.am b/doc/Makefile.am index 739346d..4669e0e 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -18,5 +18,8 @@ all: docs: ikarus-scheme-users-guide.pdf +fast: + $(TEX) ikarus-scheme-users-guide + clean: rm -f *.aux *.log *.toc *.out *.idx *.ind *.ilg *.blg *.bbl diff --git a/doc/Makefile.in b/doc/Makefile.in index 73d9d60..0bd0110 100644 --- a/doc/Makefile.in +++ b/doc/Makefile.in @@ -352,6 +352,9 @@ all: docs: ikarus-scheme-users-guide.pdf +fast: + $(TEX) ikarus-scheme-users-guide + clean: rm -f *.aux *.log *.toc *.out *.idx *.ind *.ilg *.blg *.bbl # Tell versions [3.59,3.63) of GNU make to not export all variables. diff --git a/doc/ikarus-scheme-users-guide.pdf b/doc/ikarus-scheme-users-guide.pdf index 74979cc..514fa24 100644 Binary files a/doc/ikarus-scheme-users-guide.pdf and b/doc/ikarus-scheme-users-guide.pdf differ diff --git a/doc/ikarus-scheme-users-guide.tex b/doc/ikarus-scheme-users-guide.tex index 26f9034..85e68bf 100644 --- a/doc/ikarus-scheme-users-guide.tex +++ b/doc/ikarus-scheme-users-guide.tex @@ -2242,10 +2242,10 @@ unspecified.} \newpage -\defun{pointer-set-char}{procedure} -\texttt{(pointer-set-char p i n)} +\defun{pointer-set-c-char!}{procedure} +\texttt{(pointer-set-c-char! p i n)} -The procedure \texttt{pointer-set-char} sets a single byte of memory +The procedure \texttt{pointer-set-c-char!} sets a single byte of memory located at offset \texttt{i} from the pointer \texttt{p} to the value of \texttt{n}. The pointer \texttt{p} must be a valid pointer. The index \texttt{i} must be an exact integer. The value @@ -2253,186 +2253,186 @@ of \texttt{n} must be an exact integer. Only the 8 lowermost bits of \texttt{n} are used in the operation and the remaining bits are ignored. -\defun{pointer-set-short}{procedure} -\texttt{(pointer-set-short p i n)} +\defun{pointer-set-c-short!}{procedure} +\texttt{(pointer-set-c-short! p i n)} -The procedure \texttt{pointer-set-char} sets two bytes located at +The procedure \texttt{pointer-set-c-char!!} sets two bytes located at offset \texttt{i} and \texttt{(+ i 1)} to the 16 lowermost bits of the exact integer \texttt{n}. Note that the offset \texttt{i} is a -byte offset; \texttt{pointer-set-short} does not perform any pointer +byte offset; \texttt{pointer-set-c-short!} does not perform any pointer arithmetic such as scaling the offset by the size of the memory location. -\defun{pointer-set-int}{procedure} -\texttt{(pointer-set-int p i n)} +\defun{pointer-set-c-int!}{procedure} +\texttt{(pointer-set-c-int! p i n)} -The procedure \texttt{pointer-set-int} sets four bytes located at +The procedure \texttt{pointer-set-c-int!} sets four bytes located at offset \texttt{i} to \texttt{(+ i 3)} to the 32 lowermost bits of -the exact integer \texttt{n}. Like \texttt{pointer-set-short}, -\texttt{pointer-set-int} does not scale the offset \texttt{i}. +the exact integer \texttt{n}. Like \texttt{pointer-set-c-short!}, +\texttt{pointer-set-c-int!} does not scale the offset \texttt{i}. -\defun{pointer-set-long}{procedure} -\texttt{(pointer-set-long p i n)} +\defun{pointer-set-c-long!}{procedure} +\texttt{(pointer-set-c-long! p i n)} -On 64-bit systems, the procedure \texttt{pointer-set-long} sets +On 64-bit systems, the procedure \texttt{pointer-set-c-long!} sets eight bytes located at offset \texttt{i} to \texttt{(+ i 7)} to the 64 lowermost bits of the exact integer \texttt{n}. Like the -previous procedures, \texttt{pointer-set-long} does not scale the -offset \texttt{i}. On 32-bit systems, \texttt{pointer-set-long} -performs the same task as \texttt{pointer-set-int}. +previous procedures, \texttt{pointer-set-c-long!} does not scale the +offset \texttt{i}. On 32-bit systems, \texttt{pointer-set-c-long!} +performs the same task as \texttt{pointer-set-c-int!}. -\defun{pointer-set-float}{procedure} -\texttt{(pointer-set-float p i fl)} +\defun{pointer-set-c-float!}{procedure} +\texttt{(pointer-set-c-float! p i fl)} -The procedure \texttt{pointer-set-float} converts the Scheme +The procedure \texttt{pointer-set-c-float!} converts the Scheme floating point number \texttt{fl} (represented in Ikarus as an IEEE-754 double precision floating point number) to a float (an IEEE-754 single precision floating point number) and stores the result in the four bytes at offset \texttt{i} of the pointer \texttt{p}. -\defun{pointer-set-double}{procedure} -\texttt{(pointer-set-double p i fl)} +\defun{pointer-set-c-double!}{procedure} +\texttt{(pointer-set-c-double! p i fl)} -The procedure \texttt{pointer-set-double} stores the double +The procedure \texttt{pointer-set-c-double!} stores the double precision IEEE-754 floating point value of the Scheme flonum \texttt{fl} in the eight bytes at offset \texttt{i} of the pointer \texttt{p}. -\defun{pointer-set-pointer}{procedure} -\texttt{(pointer-set-pointer p i pv)} +\defun{pointer-set-c-pointer!}{procedure} +\texttt{(pointer-set-c-pointer! p i pv)} -On 64-bit systems, the procedure \texttt{pointer-set-pointer} sets +On 64-bit systems, the procedure \texttt{pointer-set-c-pointer!} sets eight bytes located at offset \texttt{i} to \texttt{(+ i 7)} to the 64-bit pointer value of \texttt{pv}. On 32-bit systems, the -procedure \texttt{pointer-set-pointer} sets four bytes located at +procedure \texttt{pointer-set-c-pointer!} sets four bytes located at offset \texttt{i} to \texttt{(+ i 3)} to the 32-bit pointer value of \texttt{pv}. Like the previous procedures, -\texttt{pointer-set-pointer} does not scale the offset \texttt{i}. +\texttt{pointer-set-c-pointer!} does not scale the offset \texttt{i}. -\defun{pointer-ref-signed-char}{procedure} -\texttt{(pointer-ref-signed-char p i)} +\defun{pointer-ref-c-signed-char}{procedure} +\texttt{(pointer-ref-c-signed-char p i)} -The procedure \texttt{pointer-ref-signed-char} loads a single byte located +The procedure \texttt{pointer-ref-c-signed-char} loads a single byte located at offset \texttt{i} from the pointer \texttt{p} and returns an exact integer representing the sign-extended integer value of that byte. The resulting value is in the range of $[-128, 127]$ inclusive. -\defun{pointer-ref-unsigned-char}{procedure} -\texttt{(pointer-ref-unsigned-char p i)} +\defun{pointer-ref-c-unsigned-char}{procedure} +\texttt{(pointer-ref-c-unsigned-char p i)} -The procedure \texttt{pointer-ref-unsigned-char} loads a single byte +The procedure \texttt{pointer-ref-c-unsigned-char} loads a single byte located at offset \texttt{i} from the pointer \texttt{p} and returns an exact integer representing the unsigned integer value of that byte. The resulting value is in the range $[0, 255]$ inclusive. The following example shows the difference between -\texttt{pointer-ref-signed-char} and -\texttt{pointer-ref-unsigned-char}. +\texttt{pointer-ref-c-signed-char} and +\texttt{pointer-ref-c-unsigned-char}. \begin{verbatim} > (let ([p (malloc 3)]) - (pointer-set-char p 0 #b01111111) - (pointer-set-char p 1 #b10000000) - (pointer-set-char p 2 #b11111111) + (pointer-set-c-char! p 0 #b01111111) + (pointer-set-c-char! p 1 #b10000000) + (pointer-set-c-char! p 2 #b11111111) (let ([result - (list (pointer-ref-signed-char p 0) - (pointer-ref-signed-char p 1) - (pointer-ref-signed-char p 2) - (pointer-ref-unsigned-char p 0) - (pointer-ref-unsigned-char p 1) - (pointer-ref-unsigned-char p 2))]) + (list (pointer-ref-c-signed-char p 0) + (pointer-ref-c-signed-char p 1) + (pointer-ref-c-signed-char p 2) + (pointer-ref-c-unsigned-char p 0) + (pointer-ref-c-unsigned-char p 1) + (pointer-ref-c-unsigned-char p 2))]) (free p) result)) (127 -128 -1 127 128 255) \end{verbatim} -\defun{pointer-ref-signed-short}{procedure} -\texttt{(pointer-ref-signed-short p i)} +\defun{pointer-ref-c-signed-short}{procedure} +\texttt{(pointer-ref-c-signed-short p i)} -The procedure \texttt{pointer-ref-signed-short} loads two bytes +The procedure \texttt{pointer-ref-c-signed-short} loads two bytes located at offsets \texttt{i} and \texttt{(+ i 1)} from the pointer \texttt{p} and returns an exact integer representing the sign-extended integer value of the sequence. The resulting value is in the range $[-32768, 32767]$ inclusive. -\defun{pointer-ref-unsigned-short}{procedure} -\texttt{(pointer-ref-unsigned-short p i)} +\defun{pointer-ref-c-unsigned-short}{procedure} +\texttt{(pointer-ref-c-unsigned-short p i)} -The procedure \texttt{pointer-ref-unsigned-short} loads two bytes +The procedure \texttt{pointer-ref-c-unsigned-short} loads two bytes located at offsets \texttt{i} and \texttt{(+ i 1)} from the pointer \texttt{p} and returns an exact integer representing the unsigned integer value of the sequence. The resulting value is in the range $[0, 65535]$ inclusive. \newpage -\defun{pointer-ref-signed-int}{procedure} -\texttt{(pointer-ref-signed-int p i)} +\defun{pointer-ref-c-signed-int}{procedure} +\texttt{(pointer-ref-c-signed-int p i)} -The procedure \texttt{pointer-ref-signed-int} loads four bytes +The procedure \texttt{pointer-ref-c-signed-int} loads four bytes starting at offset \texttt{i} of pointer \texttt{p} and returns an exact integer in the range of $[-2^{31},2^{31}-1]$ inclusive. -\defun{pointer-ref-unsigned-int}{procedure} -\texttt{(pointer-ref-unsigned-int p i)} +\defun{pointer-ref-c-unsigned-int}{procedure} +\texttt{(pointer-ref-c-unsigned-int p i)} -The procedure \texttt{pointer-ref-unsigned-int} loads four bytes +The procedure \texttt{pointer-ref-c-unsigned-int} loads four bytes starting at offset \texttt{i} of pointer \texttt{p} and returns an exact integer in the range of $[0,2^{32}-1]$ inclusive. -\defun{pointer-ref-signed-long}{procedure} -\texttt{(pointer-ref-signed-long p i)} +\defun{pointer-ref-c-signed-long}{procedure} +\texttt{(pointer-ref-c-signed-long p i)} -On 64-bit systems, the procedure \texttt{pointer-ref-signed-long} +On 64-bit systems, the procedure \texttt{pointer-ref-c-signed-long} loads eight bytes starting at offset \texttt{i} of pointer \texttt{p} and returns an integer in the range of $[-2^{63},2^{63}-1]$ inclusive. On 32-bit systems, the procedure -\texttt{pointer-ref-signed-long} performs the same task as -\texttt{pointer-ref-signed-int}. +\texttt{pointer-ref-c-signed-long} performs the same task as +\texttt{pointer-ref-c-signed-int}. -\defun{pointer-ref-unsigned-long}{procedure} -\texttt{(pointer-ref-unsigned-long p i)} +\defun{pointer-ref-c-unsigned-long}{procedure} +\texttt{(pointer-ref-c-unsigned-long p i)} -On 64-bit systems, the procedure \texttt{pointer-ref-unsigned-long} +On 64-bit systems, the procedure \texttt{pointer-ref-c-unsigned-long} loads eight bytes starting at offset \texttt{i} of pointer \texttt{p} and returns an integer in the range of $[0,2^{64}-1]$ inclusive. On 32-bit systems, the procedure -\texttt{pointer-ref-unsigned-long} performs the same task as -\texttt{pointer-ref-unsigned-int}. +\texttt{pointer-ref-c-unsigned-long} performs the same task as +\texttt{pointer-ref-c-unsigned-int}. -\defun{pointer-ref-float}{procedure} -\texttt{(pointer-ref-float p i)} +\defun{pointer-ref-c-float}{procedure} +\texttt{(pointer-ref-c-float p i)} -The procedure \texttt{pointer-ref-float} returns the four-byte +The procedure \texttt{pointer-ref-c-float} returns the four-byte float (represented as IEEE-754 single precision floating point number) stored at offset \texttt{i} of the pointer \texttt{p}. The value is extended to an IEEE-754 double precision floating point number that Ikarus uses to represent inexact numbers. -\defun{pointer-ref-double}{procedure} -\texttt{(pointer-ref-double p i)} +\defun{pointer-ref-c-double}{procedure} +\texttt{(pointer-ref-c-double p i)} -The procedure \texttt{pointer-ref-double} returns the eight-byte +The procedure \texttt{pointer-ref-c-double} returns the eight-byte float (represented as IEEE-754 double precision floating point number) stored at offset \texttt{i} of the pointer \texttt{p}. -\defun{pointer-ref-pointer}{procedure} -\texttt{(pointer-ref-pointer p i)} +\defun{pointer-ref-c-pointer}{procedure} +\texttt{(pointer-ref-c-pointer p i)} -The procedure \texttt{pointer-ref-pointer} returns the pointer +The procedure \texttt{pointer-ref-c-pointer} returns the pointer stored at offset \texttt{i} from the pointer \texttt{p}. The size of the pointer (also the number of bytes loaded) depends on the architecture: it is 4 bytes on 32-bit systems and 8 bytes on 64-bit @@ -2567,12 +2567,12 @@ parameter type. -\defun{make-callout}{procedure} -\texttt{((make-callout return-type parameter-types) native-pointer)} +\defun{make-c-callout}{procedure} +\texttt{((make-c-callout return-type parameter-types) native-pointer)} -The procedure \texttt{make-callout} is the primary facility for +The procedure \texttt{make-c-callout} is the primary facility for making foreign procedures callable from Scheme. It works as -follows. First, \texttt{make-callout} receives two arguments +follows. First, \texttt{make-c-callout} receives two arguments denoting the signature of the procedure to be called. It prepares a bridge that converts from Scheme's calling conventions and data structures to their foreign counterparts. It returns a procedure @@ -2589,10 +2589,10 @@ types, calls the foreign procedure, obtains the result, and converts it to the appropriate Scheme value (depending on the \texttt{return-type}). -The interface of \texttt{make-callout} is broken down into three +The interface of \texttt{make-c-callout} is broken down into three stages in order to accomodate common usage patterns. Often types, a function signature can be used by many foreign procedures and -therefore, \texttt{make-callout} can be called once per signature +therefore, \texttt{make-c-callout} can be called once per signature and each signature can be used multiple times. Similarly, separating the foreign procedure preparation from parameter passing allows for preparing the foreign procedure once and calling it many @@ -2655,14 +2655,14 @@ specifier to mean ``no useful value is returned''.} The following example illustrates the use of the -\texttt{make-callout} procedure in combination with \texttt{dlopen} +\texttt{make-c-callout} procedure in combination with \texttt{dlopen} and \texttt{dlsym}. The session was run on a 32-bit Ikarus running under Mac OS X 10.4. First, the \texttt{libc.dylib} foreign library is loaded and is bound to the variable \texttt{libc}. Next, we obtain a pointer to the \texttt{atan} foreign procedure that is defined in \texttt{libc}. The native procedure \texttt{atan} takes a \texttt{double} as an argument and returns a \texttt{double} and -that's the signature that we use for \texttt{make-callout}. +that's the signature that we use for \texttt{make-c-callout}. Finally, we call the foreign procedure interface with one argument, \texttt{1.0}, which is a flonum and thus matches the required parameter type. The native procedure returns a \texttt{double} @@ -2678,7 +2678,7 @@ value which is converted to the Scheme flonum with value > libc-atan-ptr # > (define libc-atan - ((make-callout 'double '(double)) libc-atan-ptr)) + ((make-c-callout 'double '(double)) libc-atan-ptr)) > libc-atan # > (libc-atan 1.0) @@ -2713,14 +2713,14 @@ Figure~\ref{fig:foreign-types} on page~\pageref{fig:foreign-types} for details). -\defun{make-callback}{procedure} -\texttt{((make-callback return-type parameter-types) scheme-procedure)} +\defun{make-c-callback}{procedure} +\texttt{((make-c-callback return-type parameter-types) scheme-procedure)} -The procedure \texttt{make-callback} is similar to the procedure -\texttt{make-callout} except that it provides a bridge from native +The procedure \texttt{make-c-callback} is similar to the procedure +\texttt{make-c-callout} except that it provides a bridge from native procedures back into Scheme. While the procedure -\texttt{make-callout} takes a native pointer and returns a Scheme -procedure, \texttt{make-callback} takes a Scheme procedure and +\texttt{make-c-callout} takes a native pointer and returns a Scheme +procedure, \texttt{make-c-callback} takes a Scheme procedure and returns a native pointer. The native pointer can be called by foreign procedures. The native parameters are converted to Scheme data (according to \texttt{parameter-types}), the Scheme procedure @@ -2730,18 +2730,18 @@ control returns to the native call site. Note that the native procedure pointer obtained from -\texttt{make-callback} is indistinguishable from other native +\texttt{make-c-callback} is indistinguishable from other native procedures that are obtained using \texttt{dlsym} or similar means. -In particular, such native pointers can be used as arguments to -\texttt{make-callout} resulting in a Scheme procedure that calls out +In particular, such native pointers can be passed to +\texttt{make-c-callout} resulting in a Scheme procedure that calls out to the native procedure that in turn calls back into Scheme. The following segment illustrates a very inefficient way of extracting the lowermost 32 bits from an exact integer. \begin{verbatim} > (format "~x" - (((make-callout 'unsigned-int '(unsigned-int)) - ((make-callback 'unsigned-int '(unsigned-int)) + (((make-c-callout 'unsigned-int '(unsigned-int)) + ((make-c-callback 'unsigned-int '(unsigned-int)) values)) #xfedcba09876543210fedcba09876543210)) "76543210" diff --git a/lab/test-ffi.ss b/lab/test-ffi.ss index 7d4684c..652a56e 100644 --- a/lab/test-ffi.ss +++ b/lab/test-ffi.ss @@ -20,22 +20,22 @@ (define hosym (dlsym self "ho")) (define ho - ((make-callout 'signed-int '(pointer signed-int)) hosym)) + ((make-c-callout 'signed-int '(pointer signed-int)) hosym)) (define traced-foradd1 - ((make-callback 'signed-int '(signed-int)) + ((make-c-callback 'signed-int '(signed-int)) (trace-lambda add1 (n) (collect) (add1 n)))) (define foradd1 - ((make-callback 'signed-int '(signed-int)) + ((make-c-callback 'signed-int '(signed-int)) (lambda (n) (collect) (add1 n)))) (define foradd1-by-foreign-call - ((make-callback 'signed-int '(signed-int)) + ((make-c-callback 'signed-int '(signed-int)) (trace-lambda foradd1-by-foreign-call (n) (/ (ho traced-foradd1 n) 2)))) @@ -46,11 +46,11 @@ (define test_I_I - ((make-callout 'signed-int '(pointer signed-int)) (dlsym self "test_I_I"))) + ((make-c-callout 'signed-int '(pointer signed-int)) (dlsym self "test_I_I"))) (define test_I_II - ((make-callout 'signed-int '(pointer signed-int signed-int)) (dlsym self "test_I_II"))) + ((make-c-callout 'signed-int '(pointer signed-int signed-int)) (dlsym self "test_I_II"))) (define test_I_III - ((make-callout 'signed-int '(pointer signed-int signed-int signed-int)) (dlsym self "test_I_III"))) + ((make-c-callout 'signed-int '(pointer signed-int signed-int signed-int)) (dlsym self "test_I_III"))) (define C_add_I_I (dlsym self "add_I_I")) (define C_add_I_II (dlsym self "add_I_II")) @@ -60,10 +60,10 @@ (check = (test_I_II C_add_I_II 12 13) (+ 12 13)) (check = (test_I_III C_add_I_III 12 13 14) (+ 12 13 14)) -(define S_add_I_I ((make-callback 'signed-int '(signed-int)) +)) -(define S_add_I_II ((make-callback 'signed-int '(signed-int +(define S_add_I_I ((make-c-callback 'signed-int '(signed-int)) +)) +(define S_add_I_II ((make-c-callback 'signed-int '(signed-int signed-int)) +)) -(define S_add_I_III ((make-callback 'signed-int '(signed-int +(define S_add_I_III ((make-c-callback 'signed-int '(signed-int signed-int signed-int)) +)) @@ -73,11 +73,11 @@ (define test_D_D - ((make-callout 'double '(pointer double)) (dlsym self "test_D_D"))) + ((make-c-callout 'double '(pointer double)) (dlsym self "test_D_D"))) (define test_D_DD - ((make-callout 'double '(pointer double double)) (dlsym self "test_D_DD"))) + ((make-c-callout 'double '(pointer double double)) (dlsym self "test_D_DD"))) (define test_D_DDD - ((make-callout 'double '(pointer double double double)) (dlsym self "test_D_DDD"))) + ((make-c-callout 'double '(pointer double double double)) (dlsym self "test_D_DDD"))) (define C_add_D_D (dlsym self "add_D_D")) (define C_add_D_DD (dlsym self "add_D_DD")) @@ -87,9 +87,9 @@ (check = (test_D_DD C_add_D_DD 12.0 13.0) (+ 12.0 13.0)) (check = (test_D_DDD C_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0)) -(define S_add_D_D ((make-callback 'double '(double)) +)) -(define S_add_D_DD ((make-callback 'double '(double double)) +)) -(define S_add_D_DDD ((make-callback 'double '(double double double)) +)) +(define S_add_D_D ((make-c-callback 'double '(double)) +)) +(define S_add_D_DD ((make-c-callback 'double '(double double)) +)) +(define S_add_D_DDD ((make-c-callback 'double '(double double double)) +)) (check = (test_D_D S_add_D_D 12.0) (+ 12.0)) (check = (test_D_DD S_add_D_DD 12.0 13.0) (+ 12.0 13.0)) @@ -97,7 +97,7 @@ (define RectArea - ((make-callout 'float '(#(#(float float) #(float float)))) + ((make-c-callout 'float '(#(#(float float) #(float float)))) (dlsym self "test_area_F_R"))) (check = (RectArea '#(#(0.0 0.0) #(10.0 10.0))) 100.0) diff --git a/lib/Cocoa/helpers.ss b/lib/Cocoa/helpers.ss index 59f7399..0432ad0 100644 --- a/lib/Cocoa/helpers.ss +++ b/lib/Cocoa/helpers.ss @@ -6,13 +6,13 @@ (define kProcessTransformToForegroundApplication 1) (define self (dlopen)) (define get-current-process - ((make-callout 'void '(pointer)) + ((make-c-callout 'void '(pointer)) (dlsym self "GetCurrentProcess"))) (define transform-process-type - ((make-callout 'void '(pointer signed-int)) + ((make-c-callout 'void '(pointer signed-int)) (dlsym self "TransformProcessType"))) (define set-front-process - ((make-callout 'void '(pointer)) + ((make-c-callout 'void '(pointer)) (dlsym self "SetFrontProcess"))) (let ([p (malloc 16)]) (get-current-process p) diff --git a/lib/ikarus/foreign.ss b/lib/ikarus/foreign.ss index d536b5d..bfd7ba0 100644 --- a/lib/ikarus/foreign.ss +++ b/lib/ikarus/foreign.ss @@ -1,17 +1,29 @@ (library (ikarus foreign) - (export malloc free pointer-set-char pointer-set-short - pointer-set-int pointer-set-long pointer-set-pointer - pointer-set-float pointer-set-double - pointer-ref-signed-char pointer-ref-signed-short - pointer-ref-signed-int pointer-ref-signed-long - pointer-ref-unsigned-char pointer-ref-unsigned-short - pointer-ref-unsigned-int pointer-ref-unsigned-long - pointer-ref-pointer pointer-ref-float pointer-ref-double + (export + pointer-set-c-char! + pointer-set-c-short! + pointer-set-c-int! + pointer-set-c-long! + pointer-set-c-pointer! + pointer-set-c-float! + pointer-set-c-double! + pointer-ref-c-signed-char + pointer-ref-c-signed-short + pointer-ref-c-signed-int + pointer-ref-c-signed-long + pointer-ref-c-unsigned-char + pointer-ref-c-unsigned-short + pointer-ref-c-unsigned-int + pointer-ref-c-unsigned-long + pointer-ref-c-pointer + pointer-ref-c-float + pointer-ref-c-double + malloc free pointer->integer integer->pointer pointer? dlopen dlsym dlclose dlerror - make-callout make-callback) + make-c-callout make-c-callback) (import (ikarus system $foreign))) diff --git a/lib/objc.ss b/lib/objc.ss index 5e92127..2925337 100644 --- a/lib/objc.ss +++ b/lib/objc.ss @@ -61,7 +61,7 @@ (define (pointer-ref addr offset) (assert (pointer? addr)) - (integer->pointer (pointer-ref-signed-long addr offset))) + (pointer-ref-c-pointer addr offset)) (define (offset? x) (or (fixnum? x) (bignum? x))) @@ -70,12 +70,12 @@ (check who pointer? addr) (check who pointer? val) (check who offset? offset) - (pointer-set-long addr offset (pointer->integer val))) + (pointer-set-c-pointer! addr offset val)) (define (char*len x) (let f ([i 0]) (cond - [(zero? (pointer-ref-unsigned-char x i)) i] + [(zero? (pointer-ref-c-unsigned-char x i)) i] [else (f (+ i 1))]))) (define (char*->bv x) @@ -85,18 +85,18 @@ (cond [(= i n) bv] [else - (bytevector-u8-set! bv i (pointer-ref-unsigned-char x i)) + (bytevector-u8-set! bv i (pointer-ref-c-unsigned-char x i)) (f (+ i 1))]))))) (define (bv->char* x) (let ([n (bytevector-length x)]) (let ([p (malloc (+ n 1))]) - (pointer-set-char p n 0) + (pointer-set-c-char! p n 0) (let f ([i 0]) (cond [(= i n) p] [else - (pointer-set-char p i (bytevector-s8-ref x i)) + (pointer-set-c-char! p i (bytevector-s8-ref x i)) (f (+ i 1))]))))) (define (bv->u8* x) @@ -108,7 +108,7 @@ (cond [(= i n) p] [else - (pointer-set-char p i (bytevector-s8-ref x i)) + (pointer-set-c-char! p i (bytevector-s8-ref x i)) (f (+ i 1))])))))) (define (char*->string x) @@ -183,7 +183,7 @@ (define (class-instance-size x) (check 'class-instance-size class? x) - (pointer-ref-signed-long (class-ptr x) objc-class-instance-size-offset)) + (pointer-ref-c-signed-long (class-ptr x) objc-class-instance-size-offset)) (define (ivar-name x) (check 'ivar-name ivar? x) @@ -195,14 +195,14 @@ (define (ivar-offset x) (check 'ivar-offset ivar? x) - (pointer-ref-signed-int (ivar-ptr x) (* 2 ptrsize))) + (pointer-ref-c-signed-int (ivar-ptr x) (* 2 ptrsize))) (define (class-ivars x) (check 'class-ivars class? x) (let ([p (pointer-ref (class-ptr x) objc-class-ivars-offset)]) (if (nil? p) '() - (let ([n (pointer-ref-signed-long p 0)]) + (let ([n (pointer-ref-c-signed-long p 0)]) (let f ([i 0] [off objc-ivarlist-ivars-offset]) (if (= i n) '() @@ -223,7 +223,7 @@ [class (malloc objc-class-struct-size)] [meta (malloc objc-class-struct-size)]) ;;; init meta class - (pointer-set-long meta objc-class-info-offset CLS_META) + (pointer-set-c-long! meta objc-class-info-offset CLS_META) (pointer-set meta objc-class-name-offset (string->char* name)) (pointer-set meta objc-class-methodlists-offset (malloc objc-methodlist-methods-offset)) @@ -232,14 +232,14 @@ (pointer-set meta objc-class-isa-offset (pointer-ref (class-ptr root-class) objc-class-isa-offset)) ;;; init class - (pointer-set-long class objc-class-info-offset CLS_CLASS) + (pointer-set-c-long! class objc-class-info-offset CLS_CLASS) (pointer-set class objc-class-name-offset (string->char* name)) (pointer-set class objc-class-methodlists-offset (malloc objc-methodlist-methods-offset)) (pointer-set class objc-class-superclass-offset (class-ptr super-class)) (pointer-set class objc-class-ivars-offset ivars-ptr) - (pointer-set-long class objc-class-instance-size-offset instance-size) + (pointer-set-c-long! class objc-class-instance-size-offset instance-size) ;;; wire up (pointer-set class objc-class-isa-offset meta) (when intern? (objc_addClass class)) @@ -251,7 +251,7 @@ (check who procedure? proc) (let ([type (make-objc-type (cons rtype argtypes))]) (let ([callback - (make-callback + (make-c-callback (objc-type->ikarus-type rtype) (map objc-type->ikarus-type argtypes))]) (let ([imp (callback @@ -260,7 +260,7 @@ (apply proc (map convert-incoming argtypes args)))))]) (let ([p (malloc (+ objc-methodlist-methods-offset objc-method-size))]) - (pointer-set-int p objc-methodlist-count-offset 1) + (pointer-set-c-int! p objc-methodlist-count-offset 1) (pointer-set p (+ objc-methodlist-methods-offset objc-method-sel-offset) (selector-ptr @@ -312,11 +312,11 @@ (cond [(assq what alist) => cadr] [else (error 'class-is? "invalid what" what)])]) - (= mask (bitwise-and mask (pointer-ref-signed-long (class-ptr x) (* ptrsize 4)))))) + (= mask (bitwise-and mask (pointer-ref-c-signed-long (class-ptr x) (* ptrsize 4)))))) (define (class-methods x) (define (methods x) - (let ([n (pointer-ref-signed-int x ptrsize)] + (let ([n (pointer-ref-c-signed-int x ptrsize)] [array (integer->pointer (+ (pointer->integer x) (* 2 ptrsize)))]) (let f ([i 0]) (if (= i n) @@ -330,7 +330,7 @@ (when (class-is? x 'method-array) (error 'class-methods "BUG: not yet for method arrays")) (let ([iterator (malloc ptrsize)]) - (pointer-set-long iterator 0 0) + (pointer-set-c-long! iterator 0 0) (let f () (let ([methodlist (class_nextMethodList (class-ptr x) iterator)]) (cond @@ -354,7 +354,7 @@ (cons (make-class (integer->pointer - (pointer-ref-signed-long buffer (* ptrsize i)))) + (pointer-ref-c-signed-long buffer (* ptrsize i)))) ac))))))))) (define (nil? x) @@ -475,7 +475,7 @@ (define count (length ivars)) (define p (malloc (+ objc-ivarlist-ivars-offset (* count objc-ivar-size)))) - (pointer-set-int p objc-ivarlist-count-offset count) + (pointer-set-c-int! p objc-ivarlist-count-offset count) (let f ([ivars ivars] [poff objc-ivarlist-ivars-offset] [ivaroff (class-instance-size super-class)]) @@ -489,7 +489,7 @@ (string->char* (symbol->string name))) (pointer-set p (+ poff objc-ivar-type-offset) (string->char* ivar-type)) - (pointer-set-int p (+ poff objc-ivar-offset-offset) ivaroff) + (pointer-set-c-int! p (+ poff objc-ivar-offset-offset) ivaroff) (f (cdr ivars) (+ poff objc-ivar-size) (+ ivaroff ivar-size)))))]))) @@ -643,7 +643,7 @@ (let ([rtype (car sig)] [argtypes (cdr sig)]) (unless (= (length args) (length argtypes)) (error 'call-with-sig "incorrect number of args" args argtypes)) - (let ([ffi (make-callout + (let ([ffi (make-c-callout (objc-type->ikarus-type rtype) (map objc-type->ikarus-type argtypes))]) (let ([proc (ffi mptr)]) diff --git a/lib/ypsilon-compat.ikarus.ss b/lib/ypsilon-compat.ikarus.ss index 318f7d8..057b65c 100644 --- a/lib/ypsilon-compat.ikarus.ss +++ b/lib/ypsilon-compat.ikarus.ss @@ -80,7 +80,7 @@ (cond [(= i n) p] [else - (pointer-set-int p (* i 4) (vector-ref x i)) + (pointer-set-c-int! p (* i 4) (vector-ref x i)) (f (+ i 1))]))))] [else (die who "not an int*" x)])) @@ -104,7 +104,7 @@ (cond [(= i n) p] [else - (pointer-set-int p (* i pointer-size) + (pointer-set-c-int! p (* i pointer-size) (pointer->integer (check-char* who (vector-ref x i)))) (f (+ i 1))]))))] [else (die who "not a char**" x)])) @@ -114,12 +114,12 @@ [(bytevector? x) (let ([n (bytevector-length x)]) (let ([p (malloc (+ n 1))]) - (pointer-set-char p n 0) + (pointer-set-c-char! p n 0) (let f ([i 0]) (cond [(= i n) p] [else - (pointer-set-char p i (bytevector-u8-ref x i)) + (pointer-set-c-char! p i (bytevector-u8-ref x i)) (f (+ i 1))]))))] [else (die who "not a byte*" x)])) @@ -139,7 +139,7 @@ [(_ foreign-name val return-type (arg-type* ...)) #'(let ([t val]) (if (procedure? t) - ((make-callback + ((make-c-callback (convert-type return-type) (list (convert-type arg-type*) ...)) t) @@ -187,7 +187,7 @@ (define (strlen x) (let f ([i 0]) (cond - [(= 0 (pointer-ref-unsigned-char x i)) i] + [(= 0 (pointer-ref-c-unsigned-char x i)) i] [else (f (+ i 1))]))) (let ([n (strlen x)]) (let ([s (make-string n)]) @@ -196,7 +196,7 @@ s (begin (string-set! s i - (integer->char (pointer-ref-unsigned-char x i))) + (integer->char (pointer-ref-c-unsigned-char x i))) (f (+ i 1)))))))) (define-syntax convert-return @@ -254,7 +254,7 @@ (with-syntax ([x x] [(t* ...) (generate-temporaries #'(arg-type* ...))]) #'(let ([callout - ((make-callout + ((make-c-callout (convert-type return-type) (list (convert-type arg-type*) ...)) (lookup-shared-object lib 'foreign-name))]) diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index f48f08a..bae3564 100644 --- a/scheme/ikarus.pointers.ss +++ b/scheme/ikarus.pointers.ss @@ -2,19 +2,25 @@ (library (ikarus.pointers) (export pointer? integer->pointer pointer->integer dlopen dlerror dlclose dlsym malloc free - pointer-ref-signed-char - pointer-ref-signed-short - pointer-ref-signed-int - pointer-ref-signed-long - pointer-ref-unsigned-char - pointer-ref-unsigned-short - pointer-ref-unsigned-int - pointer-ref-unsigned-long - pointer-set-char pointer-set-short pointer-set-int pointer-set-long - pointer-set-pointer pointer-ref-pointer - pointer-set-float pointer-ref-float - pointer-set-double pointer-ref-double - make-callout make-callback) + pointer-ref-c-signed-char + pointer-ref-c-signed-short + pointer-ref-c-signed-int + pointer-ref-c-signed-long + pointer-ref-c-unsigned-char + pointer-ref-c-unsigned-short + pointer-ref-c-unsigned-int + pointer-ref-c-unsigned-long + pointer-ref-c-float + pointer-ref-c-double + pointer-ref-c-pointer + pointer-set-c-char! + pointer-set-c-short! + pointer-set-c-int! + pointer-set-c-long! + pointer-set-c-pointer! + pointer-set-c-float! + pointer-set-c-double! + make-c-callout make-c-callback) (import (except (ikarus) pointer? @@ -120,25 +126,25 @@ (define (int? x) (or (fixnum? x) (bignum? x))) - (define-getter pointer-ref-signed-char "ikrt_ref_char") - (define-getter pointer-ref-signed-short "ikrt_ref_short") - (define-getter pointer-ref-signed-int "ikrt_ref_int") - (define-getter pointer-ref-signed-long "ikrt_ref_long") - (define-getter pointer-ref-unsigned-char "ikrt_ref_uchar") - (define-getter pointer-ref-unsigned-short "ikrt_ref_ushort") - (define-getter pointer-ref-unsigned-int "ikrt_ref_uint") - (define-getter pointer-ref-unsigned-long "ikrt_ref_ulong") - (define-getter pointer-ref-float "ikrt_ref_float") - (define-getter pointer-ref-double "ikrt_ref_double") - (define-getter pointer-ref-pointer "ikrt_ref_pointer") + (define-getter pointer-ref-c-signed-char "ikrt_ref_char") + (define-getter pointer-ref-c-signed-short "ikrt_ref_short") + (define-getter pointer-ref-c-signed-int "ikrt_ref_int") + (define-getter pointer-ref-c-signed-long "ikrt_ref_long") + (define-getter pointer-ref-c-unsigned-char "ikrt_ref_uchar") + (define-getter pointer-ref-c-unsigned-short "ikrt_ref_ushort") + (define-getter pointer-ref-c-unsigned-int "ikrt_ref_uint") + (define-getter pointer-ref-c-unsigned-long "ikrt_ref_ulong") + (define-getter pointer-ref-c-float "ikrt_ref_float") + (define-getter pointer-ref-c-double "ikrt_ref_double") + (define-getter pointer-ref-c-pointer "ikrt_ref_pointer") - (define-setter pointer-set-char int? "ikrt_set_char") - (define-setter pointer-set-short int? "ikrt_set_short") - (define-setter pointer-set-int int? "ikrt_set_int") - (define-setter pointer-set-long int? "ikrt_set_long") - (define-setter pointer-set-float flonum? "ikrt_set_float") - (define-setter pointer-set-double flonum? "ikrt_set_double") - (define-setter pointer-set-pointer pointer? "ikrt_set_pointer") + (define-setter pointer-set-c-char! int? "ikrt_set_char") + (define-setter pointer-set-c-short! int? "ikrt_set_short") + (define-setter pointer-set-c-int! int? "ikrt_set_int") + (define-setter pointer-set-c-long! int? "ikrt_set_long") + (define-setter pointer-set-c-float! flonum? "ikrt_set_float") + (define-setter pointer-set-c-double! flonum? "ikrt_set_double") + (define-setter pointer-set-c-pointer! pointer? "ikrt_set_pointer") ;;; libffi interface @@ -202,8 +208,8 @@ argtypes-n rtype-n))) - (define (make-callout rtype argtypes) - (define who 'make-callout) + (define (make-c-callout rtype argtypes) + (define who 'make-c-callout) (let-values ([(cif argtypes-n rtype-n) (ffi-prep-cif rtype argtypes)]) (let* ([argtypes-vec (list->vector argtypes)] @@ -228,11 +234,11 @@ checkers argtypes-vec argsvec) (foreign-call "ikrt_ffi_call" data argsvec))))))) - (define (make-callback rtype argtypes) + (define (make-c-callback rtype argtypes) (let-values ([(cif argtypes-n rtype-n) (ffi-prep-cif rtype argtypes)]) (lambda (proc) - (define who 'make-callback) + (define who 'make-c-callback) (unless (procedure? proc) (die who "not a procedure")) (let ([proc diff --git a/scheme/last-revision b/scheme/last-revision index fed8f61..dd3467d 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1622 +1623 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index c2087f4..a5556c3 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -1455,36 +1455,36 @@ [cp0-effort-limit i] [tag-analysis-output i] [perform-tag-analysis i] - [pointer? $for] - [pointer->integer $for] - [integer->pointer $for] - [dlopen $for] - [dlerror $for] - [dlclose $for] - [dlsym $for] - [malloc $for] - [free $for] - [pointer-ref-signed-char $for] - [pointer-ref-signed-short $for] - [pointer-ref-signed-int $for] - [pointer-ref-signed-long $for] - [pointer-ref-unsigned-char $for] - [pointer-ref-unsigned-short $for] - [pointer-ref-unsigned-int $for] - [pointer-ref-unsigned-long $for] - [pointer-set-char $for] - [pointer-set-short $for] - [pointer-set-int $for] - [pointer-set-long $for] - [pointer-set-pointer $for] - [pointer-ref-pointer $for] - [pointer-set-float $for] - [pointer-ref-float $for] - [pointer-set-double $for] - [pointer-ref-double $for] - [make-callout $for] - [make-callback $for] - [host-info i] + [pointer? $for] + [pointer->integer $for] + [integer->pointer $for] + [dlopen $for] + [dlerror $for] + [dlclose $for] + [dlsym $for] + [malloc $for] + [free $for] + [pointer-ref-c-signed-char $for] + [pointer-ref-c-signed-short $for] + [pointer-ref-c-signed-int $for] + [pointer-ref-c-signed-long $for] + [pointer-ref-c-unsigned-char $for] + [pointer-ref-c-unsigned-short $for] + [pointer-ref-c-unsigned-int $for] + [pointer-ref-c-unsigned-long $for] + [pointer-ref-c-float $for] + [pointer-ref-c-double $for] + [pointer-ref-c-pointer $for] + [pointer-set-c-char! $for] + [pointer-set-c-short! $for] + [pointer-set-c-int! $for] + [pointer-set-c-long! $for] + [pointer-set-c-pointer! $for] + [pointer-set-c-float! $for] + [pointer-set-c-double! $for] + [make-c-callout $for] + [make-c-callback $for] + [host-info i] ))