- changed foreign accessors and mutator names to have '-c-' in their

names as suggested by Ken Dickey.
This commit is contained in:
Abdulaziz Ghuloum 2008-10-12 02:06:25 -04:00
parent 811c94361b
commit 1be0f2af6e
12 changed files with 246 additions and 222 deletions

View File

@ -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

View File

@ -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.

Binary file not shown.

View File

@ -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
#<pointer #x9006CB1F>
> (define libc-atan
((make-callout 'double '(double)) libc-atan-ptr))
((make-c-callout 'double '(double)) libc-atan-ptr))
> libc-atan
#<procedure>
> (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"

View File

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

View File

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

View File

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

View File

@ -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)])

View File

@ -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))])

View File

@ -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

View File

@ -1 +1 @@
1622
1623

View File

@ -1464,26 +1464,26 @@
[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]
[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]
))