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

- added (ikarus foreign) library that should be used instead of 

(ikarus system $foreign).
- changed the names of some of the pointer primitives
- changed the name of the procedure make-ffi to make-callout
- updated examples and libraries to conform with new names
- updated the users guide to provide a complete description of 
  the (ikarus foreign) library
- updated list of missing R6RS features in the users guide
This commit is contained in:
Abdulaziz Ghuloum 2008-10-06 01:19:27 -04:00
parent 997c75fabb
commit 1e5e516b08
14 changed files with 1050 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

Binary file not shown.

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

@ -2065,7 +2065,7 @@ displayed.
no collections
0 ms elapsed cpu time, including 0 ms collecting
0 ms elapsed real time, including 0 ms collecting
56 bytes allocated
24 bytes allocated
1
2
3
@ -2075,10 +2075,686 @@ displayed.
no collections
0 ms elapsed cpu time, including 0 ms collecting
0 ms elapsed real time, including 0 ms collecting
32 bytes allocated
0 bytes allocated
12
\end{verbatim}
\chapter{\label{chapter:foreign}The \texttt{(ikarus foreign)} Library}
This chapter describes the facilities through which Ikarus
interfaces with the host operating system and other external
libraries. The facilities of the \texttt{(ikarus~foreign)}
library give the Scheme program unrestricted access to the computer
memory, allowing one to allocate, access, modify, and free memory as
needed. The facilities also allow the Scheme program to \emph{call
out} to system procedures as well as allow the native procedures to
\emph{call back} into Scheme.
This chapter is organized as follows: Section~\ref{sec:ffi-overview}
gives an overview of the basic concepts such as shared libraries,
external symbols, foreign data types, pointers, and procedures.
Section~\ref{sec:ffi-memory} describes the primitives that
\texttt{(ikarus~foreign)} provides for direct manipulation of
memory. Section~\ref{sec:ffi-procedures} deals with loading
external libraries and calling out to native library procedures and
calling back into Scheme. To demonstrate the usefulness of the
foreign facilities, Ikarus ships with two libraries that also serve
as extended examples for using the system.
Section~\ref{sec:ffi-opengl} describes The OpenGL library
\texttt{(ikarus~opengl)} which allows the programmer to produce 2D
and 3D computer graphics. Section~\ref{sec:ffi-objc} describes the
\texttt{(ikarus~objc)} which allows the programmer to access
libraries and frameworks written in the Objective-C programming
language and thus provides full access to the Mac OS X system
(e.g.,~making graphical user interfaces with Cocoa and drawing
graphics with Quartz all from Scheme).
Ikarus version \texttt{0.0.4} is the first version of Ikarus to
support the described foreign interfaces.
\newpage
\section{\label{sec:ffi-overview}Overview}
In order to make full use of the computer, it is important for a
programming environment (e.g., Ikarus Scheme) to facilitate access
to the underlying architecture on which it runs. The underlying
architecture includes the API provided by the host operating system
kernel (e.g., Linux), the system libraries (e.g., \texttt{libc}),
and other site-installed libraries (e.g., \texttt{sqlite3}).
Providing direct access to such API from within Scheme allows the
programmer to write Scheme libraries that have few or no
dependencies on external programs (such as \texttt{C} development
toolchain). When dealing with system libraries, the programmer
must have a thorough understanding of many aspects of the targetted
system. This section attempts to provide answers to many questions
that are frequently encountered when interfacing to external
libraries.
\section{Memory management}
Ikarus Scheme is a managed environment. Like in many programming
environments, Ikarus manages its own memory. Scheme objects are
allocated in a special memory region (the Scheme heap) and have
type-specific object layout that allows the run time system to
distinguish object types and allows the garbage collector to locate
all potentially live objects and reclaim the memory of dead objects.
Scheme objects are also \emph{opaque} in the sense that the data
structures used to represent Scheme objects (e.g., pairs) are not
exposed to the programmer, who can only interact with objects
through an interface (e.g., \texttt{car}, \texttt{cdr}).
Unmanaged environments, such as the operating system on which Ikarus
runs, require that the programmer manages the allocation and
deallocation of system resources herself. Memory regions, file
handles, external devices, the screen, etc., are all examples of
resources whose management must be coordinated among the different
parts of the system, and this becomes the responsibility of the
programmer who is wiring the different subsystems together.
Memory, from a system's point of view, is \emph{transparent}. A
pointer is an integer denoting an address of memory. This memory
address may contain a value that requires interpretation. At the
lowest-level, each byte of memory contains eight bits, each of which
may be toggled on or off. A level higher, contiguous sequences of
bytes are grouped together and are interpreted as integers, floating
point numbers, or pointers to other memory addresses. These are the
basic data types that are often interpreted atomically. Yet a level
higher, groups of basic types form data structures such as arrays,
linked lists, trees, and so on. Objects, as found in
object-oriented programming languages, are at an even higher level
of abstraction since they are treated as opaque references that
retain state and know how to respond to messages.
The procedures in the \texttt{(ikarus~foreign)} library are meant to
provide a way to interface with the low level memory operations such
as setting and getting bytes from specific locations in memory.
Although they do not provide high-level operations, the basic
procdures make implementing high-level operations (such as the
Objective-C system presented in Chapter~\ref{chapter:objc})
possible. Programmers are encouraged to define their own
abstractions that are most suitable for the specific target library
rather than using the low-level operations directly. This results
in writing more robust and more easily maintainable libraries. To
put it more boldly: \textbf{Do not sprinkle your code with low-level
memory operations}.
\section{\label{sec:ffi-memory}Memory operations}
\defun{malloc}{procedure}
\texttt{(malloc n)}
The \texttt{malloc} procedure allocates \texttt{n} bytes of memory
and returns a pointer to the allocated memory. The \texttt{malloc}
Scheme procedure is implemented using the host-provided
\texttt{malloc} system procedure (often found in \texttt{libc}).
The number of bytes, \texttt{n}, must be a positive exact integer.
\begin{verbatim}
> (malloc 10)
#<pointer #x00300320>
> (malloc 10000)
#<pointer #x01800400>
\end{verbatim}
\newpage
\defun{free}{procedure}
\texttt{(free p)}
The \texttt{free} procedure takes a pointer and frees the memory
region at the given address. The memory region must be allocated
with \texttt{malloc}, \texttt{calloc}, or a similar system
procedure. Once freed, memory operations on the given address are
invalid and may cause the system to crash at unpredictable times.
Ikarus cannot check for such errors since the memory may be freed by
procedures that are external to Ikarus.
\defun{pointer->integer}{procedure}
\texttt{(pointer->integer p)}
The procedure \texttt{pointer->integer} converts the value of the
pointer \texttt{p} to an exact integer value. The result may be a
fixnum or a bignum depending on the pointer.
\defun{integer->pointer}{procedure}
\texttt{(integer->pointer n)}
The procedure \texttt{integer->pointer} converts the exact integer
\texttt{n} to a pointer value. The lower 32 bits (or 64 bits on
64-bit systems) of the value of \texttt{n} are significant in
computing the pointer value. It is guaranteed that
\texttt{(integer->pointer (pointer->integer p))} points to the same
address as \texttt{p}.
\defun{pointer?}{procedure}
\texttt{(pointer? x)}
The predicate \texttt{pointer?} returns \texttt{\#t} if the value
of \texttt{x} is a pointer, and returns \texttt{\#f} otherwise.
\BoxedText{Note:}{The result of calling the procedures
\texttt{eq?}, \texttt{eqv?} and \texttt{equal?} on pointer values is
unspecified.}
\newpage
\defun{pointer-set-char}{procedure}
\texttt{(pointer-set-char p i n)}
The procedure \texttt{pointer-set-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
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)}
The procedure \texttt{pointer-set-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
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)}
The procedure \texttt{pointer-set-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}.
\defun{pointer-set-long}{procedure}
\texttt{(pointer-set-long p i n)}
On 64-bit systems, the procedure \texttt{pointer-set-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}.
\defun{pointer-set-float}{procedure}
\texttt{(pointer-set-float p i fl)}
The procedure \texttt{pointer-set-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)}
The procedure \texttt{pointer-set-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)}
On 64-bit systems, the procedure \texttt{pointer-set-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
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}.
\defun{pointer-ref-signed-char}{procedure}
\texttt{(pointer-ref-signed-char p i)}
The procedure \texttt{pointer-ref-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)}
The procedure \texttt{pointer-ref-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}.
\begin{verbatim}
> (let ([p (malloc 3)])
(pointer-set-char p 0 #b01111111)
(pointer-set-char p 1 #b10000000)
(pointer-set-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))])
(free p)
result))
(127 -128 -1 127 128 255)
\end{verbatim}
\defun{pointer-ref-signed-short}{procedure}
\texttt{(pointer-ref-signed-short p i)}
The procedure \texttt{pointer-ref-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)}
The procedure \texttt{pointer-ref-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)}
The procedure \texttt{pointer-ref-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)}
The procedure \texttt{pointer-ref-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)}
On 64-bit systems, the procedure \texttt{pointer-ref-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}.
\defun{pointer-ref-unsigned-long}{procedure}
\texttt{(pointer-ref-unsigned-long p i)}
On 64-bit systems, the procedure \texttt{pointer-ref-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}.
\defun{pointer-ref-float}{procedure}
\texttt{(pointer-ref-float p i)}
The procedure \texttt{pointer-ref-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)}
The procedure \texttt{pointer-ref-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)}
The procedure \texttt{pointer-ref-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
systems.
\section{\label{sec:foreign-objects}Accessing foreign objects from
Scheme}
\defun{dlopen}{procedure}
\texttt{(dlopen)}\\
\texttt{(dlopen library-name)}\\
\texttt{(dlopen library-name lazy? global?)}
The procedure \texttt{dlopen} takes a string \texttt{library-name}
represented a system library and calls the system procedure
\texttt{dlopen} which dynamically loads the given library into the
running process. The name of the library is system-dependent and
must include the appropriate suffix (e.g., \texttt{*.so} on Linux,
\texttt{*.dylib} on Darwin and \texttt{*.dll} on Cygwin). The
\texttt{library-name} may include a full path which identifies the
location of the library, or may be just the name of the library in
which case the system will lookup the library name using the
\texttt{LD\_LIBRARY\_PATH} environment variable.
The argument \texttt{lazy?} specifies how library dependencies are
loaded. If true, \texttt{dlopen} delays the resolution and loading
of dependent libraries until they are actually used. If false, all
library dependencies are loaded before the call to \texttt{dlopen}
returns.
The argument \texttt{global?} specifies how the scope of the symbols
exported from the loaded library. If true, all exported symbols
become part of the running image, and subsequent \texttt{dlsym}
calls may not need to specify the library from which the symbol is
loaded. If false, the exported symbols are not global and the
library pointer needs to be specified for \texttt{dlsym}.
Calling \texttt{(dlopen library-name)} is equivalent to
\texttt{(dlopen library-name \#f \#f)}. Calling \texttt{(dlopen)}
without arguments returns a pointer to the current process.
If succesful, \texttt{dlopen} returns a pointer to the external
library which can be used subsequently by \texttt{dlsym} and
\texttt{dlclose}. If the library cannot be loaded, \texttt{dlopen}
returns \texttt{\#f} and the procedure \texttt{dlerror} can be used
to obtain the cause of the failure.
Consult the \texttt{dlopen(3)} page in your system manual for
further details.
\defun{dlclose}{procedure}
\texttt{(dlclose library-pointer)}
The procedure \texttt{dlclose} is a wrapped around the system
procedure with the same name. It receives a library pointer
(e.g.,~one obtained from \texttt{dlopen}) and releases the resources
loaded from that library. Closing a library renders all symbols and
static data structures that the library exports invalid and the
program may crash or corrupt its memory if such symbols are used
after a library is closed.
Most system implementations of dynamic loading employ reference
counting for \texttt{dlopen} and \texttt{dlclose} in that library
resources are not freed until the number of calls to
\texttt{dlclose} matches the number of calls to \texttt{dlopen}.
The procedure \texttt{dlclose} returns a boolean value indicating
whether the success status of the operation. If \texttt{dlclose}
returns \texttt{\#f}, the procedure \texttt{dlerror} can be used to
obtain the cause of the error.
Consult the \texttt{dlclose(3)} page in your system manual for
further details.
\defun{dlerror}{procedure}
\texttt{(dlerror)}
If any of the dynamic loading operations (i.e., \texttt{dlopen},
\texttt{dlclose}, \texttt{dlsym}) fails, the cause of the error can
be obtained by calling \texttt{dlerror} which returns a string
describing the error. The procedure \texttt{dlerror} returns
\texttt{\#f} if there was no dynamic loading error.
Consult the \texttt{dlerror(3)} page in your system manual for
further details.
\defun{dlsym}{procedure}
\texttt{(dlsym library-pointer string)}
The procedure \texttt{dlsym} takes a library pointer (e.g., one
obtained by a call to \texttt{dlopen}) and a string representing the
name of a symbol that the library exports and returns a pointer to
the location of that symbol in memory. If \texttt{dlsym} fails, it
returns \texttt{\#f} and the cause of the error can be obtained
using the procedure \texttt{dlerror}.
Consult the \texttt{dlsym(3)} page in your system manual for
further details.
\section{\label{sec:callout}Calling out to foreign procedures}
Ikarus provides the means to call out from Scheme to foreign
procedures. This allows the programmers to extend Ikarus to access
system-specific facilities that is available on the host machine.
In order to call out to a foreign procedure, one must provide two
pieces of information: the signature of the foreign procedure (e.g.,
its type declaration if it is a \texttt{C} procedure) and the
address of the procedure in memory. The address of the procedure
can be easily obtained using \texttt{dlsym} if the name of the
procedure and its exporting library are known. The signature of the
procedure cannot, in general, be obtained dynamically, and therefore
must be hard coded into the program.
The signature of the foreign procedure is required for proper
linkeage between the Scheme system and the foreign system. Using
the signature, Ikarus determines how Scheme values are converted
into native values, and where (e.g., in which registers and stack
slots) to put these arguments. The signature also determines where
the returned values are placed and how they are converted from the
system data types to the corresponding Scheme data types.
A procedure's signature is composed of two parts: the return type
and the parameter types. The return type is a symbol that can be
any one of the type specifiers listed in
Figure~\ref{fig:foreign-types}, page~\pageref{fig:foreign-types}.
The parameter types is a list of type specifier symbols. The symbol
\texttt{void} can appear as a return type but cannot appear as a
parameter type.
\defun{make-callout}{procedure}
\texttt{((make-callout return-type parameter-types) native-pointer)}
The procedure \texttt{make-callout} is the primary facility for
making foreign procedures callable from Scheme. It works as
follows. First, \texttt{make-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
$p_1$. Second, the procedure $p_1$ accepts a pointer to a foreign
procedure (e.g., one obtained from \texttt{dlsym}) and returns a
Scheme procedure $p_2$ that encapsulates the foreign procedure. The
final procedure $p_2$ can be called with as many arguments as the
ones specified in the \texttt{parameter-types}. The parameters
supplies to $p_2$ must match the types supplied as the
\texttt{parameter-types} according to the ``Valid Scheme types''
column in the table in Figure~\ref{fig:foreign-types}. The
procedure $p_2$ converts the parameters from Scheme types to native
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
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
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
times.
The types listed in Figure~\ref{fig:foreign-types} are restricted to
basic types and provide no automatic conversion from composite
Scheme data structures (such as strings, symbols, vectors, and
lists) to native types. The restriction is intentional in order for
Ikarus to avoid making invalid assumptions about the memory
management of the targeted library. For example, while Ikarus
\emph{can} convert a Scheme string to a native byte array (e.g.,
using \texttt{string->bytevector} to decode the string, then using
\texttt{malloc} to allocate a temporary buffer, and copying the
bytes from the bytevector to the allocated memory), it cannot decide
when this allocated byte array is no longer needed and should be
freed. This knowledge is library-dependent and is often
procedure-dependent. Therefore, Ikarus leaves it to the programmer
to manage all memory related issues.
Outgoing parameters to foreign procedures are checked against the
declared types. For example, if a callback is prepared to expect a
parameter of type \texttt{signed-int}, only exact integers are
allowed to be passed out. For integer types, only a fixed number of
bits is used and the remaining bits are ignored. For floating point
types, the argument is checked to be a Scheme flonum. No implicit
conversion between exact and inexact numbers is performed.
{
\begin{figure}[b!]
\begin{center}
\begin{tabular}{@{}llll@{}}
\hline
Type specifier & Size & Valid Scheme types & Corresponding \texttt{C} types\\
\hline
\texttt{signed-char} & 1 byte & exact integer & \texttt{char}\\
\texttt{unsigned-char} & 1 byte & exact integer & \texttt{unsigned char}\\
\texttt{signed-short} & 2 bytes & exact integer & \texttt{short}\\
\texttt{unsigned-short} & 2 bytes & exact integer & \texttt{unsigned short}\\
\texttt{signed-int} & 4 bytes & exact integer & \texttt{int}\\
\texttt{unsigned-int} & 4 bytes & exact integer & \texttt{unsigned int}\\
\texttt{signed-long} & 4/8 bytes & exact integer & \texttt{long}\\
\texttt{unsigned-long} & 4/8 bytes & exact integer & \texttt{unsigned long}\\
\texttt{float} & 4 bytes & flonum & \texttt{float}\\
\texttt{double} & 8 bytes & flonum & \texttt{double}\\
\texttt{pointer} & 4/8 bytes & pointer &
\texttt{void*}, \texttt{char*}, \texttt{int*}, \texttt{int**}, \\
&&& \texttt{int(*)(int,int,int)}, etc. \\
\texttt{void} & -- & -- & \texttt{void}\\
\hline
\end{tabular}
\end{center}
\caption{\label{fig:foreign-types}The above table lists valid type
specifiers that can be used in callout and callback signatures.
Specifiers with ``4/8 bytes'' have size that depends on the system:
it is 4 bytes on 32-bit systems and 8 bytes on 64-bit systems. The
\texttt{void} specifier can only be used as a return value
specifier to mean ``no useful value is returned''.}
\end{figure}
}
The following example illustrates the use of the
\texttt{make-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}.
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}
value which is converted to the Scheme flonum with value
\texttt{0.7853981633974483}.
\begin{verbatim}
> (import (ikarus foreign))
> (define libc (dlopen "libc.dylib"))
> libc
#<pointer #x00100770>
> (define libc-atan-ptr (dlsym libc "atan"))
> libc-atan-ptr
#<pointer #x9006CB1F>
> (define libc-atan
((make-callout 'double '(double)) libc-atan-ptr))
> libc-atan
#<procedure>
> (libc-atan 1.0)
0.7853981633974483
> (libc-atan 1)
Unhandled exception
Condition components:
1. &assertion
2. &who: callout-procedure
3. &message: "argument does not match type double"
4. &irritants: (1)
\end{verbatim}
\section{\label{sec:callback}Calling back to Scheme}
In order to provide full interoperability with native procedures,
Ikarus allows native procedures to call back into Scheme just as it
allows Scheme to call out to native procedures. This is important
for many system libraries that provide graphical user interfaces
with event handling (e.g., Cocoa, GTK+, GLUT, etc.), database
engines (e.g., libsqlite, libmysql, etc.), among others.
The native calling site for the call back is compiled with a
specific callback signature encoding the expected parameter types
and return type. Therefore, a Scheme procedure used for a call back
must be wrapped with a proper adapter that converts the incoming
parameters from native format to Scheme values as well as convert
the value that the Scheme procedure returns back to native format.
The signature format is similar to the one used for call outs (see
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)}
The procedure \texttt{make-callback} is similar to the procedure
\texttt{make-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
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
is called with these parameters, and the returned value is converted
back into native format (according to \texttt{return-type}) before
control returns to the native call site.
Note that the native procedure pointer obtained from
\texttt{make-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
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))
values))
#xfedcba09876543210fedcba09876543210))
"76543210"
\end{verbatim}
\BoxedText{Caveat emptor:}{Preparing each call out and call back
procedure leaks a small amount of memory. This is because the
system cannot track such pointers that go into native code
(which may retain such pointers indefinitely). Use judiciously.}
% \chapter{\label{chapter:objc}The \texttt{(ikarus~objc)} Library}
% \newpage
\chapter{\label{chapter:contributed}Contributed Libraries}
We try to keep Ikarus Scheme small and its complexity manageable.
@ -2166,7 +2842,15 @@ following lines:
export IKARUS_LIBRARY_PATH
\end{verbatim}
\newpage
\section{\label{sec:aux-opengl}\texttt{(gl)} and \texttt{(glut)}}
FIXME
\newpage
\section{\texttt{(srfi *)}}
Ported by: Derick Eddington
@ -2253,15 +2937,14 @@ URL: \url{https://launchpad.net/r6rs-clos}
\rnrs{6}-clos is a port of tiny-clos to the latest
(6$^{\textrm{th}}$) revision
of the language standard for scheme. It uses the library
system that is new in \rnrs{6} to structure the code based on
functionality (bootstrap of core classes and generic functions,
actual implementation of the standard protocols, class layout
and slot access \ldots).
(6$^{\mathrm{th}}$) revision of the language standard for scheme. It
uses the library system that is new in \rnrs{6} to structure the
code based on functionality (bootstrap of core classes and generic
functions, actual implementation of the standard protocols, class
layout and slot access \ldots).
The homepage for now is \url{https://launchpad.net/r6rs-clos},
where my current development branch can be found.
The homepage for now is \url{https://launchpad.net/r6rs-clos}, where
my current development branch can be found.
% Currently the code in my repository will only work with the
% 0.0.2 release of Ikarus and uses a private copy of two
@ -2313,77 +2996,48 @@ To load both stream libraries, say:
\chapter{Missing Features}
Ikarus does not fully conform to \rnrs{6} yet. Although it
implements more than 94\% of \rnrs{6}'s macros and procedures, some
are still missing. This section summarizes the set of missing
features and procedures.
implements most of \rnrs{6}'s macros and procedures, some are still
missing. This section summarizes the set of missing features and
procedures.
\begin{itemize}
\item Numeric tower is complete except for complex numbers.\\
Consequences: \\
-- Reader does not recognize complex number notation
(e.g.~\texttt{5-7i}).\\
-- Procedures that may construct complex numbers from non-complex
arguments may signal an error or return an incorrect value
(e.g., \texttt{(sqrt~-1)} should return \verb|+i| instead
of signaling an error).
\item The procedure \texttt{equal?}\ may not terminate on
\texttt{equal?}\ infinite (circular) input.
\item \texttt{number->string} does not accept the third argument
(precision). Similarly, \texttt{string->number} and the reader do
not recognize the \texttt{|p} notation.
\end{itemize}
\newpage
\section{List of missing \rnrs{6} procedures}
The following procedures are missing from \texttt{(rnrs base)}:
\item The following procedures are missing from \texttt{(rnrs unicode)}:
\begin{Verbatim}
angle make-polar make-rectangular
\end{Verbatim}
% magnitude
% string->utf16
% string->utf32
% utf16->string
% utf32->string
The following procedures are missing from \texttt{(rnrs unicode)}:
\begin{Verbatim}
string-downcase string-titlecase string-upcase
string-titlecase
string-normalize-nfc string-normalize-nfd
string-normalize-nfkc string-normalize-nfkd
\end{Verbatim}
The following procedures are missing from \texttt{(rnrs arithmetic
\item The following procedures are missing from \texttt{(rnrs arithmetic
bitwise)}:
\begin{Verbatim}
bitwise-ior bitwise-xor bitwise-if bitwise-copy-bit-field
bitwise-reverse-bit-field bitwise-rotate-bit-field
\end{Verbatim}
% bitwise-bit-field
% bitwise-copy-bit
% bitwise-length
The following procedures are missing from \texttt{(rnrs arithmetic
\item The following procedures are missing from \texttt{(rnrs arithmetic
fixnum)}:
\begin{Verbatim}
fxreverse-bit-field fxrotate-bit-field
\end{Verbatim}
The following procedures are missing from \texttt{(rnrs hashtables)}:
\item The following procedures are missing from \texttt{(rnrs hashtables)}:
\begin{Verbatim}
make-eqv-hashtable make-hashtable equal-hash
hashtable-hash-function hashtable-equivalence-function
\end{Verbatim}
The following procedures are missing from \texttt{(rnrs io ports)}:
\item The following procedures are missing from \texttt{(rnrs io ports)}:
\begin{Verbatim}
string->bytevector bytevector->string
port-has-port-position? port-position
port-has-set-port-position!? set-port-position!
make-custom-binary-input/output-port
@ -2391,31 +3045,7 @@ make-custom-textual-input/output-port
open-file-input/output-port
\end{Verbatim}
% get-bytevector-some
% call-with-bytevector-output-port
% call-with-string-output-port
% binary-port?
% textual-port?
% port-eof?
% call-with-port
% lookahead-char
% lookahead-u8
% get-bytevector-all
% get-bytevector-some
% get-string-all
% make-custom-binary-input-port
% make-custom-binary-output-port
% make-custom-textual-input-port
% make-custom-textual-output-port
% open-bytevector-input-port
% open-bytevector-output-port
% open-file-input-port
% open-file-output-port
% transcoded-port
% port-transcoder
% put-bytevector
% output-port-buffer-mode
\end{itemize}

9
lab/objc-create-class.ss
View File

@ -14,4 +14,13 @@
1
(* n [$ self fact: (sub1 n)]))))
(class-add-class-method IKFact 'fact:ac: 'int '(class selector int int)
(trace-lambda fact (self sel n ac)
(if (zero? n)
ac
[$ self fact: (sub1 n) ac: (* n ac)])))
(printf "(fact 5) = ~s\n" [$ IKFact fact: 5])
(printf "(fact 5) = ~s\n" [$ IKFact fact: 5 ac: 1])

8
lib/Cocoa/helpers.ss
View File

@ -4,15 +4,15 @@
(define (make-app)
(define kProcessTransformToForegroundApplication 1)
(define self (dlopen #f))
(define self (dlopen))
(define get-current-process
((make-ffi 'void '(pointer))
((make-callout 'void '(pointer))
(dlsym self "GetCurrentProcess")))
(define transform-process-type
((make-ffi 'void '(pointer sint32))
((make-callout 'void '(pointer signed-int))
(dlsym self "TransformProcessType")))
(define set-front-process
((make-ffi 'void '(pointer))
((make-callout 'void '(pointer))
(dlsym self "SetFrontProcess")))
(let ([p (malloc 16)])
(get-current-process p)

3
lib/Makefile.am
View File

@ -1,8 +1,11 @@
libstreamsdir=$(pkglibdir)/streams
dist_libstreams_DATA=streams/primitive.ss streams/derived.ss
libikarusdir=$(pkglibdir)/ikarus
dist_libikarus_DATA=ikarus/foreign.ss
libCocoadir=$(pkglibdir)/Cocoa
dist_libCocoa_DATA=Cocoa/helpers.ss
dist_pkglib_DATA= streams.ss match.ss pregexp.ss gl.ss glut.ss \
ypsilon-compat.ikarus.ss ypsilon-compat.ypsilon.ss \
objc.ss Cocoa.ss

59
lib/Makefile.in
View File

@ -34,9 +34,9 @@ build_triplet = @build@
host_triplet = @host@
target_triplet = @target@
subdir = lib
DIST_COMMON = $(dist_libCocoa_DATA) $(dist_libstreams_DATA) \
$(dist_pkglib_DATA) $(srcdir)/Makefile.am \
$(srcdir)/Makefile.in
DIST_COMMON = $(dist_libCocoa_DATA) $(dist_libikarus_DATA) \
$(dist_libstreams_DATA) $(dist_pkglib_DATA) \
$(srcdir)/Makefile.am $(srcdir)/Makefile.in
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
am__aclocal_m4_deps = $(top_srcdir)/configure.ac
am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
@ -53,12 +53,14 @@ am__vpath_adj = case $$p in \
esac;
am__strip_dir = `echo $$p | sed -e 's|^.*/||'`;
am__installdirs = "$(DESTDIR)$(libCocoadir)" \
"$(DESTDIR)$(libstreamsdir)" "$(DESTDIR)$(pkglibdir)"
"$(DESTDIR)$(libikarusdir)" "$(DESTDIR)$(libstreamsdir)" \
"$(DESTDIR)$(pkglibdir)"
dist_libCocoaDATA_INSTALL = $(INSTALL_DATA)
dist_libikarusDATA_INSTALL = $(INSTALL_DATA)
dist_libstreamsDATA_INSTALL = $(INSTALL_DATA)
dist_pkglibDATA_INSTALL = $(INSTALL_DATA)
DATA = $(dist_libCocoa_DATA) $(dist_libstreams_DATA) \
$(dist_pkglib_DATA)
DATA = $(dist_libCocoa_DATA) $(dist_libikarus_DATA) \
$(dist_libstreams_DATA) $(dist_pkglib_DATA)
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
ACLOCAL = @ACLOCAL@
AMTAR = @AMTAR@
@ -163,6 +165,8 @@ top_builddir = @top_builddir@
top_srcdir = @top_srcdir@
libstreamsdir = $(pkglibdir)/streams
dist_libstreams_DATA = streams/primitive.ss streams/derived.ss
libikarusdir = $(pkglibdir)/ikarus
dist_libikarus_DATA = ikarus/foreign.ss
libCocoadir = $(pkglibdir)/Cocoa
dist_libCocoa_DATA = Cocoa/helpers.ss
dist_pkglib_DATA = streams.ss match.ss pregexp.ss gl.ss glut.ss \
@ -218,6 +222,23 @@ uninstall-dist_libCocoaDATA:
echo " rm -f '$(DESTDIR)$(libCocoadir)/$$f'"; \
rm -f "$(DESTDIR)$(libCocoadir)/$$f"; \
done
install-dist_libikarusDATA: $(dist_libikarus_DATA)
@$(NORMAL_INSTALL)
test -z "$(libikarusdir)" || $(MKDIR_P) "$(DESTDIR)$(libikarusdir)"
@list='$(dist_libikarus_DATA)'; for p in $$list; do \
if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
f=$(am__strip_dir) \
echo " $(dist_libikarusDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(libikarusdir)/$$f'"; \
$(dist_libikarusDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(libikarusdir)/$$f"; \
done
uninstall-dist_libikarusDATA:
@$(NORMAL_UNINSTALL)
@list='$(dist_libikarus_DATA)'; for p in $$list; do \
f=$(am__strip_dir) \
echo " rm -f '$(DESTDIR)$(libikarusdir)/$$f'"; \
rm -f "$(DESTDIR)$(libikarusdir)/$$f"; \
done
install-dist_libstreamsDATA: $(dist_libstreams_DATA)
@$(NORMAL_INSTALL)
test -z "$(libstreamsdir)" || $(MKDIR_P) "$(DESTDIR)$(libstreamsdir)"
@ -289,7 +310,7 @@ check-am: all-am
check: check-am
all-am: Makefile $(DATA)
installdirs:
for dir in "$(DESTDIR)$(libCocoadir)" "$(DESTDIR)$(libstreamsdir)" "$(DESTDIR)$(pkglibdir)"; do \
for dir in "$(DESTDIR)$(libCocoadir)" "$(DESTDIR)$(libikarusdir)" "$(DESTDIR)$(libstreamsdir)" "$(DESTDIR)$(pkglibdir)"; do \
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
done
install: install-am
@ -334,7 +355,8 @@ info: info-am
info-am:
install-data-am: install-dist_libCocoaDATA install-dist_libstreamsDATA
install-data-am: install-dist_libCocoaDATA install-dist_libikarusDATA \
install-dist_libstreamsDATA
install-dvi: install-dvi-am
@ -368,7 +390,7 @@ ps: ps-am
ps-am:
uninstall-am: uninstall-dist_libCocoaDATA \
uninstall-am: uninstall-dist_libCocoaDATA uninstall-dist_libikarusDATA \
uninstall-dist_libstreamsDATA uninstall-dist_pkglibDATA
.MAKE: install-am install-strip
@ -376,15 +398,16 @@ uninstall-am: uninstall-dist_libCocoaDATA \
.PHONY: all all-am check check-am clean clean-generic distclean \
distclean-generic distdir dvi dvi-am html html-am info info-am \
install install-am install-data install-data-am \
install-dist_libCocoaDATA install-dist_libstreamsDATA \
install-dist_pkglibDATA install-dvi install-dvi-am \
install-exec install-exec-am install-html install-html-am \
install-info install-info-am install-man install-pdf \
install-pdf-am install-ps install-ps-am install-strip \
installcheck installcheck-am installdirs maintainer-clean \
maintainer-clean-generic mostlyclean mostlyclean-generic pdf \
pdf-am ps ps-am uninstall uninstall-am \
uninstall-dist_libCocoaDATA uninstall-dist_libstreamsDATA \
install-dist_libCocoaDATA install-dist_libikarusDATA \
install-dist_libstreamsDATA install-dist_pkglibDATA \
install-dvi install-dvi-am install-exec install-exec-am \
install-html install-html-am install-info install-info-am \
install-man install-pdf install-pdf-am install-ps \
install-ps-am install-strip installcheck installcheck-am \
installdirs maintainer-clean maintainer-clean-generic \
mostlyclean mostlyclean-generic pdf pdf-am ps ps-am uninstall \
uninstall-am uninstall-dist_libCocoaDATA \
uninstall-dist_libikarusDATA uninstall-dist_libstreamsDATA \
uninstall-dist_pkglibDATA
# Tell versions [3.59,3.63) of GNU make to not export all variables.

17
lib/ikarus/foreign.ss Normal file
View File

@ -0,0 +1,17 @@
(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
pointer->integer integer->pointer pointer? dlopen dlsym
dlclose dlerror
make-callout make-callback)
(import (ikarus system $foreign)))

26
lib/objc.ss
View File

@ -61,7 +61,7 @@
(define (pointer-ref addr offset)
(assert (pointer? addr))
(integer->pointer (pointer-ref-long addr offset)))
(integer->pointer (pointer-ref-signed-long addr offset)))
(define (offset? x) (or (fixnum? x) (bignum? x)))
@ -75,7 +75,7 @@
(define (char*len x)
(let f ([i 0])
(cond
[(zero? (pointer-ref-uchar x i)) i]
[(zero? (pointer-ref-unsigned-char x i)) i]
[else (f (+ i 1))])))
(define (char*->bv x)
@ -85,7 +85,7 @@
(cond
[(= i n) bv]
[else
(bytevector-u8-set! bv i (pointer-ref-uchar x i))
(bytevector-u8-set! bv i (pointer-ref-unsigned-char x i))
(f (+ i 1))])))))
(define (bv->char* x)
@ -183,7 +183,7 @@
(define (class-instance-size x)
(check 'class-instance-size class? x)
(pointer-ref-long (class-ptr x) objc-class-instance-size-offset))
(pointer-ref-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-int (ivar-ptr x) (* 2 ptrsize)))
(pointer-ref-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-long p 0)])
(let ([n (pointer-ref-signed-long p 0)])
(let f ([i 0] [off objc-ivarlist-ivars-offset])
(if (= i n)
'()
@ -312,11 +312,11 @@
(cond
[(assq what alist) => cadr]
[else (error 'class-is? "invalid what" what)])])
(= mask (bitwise-and mask (pointer-ref-long (class-ptr x) (* ptrsize 4))))))
(= mask (bitwise-and mask (pointer-ref-signed-long (class-ptr x) (* ptrsize 4))))))
(define (class-methods x)
(define (methods x)
(let ([n (pointer-ref-int x ptrsize)]
(let ([n (pointer-ref-signed-int x ptrsize)]
[array (integer->pointer (+ (pointer->integer x) (* 2 ptrsize)))])
(let f ([i 0])
(if (= i n)
@ -354,7 +354,7 @@
(cons
(make-class
(integer->pointer
(pointer-ref-long buffer (* ptrsize i))))
(pointer-ref-signed-long buffer (* ptrsize i))))
ac)))))))))
(define (nil? x)
@ -569,9 +569,9 @@
[(class) 'pointer]
[(void) 'void]
[(float) 'float]
[(uint) 'uint32]
[(int) 'sint32]
[(char) 'sint8]
[(uint) 'unsigned-int]
[(int) 'signed-int]
[(char) 'signed-char]
[(char*) 'pointer]
[else (error 'objc-type->ikarus-type "invalid type" x)])]))
@ -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-ffi
(let ([ffi (make-callout
(objc-type->ikarus-type rtype)
(map objc-type->ikarus-type argtypes))])
(let ([proc (ffi mptr)])

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

@ -54,6 +54,9 @@
(define-record-type library (fields name pointer))
(define (load-shared-object libname)
(unless (string? libname)
(error 'load-shared-object "library name must be a string"
libname))
(make-library libname
(or (dlopen libname)
(error 'load-shared-object (dlerror) libname))))
@ -184,7 +187,7 @@
(define (strlen x)
(let f ([i 0])
(cond
[(= 0 (pointer-ref-uchar x i)) i]
[(= 0 (pointer-ref-unsigned-char x i)) i]
[else (f (+ i 1))])))
(let ([n (strlen x)])
(let ([s (make-string n)])
@ -192,7 +195,8 @@
(if (= i n)
s
(begin
(string-set! s i (integer->char (pointer-ref-uchar x i)))
(string-set! s i
(integer->char (pointer-ref-unsigned-char x i)))
(f (+ i 1))))))))
(define-syntax convert-return
@ -213,7 +217,7 @@
[double double]
[void* pointer]
[byte* pointer]
[int sint32]))
[int signed-int]))
(define (valid x)
(cond
[(and (list? x) (= (length x) 3) (eq? (car x) 'c-callback))
@ -250,7 +254,7 @@
(with-syntax ([x x]
[(t* ...) (generate-temporaries #'(arg-type* ...))])
#'(let ([callout
((make-ffi
((make-callout
(convert-type return-type)
(list (convert-type arg-type*) ...))
(lookup-shared-object lib 'foreign-name))])

186
scheme/ikarus.pointers.ss
View File

@ -2,10 +2,19 @@
(library (ikarus.pointers)
(export pointer? integer->pointer pointer->integer
dlopen dlerror dlclose dlsym malloc free
pointer-ref-char pointer-ref-short pointer-ref-int pointer-ref-long
pointer-ref-uchar pointer-ref-ushort pointer-ref-uint pointer-ref-ulong
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
make-ffi make-callback)
pointer-set-pointer pointer-ref-pointer
pointer-set-float pointer-ref-float
pointer-set-double pointer-ref-double
make-callout make-callback)
(import
(except (ikarus)
pointer?
@ -41,15 +50,18 @@
(and p (utf8->string p)))))
(define dlopen
(case-lambda
[(x) (dlopen x #t #t)]
[(x lazy? global?)
(define (open x)
(foreign-call "ikrt_dlopen" x lazy? global?))
(cond
[(not x) (open #f)]
[(string? x) (open (string->utf8 x))]
[else (die 'dlopen "name should be a string or #f" x)])]))
(let ()
(define (open x lazy? global?)
(foreign-call "ikrt_dlopen" x lazy? global?))
(case-lambda
[()
(open #f #f #f)]
[(x)
(dlopen x #f #f)]
[(x lazy? global?)
(cond
[(string? x) (open (string->utf8 x) lazy? global?)]
[else (die 'dlopen "library name must be a string" x)])])))
(define dlclose
(lambda (x)
@ -93,34 +105,74 @@
(define-syntax define-setter
(syntax-rules ()
[(_ name foreign-name)
[(_ name pred? foreign-name)
(define name
(lambda (p i v)
(if (pointer? p)
(if (fixnum? i)
(if (or (fixnum? v) (bignum? v))
(if (pred? v)
(foreign-call foreign-name p i v)
(die 'name "value must be a fixnum or bignum" v))
(die 'name
(format "value must satisfy the predicate ~a" 'pred?)
v))
(die 'name "index is not a fixnum" i))
(die 'name "not a pointer" p))))]))
(define-getter pointer-ref-char "ikrt_ref_char")
(define-getter pointer-ref-short "ikrt_ref_short")
(define-getter pointer-ref-int "ikrt_ref_int")
(define-getter pointer-ref-long "ikrt_ref_long")
(define-getter pointer-ref-uchar "ikrt_ref_uchar")
(define-getter pointer-ref-ushort "ikrt_ref_ushort")
(define-getter pointer-ref-uint "ikrt_ref_uint")
(define-getter pointer-ref-ulong "ikrt_ref_ulong")
(define (int? x) (or (fixnum? x) (bignum? x)))
(define-setter pointer-set-char "ikrt_set_char")
(define-setter pointer-set-short "ikrt_set_short")
(define-setter pointer-set-int "ikrt_set_int")
(define-setter pointer-set-long "ikrt_set_long")
(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-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")
;;; libffi interface
(define (checker who)
(define (checker t)
(cond
[(vector? t)
(let ([t* (vector-map checker t)])
(lambda (v)
(and (vector? v)
(let ([n (vector-length v)])
(and (= n (vector-length t))
(let f ([i 0])
(or (= i n)
(and ((vector-ref t* i) (vector-ref v i))
(f (+ i 1))))))))))]
[else
(case t
[(unsigned-char) int?]
[(signed-char) int?]
[(unsigned-short) int?]
[(signed-short) int?]
[(unsigned-int) int?]
[(signed-int) int?]
[(unsigned-long) int?]
[(signed-long) int?]
[(float) flonum?]
[(double) flonum?]
[(pointer) pointer?]
[else (die who "invalid type" t)])]))
checker)
(define (ffi-prep-cif rtype argtypes)
(define who 'ffi-prep-cif)
(define (convert x)
@ -128,18 +180,18 @@
[(vector? x) (vector-map convert x)]
[else
(case x
[(void) 1]
[(uint8) 2]
[(sint8) 3]
[(uint16) 4]
[(sint16) 5]
[(uint32) 6]
[(sint32) 7]
[(uint64) 8]
[(sint64) 9]
[(float) 10]
[(double) 11]
[(pointer) 12]
[(void) 1]
[(unsigned-char) 2]
[(signed-char) 3]
[(unsigned-short) 4]
[(signed-short) 5]
[(unsigned-int) 6]
[(signed-int) 7]
[(unsigned-long) 8]
[(signed-long) 9]
[(float) 10]
[(double) 11]
[(pointer) 12]
[else (die who "invalid type" x)])]))
(unless (list? argtypes)
(die who "arg types is not a list" argtypes))
@ -150,31 +202,55 @@
argtypes-n
rtype-n)))
(define (make-ffi rtype argtypes)
(define who 'make-ffi)
(define (make-callout rtype argtypes)
(define who 'make-callout)
(let-values ([(cif argtypes-n rtype-n)
(ffi-prep-cif rtype argtypes)])
(lambda (cfun)
(define data (vector cif cfun argtypes-n rtype-n))
(unless (pointer? cfun)
(die 'ffi "not a pointer" cfun))
(lambda args
(let ([argsvec (list->vector args)])
(unless (= (vector-length argsvec)
(vector-length argtypes-n))
(error 'ffi "args mismatch" argtypes args))
(foreign-call "ikrt_ffi_call" data argsvec))))))
(let* ([argtypes-vec (list->vector argtypes)]
[checkers (vector-map (checker who) argtypes-vec)])
(lambda (cfun)
(define data (vector cif cfun argtypes-n rtype-n))
(unless (pointer? cfun)
(die who "not a pointer" cfun))
(lambda args
(let ([argsvec (list->vector args)])
(unless (= (vector-length argsvec)
(vector-length argtypes-vec))
(error 'callout-procedure "arg length mismatch"
(vector->list argtypes-vec)
args))
(vector-for-each
(lambda (p? t x)
(unless (p? x)
(die 'callout-procedure
(format "argument does not match type ~a" t)
x)))
checkers argtypes-vec argsvec)
(foreign-call "ikrt_ffi_call" data argsvec)))))))
(define (make-callback rtype argtypes)
(let-values ([(cif argtypes-n rtype-n)
(ffi-prep-cif rtype argtypes)])
(lambda (proc)
(define who 'make-callback)
(define data (vector cif proc argtypes-n rtype-n))
(unless (procedure? proc)
(die who "not a procedure"))
(or (foreign-call "ikrt_prepare_callback" data)
(die who "cannot prepare foreign callback")))))
(let ([proc
(cond
[(eq? rtype 'void) proc]
[else
(let ([p? ((checker who) rtype)])
(lambda args
(let ([v (apply proc args)])
(unless (p? v)
(die 'callback
(format "returned value does not match type ~a"
rtype)
v))
v)))])])
(let ([data (vector cif proc argtypes-n rtype-n)])
(or (foreign-call "ikrt_prepare_callback" data)
(die who "cannot prepare foreign callback")))))))
)

2
scheme/last-revision
View File

@ -1 +1 @@
1617
1620

52
scheme/makefile.ss
View File

@ -1455,29 +1455,35 @@
[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-char $for]
[pointer-ref-short $for]
[pointer-ref-int $for]
[pointer-ref-long $for]
[pointer-ref-uchar $for]
[pointer-ref-ushort $for]
[pointer-ref-uint $for]
[pointer-ref-ulong $for]
[pointer-set-char $for]
[pointer-set-short $for]
[pointer-set-int $for]
[pointer-set-long $for]
[make-ffi $for]
[make-callback $for]
[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]
))

18
scheme/tests/pointers.ss
View File

@ -90,7 +90,7 @@
(let ([m (getter p 0)])
(free p)
m))])
(unless (= n m)
(unless (= n m)
(error 'test "failed" getter setter n m))))
combinations))
@ -115,14 +115,14 @@
(for-each check-combinations '(8 16 32 64))
(test-pointer-values)
(test-ref/set 'char (s* 8) pointer-ref-char pointer-set-char)
(test-ref/set 'short (s* 16) pointer-ref-short pointer-set-short)
(test-ref/set 'int (s* 32) pointer-ref-int pointer-set-int)
(test-ref/set 'long (s* 64) pointer-ref-long pointer-set-long)
(test-ref/set 'uchar (u* 8) pointer-ref-uchar pointer-set-char)
(test-ref/set 'ushort (u* 16) pointer-ref-ushort pointer-set-short)
(test-ref/set 'uint (u* 32) pointer-ref-uint pointer-set-int)
(test-ref/set 'ulong (u* 64) pointer-ref-ulong pointer-set-long)
(test-ref/set 'char (s* 8) pointer-ref-signed-char pointer-set-char)
(test-ref/set 'short (s* 16) pointer-ref-signed-short pointer-set-short)
(test-ref/set 'int (s* 32) pointer-ref-signed-int pointer-set-int)
(test-ref/set 'long (s* 64) pointer-ref-signed-long pointer-set-long)
(test-ref/set 'uchar (u* 8) pointer-ref-unsigned-char pointer-set-char)
(test-ref/set 'ushort (u* 16) pointer-ref-unsigned-short pointer-set-short)
(test-ref/set 'uint (u* 32) pointer-ref-unsigned-int pointer-set-int)
(test-ref/set 'ulong (u* 64) pointer-ref-unsigned-long pointer-set-long)
)

86
src/ikarus-pointers.c
View File

@ -43,13 +43,26 @@ make_pointer(long int x, ikpcb* pcb) {
return r+vector_tag;
}
#define bnfst_negative(x) \
(((unsigned long int)(x)) & bignum_sign_mask)
static long
integer_to_long(ikptr x) {
if (is_fixnum(x)) {
return ((long)x) >> fx_shift;
} else {
if(bnfst_negative(ref(x, -vector_tag))){
return -(long)ref(x, wordsize-vector_tag);
} else {
return (long)ref(x, wordsize-vector_tag);
}
}
}
ikptr
ikrt_fx_to_pointer(ikptr x, ikpcb* pcb) {
return make_pointer(unfix(x), pcb);
}
#define bnfst_negative(x) \
(((unsigned long int)(x)) & bignum_sign_mask)
ikptr
ikrt_bn_to_pointer(ikptr x, ikpcb* pcb) {
if(bnfst_negative(ref(x, -vector_tag))){
@ -152,6 +165,67 @@ ikrt_ref_ushort(ikptr p, ikptr off /*, ikpcb* pcb*/) {
return fix(*((unsigned short*)(((long)ref(p, off_pointer_data)) + unfix(off))));
}
ikptr
ikrt_ref_pointer(ikptr p, ikptr off, ikpcb* pcb) {
long idx = integer_to_long(off);
void* ptr = (void*)ref(p, off_pointer_data);
return make_pointer(ref(ptr, idx), pcb);
}
ikptr
ikrt_set_pointer(ikptr p, ikptr off, ikptr v /*, ikpcb* pcb*/) {
long idx = integer_to_long(off);
void* ptr = (void*)ref(p, off_pointer_data);
ref(ptr, idx) = ref(v, off_pointer_data);
return void_object;
}
static ikptr
double_to_flonum(double x, ikpcb* pcb){
ikptr r = ik_safe_alloc(pcb, flonum_size) + vector_tag;
ref(r, -vector_tag) = flonum_tag;
flonum_data(r) = x;
return r;
}
ikptr
ikrt_set_float(ikptr p, ikptr off, ikptr v /*, ikpcb* pcb*/) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
*((float*)(ptr+idx)) = flonum_data(v);
return void_object;
}
ikptr
ikrt_ref_float(ikptr p, ikptr off, ikpcb* pcb) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
double v = *((float*)(ptr+idx));
return double_to_flonum(v, pcb);
}
ikptr
ikrt_set_double(ikptr p, ikptr off, ikptr v /*, ikpcb* pcb*/) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
*((double*)(ptr+idx)) = flonum_data(v);
return void_object;
}
ikptr
ikrt_ref_double(ikptr p, ikptr off, ikpcb* pcb) {
long idx = integer_to_long(off);
ikptr ptr = ref(p, off_pointer_data);
double v = *((double*)(ptr+idx));
return double_to_flonum(v, pcb);
}
ikptr
s_to_number(signed long n, ikpcb* pcb) {
ikptr fx = fix(n);
@ -234,16 +308,18 @@ long
extract_num(ikptr x) {
if (is_fixnum(x)) {
return unfix(x);
} else if (x == void_object) {
return 0;
} else {
if (x == void_object) { return 0; }
if(bnfst_negative(ref(x, -vector_tag))){
if (bnfst_negative(ref(x, -vector_tag))){
return (long)(-ref(x, wordsize-vector_tag));
} else {
return (long)(ref(x, wordsize-vector_tag));
}
}
}
}
ikptr
ikrt_set_char(ikptr p, ikptr off, ikptr v/*, ikpcb* pcb*/) {
*((signed char*)(((long)ref(p, off_pointer_data)) + unfix(off))) =