diff --git a/doc/ikarus-scheme-users-guide.pdf b/doc/ikarus-scheme-users-guide.pdf index 4dae00d..74979cc 100644 Binary files a/doc/ikarus-scheme-users-guide.pdf and b/doc/ikarus-scheme-users-guide.pdf differ diff --git a/doc/ikarus-scheme-users-guide.tex b/doc/ikarus-scheme-users-guide.tex index 5385d9c..26f9034 100644 --- a/doc/ikarus-scheme-users-guide.tex +++ b/doc/ikarus-scheme-users-guide.tex @@ -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) + # + > (malloc 10000) + # +\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 + # + > (define libc-atan-ptr (dlsym libc "atan")) + > libc-atan-ptr + # + > (define libc-atan + ((make-callout 'double '(double)) libc-atan-ptr)) + > libc-atan + # + > (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} diff --git a/lab/objc-create-class.ss b/lab/objc-create-class.ss index d85b8f3..51b080d 100755 --- a/lab/objc-create-class.ss +++ b/lab/objc-create-class.ss @@ -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]) + diff --git a/lib/Cocoa/helpers.ss b/lib/Cocoa/helpers.ss index d0ed0f4..59f7399 100644 --- a/lib/Cocoa/helpers.ss +++ b/lib/Cocoa/helpers.ss @@ -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) diff --git a/lib/Makefile.am b/lib/Makefile.am index 17af419..4f72f63 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -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 diff --git a/lib/Makefile.in b/lib/Makefile.in index 69976c8..60c27b1 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -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. diff --git a/lib/ikarus/foreign.ss b/lib/ikarus/foreign.ss new file mode 100644 index 0000000..d536b5d --- /dev/null +++ b/lib/ikarus/foreign.ss @@ -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))) + diff --git a/lib/objc.ss b/lib/objc.ss index c1e8c87..5e92127 100644 --- a/lib/objc.ss +++ b/lib/objc.ss @@ -61,7 +61,7 @@ (define (pointer-ref addr offset) (assert (pointer? addr)) - (integer->pointer (pointer-ref-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)]) diff --git a/lib/ypsilon-compat.ikarus.ss b/lib/ypsilon-compat.ikarus.ss index d9fe5f6..318f7d8 100644 --- a/lib/ypsilon-compat.ikarus.ss +++ b/lib/ypsilon-compat.ikarus.ss @@ -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))]) diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index 686b78e..f48f08a 100644 --- a/scheme/ikarus.pointers.ss +++ b/scheme/ikarus.pointers.ss @@ -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"))))))) ) diff --git a/scheme/last-revision b/scheme/last-revision index f800fc8..c772079 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1617 +1620 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 8df923d..8a69fbe 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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] )) diff --git a/scheme/tests/pointers.ss b/scheme/tests/pointers.ss index 25398b1..bade174 100644 --- a/scheme/tests/pointers.ss +++ b/scheme/tests/pointers.ss @@ -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) ) diff --git a/src/ikarus-pointers.c b/src/ikarus-pointers.c index 27d16a6..adf1bd1 100644 --- a/src/ikarus-pointers.c +++ b/src/ikarus-pointers.c @@ -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))) =