conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

- 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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
doc/Makefile.am
View File

@ -18,5 +18,8 @@ all:
docs: ikarus-scheme-users-guide.pdf docs: ikarus-scheme-users-guide.pdf
fast:
$(TEX) ikarus-scheme-users-guide
clean: clean:
rm -f *.aux *.log *.toc *.out *.idx *.ind *.ilg *.blg *.bbl rm -f *.aux *.log *.toc *.out *.idx *.ind *.ilg *.blg *.bbl

3
doc/Makefile.in
View File

@ -352,6 +352,9 @@ all:
docs: ikarus-scheme-users-guide.pdf docs: ikarus-scheme-users-guide.pdf
fast:
$(TEX) ikarus-scheme-users-guide
clean: clean:
rm -f *.aux *.log *.toc *.out *.idx *.ind *.ilg *.blg *.bbl 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. # Tell versions [3.59,3.63) of GNU make to not export all variables.

BIN
doc/ikarus-scheme-users-guide.pdf
View File

Binary file not shown.

194
doc/ikarus-scheme-users-guide.tex
View File

@ -2242,10 +2242,10 @@ unspecified.}
\newpage \newpage
\defun{pointer-set-char}{procedure} \defun{pointer-set-c-char!}{procedure}
\texttt{(pointer-set-char p i n)} \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 located at offset \texttt{i} from the pointer \texttt{p} to the
value of \texttt{n}. The pointer \texttt{p} must be a valid value of \texttt{n}. The pointer \texttt{p} must be a valid
pointer. The index \texttt{i} must be an exact integer. The value 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 bits of \texttt{n} are used in the operation and the remaining bits
are ignored. are ignored.
\defun{pointer-set-short}{procedure} \defun{pointer-set-c-short!}{procedure}
\texttt{(pointer-set-short p i n)} \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 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 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 arithmetic such as scaling the offset by the size of the memory
location. location.
\defun{pointer-set-int}{procedure} \defun{pointer-set-c-int!}{procedure}
\texttt{(pointer-set-int p i n)} \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 offset \texttt{i} to \texttt{(+ i 3)} to the 32 lowermost bits of
the exact integer \texttt{n}. Like \texttt{pointer-set-short}, the exact integer \texttt{n}. Like \texttt{pointer-set-c-short!},
\texttt{pointer-set-int} does not scale the offset \texttt{i}. \texttt{pointer-set-c-int!} does not scale the offset \texttt{i}.
\defun{pointer-set-long}{procedure} \defun{pointer-set-c-long!}{procedure}
\texttt{(pointer-set-long p i n)} \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 eight bytes located at offset \texttt{i} to \texttt{(+ i 7)} to the
64 lowermost bits of the exact integer \texttt{n}. Like the 64 lowermost bits of the exact integer \texttt{n}. Like the
previous procedures, \texttt{pointer-set-long} does not scale the previous procedures, \texttt{pointer-set-c-long!} does not scale the
offset \texttt{i}. On 32-bit systems, \texttt{pointer-set-long} offset \texttt{i}. On 32-bit systems, \texttt{pointer-set-c-long!}
performs the same task as \texttt{pointer-set-int}. performs the same task as \texttt{pointer-set-c-int!}.
\defun{pointer-set-float}{procedure} \defun{pointer-set-c-float!}{procedure}
\texttt{(pointer-set-float p i fl)} \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 floating point number \texttt{fl} (represented in Ikarus as an
IEEE-754 double precision floating point number) to a float (an IEEE-754 double precision floating point number) to a float (an
IEEE-754 single precision floating point number) and stores the IEEE-754 single precision floating point number) and stores the
result in the four bytes at offset \texttt{i} of the pointer result in the four bytes at offset \texttt{i} of the pointer
\texttt{p}. \texttt{p}.
\defun{pointer-set-double}{procedure} \defun{pointer-set-c-double!}{procedure}
\texttt{(pointer-set-double p i fl)} \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 precision IEEE-754 floating point value of the Scheme flonum
\texttt{fl} in the eight bytes at offset \texttt{i} of the pointer \texttt{fl} in the eight bytes at offset \texttt{i} of the pointer
\texttt{p}. \texttt{p}.
\defun{pointer-set-pointer}{procedure} \defun{pointer-set-c-pointer!}{procedure}
\texttt{(pointer-set-pointer p i pv)} \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 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 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 offset \texttt{i} to \texttt{(+ i 3)} to the 32-bit pointer value of
\texttt{pv}. Like the previous procedures, \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} \defun{pointer-ref-c-signed-char}{procedure}
\texttt{(pointer-ref-signed-char p i)} \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 at offset \texttt{i} from the pointer \texttt{p} and returns an
exact integer representing the sign-extended integer value of that exact integer representing the sign-extended integer value of that
byte. The resulting value is in the range of $[-128, 127]$ inclusive. byte. The resulting value is in the range of $[-128, 127]$ inclusive.
\defun{pointer-ref-unsigned-char}{procedure} \defun{pointer-ref-c-unsigned-char}{procedure}
\texttt{(pointer-ref-unsigned-char p i)} \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 located at offset \texttt{i} from the pointer \texttt{p} and returns
an exact integer representing the unsigned integer value of that an exact integer representing the unsigned integer value of that
byte. The resulting value is in the range $[0, 255]$ inclusive. byte. The resulting value is in the range $[0, 255]$ inclusive.
The following example shows the difference between The following example shows the difference between
\texttt{pointer-ref-signed-char} and \texttt{pointer-ref-c-signed-char} and
\texttt{pointer-ref-unsigned-char}. \texttt{pointer-ref-c-unsigned-char}.
\begin{verbatim} \begin{verbatim}
> (let ([p (malloc 3)]) > (let ([p (malloc 3)])
(pointer-set-char p 0 #b01111111) (pointer-set-c-char! p 0 #b01111111)
(pointer-set-char p 1 #b10000000) (pointer-set-c-char! p 1 #b10000000)
(pointer-set-char p 2 #b11111111) (pointer-set-c-char! p 2 #b11111111)
(let ([result (let ([result
(list (pointer-ref-signed-char p 0) (list (pointer-ref-c-signed-char p 0)
(pointer-ref-signed-char p 1) (pointer-ref-c-signed-char p 1)
(pointer-ref-signed-char p 2) (pointer-ref-c-signed-char p 2)
(pointer-ref-unsigned-char p 0) (pointer-ref-c-unsigned-char p 0)
(pointer-ref-unsigned-char p 1) (pointer-ref-c-unsigned-char p 1)
(pointer-ref-unsigned-char p 2))]) (pointer-ref-c-unsigned-char p 2))])
(free p) (free p)
result)) result))
(127 -128 -1 127 128 255) (127 -128 -1 127 128 255)
\end{verbatim} \end{verbatim}
\defun{pointer-ref-signed-short}{procedure} \defun{pointer-ref-c-signed-short}{procedure}
\texttt{(pointer-ref-signed-short p i)} \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 located at offsets \texttt{i} and \texttt{(+ i 1)} from the pointer
\texttt{p} and returns an exact integer representing the \texttt{p} and returns an exact integer representing the
sign-extended sign-extended
integer value of the sequence. The resulting value is in the range integer value of the sequence. The resulting value is in the range
$[-32768, 32767]$ inclusive. $[-32768, 32767]$ inclusive.
\defun{pointer-ref-unsigned-short}{procedure} \defun{pointer-ref-c-unsigned-short}{procedure}
\texttt{(pointer-ref-unsigned-short p i)} \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 located at offsets \texttt{i} and \texttt{(+ i 1)} from the pointer
\texttt{p} and returns an exact integer representing the unsigned \texttt{p} and returns an exact integer representing the unsigned
integer value of the sequence. The resulting value is in the range integer value of the sequence. The resulting value is in the range
$[0, 65535]$ inclusive. $[0, 65535]$ inclusive.
\newpage \newpage
\defun{pointer-ref-signed-int}{procedure} \defun{pointer-ref-c-signed-int}{procedure}
\texttt{(pointer-ref-signed-int p i)} \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 starting at offset \texttt{i} of pointer \texttt{p} and returns an
exact integer in the range of $[-2^{31},2^{31}-1]$ inclusive. exact integer in the range of $[-2^{31},2^{31}-1]$ inclusive.
\defun{pointer-ref-unsigned-int}{procedure} \defun{pointer-ref-c-unsigned-int}{procedure}
\texttt{(pointer-ref-unsigned-int p i)} \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 starting at offset \texttt{i} of pointer \texttt{p} and returns an
exact integer in the range of $[0,2^{32}-1]$ inclusive. exact integer in the range of $[0,2^{32}-1]$ inclusive.
\defun{pointer-ref-signed-long}{procedure} \defun{pointer-ref-c-signed-long}{procedure}
\texttt{(pointer-ref-signed-long p i)} \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 loads eight bytes starting at offset \texttt{i} of pointer
\texttt{p} and returns an integer in the range of \texttt{p} and returns an integer in the range of
$[-2^{63},2^{63}-1]$ inclusive. On 32-bit systems, the procedure $[-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-c-signed-long} performs the same task as
\texttt{pointer-ref-signed-int}. \texttt{pointer-ref-c-signed-int}.
\defun{pointer-ref-unsigned-long}{procedure} \defun{pointer-ref-c-unsigned-long}{procedure}
\texttt{(pointer-ref-unsigned-long p i)} \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 loads eight bytes starting at offset \texttt{i} of pointer
\texttt{p} and returns an integer in the range of \texttt{p} and returns an integer in the range of
$[0,2^{64}-1]$ inclusive. On 32-bit systems, the procedure $[0,2^{64}-1]$ inclusive. On 32-bit systems, the procedure
\texttt{pointer-ref-unsigned-long} performs the same task as \texttt{pointer-ref-c-unsigned-long} performs the same task as
\texttt{pointer-ref-unsigned-int}. \texttt{pointer-ref-c-unsigned-int}.
\defun{pointer-ref-float}{procedure} \defun{pointer-ref-c-float}{procedure}
\texttt{(pointer-ref-float p i)} \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 float (represented as IEEE-754 single precision floating point
number) stored at offset \texttt{i} of the pointer \texttt{p}. number) stored at offset \texttt{i} of the pointer \texttt{p}.
The value is extended to an IEEE-754 double precision floating The value is extended to an IEEE-754 double precision floating
point number that Ikarus uses to represent inexact numbers. point number that Ikarus uses to represent inexact numbers.
\defun{pointer-ref-double}{procedure} \defun{pointer-ref-c-double}{procedure}
\texttt{(pointer-ref-double p i)} \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 float (represented as IEEE-754 double precision floating point
number) stored at offset \texttt{i} of the pointer \texttt{p}. number) stored at offset \texttt{i} of the pointer \texttt{p}.
\defun{pointer-ref-pointer}{procedure} \defun{pointer-ref-c-pointer}{procedure}
\texttt{(pointer-ref-pointer p i)} \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 stored at offset \texttt{i} from the pointer \texttt{p}. The size
of the pointer (also the number of bytes loaded) depends on the 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 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} \defun{make-c-callout}{procedure}
\texttt{((make-callout return-type parameter-types) native-pointer)} \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 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 denoting the signature of the procedure to be called. It prepares a
bridge that converts from Scheme's calling conventions and data bridge that converts from Scheme's calling conventions and data
structures to their foreign counterparts. It returns a procedure 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 it to the appropriate Scheme value (depending on the
\texttt{return-type}). \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 stages in order to accomodate common usage patterns. Often types, a
function signature can be used by many foreign procedures and 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, and each signature can be used multiple times. Similarly,
separating the foreign procedure preparation from parameter passing separating the foreign procedure preparation from parameter passing
allows for preparing the foreign procedure once and calling it many 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 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 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 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 is loaded and is bound to the variable \texttt{libc}. Next, we
obtain a pointer to the \texttt{atan} foreign procedure that is obtain a pointer to the \texttt{atan} foreign procedure that is
defined in \texttt{libc}. The native procedure \texttt{atan} takes defined in \texttt{libc}. The native procedure \texttt{atan} takes
a \texttt{double} as an argument and returns a \texttt{double} and 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, Finally, we call the foreign procedure interface with one argument,
\texttt{1.0}, which is a flonum and thus matches the required \texttt{1.0}, which is a flonum and thus matches the required
parameter type. The native procedure returns a \texttt{double} 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 > libc-atan-ptr
#<pointer #x9006CB1F> #<pointer #x9006CB1F>
> (define libc-atan > (define libc-atan
((make-callout 'double '(double)) libc-atan-ptr)) ((make-c-callout 'double '(double)) libc-atan-ptr))
> libc-atan > libc-atan
#<procedure> #<procedure>
> (libc-atan 1.0) > (libc-atan 1.0)
@ -2713,14 +2713,14 @@ Figure~\ref{fig:foreign-types} on page~\pageref{fig:foreign-types} for
details). details).
\defun{make-callback}{procedure} \defun{make-c-callback}{procedure}
\texttt{((make-callback return-type parameter-types) scheme-procedure)} \texttt{((make-c-callback return-type parameter-types) scheme-procedure)}
The procedure \texttt{make-callback} is similar to the procedure The procedure \texttt{make-c-callback} is similar to the procedure
\texttt{make-callout} except that it provides a bridge from native \texttt{make-c-callout} except that it provides a bridge from native
procedures back into Scheme. While the procedure procedures back into Scheme. While the procedure
\texttt{make-callout} takes a native pointer and returns a Scheme \texttt{make-c-callout} takes a native pointer and returns a Scheme
procedure, \texttt{make-callback} takes a Scheme procedure and procedure, \texttt{make-c-callback} takes a Scheme procedure and
returns a native pointer. The native pointer can be called by returns a native pointer. The native pointer can be called by
foreign procedures. The native parameters are converted to Scheme foreign procedures. The native parameters are converted to Scheme
data (according to \texttt{parameter-types}), the Scheme procedure 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 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. procedures that are obtained using \texttt{dlsym} or similar means.
In particular, such native pointers can be used as arguments to In particular, such native pointers can be passed to
\texttt{make-callout} resulting in a Scheme procedure that calls out \texttt{make-c-callout} resulting in a Scheme procedure that calls out
to the native procedure that in turn calls back into Scheme. The to the native procedure that in turn calls back into Scheme. The
following segment illustrates a very inefficient way of extracting following segment illustrates a very inefficient way of extracting
the lowermost 32 bits from an exact integer. the lowermost 32 bits from an exact integer.
\begin{verbatim} \begin{verbatim}
> (format "~x" > (format "~x"
(((make-callout 'unsigned-int '(unsigned-int)) (((make-c-callout 'unsigned-int '(unsigned-int))
((make-callback 'unsigned-int '(unsigned-int)) ((make-c-callback 'unsigned-int '(unsigned-int))
values)) values))
#xfedcba09876543210fedcba09876543210)) #xfedcba09876543210fedcba09876543210))
"76543210" "76543210"

34
lab/test-ffi.ss
View File

@ -20,22 +20,22 @@
(define hosym (dlsym self "ho")) (define hosym (dlsym self "ho"))
(define ho (define ho
((make-callout 'signed-int '(pointer signed-int)) hosym)) ((make-c-callout 'signed-int '(pointer signed-int)) hosym))
(define traced-foradd1 (define traced-foradd1
((make-callback 'signed-int '(signed-int)) ((make-c-callback 'signed-int '(signed-int))
(trace-lambda add1 (n) (trace-lambda add1 (n)
(collect) (collect)
(add1 n)))) (add1 n))))
(define foradd1 (define foradd1
((make-callback 'signed-int '(signed-int)) ((make-c-callback 'signed-int '(signed-int))
(lambda (n) (lambda (n)
(collect) (collect)
(add1 n)))) (add1 n))))
(define foradd1-by-foreign-call (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) (trace-lambda foradd1-by-foreign-call (n)
(/ (ho traced-foradd1 n) 2)))) (/ (ho traced-foradd1 n) 2))))
@ -46,11 +46,11 @@
(define test_I_I (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 (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 (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_I (dlsym self "add_I_I"))
(define C_add_I_II (dlsym self "add_I_II")) (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_II C_add_I_II 12 13) (+ 12 13))
(check = (test_I_III C_add_I_III 12 13 14) (+ 12 13 14)) (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_I ((make-c-callback 'signed-int '(signed-int)) +))
(define S_add_I_II ((make-callback 'signed-int '(signed-int (define S_add_I_II ((make-c-callback 'signed-int '(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
signed-int)) +)) signed-int)) +))
@ -73,11 +73,11 @@
(define test_D_D (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 (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 (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_D (dlsym self "add_D_D"))
(define C_add_D_DD (dlsym self "add_D_DD")) (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_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)) (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_D ((make-c-callback 'double '(double)) +))
(define S_add_D_DD ((make-callback 'double '(double double)) +)) (define S_add_D_DD ((make-c-callback 'double '(double double)) +))
(define S_add_D_DDD ((make-callback 'double '(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_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)) (check = (test_D_DD S_add_D_DD 12.0 13.0) (+ 12.0 13.0))
@ -97,7 +97,7 @@
(define RectArea (define RectArea
((make-callout 'float '(#(#(float float) #(float float)))) ((make-c-callout 'float '(#(#(float float) #(float float))))
(dlsym self "test_area_F_R"))) (dlsym self "test_area_F_R")))
(check = (RectArea '#(#(0.0 0.0) #(10.0 10.0))) 100.0) (check = (RectArea '#(#(0.0 0.0) #(10.0 10.0))) 100.0)

6
lib/Cocoa/helpers.ss
View File

@ -6,13 +6,13 @@
(define kProcessTransformToForegroundApplication 1) (define kProcessTransformToForegroundApplication 1)
(define self (dlopen)) (define self (dlopen))
(define get-current-process (define get-current-process
((make-callout 'void '(pointer)) ((make-c-callout 'void '(pointer))
(dlsym self "GetCurrentProcess"))) (dlsym self "GetCurrentProcess")))
(define transform-process-type (define transform-process-type
((make-callout 'void '(pointer signed-int)) ((make-c-callout 'void '(pointer signed-int))
(dlsym self "TransformProcessType"))) (dlsym self "TransformProcessType")))
(define set-front-process (define set-front-process
((make-callout 'void '(pointer)) ((make-c-callout 'void '(pointer))
(dlsym self "SetFrontProcess"))) (dlsym self "SetFrontProcess")))
(let ([p (malloc 16)]) (let ([p (malloc 16)])
(get-current-process p) (get-current-process p)

30
lib/ikarus/foreign.ss
View File

@ -1,17 +1,29 @@
(library (ikarus foreign) (library (ikarus foreign)
(export malloc free pointer-set-char pointer-set-short (export
pointer-set-int pointer-set-long pointer-set-pointer pointer-set-c-char!
pointer-set-float pointer-set-double pointer-set-c-short!
pointer-ref-signed-char pointer-ref-signed-short pointer-set-c-int!
pointer-ref-signed-int pointer-ref-signed-long pointer-set-c-long!
pointer-ref-unsigned-char pointer-ref-unsigned-short pointer-set-c-pointer!
pointer-ref-unsigned-int pointer-ref-unsigned-long pointer-set-c-float!
pointer-ref-pointer pointer-ref-float pointer-ref-double 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 pointer->integer integer->pointer pointer? dlopen dlsym
dlclose dlerror dlclose dlerror
make-callout make-callback) make-c-callout make-c-callback)
(import (ikarus system $foreign))) (import (ikarus system $foreign)))

44
lib/objc.ss
View File

@ -61,7 +61,7 @@
(define (pointer-ref addr offset) (define (pointer-ref addr offset)
(assert (pointer? addr)) (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))) (define (offset? x) (or (fixnum? x) (bignum? x)))
@ -70,12 +70,12 @@
(check who pointer? addr) (check who pointer? addr)
(check who pointer? val) (check who pointer? val)
(check who offset? offset) (check who offset? offset)
(pointer-set-long addr offset (pointer->integer val))) (pointer-set-c-pointer! addr offset val))
(define (char*len x) (define (char*len x)
(let f ([i 0]) (let f ([i 0])
(cond (cond
[(zero? (pointer-ref-unsigned-char x i)) i] [(zero? (pointer-ref-c-unsigned-char x i)) i]
[else (f (+ i 1))]))) [else (f (+ i 1))])))
(define (char*->bv x) (define (char*->bv x)
@ -85,18 +85,18 @@
(cond (cond
[(= i n) bv] [(= i n) bv]
[else [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))]))))) (f (+ i 1))])))))
(define (bv->char* x) (define (bv->char* x)
(let ([n (bytevector-length x)]) (let ([n (bytevector-length x)])
(let ([p (malloc (+ n 1))]) (let ([p (malloc (+ n 1))])
(pointer-set-char p n 0) (pointer-set-c-char! p n 0)
(let f ([i 0]) (let f ([i 0])
(cond (cond
[(= i n) p] [(= i n) p]
[else [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))]))))) (f (+ i 1))])))))
(define (bv->u8* x) (define (bv->u8* x)
@ -108,7 +108,7 @@
(cond (cond
[(= i n) p] [(= i n) p]
[else [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))])))))) (f (+ i 1))]))))))
(define (char*->string x) (define (char*->string x)
@ -183,7 +183,7 @@
(define (class-instance-size x) (define (class-instance-size x)
(check 'class-instance-size class? 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) (define (ivar-name x)
(check 'ivar-name ivar? x) (check 'ivar-name ivar? x)
@ -195,14 +195,14 @@
(define (ivar-offset x) (define (ivar-offset x)
(check 'ivar-offset ivar? 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) (define (class-ivars x)
(check 'class-ivars class? x) (check 'class-ivars class? x)
(let ([p (pointer-ref (class-ptr x) objc-class-ivars-offset)]) (let ([p (pointer-ref (class-ptr x) objc-class-ivars-offset)])
(if (nil? p) (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]) (let f ([i 0] [off objc-ivarlist-ivars-offset])
(if (= i n) (if (= i n)
'() '()
@ -223,7 +223,7 @@
[class (malloc objc-class-struct-size)] [class (malloc objc-class-struct-size)]
[meta (malloc objc-class-struct-size)]) [meta (malloc objc-class-struct-size)])
;;; init meta class ;;; 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-name-offset (string->char* name))
(pointer-set meta objc-class-methodlists-offset (pointer-set meta objc-class-methodlists-offset
(malloc objc-methodlist-methods-offset)) (malloc objc-methodlist-methods-offset))
@ -232,14 +232,14 @@
(pointer-set meta objc-class-isa-offset (pointer-set meta objc-class-isa-offset
(pointer-ref (class-ptr root-class) objc-class-isa-offset)) (pointer-ref (class-ptr root-class) objc-class-isa-offset))
;;; init class ;;; 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-name-offset (string->char* name))
(pointer-set class objc-class-methodlists-offset (pointer-set class objc-class-methodlists-offset
(malloc objc-methodlist-methods-offset)) (malloc objc-methodlist-methods-offset))
(pointer-set class objc-class-superclass-offset (pointer-set class objc-class-superclass-offset
(class-ptr super-class)) (class-ptr super-class))
(pointer-set class objc-class-ivars-offset ivars-ptr) (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 ;;; wire up
(pointer-set class objc-class-isa-offset meta) (pointer-set class objc-class-isa-offset meta)
(when intern? (objc_addClass class)) (when intern? (objc_addClass class))
@ -251,7 +251,7 @@
(check who procedure? proc) (check who procedure? proc)
(let ([type (make-objc-type (cons rtype argtypes))]) (let ([type (make-objc-type (cons rtype argtypes))])
(let ([callback (let ([callback
(make-callback (make-c-callback
(objc-type->ikarus-type rtype) (objc-type->ikarus-type rtype)
(map objc-type->ikarus-type argtypes))]) (map objc-type->ikarus-type argtypes))])
(let ([imp (callback (let ([imp (callback
@ -260,7 +260,7 @@
(apply proc (map convert-incoming argtypes args)))))]) (apply proc (map convert-incoming argtypes args)))))])
(let ([p (malloc (+ objc-methodlist-methods-offset (let ([p (malloc (+ objc-methodlist-methods-offset
objc-method-size))]) 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 (pointer-set p
(+ objc-methodlist-methods-offset objc-method-sel-offset) (+ objc-methodlist-methods-offset objc-method-sel-offset)
(selector-ptr (selector-ptr
@ -312,11 +312,11 @@
(cond (cond
[(assq what alist) => cadr] [(assq what alist) => cadr]
[else (error 'class-is? "invalid what" what)])]) [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 (class-methods x)
(define (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)))]) [array (integer->pointer (+ (pointer->integer x) (* 2 ptrsize)))])
(let f ([i 0]) (let f ([i 0])
(if (= i n) (if (= i n)
@ -330,7 +330,7 @@
(when (class-is? x 'method-array) (when (class-is? x 'method-array)
(error 'class-methods "BUG: not yet for method arrays")) (error 'class-methods "BUG: not yet for method arrays"))
(let ([iterator (malloc ptrsize)]) (let ([iterator (malloc ptrsize)])
(pointer-set-long iterator 0 0) (pointer-set-c-long! iterator 0 0)
(let f () (let f ()
(let ([methodlist (class_nextMethodList (class-ptr x) iterator)]) (let ([methodlist (class_nextMethodList (class-ptr x) iterator)])
(cond (cond
@ -354,7 +354,7 @@
(cons (cons
(make-class (make-class
(integer->pointer (integer->pointer
(pointer-ref-signed-long buffer (* ptrsize i)))) (pointer-ref-c-signed-long buffer (* ptrsize i))))
ac))))))))) ac)))))))))
(define (nil? x) (define (nil? x)
@ -475,7 +475,7 @@
(define count (length ivars)) (define count (length ivars))
(define p (define p
(malloc (+ objc-ivarlist-ivars-offset (* count objc-ivar-size)))) (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] (let f ([ivars ivars]
[poff objc-ivarlist-ivars-offset] [poff objc-ivarlist-ivars-offset]
[ivaroff (class-instance-size super-class)]) [ivaroff (class-instance-size super-class)])
@ -489,7 +489,7 @@
(string->char* (symbol->string name))) (string->char* (symbol->string name)))
(pointer-set p (+ poff objc-ivar-type-offset) (pointer-set p (+ poff objc-ivar-type-offset)
(string->char* ivar-type)) (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) (f (cdr ivars)
(+ poff objc-ivar-size) (+ poff objc-ivar-size)
(+ ivaroff ivar-size)))))]))) (+ ivaroff ivar-size)))))])))
@ -643,7 +643,7 @@
(let ([rtype (car sig)] [argtypes (cdr sig)]) (let ([rtype (car sig)] [argtypes (cdr sig)])
(unless (= (length args) (length argtypes)) (unless (= (length args) (length argtypes))
(error 'call-with-sig "incorrect number of args" args 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) (objc-type->ikarus-type rtype)
(map objc-type->ikarus-type argtypes))]) (map objc-type->ikarus-type argtypes))])
(let ([proc (ffi mptr)]) (let ([proc (ffi mptr)])

16
lib/ypsilon-compat.ikarus.ss
View File

@ -80,7 +80,7 @@
(cond (cond
[(= i n) p] [(= i n) p]
[else [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))]))))] (f (+ i 1))]))))]
[else (die who "not an int*" x)])) [else (die who "not an int*" x)]))
@ -104,7 +104,7 @@
(cond (cond
[(= i n) p] [(= i n) p]
[else [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)))) (pointer->integer (check-char* who (vector-ref x i))))
(f (+ i 1))]))))] (f (+ i 1))]))))]
[else (die who "not a char**" x)])) [else (die who "not a char**" x)]))
@ -114,12 +114,12 @@
[(bytevector? x) [(bytevector? x)
(let ([n (bytevector-length x)]) (let ([n (bytevector-length x)])
(let ([p (malloc (+ n 1))]) (let ([p (malloc (+ n 1))])
(pointer-set-char p n 0) (pointer-set-c-char! p n 0)
(let f ([i 0]) (let f ([i 0])
(cond (cond
[(= i n) p] [(= i n) p]
[else [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))]))))] (f (+ i 1))]))))]
[else (die who "not a byte*" x)])) [else (die who "not a byte*" x)]))
@ -139,7 +139,7 @@
[(_ foreign-name val return-type (arg-type* ...)) [(_ foreign-name val return-type (arg-type* ...))
#'(let ([t val]) #'(let ([t val])
(if (procedure? t) (if (procedure? t)
((make-callback ((make-c-callback
(convert-type return-type) (convert-type return-type)
(list (convert-type arg-type*) ...)) (list (convert-type arg-type*) ...))
t) t)
@ -187,7 +187,7 @@
(define (strlen x) (define (strlen x)
(let f ([i 0]) (let f ([i 0])
(cond (cond
[(= 0 (pointer-ref-unsigned-char x i)) i] [(= 0 (pointer-ref-c-unsigned-char x i)) i]
[else (f (+ i 1))]))) [else (f (+ i 1))])))
(let ([n (strlen x)]) (let ([n (strlen x)])
(let ([s (make-string n)]) (let ([s (make-string n)])
@ -196,7 +196,7 @@
s s
(begin (begin
(string-set! s i (string-set! s i
(integer->char (pointer-ref-unsigned-char x i))) (integer->char (pointer-ref-c-unsigned-char x i)))
(f (+ i 1)))))))) (f (+ i 1))))))))
(define-syntax convert-return (define-syntax convert-return
@ -254,7 +254,7 @@
(with-syntax ([x x] (with-syntax ([x x]
[(t* ...) (generate-temporaries #'(arg-type* ...))]) [(t* ...) (generate-temporaries #'(arg-type* ...))])
#'(let ([callout #'(let ([callout
((make-callout ((make-c-callout
(convert-type return-type) (convert-type return-type)
(list (convert-type arg-type*) ...)) (list (convert-type arg-type*) ...))
(lookup-shared-object lib 'foreign-name))]) (lookup-shared-object lib 'foreign-name))])

76
scheme/ikarus.pointers.ss
View File

@ -2,19 +2,25 @@
(library (ikarus.pointers) (library (ikarus.pointers)
(export pointer? integer->pointer pointer->integer (export pointer? integer->pointer pointer->integer
dlopen dlerror dlclose dlsym malloc free dlopen dlerror dlclose dlsym malloc free
pointer-ref-signed-char pointer-ref-c-signed-char
pointer-ref-signed-short pointer-ref-c-signed-short
pointer-ref-signed-int pointer-ref-c-signed-int
pointer-ref-signed-long pointer-ref-c-signed-long
pointer-ref-unsigned-char pointer-ref-c-unsigned-char
pointer-ref-unsigned-short pointer-ref-c-unsigned-short
pointer-ref-unsigned-int pointer-ref-c-unsigned-int
pointer-ref-unsigned-long pointer-ref-c-unsigned-long
pointer-set-char pointer-set-short pointer-set-int pointer-set-long pointer-ref-c-float
pointer-set-pointer pointer-ref-pointer pointer-ref-c-double
pointer-set-float pointer-ref-float pointer-ref-c-pointer
pointer-set-double pointer-ref-double pointer-set-c-char!
make-callout make-callback) 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 (import
(except (ikarus) (except (ikarus)
pointer? pointer?
@ -120,25 +126,25 @@
(define (int? x) (or (fixnum? x) (bignum? x))) (define (int? x) (or (fixnum? x) (bignum? x)))
(define-getter pointer-ref-signed-char "ikrt_ref_char") (define-getter pointer-ref-c-signed-char "ikrt_ref_char")
(define-getter pointer-ref-signed-short "ikrt_ref_short") (define-getter pointer-ref-c-signed-short "ikrt_ref_short")
(define-getter pointer-ref-signed-int "ikrt_ref_int") (define-getter pointer-ref-c-signed-int "ikrt_ref_int")
(define-getter pointer-ref-signed-long "ikrt_ref_long") (define-getter pointer-ref-c-signed-long "ikrt_ref_long")
(define-getter pointer-ref-unsigned-char "ikrt_ref_uchar") (define-getter pointer-ref-c-unsigned-char "ikrt_ref_uchar")
(define-getter pointer-ref-unsigned-short "ikrt_ref_ushort") (define-getter pointer-ref-c-unsigned-short "ikrt_ref_ushort")
(define-getter pointer-ref-unsigned-int "ikrt_ref_uint") (define-getter pointer-ref-c-unsigned-int "ikrt_ref_uint")
(define-getter pointer-ref-unsigned-long "ikrt_ref_ulong") (define-getter pointer-ref-c-unsigned-long "ikrt_ref_ulong")
(define-getter pointer-ref-float "ikrt_ref_float") (define-getter pointer-ref-c-float "ikrt_ref_float")
(define-getter pointer-ref-double "ikrt_ref_double") (define-getter pointer-ref-c-double "ikrt_ref_double")
(define-getter pointer-ref-pointer "ikrt_ref_pointer") (define-getter pointer-ref-c-pointer "ikrt_ref_pointer")
(define-setter pointer-set-char int? "ikrt_set_char") (define-setter pointer-set-c-char! int? "ikrt_set_char")
(define-setter pointer-set-short int? "ikrt_set_short") (define-setter pointer-set-c-short! int? "ikrt_set_short")
(define-setter pointer-set-int int? "ikrt_set_int") (define-setter pointer-set-c-int! int? "ikrt_set_int")
(define-setter pointer-set-long int? "ikrt_set_long") (define-setter pointer-set-c-long! int? "ikrt_set_long")
(define-setter pointer-set-float flonum? "ikrt_set_float") (define-setter pointer-set-c-float! flonum? "ikrt_set_float")
(define-setter pointer-set-double flonum? "ikrt_set_double") (define-setter pointer-set-c-double! flonum? "ikrt_set_double")
(define-setter pointer-set-pointer pointer? "ikrt_set_pointer") (define-setter pointer-set-c-pointer! pointer? "ikrt_set_pointer")
;;; libffi interface ;;; libffi interface
@ -202,8 +208,8 @@
argtypes-n argtypes-n
rtype-n))) rtype-n)))
(define (make-callout rtype argtypes) (define (make-c-callout rtype argtypes)
(define who 'make-callout) (define who 'make-c-callout)
(let-values ([(cif argtypes-n rtype-n) (let-values ([(cif argtypes-n rtype-n)
(ffi-prep-cif rtype argtypes)]) (ffi-prep-cif rtype argtypes)])
(let* ([argtypes-vec (list->vector argtypes)] (let* ([argtypes-vec (list->vector argtypes)]
@ -228,11 +234,11 @@
checkers argtypes-vec argsvec) checkers argtypes-vec argsvec)
(foreign-call "ikrt_ffi_call" data 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) (let-values ([(cif argtypes-n rtype-n)
(ffi-prep-cif rtype argtypes)]) (ffi-prep-cif rtype argtypes)])
(lambda (proc) (lambda (proc)
(define who 'make-callback) (define who 'make-c-callback)
(unless (procedure? proc) (unless (procedure? proc)
(die who "not a procedure")) (die who "not a procedure"))
(let ([proc (let ([proc

2
scheme/last-revision
View File

@ -1 +1 @@
1622 1623

60
scheme/makefile.ss
View File

@ -1455,36 +1455,36 @@
[cp0-effort-limit i] [cp0-effort-limit i]
[tag-analysis-output i] [tag-analysis-output i]
[perform-tag-analysis i] [perform-tag-analysis i]
[pointer? $for] [pointer? $for]
[pointer->integer $for] [pointer->integer $for]
[integer->pointer $for] [integer->pointer $for]
[dlopen $for] [dlopen $for]
[dlerror $for] [dlerror $for]
[dlclose $for] [dlclose $for]
[dlsym $for] [dlsym $for]
[malloc $for] [malloc $for]
[free $for] [free $for]
[pointer-ref-signed-char $for] [pointer-ref-c-signed-char $for]
[pointer-ref-signed-short $for] [pointer-ref-c-signed-short $for]
[pointer-ref-signed-int $for] [pointer-ref-c-signed-int $for]
[pointer-ref-signed-long $for] [pointer-ref-c-signed-long $for]
[pointer-ref-unsigned-char $for] [pointer-ref-c-unsigned-char $for]
[pointer-ref-unsigned-short $for] [pointer-ref-c-unsigned-short $for]
[pointer-ref-unsigned-int $for] [pointer-ref-c-unsigned-int $for]
[pointer-ref-unsigned-long $for] [pointer-ref-c-unsigned-long $for]
[pointer-set-char $for] [pointer-ref-c-float $for]
[pointer-set-short $for] [pointer-ref-c-double $for]
[pointer-set-int $for] [pointer-ref-c-pointer $for]
[pointer-set-long $for] [pointer-set-c-char! $for]
[pointer-set-pointer $for] [pointer-set-c-short! $for]
[pointer-ref-pointer $for] [pointer-set-c-int! $for]
[pointer-set-float $for] [pointer-set-c-long! $for]
[pointer-ref-float $for] [pointer-set-c-pointer! $for]
[pointer-set-double $for] [pointer-set-c-float! $for]
[pointer-ref-double $for] [pointer-set-c-double! $for]
[make-callout $for] [make-c-callout $for]
[make-callback $for] [make-c-callback $for]
[host-info i] [host-info i]
)) ))