psdir = @psdir@
INST_TARGETS = @INST_TARGETS@
-SUBDIRS = imail ref-manual sos user-manual
+SUBDIRS = ffi imail ref-manual sos user-manual
DISTCLEAN_FILES = Makefile make-common config.log config.status
all:
install-info-gz install-info:
$(mkinstalldirs) $(DESTDIR)$(infodir)
- test ! -e $(DESTDIR)$(infodir)/dir \
- && $(INSTALL_DATA) info-dir $(DESTDIR)$(infodir)/dir
+ if [ ! -e $(DESTDIR)$(infodir)/dir ]; then \
+ $(INSTALL_DATA) info-dir $(DESTDIR)$(infodir)/dir; fi
@for D in $(SUBDIRS); do \
echo "making $@ in $${D}";\
( cd $${D} && $(MAKE) $@ ) || exit 1;\
AC_CONFIG_FILES([
Makefile
make-common
+ ffi/Makefile
imail/Makefile
ref-manual/Makefile
sos/Makefile
--- /dev/null
+# $Id: $
+# doc/ffi/Makefile.in
+
+@SET_MAKE@
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+
+SOURCES = ffi.texinfo ../../src/ffi/prhello.cdecl ../../src/ffi/prhello.scm
+TARGET_ROOT = mit-scheme-ffi
+
+include $(top_srcdir)/make-common
--- /dev/null
+\input texinfo @c -*-Texinfo-*-
+@comment $Id: $
+@comment %**start of header
+@setfilename mit-scheme-ffi
+@set VERSION 0.1
+@settitle FFI @value{VERSION}
+@comment %**end of header
+
+@macro myresult{}
+@ifhtml
+ =>
+@end ifhtml
+@ifnothtml
+ @result{}
+@end ifnothtml
+@end macro
+
+@copying
+This manual documents @acronym{FFI} @value{VERSION}.
+
+Copyright @copyright{} 2006, 2007, 2008, 2009 Matthew Birkholz
+
+@quotation
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.2 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
+and with the Back-Cover Texts as in (a) below. A copy of the
+license is included in the section entitled ``GNU Free Documentation
+License.''
+
+(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
+this GNU Manual, like GNU software. Copies published by the Free
+Software Foundation raise funds for GNU development.''
+@end quotation
+@end copying
+
+@dircategory Programming Languages
+@direntry
+* FFI: (mit-scheme-ffi). MIT/GNU Scheme Foreign Functions
+@end direntry
+
+@titlepage
+@title The FFI Reference Manual
+@subtitle a Foreign Function Interface (@value{VERSION})
+@subtitle for MIT/GNU Scheme version 7.7.90+
+@author by Matt Birkholz
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@ifnottex
+@node Top, Introduction, (dir), (dir)
+@top FFI
+
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction:: A synopsis and quick summary.
+* C Declarations:: Declare C types and functions.
+* Alien Data:: Manipulate C data.
+* Alien Functions:: Generate callout trampolines and call them.
+* Callbacks:: Generate callback trampolines and get interrupted by them.
+* Compiling and Linking:: Build and install the shim.
+* Hello World:: A short example.
+* GNU Free Documentation License::
+@end menu
+
+
+@node Introduction, C Declarations, Top, Top
+@chapter Introduction
+
+This FFI provides syntax for calling C functions and accessing C data
+structures from Scheme. The functions and data structures, as well as
+any callback functions, are first declared in a case sensitive
+@file{.cdecl} file, which is used by a shim generator to produce
+callout and callback trampoline functions. The trampolines are then
+compiled and linked to the C toolkit, and may be linked into the
+Scheme machine or into a shared object that Scheme can dynamically
+load.
+
+@heading Synopsis
+
+Examples of the new syntax:
+
+@example
+(C-include "prhello")
+
+@group
+(malloc (C-sizeof "GdkEvent"))
+@myresult{} #[alien 42 0x081afc60]
+@end group
+
+@group
+(C-> @verb{"#@42"} "GdkEvent any type")
+@myresult{} 14
+@end group
+
+(C->= @verb{"#@42"} "GdkEvent any type" 13)
+
+@group
+(C-enum "GDK_MAP")
+@myresult{} 14
+@end group
+
+@group
+(C-enum "GdkEventType" 14)
+@myresult{} |GDK_MAP|
+@end group
+
+@group
+(C-sizeof "GdkColor")
+@myresult{} 12
+@end group
+
+@group
+(C-offset "GdkColor blue")
+@myresult{} 8
+@end group
+
+@group
+(C-array-loc @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_NORMAL"))
+@myresult{} #[alien 44 0x081afc60] @r{; New alien.}
+@end group
+
+@group
+(C-array-loc! @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_PRELIGHT"))
+@myresult{} #[alien 43 0x081afc78] @r{; Modified alien.}
+@end group
+
+@group
+(C-call "gtk_window_new" retval args @dots{})
+@myresult{} #!unspecific
+@end group
+
+@group
+(C-callback "delete_event")
+@myresult{} #[alien-function 44 Scm_delete_event]
+@end group
+
+@group
+(C-callback (lambda (window event) @dots{}))
+@myresult{} 13 @r{; A fixnum registration ID.}
+@end group
+
+@end example
+@comment The C-array-loc! example assumes 2 GdkColors are 6 words, #x18bytes.
+@comment 0x081afc78 - 0x081afc60 = 0x18
+
+@heading Summary
+
+A Scheme-like declaration of a toolkit's C functions, constants, and
+data types is given in a case sensitive @file{.cdecl} file. The C
+declarations look like this:
+
+@smallexample
+(extern (* GtkWidget) @r{; gtk+-2.4.0/gtk/gtkwindow.h}
+ gtk_window_new
+ (type GtkWindowType))
+
+(typedef GtkWindowType @r{; gtk+-2.4.0/gtk/gtkenums.h}
+ (enum
+ (GTK_WINDOW_TOPLEVEL)
+ (GTK_WINDOW_POPUP)))
+@end smallexample
+
+The @strong{@code{c-generate}} procedure reads these declarations and
+writes three files: @file{@i{library}-types.bin} (a fasdump of the
+parsed declarations), @file{@i{library}-const.c} (a C program that
+prints C constants and struct offsets), and @file{@i{library}-shim.c}
+(trampoline functions adapting Scheme procedure application to C
+function call). The @file{-const.c} program generates a
+@file{-const.scm} file, which can be syntaxed to produce a
+@file{-const.bin} file.
+
+@smallexample
+(load-option 'FFI)
+(c-generate "prhello" "#include <gtk/gtk.h>")
+@end smallexample
+
+The @file{-types.bin} and @file{-const.bin} files together provide
+the information needed to expand @code{C-...} syntax, and are only
+needed at syntax time. The @file{-shim.c} file is used at run time,
+linked into the Scheme machine or a shared object. @ref{Compiling and
+Linking}, which describes these files in more detail, and shows how
+they might be built and installed.
+
+@smallexample
+(C-include "prhello")
+@end smallexample
+
+The @strong{@code{C-include}} syntax loads the @file{-types.bin} and
+@file{-const.bin} files @emph{at syntax time}. It should appear
+at the top level of any file containing @code{C-...} syntax, or be
+evaluated in the syntax environment of such code.
+
+The @strong{@code{C-call}} syntax arranges to invoke a callout
+trampoline. Arguments to the trampoline can be integers, floats,
+strings or aliens (non-heap pointers, to C data structures,
+@pxref{Alien Data}).
+
+@smallexample
+(let ((alien (make-alien '|GtkWidget|)))
+ (C-call "gtk_window_new" alien type)
+ (if (alien-null? alien) (error "could not open new window"))
+ alien)
+@end smallexample
+
+The @strong{@code{C-callback}} syntax is used when registering a
+Scheme callback trampoline. The two forms of the syntax provide two
+arguments for the registration function: the callback trampoline's
+address, and a ``user data'' argument. When the toolkit calls the
+trampoline, it must provide the fixnum-sized user data as an argument.
+
+@smallexample
+(C-call "g_signal_connect" window "delete_event"
+ (C-callback "delete_event") ; @r{@i{e.g. &Scm_delete_event}}
+ (C-callback ; @r{@i{e.g. 314}}
+ (lambda (window event)
+ (C-call "gtk_widget_destroy" window)
+ 0)))
+@end smallexample
+
+The first use of @code{C-callback} (above) expands into a callback
+trampoline address --- an alien function. The second use evaluates to
+a fixnum, which is associated with the given Scheme procedure.
+
+The @strong{@code{C->}} and @strong{@code{C->=}} syntaxes peek and
+poke values into alien data structures. They take an alien and a
+constant string specifying the alien data type and the member to be
+accessed (if any).
+
+@smallexample
+@group
+(C-> alien "GdkRectangle y")
+@expansion{}
+(#[primitive c-peek-int] alien 4)
+@end group
+
+@group
+(C->= alien "GdkRectangle width" 0)
+@expansion{}
+(#[primitive c-poke-int] alien 8 0)
+@end group
+@end smallexample
+
+@smallexample
+@group
+(C-> alien "GdkEvent any type")
+@expansion{}
+(#[primitive c-peek-int] alien 0)
+@end group
+@end smallexample
+
+@smallexample
+@group
+(C-> alien "gfloat")
+@expansion{}
+(#[primitive c-peek-float] alien 0)
+@end group
+@end smallexample
+
+A three argument form of the syntax provides an alien to receive a
+peeked pointer. This avoids consing a new alien.
+
+@smallexample
+(C-> alien "* mumble" alien)
+@end smallexample
+
+The above syntax is understood to say ``The data at this @code{alien}
+address is a pointer to @code{mumble}. Load the mumble's address into
+@code{alien}, clobbering @code{alien}'s old address.'' Note that the
+pointer declaration is in reverse polish ``Scheme style'', with the
+\verb|*| operator placed ahead of the target type.
+
+The @strong{@code{C-enum}}, @strong{@code{C-sizeof}} and
+@strong{@code{C-offset}} syntaxes all
+transform into integer constants. The last two transform into a padded
+byte size and a byte offset respectively.
+
+@smallexample
+@group
+(C-enum "GTK_WINDOW_POPUP")
+@expansion{}
+1
+@end group
+
+@group
+(C-sizeof "GdkColor")
+@expansion{}
+12
+@end group
+
+@group
+(C-offset "GdkColor blue")
+@expansion{}
+8
+@end group
+
+@end smallexample
+
+The two element form of the @code{C-enum} syntax can be used to find
+the name of a constant given its runtime value. It expects the name
+of an enum type in a constant string. If the runtime (second)
+argument is not one of the constants declared by that type, the
+returned value is @code{#f}.
+
+@smallexample
+@group
+(C-enum "GdkEventType" (C-> @verb{"#@42"} "GdkEvent any type"))
+@myresult{}
+|GDK_MAP|
+@end group
+@end smallexample
+
+The @strong{@code{c-array-loc}} and @strong{@code{c-array-loc!}}
+syntaxes compute the locations of C array elements. They can be used
+to advance a scan pointer or locate an element by its index. The
+examples in the synopsis might expand as shown here.
+
+@smallexample
+(C-array-loc @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_NORMAL"))
+@expansion{}
+(alien-byte-increment @verb{"#@43"} (* (C-sizeof "GdkColor")
+ (C-enum "GTK_STATE_NORMAL")))
+@expansion{}
+(alien-byte-increment @verb{"#@43"} 0)
+@myresult{}
+@verb{"#@44"}
+
+(C-array-loc! @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_PRELIGHT"))
+@expansion{}
+(alien-byte-increment! @verb{"#@43"} (* (C-sizeof "GdkColor")
+ (C-enum "GTK_STATE_PRELIGHT")))
+@expansion{}
+(alien-byte-increment! @verb{"#@43"} 24)
+@myresult{}
+@verb{"#@43"}
+@end smallexample
+
+A simple scan of characters in the wide string @code{alien} might
+look like this.
+
+@smallexample
+(let ((len (C-> alien "toolkit_string_type int_member"))
+ (scan (C-> alien "toolkit_string_type array_member")))
+ (let loop ((n 0))
+ (if (< n len)
+ (let ((wchar (C-> scan "wchar")))
+ (process wchar)
+ (C-array-loc! scan "wchar" 1)
+ (loop (1+ n))))))
+@end smallexample
+
+That is a quick look at the facilities. The next section describes
+the C declaration language, and the following sections examine the FFI's
+syntax and runtime facilities in detail. Final sections provide an
+example program and show how its dynamically loaded shim is built.
+
+
+@node C Declarations, Alien Data, Introduction, Top
+@chapter C Declarations
+
+A shim between Scheme and a C toolkit is specified by a case sensitive
+@file{.cdecl} file containing Scheme-like declarations of all relevant
+toolkit types, constants, and functions. Callback functions to be
+passed to the toolkit are also specified here.
+
+There are some limitations on the C types that can be declared.
+Basic, struct, union, enum and pointer types are allowed, but
+bit-field members are not supported. C function parameters can be
+basic, enum or pointer types. The return type of a C function is the
+same plus @code{void}. Basically, no struct or union argument or
+return types, at the moment.
+
+Each top-level form in the C declaration file must look like one of
+these:
+
+@smallexample
+(include "filename")
+(typedef Name @var{any})
+(struct Name (Member @var{type}) @dots{})
+(union Name (Member @var{type}) @dots{})
+(enum @i{Name} (Member) @dots{})
+(extern @var{return-type} Name (param1 @var{arg-type}) @dots{})
+(callback @var{return-type} Name (param1 @var{arg-type}) @dots{})
+@end smallexample
+
+An enum's @i{@var{Name}} is optional.
+
+@var{arg-type} is currently restricted to the following forms. It is
+assumed that a lone @var{Name} is defined as a type on this list:
+
+@smallexample
+Name
+@var{basics}
+(* @var{any})
+(enum Name)
+(enum @i{Name} (Member) @dots{})
+@end smallexample
+
+@var{return-type} can be either @var{arg-type} or the word @code{void}.
+
+@var{basics} can be any of the words: @code{char}, @code{uchar},
+@code{short}, @code{ushort}, @code{int}, @code{uint}, @code{long},
+@code{ulong}, @code{float}, or @code{double} (all lowercase).
+
+@var{type} includes structs and unions:
+
+@smallexample
+@var{arg-type}
+(struct Name)
+(struct @i{Name} (Member @var{type}) @dots{})
+(union Name)
+(union @i{Name} (Member @var{type}) @dots{})
+@end smallexample
+
+@var{any} is any @var{type} @emph{or} @code{void}.
+
+The @code{include} expression includes another @file{.cdecl} file in
+the current @file{.cdecl} file. The string argument is interpreted
+relative to the current file's directory.
+
+While the informal grammar above allows anonymous structs to be
+specified for argument or member types, they are of little use outside
+top-level, @i{named} struct or union declarations. The peek and poke
+(@code{C->} and @code{C->=}) syntax expects a type name (e.g.
+@code{"GdkEventAny"} or @code{"struct _GdkEventAny"}) before any
+member names.
+
+@smallexample
+(C-include "prhello")
+@end smallexample
+
+The @strong{@code{C-include}} syntax takes a library name and loads
+the corresponding @file{-types} and @file{-const} files at syntax
+time. This makes the C types and constants available to the other
+@code{C-...} syntax expanders. The form binds @code{c-includes} in
+the syntax environment @i{unless} it is already defined there. Thus a
+@code{(C-includes "library")} form can be placed at the top of every
+file with @code{C-...} syntax, @emph{or} loaded into the syntax-time
+environment of those files.
+
+
+@node Alien Data, Alien Functions, C Declarations, Top
+@chapter Alien Data
+
+A C data structure is represented by an alien containing the data
+structure's memory address. ``Peek'' primitives are available to read
+pointers and the basic C types (e.g. ints, floats) at small (fixnum)
+offsets from an alien's address. They return to Scheme an alien
+address, integer or flonum as appropriate. ``Poke'' primitives
+do the reverse, storing pointers, integers or floats at fixnum offsets
+from alien addresses.
+Other procedures on aliens are @code{alien?},
+@code{alien-null?}, @code{alien-null!}, @code{copy-alien}, @code{alien=?},
+@code{alien-byte-increment}, and @code{c-peek-cstring}. Refer to
+@file{ffi.pkg} in The Source for a complete list.
+
+The @code{C->} and @code{C->=} syntaxes apply the peek and poke
+primitives to constant offsets. They expect their first argument
+subform to be a constant string --- space-separated words naming a C
+type and any member to be accessed. A member within a struct or union
+member is specified by appending its name. For example @code{"struct
+_GdkEvent any window"} would specify a peek at the @code{window}
+member of the @code{any} member of the @code{struct _GdkEvent} data at
+some alien address. Note that the final member's type must be a basic
+C type, pointer type, or enum type. Otherwise, an error is signaled
+at syntax time.
+
+@smallexample
+@group
+(C-> alien "struct _GdkEvent any window" window-alien)
+@expansion{}
+(#[primitive c-peek-pointer] alien 0 window-alien)
+@myresult{}
+#[alien 44 (* GdkWindow) 0x081afc60]
+@end group
+@end smallexample
+
+Note that in the example above, the final member has a pointer type.
+In this case an extra alien argument can be provided to receive the
+peeked pointer. Otherwise a new alien is created and returned.
+
+@heading Malloc
+
+The @code{malloc} procedure returns an alien that will automatically
+free the malloced memory when it is garbage collected.
+It can also be explicitly freed with the @code{free} procedure. The alien
+address can be incremented to scan the malloced memory, then freed
+(without returning it to the original, malloced address). A band
+restore marks all malloced aliens as though they have been freed.
+
+@smallexample
+(free (malloc '|GdkRectangle|))
+@end smallexample
+
+In general, if a callout returns a pointer to a toolkit resource that
+should be freed, some care is necessary. Typically such a resource is
+registered with a weak reference to a Scheme representative. When the
+representative disappears (is garbage collected), the resource is
+freed. The callout trampoline might cons a fresh alien and return it
+to Scheme, to be registered for later freeing, but an interrupt
+between the return and the registration may leave the
+alien un-registered, never to be freed.
+
+@smallexample
+ (let* ((alien (make-alien)))
+ (c-call "library_function" alien)
+ ;; An interrupt or non-local exit here can drop the alien resource.
+ (register-alien-to-free! alien)
+ ...mumble...
+ (c-free alien))
+@end smallexample
+
+To close the hole a null alien can be allocated and registered
+@emph{before} the callout. If something interrupts normal execution
+before the callout trampoline can write to it, and the continuation is
+eventually abandoned, the null alien will be swept up in the next GC,
+but not erroneously freed. If the alien is dropped immediately after
+the trampoline returns to Scheme, it will still be swept up and, no
+longer null, properly freed.
+
+@smallexample
+ (let* ((alien (make-alien '|GdkRectangle|)))
+ (register-alien-to-free! alien)
+ ;; Prepared to free the resource whether allocated or not.
+ (c-call "library_function" alien)
+ ...mumble...
+ (c-free alien))
+@end smallexample
+
+
+@node Alien Functions, Callbacks, Alien Data, Top
+@chapter Alien Functions
+
+The @code{C-call} syntax produces code that applies @code{call-alien}
+to an alien function structure --- a cache for the callout
+trampoline's entry address.
+
+@smallexample
+@group
+(C-call "gtk_button_new" (make-alien '(* |GtkWidget|)))
+@expansion{}
+(call-alien '#[alien-function gtk_button_new] (make-alien @dots{}))
+@end group
+@end smallexample
+
+The alien function contains all the information needed to load the
+callout trampoline on demand (i.e. its name and library). Once the
+alien function has cached the entry address, @code{call-alien} can
+invoke the trampoline (via @code{#[primitive c-call]}). The
+trampoline gets its arguments off the Scheme stack, converts them to C
+values, calls the C function, conses a result, and returns it to
+Scheme. As a special case a function returning a pointer type
+expects an extra first argument. If this argument is @code{#f}, the
+return value is discarded. If the argument is an alien, the
+function's return value clobbers the alien's address. This makes it
+easy to grab pointers to toolkit resources without dropping them, or
+avoid unnecessary consing of aliens.
+
+The @code{alien-function} structures are fasdumpable. The caching
+mechanism invalidates the cache when a band is restored, or a
+fasdumped object is fasloaded. The alien function will lookup the
+trampoline entry point again on demand.
+
+
+@node Callbacks, Compiling and Linking, Alien Functions, Top
+@chapter Callbacks
+
+A callback declaration must include a parameter named ``ID''. The ID
+argument will be used to find the Scheme callback procedure. It must
+be the same ``user data'' value provided to the toolkit when the
+callback was registered. For example, a callback trampoline named
+@code{Scm_delete_event} might be declared like this:
+
+@smallexample
+(callback gint
+ delete_event
+ (window (* GtkWidget))
+ (event (* GdkEventAny))
+ (ID gpointer))
+@end smallexample
+
+The callback might be registered with the toolkit like this:
+
+@smallexample
+(C-call "g_signal_connect" window "delete_event"
+ (C-callback "delete_event") ; @r{@i{e.g. &Scm_delete_event}}
+ (C-callback ; @r{@i{e.g. 314}}
+ (lambda (window event)
+ (C-call "gtk_widget_destroy" window)
+ 0)))
+@end smallexample
+
+The toolkit's registration function, @code{g_signal_connect}, would be
+declared like this:
+
+@smallexample
+(extern void
+ g_signal_connect
+ (object (* GtkObject))
+ (name (* gchar))
+ (CALLBACK GtkSignalFunc)
+ (ID gpointer))
+@end smallexample
+
+This function should have parameters named @code{CALLBACK} and
+@code{ID}. The callout trampoline will convert the callback argument
+from a Scheme alien function to an entry address. The @code{ID} argument
+will be converted to a C integer and then cast to its declared type
+(in this example, @code{gpointer}).
+
+Note that the registered callback procedures are effectively pinned.
+They cannot be garbage collected. They are ``on call'' to handle
+callbacks from the toolkit until they are explicitly de-registered. A
+band restore automatically de-registers all callbacks.
+
+The callback procedures are executed like an interrupt handler. They
+actually interrupt the thread executing the most recent callout,
+e.g. to @code{gtk_main}. The thread runs with thread switching
+disabled for the duration of the callback, and can callout to the
+toolkit, which can callback again. The (nested) callbacks and nested
+callouts all run in the same thread, and so will return in LIFO order
+as expected by the toolkit. Note that the runtime system will not
+balk at a callback procedure that calls @code{yield-thread}, waits for
+I/O, sleeps, or otherwise causes a thread switch. Presumably such a
+procedure has some other way of enforcing the LIFO ordering.
+
+The @code{outf-console} procedure is provided for debugging purposes.
+It writes one or more argument strings (and @code{write}s any
+non-strings) to the console and flushes, atomically, via a machine
+primitive, bypassing the runtime's I/O buffering and thread switching.
+Thus multiple debugging trace messages arrive on the console intact
+and uninterrupted.
+
+
+@node Compiling and Linking, Hello World, Callbacks, Top
+@chapter Compiling and Linking
+
+The @strong{@code{c-generate}} procedure takes a library name and an
+optional prefix. It reads the @file{@i{library}.cdecl} file and
+writes two @file{.c} files. The prefix is included at the top of
+both. It typically contains @code{#include} C pre-processor
+directives required by the C library, but could include additional
+shim code. Here is a short script that generates a shim for the
+example ``Hello, World!'' program.
+
+@smallexample
+(load-option 'FFI)
+(c-generate "prhello" "#include <gtk/gtk.h>")
+@end smallexample
+
+This script will produce three files:
+
+@table @file
+
+@item prhello-shim.c
+This file contains the trampoline functions --- one for each declared
+C extern or callback. It includes the @file{mit-scheme.h} header
+file, found in the @code{AUXDIR} directory ---
+e.g. @file{/usr/local/lib/mit-scheme/}.
+
+@item prhello-const.c
+This file contains a C program that creates
+@file{prhello-const.scm}. It is compiled and linked
+as normal for programs using the toolkit, and does not depend on the
+Scheme machine. It does not actually call any
+toolkit functions. It just collects information from the compiler
+about the declared C types and constants.
+
+@item prhello-types.bin
+This file is a fasdumped @code{c-includes} structure containing all of
+the types, constants and functions declared in the @file{.cdecl} file.
+
+@end table
+
+The following Makefile rules describe the process of building and
+installing a shim for the example ``Hello, World!'' program.
+
+@example
+@comment INCLUDE ../../src/ffi/Makefile-fragment FROM /^install-example:/ TO END
+@verbatim
+install-example: build-example
+ $(INSTALL_DATA) prhello-types.bin /usr/local/lib/mit-scheme/lib/.
+ $(INSTALL_DATA) prhello-const.bin /usr/local/lib/mit-scheme/lib/.
+ $(INSTALL_DATA) prhello-shim.so /usr/local/lib/mit-scheme/lib/.
+
+build-example: prhello-shim.so prhello-types.bin prhello-const.bin
+
+prhello-shim.so: prhello-shim.o
+ $(CC) -shared -fPIC -o $@ $^ `pkg-config --libs gtk+-2.0`
+
+prhello-shim.o: prhello-shim.c
+ $(CC) -I../lib -Wall -fPIC `pkg-config --cflags gtk+-2.0` -o $@ -c $<
+
+prhello-shim.c prhello-const.c prhello-types.bin: prhello.cdecl
+ (echo "(load-option 'FFI)"; \
+ echo '(C-generate "prhello" "#include <gtk/gtk.h>")') \
+ | mit-scheme --batch-mode
+
+prhello-const.bin: prhello-const.scm
+ echo '(sf "prhello-const")' | mit-scheme --compiler --batch-mode
+
+prhello-const.scm: prhello-const
+ ./prhello-const
+
+prhello-const: prhello-const.o
+ @rm -f $@
+ $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ `pkg-config --libs gtk+-2.0`
+
+prhello-const.o: prhello-const.c
+ $(CC) `pkg-config --cflags gtk+-2.0` $(CFLAGS) -o $@ -c $<
+@end verbatim
+@end example
+
+
+@node Hello World, GNU Free Documentation License, Compiling and Linking, Top
+@chapter Hello World
+
+This
+@iftex
+chapter
+@end iftex
+@ifnottex
+node
+@end ifnottex
+includes the C declarations and Scheme code required to implement
+Havoc Pennington's Hello World example from
+@uref{http://developer.gnome.org/doc/GGAD/, GGAD}. For an extra,
+Schemely treat, its @code{delete_event} callback is a Scheme procedure
+closed over a binding of @code{counter} that is used to implement some
+impertinent behavior.
+@example
+@verbatiminclude ../../src/ffi/prhello.scm
+@end example
+
+Here are the C declarations.
+@example
+@verbatiminclude ../../src/ffi/prhello.cdecl
+@end example
+
+To run the example, first build and install its shim per the example
+Makefile rules in @ref{Compiling and Linking}. Then enter the
+following three lines at your Scheme REPL:
+
+@smallexample
+@verbatim
+ (load-option 'FFI)
+ (load "prhello.scm")
+ (hello)
+@end verbatim
+@end smallexample
+
+You might also syntax the Scheme code first. The syntactic
+transformers of the FFI will again be needed.
+
+@smallexample
+@verbatim
+ (load-option 'FFI)
+ (cf "prhello.scm")
+@end verbatim
+@end smallexample
+
+The resulting @file{prhello.com} file can be loaded and run with just
+your FFI-enhanced runtime. The FFI option is no longer needed. In a
+fresh mit-scheme machine, you can enter just these two lines.
+
+@smallexample
+@verbatim
+ (load "prhello")
+ (hello)
+@end verbatim
+@end smallexample
+
+
+@node GNU Free Documentation License, , Hello World, Top
+@appendix GNU Free Documentation License
+
+@center Version 1.2, November 2002
+
+@display
+Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc.
+51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+@end display
+
+@enumerate 0
+@item
+PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document @dfn{free} in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of ``copyleft'', which means that derivative
+works of the document must themselves be free in the same sense. It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does. But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book. We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@item
+APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License. Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein. The ``Document'', below,
+refers to any such manual or work. Any member of the public is a
+licensee, and is addressed as ``you''. You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A ``Modified Version'' of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A ``Secondary Section'' is a named appendix or a front-matter section
+of the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall
+subject (or to related matters) and contains nothing that could fall
+directly within that overall subject. (Thus, if the Document is in
+part a textbook of mathematics, a Secondary Section may not explain
+any mathematics.) The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The ``Invariant Sections'' are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License. If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant. The Document may contain zero
+Invariant Sections. If the Document does not identify any Invariant
+Sections then there are none.
+
+The ``Cover Texts'' are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License. A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A ``Transparent'' copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters. A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text. A copy that is not ``Transparent'' is called ``Opaque''.
+
+Examples of suitable formats for Transparent copies include plain
+@sc{ascii} without markup, Texinfo input format, La@TeX{} input
+format, @acronym{SGML} or @acronym{XML} using a publicly available
+@acronym{DTD}, and standard-conforming simple @acronym{HTML},
+PostScript or @acronym{PDF} designed for human modification. Examples
+of transparent image formats include @acronym{PNG}, @acronym{XCF} and
+@acronym{JPG}. Opaque formats include proprietary formats that can be
+read and edited only by proprietary word processors, @acronym{SGML} or
+@acronym{XML} for which the @acronym{DTD} and/or processing tools are
+not generally available, and the machine-generated @acronym{HTML},
+PostScript or @acronym{PDF} produced by some word processors for
+output purposes only.
+
+The ``Title Page'' means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page. For works in
+formats which do not have any title page as such, ``Title Page'' means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+A section ``Entitled XYZ'' means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language. (Here XYZ stands for a
+specific section name mentioned below, such as ``Acknowledgements'',
+``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title''
+of such a section when you modify the Document means that it remains a
+section ``Entitled XYZ'' according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document. These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@item
+VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License. You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute. However, you may accept
+compensation in exchange for copies. If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@item
+COPYING IN QUANTITY
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document's license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover. Both covers must also clearly and legibly identify
+you as the publisher of these copies. The front cover must present
+the full title with all words of the title equally prominent and
+visible. You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@item
+MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it. In addition, you must do these things in the Modified Version:
+
+@enumerate A
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document). You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document's license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled ``History'', Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page. If
+there is no section Entitled ``History'' in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on. These may be placed in the ``History'' section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
+the Title of the section, and preserve in the section all the
+substance and tone of each of the contributor acknowledgements and/or
+dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles. Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled ``Endorsements''. Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled ``Endorsements'' or
+to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant. To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled ``Endorsements'', provided it contains
+nothing but endorsements of your Modified Version by various
+parties---for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version. Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity. If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@item
+COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy. If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled ``History''
+in the various original documents, forming one section Entitled
+``History''; likewise combine any sections Entitled ``Acknowledgements'',
+and any sections Entitled ``Dedications''. You must delete all
+sections Entitled ``Endorsements.''
+
+@item
+COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@item
+AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an ``aggregate'' if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation's users beyond what the individual works permit.
+When the Document is included an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document's Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@item
+TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections. You may include a
+translation of this License, and all the license notices in the
+Document, and any Warrany Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers. In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled ``Acknowledgements'',
+``Dedications'', or ``History'', the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@item
+TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document except
+as expressly provided for under this License. Any other attempt to
+copy, modify, sublicense or distribute the Document is void, and will
+automatically terminate your rights under this License. However,
+parties who have received copies, or rights, from you under this
+License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+@item
+FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns. See
+@uref{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License ``or any later version'' applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation. If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.
+@end enumerate
+
+@page
+@appendixsec ADDENDUM: How to use this License for your documents
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@smallexample
+@group
+ Copyright (C) @var{year} @var{your name}.
+ Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.2
+ or any later version published by the Free Software Foundation;
+ with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
+ A copy of the license is included in the section entitled ``GNU
+ Free Documentation License''.
+@end group
+@end smallexample
+
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the ``with...Texts.'' line with this:
+
+@smallexample
+@group
+ with the Invariant Sections being @var{list their titles}, with
+ the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
+ being @var{list}.
+@end group
+@end smallexample
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+@bye
<html>
+<!-- $Id: $ -->
<head><title>MIT/GNU Scheme Documentation</title></head>
<li><a href="mit-scheme-user/index.html">MIT/GNU Scheme User's Manual</a></li>
<li><a href="mit-scheme-sos/index.html">SOS Reference Manual</a></li>
<li><a href="mit-scheme-imail/index.html">IMAIL User's Manual</a></li>
+<li><a href="mit-scheme-ffi/index.html">FFI User's Manual</a></li>
</ul>
</body>
# **** END BOILERPLATE ****
LIARC_BOOT_BUNDLES = compiler cref sf star-parser
-LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin imail sos ssp xml
+LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml
SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc
INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES)
all: @ALL_TARGET@
all-native: compile-microcode
- @$(top_srcdir)/etc/compile.sh mit-scheme-native --compiler
+ @$(top_srcdir)/etc/compile.sh mit-scheme-native --compiler --batch-mode
$(MAKE) build-bands
all-liarc:
- @$(top_srcdir)/etc/c-compile.sh mit-scheme-c --compiler
+ @$(top_srcdir)/etc/c-compile.sh mit-scheme-c --compiler --batch-mode
$(MAKE) compile-liarc-bundles build-bands
compile-microcode:
The core subsystem consists of these directories:
* "microcode" contains the C code that is used to build the executable
- programs "scheme" and "bchscheme".
+ program "scheme".
* "runtime" contains the bulk of the run-time library, including
almost everything documented in the reference manual.
* "xml" contains support for XML and XHTML I/O.
+* "ffi" provides syntax for calling foreign (C) functions and
+ manipulating alien (C) data.
+
The compiler subsystem consists of these three directories:
* "sf" contains a program that translates Scheme source code to an
tar xzf mit-scheme-7.7.1-ix86-gnu-linux.tar.gz # If not already
cp -fp scheme-7.7.1/src/microcode/scheme bin/.
- cp -fp scheme-7.7.1/src/microcode/bchscheme bin/.
Clobbering/replacing the copies of the binary release microcode
file(s) shouldn't disturb you since, presumably, the main reason
. etc/functions.sh
-INSTALLED_SUBDIRS="cref edwin imail sf sos ssp star-parser xml"
+INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml"
OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode"
# lib
maybe_link lib/optiondb.scm ../etc/optiondb.scm
maybe_link lib/runtime ../runtime
maybe_link lib/utabmd.bin ../microcode/utabmd.bin
+maybe_link lib/mit-scheme.h ../microcode/pruxffi.h
+maybe_link lib/ffi ../ffi
for SUBDIR in ${INSTALLED_SUBDIRS} ${OTHER_SUBDIRS}; do
echo "setting up ${SUBDIR}"
compiler/Makefile
cref/Makefile
edwin/Makefile
+ffi/Makefile
imail/Makefile
runtime/Makefile
sf/Makefile
for BN in star-parser; do
(cd lib; rm -f ${BN}; ${LN_S} ../${BN} .)
done
- for BUNDLE in 6001 compiler cref edwin imail sf sos ssp star-parser xdoc xml; do
+ for BUNDLE in 6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml; do
SO=${BUNDLE}.so
(cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .)
done
(with-working-directory-pathname "sos"
(lambda ()
(load "load")))
- (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp")))
+ (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp" "ffi")))
(define (compile-boot-dirs compile-dir)
(compile-cref compile-dir)
run_cmd ln -s machines/"${MDIR}" compiler/machine
run_cmd ln -s machine/compiler.pkg compiler/.
-BUNDLES="6001 compiler cref edwin imail sf sos ssp star-parser xdoc xml"
+BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml"
: ${MIT_SCHEME_EXE='mit-scheme'}
-run_cmd ${MIT_SCHEME_EXE} --heap 4000 <<EOF
+run_cmd ${MIT_SCHEME_EXE} --heap 4000 --batch-mode <<EOF
(begin
(load "etc/utilities")
(generate-c-bundles (quote (${BUNDLES})) "${MDIR}"))
for SUBDIR in ${BUNDLES} runtime win32; do
echo "creating ${SUBDIR}/Makefile.in"
rm -f ${SUBDIR}/Makefile.in
- cat etc/std-makefile-prefix > ${SUBDIR}/Makefile.in
- cat ${SUBDIR}/Makefile-fragment >> ${SUBDIR}/Makefile.in
+ cat etc/std-makefile-prefix ${SUBDIR}/Makefile-fragment \
+ > ${SUBDIR}/Makefile.in
if test -f ${SUBDIR}/Makefile-bundle; then
cat ${SUBDIR}/Makefile-bundle >> ${SUBDIR}/Makefile.in
rm -f ${SUBDIR}/Makefile-bundle
(define-load-option 'CREF
(guarded-system-loader '(cross-reference) "cref"))
+(define-load-option 'FFI
+ (guarded-system-loader '(ffi) "ffi"))
+
(define-load-option 'IMAIL
(guarded-system-loader '(edwin imail) "imail"))
--- /dev/null
+#-*-Makefile-*-
+# $Id: $
+# ffi/Makefile-fragment
+
+TARGET_DIR = $(AUXDIR)/ffi
+
+install:
+ rm -rf $(DESTDIR)$(TARGET_DIR)
+ $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
+ $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) ffi-*.pkd $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) load.scm $(DESTDIR)$(TARGET_DIR)/.
+
+clean-example:
+ rm -rf prhello-shim.* prhello-types.bin
+ rm -rf prhello-const prhello-const.*
+
+install-example: build-example
+ $(INSTALL_DATA) prhello-types.bin /usr/local/lib/mit-scheme/lib/.
+ $(INSTALL_DATA) prhello-const.bin /usr/local/lib/mit-scheme/lib/.
+ $(INSTALL_DATA) prhello-shim.so /usr/local/lib/mit-scheme/lib/.
+
+build-example: prhello-shim.so prhello-types.bin prhello-const.bin
+
+prhello-shim.so: prhello-shim.o
+ $(CC) -shared -fPIC -o $@ $^ `pkg-config --libs gtk+-2.0`
+
+prhello-shim.o: prhello-shim.c
+ $(CC) -I../lib -Wall -fPIC `pkg-config --cflags gtk+-2.0` -o $@ -c $<
+
+prhello-shim.c prhello-const.c prhello-types.bin: prhello.cdecl
+ (echo "(load-option 'FFI)"; \
+ echo '(C-generate "prhello" "#include <gtk/gtk.h>")') \
+ | mit-scheme --batch-mode
+
+prhello-const.bin: prhello-const.scm
+ echo '(sf "prhello-const")' | mit-scheme --compiler --batch-mode
+
+prhello-const.scm: prhello-const
+ ./prhello-const
+
+prhello-const: prhello-const.o
+ @rm -f $@
+ $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ `pkg-config --libs gtk+-2.0`
+
+prhello-const.o: prhello-const.c
+ $(CC) `pkg-config --cflags gtk+-2.0` $(CFLAGS) -o $@ -c $<
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C Declarations
+;;; package: (ffi syntax)
+
+
+(define-structure (c-includes (conc-name c-includes/)
+ (constructor make-c-includes (library))
+ ;; To be fasdump/loadable.
+ (type vector) (named 'c-includes))
+ library ; String naming the DLL of trampolines (the shim).
+ (files '()) ;; Included file names and their modtimes when read.
+ (type-names '()) ;; E.g. ((gpointer (* mumble) . "prhello.cdecl")...)
+ (structs '()) ;; E.g. ((|_GdkColor| (struct ...) . "gdkcolor.cdecl")...)
+ (unions '()) ;; E.g. ((|_GdkEvent| (union ...) . "gdkevents.cdecl")...)
+ (enums '()) ;; E.g. ((|_cairo_status| (enum ...) . "cairo.cdecl")...)
+ (enum-constants'()) ;;E.g. ((|CAIRO_STATUS_SUCCESS| . "prhello.cdecl")...)
+ (callouts '()) ;; E.g. ((|gdk_window_new| . #<alien-function 42...>)...)
+ (callbacks '()) ;; E.g. ((|delete_event| . #<alien-function 42...>)...)
+ (enum-values '()) ;; E.g. ((|CAIRO_STATUS_SUCCESS| . 0)...) from groveler.
+ (struct-values'()) ;; List of struct info from the groveler:
+ ;; (((sizeof |GdkColor|) . 12)
+ ;; ((offset |GdkColor| pixel) . (0 . int))
+ ;; ((offset |GdkColor| red) . (4 . short))
+ ;; ((offset |GdkColor| green) . (6 . short))
+ ;; ((offset |GdkColor| blue) . (8 . short))
+ ;; ((sizeof (struct |_GdkColor|)) . 12)
+ ;; ((offset (struct |_GdkColor|) pixel) . (0 . int))
+ ;; ((offset (struct |_GdkColor|) red) . (4 . short))
+ ;; ((offset (struct |_GdkColor|) green) . (6 . short))
+ ;; ((offset (struct |_GdkColor|) blue) . (8 . short))...)
+ )
+
+(define (include-cdecls library)
+ ;; Toplevel entry point for the generator.
+ ;; Returns a new C-INCLUDES structure.
+ (let ((includes (make-c-includes library))
+ (cwd (if load/loading?
+ (directory-pathname (current-load-pathname))
+ (working-directory-pathname))))
+ (include-cdecl-file library cwd cwd includes)
+ includes))
+
+(define c-include-noisily? #t)
+(define current-filename)
+
+(define (include-cdecl-file filename cwd twd includes)
+ ;; Adds the C declarations in FILENAME to INCLUDES. Interprets
+ ;; FILENAME relative to CWD (current working directory).
+ ;; Abbreviates namestrings under TWD (topmost working, build directory).
+
+ (let* ((pathname (merge-pathnames
+ (pathname-default-type filename "cdecl") cwd))
+ (new-cwd (directory-pathname pathname))
+ (namestring (enough-namestring pathname twd))
+ (modtime (file-modification-time-indirect namestring))
+ (files (c-includes/files includes)))
+ (if (not (assoc namestring files))
+ (fluid-let ((current-filename namestring))
+ (set-c-includes/files! includes
+ (cons (cons namestring modtime) files))
+
+ (define (kernel)
+ (call-with-input-file namestring
+ (lambda (inport)
+ (let loop ()
+ (let ((form (parse-object inport read-environment)))
+ (if (not (eof-object? form))
+ (begin
+ (include-cdecl form new-cwd twd includes)
+ (loop))))))))
+
+ (if c-include-noisily?
+ (with-notification (lambda (port)
+ (write-string "Including " port)
+ (write-string namestring port))
+ kernel)
+ (kernel))))))
+
+(define read-environment
+ (make-top-level-environment '(*PARSER-CANONICALIZE-SYMBOLS?*) '(#f)))
+
+(define (include-cdecl form cwd twd includes)
+ ;; Add a top-level C declaration to INCLUDES. If it is an
+ ;; include, interprete the included filenames relative to CWD
+ ;; (current working directory).
+ (if (not (and (pair? form) (symbol? (car form)) (pair? (cdr form))))
+ (cerror form "malformed top level C declaration"))
+ (let ((keyword (car form))
+ (name (cadr form))
+ (rest (cddr form)))
+ (case keyword
+ ((|include|)
+ (for-each (lambda (file) (include-cdecl-file file cwd twd includes))
+ (cdr form)))
+ ((|typedef|) (include-typedef form name rest includes))
+ ((|struct|) (include-struct form name rest includes))
+ ((|union|) (include-union form name rest includes))
+ ((|enum|) (include-enum form name rest includes))
+ ((|extern|) (include-function form name rest includes))
+ ((|callback|) (include-function form name rest includes))
+ (else (cerror form "unknown top level keyword"))))
+ unspecific)
+
+(define (include-typedef form name rest includes)
+ ;; Add a top-level (typedef NAME . REST) C declaration to INCLUDES.
+ (if (not (and (symbol? name)
+ (pair? rest) (null? (cdr rest))))
+ (cerror form "malformed typedef declaration"))
+ (let* ((ctypes (c-includes/type-names includes))
+ (entry (assq name ctypes)))
+ (if entry (cerror form "already defined in " (cddr entry)))
+ (let* ((ctype (valid-ctype (car rest) includes))
+ (new (cons name (cons ctype current-filename))))
+ (set-c-includes/type-names! includes (cons new ctypes))
+ unspecific)))
+
+(define (include-struct form name members includes)
+ ;; Add a top-level (struct NAME . MEMBERS) C declaration to INCLUDES.
+ (if (not (and (symbol? name) (pair? members) (list? members)))
+ (cerror form "malformed named struct declaration"))
+ (let* ((structs (c-includes/structs includes))
+ (entry (assq name structs)))
+ (if entry (cerror form "already defined in " (cddr entry)))
+ (let* ((anon (cons 'STRUCT
+ (map (lambda (member)
+ (valid-struct-member member includes))
+ members)))
+ (info (cons anon current-filename)))
+ (set-c-includes/structs!
+ includes (cons (cons name info) structs))
+ unspecific)))
+
+(define (valid-struct-member form includes)
+ ;; Returns (NAME . CTYPE) given a MEMBER C declaration.
+ ;; Adds any internal named struct/union/enum types to INCLUDES.
+ (if (not (and (pair? form) (symbol? (car form))
+ (pair? (cdr form)) (null? (cddr form))))
+ (cerror form "malformed struct member"))
+ (let ((name (car form))
+ (ctype (valid-ctype (cadr form) includes)))
+ (cons name ctype)))
+
+(define (include-union form name members includes)
+ ;; Add a top-level (union NAME . MEMBERS) C declaration to INCLUDES.
+ (if (not (and (symbol? name) (pair? members) (list? members)))
+ (cerror form "malformed named union declaration"))
+ (let* ((unions (c-includes/unions includes))
+ (entry (assq name unions)))
+ (if entry (cerror form "already defined in " (cddr entry)))
+ (let* ((anon (cons 'UNION
+ (map (lambda (member)
+ (valid-union-member member includes))
+ members)))
+ (info (cons anon current-filename)))
+ (set-c-includes/unions!
+ includes (cons (cons name info) unions))
+ unspecific)))
+
+(define (valid-union-member form includes)
+ ;; Returns (NAME . CTYPE) given a MEMBER C declaration.
+ ;; Adds any internal named struct/union/enum types to INCLUDES.
+ (if (not (and (pair? form) (symbol? (car form))
+ (pair? (cdr form)) (null? (cddr form))))
+ (cerror form "malformed union member"))
+ (let ((name (car form))
+ (ctype (valid-ctype (cadr form) includes)))
+ (cons name ctype)))
+
+(define (include-enum form name constants includes)
+ ;; Add a top-level (enum NAME . CONSTANTS) C declaration to INCLUDES.
+ ;; Also accepts an unnamed (enum . CONSTANTS) C declaration.
+ (if (not (list? constants))
+ (cerror form "malformed named enum declaration"))
+ (if (symbol? name)
+ (let* ((enums (c-includes/enums includes))
+ (entry (assq name enums)))
+ (if entry (cerror form "already defined in " (cddr entry)))
+ (let* ((anon (cons 'ENUM
+ (valid-enum-constants constants includes)))
+ (info (cons anon current-filename)))
+ (set-c-includes/enums!
+ includes (cons (cons name info) enums))))
+ (valid-enum-constants (cdr form) includes)))
+
+(define (valid-enum-constants forms includes)
+ ;; Returns a list of (NAME) pairs for each enum constant declaration
+ ;; in FORMS. Also adds enum constants to INCLUDES.
+ (let loop ((forms forms))
+ (if (null? forms) '()
+ (let ((name (valid-enum-constant (car forms) includes)))
+ (cons name (loop (cdr forms)))))))
+
+(define (valid-enum-constant form includes)
+ ;; Returns (NAME), the name of the validated enum constant declared
+ ;; by FORM. Immediately adds the constant to the list in INCLUDES,
+ ;; checking that it is not already there.
+ (if (not (and (pair? form) (symbol? (car form))
+ ;; 1 or 2 args
+ (or (null? (cdr form))
+ (and (pair? (cdr form)) (null? (cddr form))))))
+ (cerror form "malformed enum constant declaration"))
+ (if (pair? (cdr form))
+ (cwarn (cadr form) "ignored enum value"))
+ (let* ((name (car form))
+ (constants (c-includes/enum-constants includes))
+ (entry (assq name constants)))
+ (if entry (cerror form "already defined in " (cdr entry)))
+ (set-c-includes/enum-constants!
+ includes (cons (cons name current-filename) constants))
+ (list name)))
+
+(define (include-function form rettype rest includes)
+ ;; Callouts/backs have much in common here, thus this shared
+ ;; procedure, which uses the keyword still at the head of FORM to
+ ;; munge the correct alist in INCLUDES.
+ (if (not (and (pair? rest) (symbol? (car rest))
+ (list? (cdr rest))))
+ (cerror form "malformed "(symbol-name (car form))" declaration"))
+ (let* ((name (car rest))
+ (params (cdr rest))
+ (others (if (eq? 'EXTERN (car form))
+ (c-includes/callouts includes)
+ (c-includes/callbacks includes)))
+ (entry (assq name others)))
+ (if entry (cerror form "already defined in "
+ (alien-function/filename (cdr entry))))
+ (let ((new (cons name
+ (make-alien-function
+ (symbol-name name)
+ (c-includes/library includes)
+ (valid-ctype rettype includes)
+ (valid-params params includes)
+ current-filename))))
+ (if (eq? 'EXTERN (car form))
+ (set-c-includes/callouts! includes (cons new others))
+ (set-c-includes/callbacks! includes (cons new others)))
+ unspecific)))
+
+(define (valid-params forms includes)
+ ;; Returns a list -- (NAME CTYPE) for each parameter declaration
+ ;; form in FORMS.
+ (if (null? forms) '()
+ (cons (valid-param (car forms) includes)
+ (valid-params (cdr forms) includes))))
+
+(define (valid-param form includes)
+ ;; Returns (NAME CTYPE) after validating FORM.
+ (if (not (and (pair? form) (symbol? (car form))
+ (pair? (cdr form))
+ (null? (cddr form))))
+ (cerror form "malformed parameter declaration"))
+ (let ((name (car form))
+ (ctype (valid-ctype (cadr form) includes)))
+ (list name ctype)))
+
+(define (valid-ctype form includes)
+ ;; Returns a valid ctype expression, a copy of FORM. Modifies
+ ;; INCLUDES with any internal struct/union/enum declarations.
+ (cond ((symbol? form) form)
+ ((ctype/pointer? form) form)
+ ((ctype/const? form)
+ (list 'CONST (valid-ctype (cadr form) includes)))
+
+ ((ctype/struct-name? form) form)
+ ((ctype/struct-anon? form)
+ (cons 'STRUCT (map (lambda (member)
+ (valid-struct-member member includes))
+ (cdr form))))
+ ((ctype/struct-named? form)
+ (include-struct form (cadr form) (cddr form) includes)
+ (list 'STRUCT (cadr form)))
+
+ ((ctype/union-name? form) form)
+ ((ctype/union-anon? form)
+ (cons 'UNION (map (lambda (member)
+ (valid-union-member member includes))
+ (cdr form))))
+ ((ctype/union-named? form)
+ (include-union form (cadr form) (cddr form))
+ (list 'UNION (cadr form)))
+
+ ((ctype/enum-name? form) form)
+ ((ctype/enum-anon? form)
+ (cons 'ENUM (valid-enum-constants (cdr form) includes)))
+ ((ctype/enum-named? form)
+ (include-enum form (cadr form) (cddr form) includes)
+ (list 'ENUM (cadr form)))
+
+ ((ctype/array? form)
+ (list 'ARRAY
+ (valid-ctype (ctype-array/element-type form) includes)
+ (ctype-array/size form)))
+
+ (else (cerror form "bogus C type declaration"))))
+
+(define condition-type:cerror
+ (make-condition-type
+ 'ffi-cdecl-error
+ condition-type:error
+ '(FORM FILENAME MESSAGE)
+ (lambda (condition port)
+ (write-string "Error: " port)
+ (write-string (access-condition condition 'MESSAGE) port)
+ (write-string ":" port)
+ (write-string (access-condition condition 'FILENAME) port)
+ (write-string ": " port)
+ (write (access-condition condition 'FORM) port))))
+
+(define cerror
+ (let ((signaller (condition-signaller condition-type:cerror
+ '(FORM FILENAME MESSAGE)
+ standard-error-handler)))
+ (named-lambda (cerror form message . args)
+ (signaller form current-filename
+ (apply string-append
+ (map (lambda (obj)
+ (if (string? obj) obj (write-to-string obj)))
+ (cons message args)))))))
+
+(define condition-type:cwarn
+ (make-condition-type
+ 'ffi-cdecl-warning
+ condition-type:warning
+ '(FORM FILENAME MESSAGE)
+ (lambda (condition port)
+ (write-string (access-condition condition 'MESSAGE) port)
+ (write-string ":" port)
+ (write-string (access-condition condition 'FILENAME) port)
+ (write-string ": " port)
+ (write (access-condition condition 'FORM) port))))
+
+(define cwarn
+ (let ((signaller (condition-signaller condition-type:cwarn
+ '(FORM FILENAME MESSAGE)
+ standard-warning-handler)))
+ (named-lambda (cwarn form message . args)
+ (with-simple-restart 'MUFFLE-WARNING "Ignore warning."
+ (lambda ()
+ (signaller form current-filename
+ (apply string-append
+ (map (lambda (obj)
+ (if (string? obj) obj (write-to-string obj)))
+ (cons message args)))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Compile the FFI system. |#
+
+(load-option 'CREF)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (let ((ffi-files '("ctypes" "cdecls" "syntax" "generator")))
+
+ ;; Build an empty package for use at syntax-time.
+ ;; The imports should bind ucode-primitive (ffi).
+ (if (not (name->package '(FFI)))
+ (let ((package-set (package-set-pathname "ffi")))
+ (if (not (file-exists? package-set))
+ (cref/generate-trivial-constructor "ffi"))
+ (construct-packages-from-file (fasload package-set))))
+
+ ;; Syntax in (ffi).
+ (fluid-let ((sf/default-syntax-table (->environment '(ffi)))
+ (sf/default-declarations
+ (cons '(usual-integrations) sf/default-declarations)))
+ (for-each (lambda (f) (sf-conditionally f #t)) ffi-files))
+
+ ;; Cross-check.
+ (cref/generate-constructors "ffi" 'ALL)
+
+ ;; Compile.
+ (for-each compile-file ffi-files))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C Types and C Type Simplification
+;;; package: (ffi syntax)
+
+
+;;; C Types
+
+(define (ctype/basic? ctype)
+ ;; Returns #t iff CTYPE is a basic C type, e.g. char, int or double.
+ (and (symbol? ctype)
+ (not (eq? ctype '*))
+ (assq ctype peek-poke-primitives)))
+
+(define (ctype/pointer? ctype)
+ ;; Returns #t iff CTYPE is a pointer type, e.g. (* GtkWidget).
+ (or (eq? ctype '*)
+ (and (pair? ctype) (eq? '* (car ctype))
+ (pair? (cdr ctype)) (null? (cddr ctype)))))
+
+(define ctype-pointer/target-type cadr)
+
+(define (ctype/void? ctype)
+ (eq? ctype 'VOID))
+
+(define (ctype/const? ctype)
+ (and (pair? ctype) (eq? 'CONST (car ctype))
+ (pair? (cdr ctype)) (null? (cddr ctype))))
+
+(define ctype-const/qualified-type cadr)
+
+(define (ctype/struct-name? ctype)
+ ;; Returns #t iff CTYPE is a struct name, e.g. (struct _GValue).
+ (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ (pair? (cdr ctype)) (symbol? (cadr ctype))
+ (null? (cddr ctype))))
+
+(define (ctype/struct-anon? ctype)
+ ;; Returns #t iff CTYPE is an anonymous struct
+ ;; -- (struct (MEMBER . TYPE)...).
+ (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ (pair? (cdr ctype)) (pair? (cadr ctype))))
+
+(define (ctype/struct-named? ctype)
+ ;; Returns #t iff CTYPE is a named struct
+ ;; -- (struct NAME (MEMBER VALUE)...).
+ (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ (pair? (cdr ctype)) (symbol? (cadr ctype))
+ (pair? (cddr ctype)) (pair? (caddr ctype))))
+
+(define (ctype/struct-defn? ctype)
+ (or (ctype/struct-anon? ctype)
+ (ctype/struct-named? ctype)))
+
+(define (ctype-struct-defn/members ctype)
+ (cond ((ctype/struct-anon? ctype) (cdr ctype))
+ ((ctype/struct-named? ctype) (cddr ctype))
+ (else (error "Bogus C struct type:" ctype))))
+
+(define (ctype/struct? ctype)
+ (or (ctype/struct-name? ctype) (ctype/struct-defn? ctype)))
+
+(define (ctype-struct/name ctype)
+ ;; This works on a struct name as well as definitions.
+ (and (or (and (eq? 'STRUCT (car ctype))
+ (pair? (cdr ctype)))
+ (error:wrong-type-argument ctype "C struct type" 'ctype-struct/name))
+ (symbol? (cadr ctype))
+ (cadr ctype)))
+
+(define (make-ctype-struct name members)
+ (if name
+ (cons* 'STRUCT name members)
+ (cons 'STRUCT members)))
+
+(define (ctype/union-name? ctype)
+ ;; Returns #t iff CTYPE is a union name, e.g. (union _GdkEvent).
+ (and (pair? ctype) (eq? 'UNION (car ctype))
+ (pair? (cdr ctype)) (symbol? (cadr ctype))
+ (null? (cddr ctype))))
+
+(define (ctype/union-anon? ctype)
+ ;; Returns #t iff CTYPE is an anonymous union
+ ;; -- (union (MEMBER . TYPE)...).
+ (and (pair? ctype) (eq? 'UNION (car ctype))
+ (pair? (cdr ctype)) (pair? (cadr ctype))))
+
+(define (ctype/union-named? ctype)
+ ;; Returns #t iff CTYPE is a named union
+ ;; -- (union NAME (MEMBER TYPE)...).
+ (and (pair? ctype) (eq? 'UNION (car ctype))
+ (pair? (cdr ctype)) (symbol? (cadr ctype))
+ (pair? (cddr ctype)) (pair? (caddr ctype))))
+
+(define (ctype/union-defn? ctype)
+ (or (ctype/union-anon? ctype)
+ (ctype/union-named? ctype)))
+
+(define (ctype-union-defn/members ctype)
+ (cond ((ctype/union-named? ctype) (cddr ctype))
+ ((ctype/union-anon? ctype) (cdr ctype))
+ (else (error "Bogus C union type:" ctype))))
+
+(define (ctype/union? ctype)
+ (or (ctype/union-name? ctype) (ctype/union-defn? ctype)))
+
+(define (ctype-union/name ctype)
+ ;; This works on union names as well as definitions.
+ (and (or (and (eq? 'UNION (car ctype))
+ (pair? (cdr ctype)))
+ (error:wrong-type-argument ctype "C union type" 'ctype-union/name))
+ (symbol? (cadr ctype))
+ (cadr ctype)))
+
+(define (make-ctype-union name members)
+ (if name
+ (cons* 'UNION name members)
+ (cons 'UNION members)))
+
+(define (ctype/enum-name? ctype)
+ ;; Returns #t iff CTYPE is an enum name, e.g. (enum GdkEventType).
+ (and (pair? ctype) (eq? 'ENUM (car ctype))
+ (pair? (cdr ctype)) (symbol? (cadr ctype))
+ (null? (cddr ctype))))
+
+(define (ctype/enum-anon? ctype)
+ ;; Returns #t iff CTYPE is an anonymous enum
+ ;; -- (enum (CONSTANT . VALUE)...).
+ (and (pair? ctype) (eq? 'ENUM (car ctype))
+ (pair? (cdr ctype)) (pair? (cadr ctype))))
+
+(define (ctype/enum-named? ctype)
+ ;; Returns #t iff CTYPE is a named enum
+ ;; -- (enum NAME (CONSTANT . VALUE)...).
+ (and (pair? ctype) (eq? 'ENUM (car ctype))
+ (pair? (cdr ctype)) (symbol? (cadr ctype))
+ (pair? (cddr ctype)) (pair? (caddr ctype))))
+
+(define (ctype/enum-defn? ctype)
+ (or (ctype/enum-anon? ctype)
+ (ctype/enum-named? ctype)))
+
+(define (ctype-enum-defn/constants ctype)
+ (cond ((ctype/enum-named? ctype) (cddr ctype))
+ ((ctype/enum-anon? ctype) (cdr ctype))
+ (else (error "Bogus C enum type:" ctype))))
+
+(define (ctype/enum? ctype)
+ (or (ctype/enum-name? ctype) (ctype/enum-defn? ctype)))
+
+(define (ctype-enum/name ctype)
+ ;; This works on enum names as well as definitions.
+ (and (or (and (eq? 'ENUM (car ctype))
+ (pair? (cdr ctype)))
+ (error:wrong-type-argument ctype "C enum type" 'ctype-enum/name))
+ (symbol? (cadr ctype))
+ (cadr ctype)))
+
+(define (make-ctype-enum name constants)
+ (if name
+ (cons* 'ENUM name constants)
+ (cons 'ENUM constants)))
+
+(define (ctype/array? ctype)
+ ;; Returns #t iff CTYPE is an array type, e.g. (ARRAY (* GtkWidget) 5).
+ (and (pair? ctype) (eq? 'ARRAY (car ctype))
+ (pair? (cdr ctype))
+ (or (null? (cddr ctype))
+ (and (pair? (cddr ctype)) (null? (cdddr ctype))))))
+
+(define ctype-array/element-type cadr)
+
+(define (ctype-array/size ctype)
+ (and (pair? (cddr ctype)) (caddr ctype)))
+
+(define (make-ctype-array ctype size)
+ (list 'ARRAY ctype size))
+
+(define (ctype/primitive-accessor ctype)
+ ;; Returns the primitive to use when reading from CTYPE, a basic ctype.
+ (let ((entry (assq ctype peek-poke-primitives)))
+ (and entry
+ (car (cdr entry)))))
+
+(define (ctype/primitive-modifier ctype)
+ ;; Returns the primitive to use when writing to CTYPE, a basic ctype.
+ (let ((entry (assq ctype peek-poke-primitives)))
+ (and entry
+ (cadr (cdr entry)))))
+
+(define peek-poke-primitives
+ ;; Alist: basic type names x (prim-access prim-modify).
+ ;;
+ ;; A couple type converters in generator.scm depend on handling
+ ;; ALL of this list.
+ `((char ,(ucode-primitive c-peek-char 2) ,(ucode-primitive c-poke-char 3))
+ (uchar ,(ucode-primitive c-peek-uchar 2) ,(ucode-primitive c-poke-uchar 3))
+ (short ,(ucode-primitive c-peek-short 2) ,(ucode-primitive c-poke-short 3))
+ (ushort ,(ucode-primitive c-peek-ushort 2) ,(ucode-primitive c-poke-ushort 3))
+ (int ,(ucode-primitive c-peek-int 2) ,(ucode-primitive c-poke-int 3))
+ (uint ,(ucode-primitive c-peek-uint 2) ,(ucode-primitive c-poke-uint 3))
+ (long ,(ucode-primitive c-peek-long 2) ,(ucode-primitive c-poke-long 3))
+ (ulong ,(ucode-primitive c-peek-ulong 2) ,(ucode-primitive c-poke-ulong 3))
+ (float ,(ucode-primitive c-peek-float 2) ,(ucode-primitive c-poke-float 3))
+ (double ,(ucode-primitive c-peek-double 2) ,(ucode-primitive c-poke-double 3))
+ (* ,(ucode-primitive c-peek-pointer 3),(ucode-primitive c-poke-pointer 3))
+ ))
+\f
+
+;;; C Type Lookup
+
+(define (definite-ctype ctype includes)
+ ;; Returns a definite C type equivalent to CTYPE. If CTYPE is a
+ ;; name, e.g.
+ ;;
+ ;; |GdkColor|, (struct |_GdkColor|), (union |_GdkEvent|)
+ ;;
+ ;; returns the definite C type of its definition per INCLUDES. A
+ ;; definite C type is a basic type name, array or pointer type, or
+ ;; struct, union or enum names or definitions.
+
+ (let loop ((stack '())
+ (ctype ctype))
+ (cond ((or (ctype/basic? ctype)
+ (ctype/void? ctype)
+ (eq? 'ENUM ctype)
+ (eq? '* ctype)) ctype)
+ ((symbol? ctype)
+ (if (memq ctype stack)
+ (error "Circular definition of C type:" (car (last-pair stack))))
+ (let ((entry (assq ctype (c-includes/type-names includes))))
+ (if (not entry)
+ (error "Unknown type:" ctype)
+ (loop (cons ctype stack) (cadr entry)))))
+ ((ctype/const? ctype)
+ (loop stack (ctype-const/qualified-type ctype)))
+ ((or (ctype/array? ctype)
+ (ctype/pointer? ctype)
+ (ctype/struct? ctype)
+ (ctype/union? ctype)
+ (ctype/enum? ctype)) ctype)
+ (else
+ (error:wrong-type-argument ctype "a C type" 'definite-ctype)))))
+
+(define (ctype-definition ctype includes)
+ (let ((type (definite-ctype ctype includes)))
+ (cond ((or (ctype/basic? type)
+ (ctype/void? type)
+ (ctype/array? type)
+ (ctype/pointer? type)
+ (ctype/struct-defn? type)
+ (ctype/union-defn? type)
+ (ctype/enum-defn? type)
+ ;; Enum constants are not enumerated in -const.scm files.
+ (eq? 'ENUM type)) type)
+ ((ctype/struct-name? type)
+ (let ((entry (assq (cadr type) (c-includes/structs includes))))
+ (if (not entry)
+ (error "Unknown type:" type)
+ (cadr entry))))
+ ((ctype/union-name? type)
+ (let ((entry (assq (cadr type) (c-includes/unions includes))))
+ (if (not entry)
+ (error "Unknown type:" type)
+ (cadr entry))))
+ ((ctype/enum-name? type)
+ (let ((entry (assq (cadr type) (c-includes/enums includes))))
+ (if (not entry)
+ (error "Unknown type:" type)
+ (cadr entry))))
+ (else (error "Unexpected C type:" ctype)))))
\ No newline at end of file
--- /dev/null
+#| -*- Scheme -*-
+
+$Id: $
+
+FFI buffer packaging info |#
+
+(standard-scheme-find-file-initialization
+ '#(
+ ("ctypes" (ffi))
+ ("cdecls" (ffi))
+ ("syntax" (ffi))
+ ("generator" (ffi generate))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+FFI System Packaging |#
+
+(global-definitions "../runtime/runtime")
+
+(define-package (ffi)
+ (parent ())
+ (files "ctypes" "cdecls" "syntax")
+ (import (runtime)
+ ucode-primitive)
+ (import (runtime ffi)
+ make-alien-function
+ alien-function/filename)
+ (export ()
+ c-include
+ load-c-includes
+ c-include-noisily?
+ c->
+ c->=
+ c-enum
+ c-call
+ c-callback
+ c-sizeof
+ c-offset
+ c-array-loc
+ c-array-loc!))
+
+(define-package (ffi generator)
+ (parent (ffi))
+ (files "generator")
+ (import (runtime ffi)
+ alien-function/parameters
+ alien-function/return-type)
+ (export ()
+ c-generate))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Trampoline Generator
+;;; package: (ffi generator)
+
+
+(define c-generate-noisily? #t)
+
+(define (c-generate library #!optional prefix)
+ (let ((prefix (if (default-object? prefix) "" prefix))
+ (includes (include-cdecls library)))
+ (guarantee-string prefix 'c-generate)
+ (let ((shim.c (string-append library "-shim.c")))
+ (if c-generate-noisily?
+ (with-notification
+ (lambda (port)
+ (write-string "Generating " port)
+ (write shim.c port))
+ (lambda ()
+ (gen-trampolines shim.c prefix includes)))
+ (gen-trampolines shim.c prefix includes)))
+ (let ((const.c (string-append library "-const.c")))
+ (if c-generate-noisily?
+ (with-notification
+ (lambda (port)
+ (write-string "Generating " port)
+ (write (enough-namestring const.c) port))
+ (lambda ()
+ (gen-groveler const.c prefix includes)))
+ (gen-groveler const.c prefix includes)))
+ (let ((types.bin (string-append library "-types.bin")))
+ (fasdump includes types.bin (not c-generate-noisily?)))))
+
+(define (gen-trampolines pathname prefix includes)
+ (with-output-to-file pathname
+ (lambda ()
+ (write-string
+ (string-append
+ "/* -*-C-*- */
+
+#include <mit-scheme.h>
+
+/* Prefix */
+" prefix "
+/* End Prefix */
+"))
+ (gen-callout-trampolines includes)
+ (if (null? (c-includes/callbacks includes))
+ unspecific
+ (gen-callback-trampolines includes)))))
+\f
+
+;;; Callout Trampolines
+
+(define (gen-callout-trampolines includes)
+ (for-each
+ (lambda (name.alienf)
+ (with-simple-restart 'CONTINUE "Continue generating callout trampolines."
+ (lambda ()
+ (bind-condition-handler
+ (list condition-type:simple-error)
+ (lambda (condition)
+ (let ((restart (find-restart 'CONTINUE condition))
+ (msg (access-condition condition 'MESSAGE))
+ (irr (access-condition condition 'IRRITANTS)))
+ (apply warn msg irr)
+ (if restart
+ (invoke-restart restart))))
+ (lambda ()
+ (gen-callout-trampoline (car name.alienf) (cdr name.alienf)
+ includes))))))
+ (reverse (c-includes/callouts includes))))
+
+(define (gen-callout-trampoline name alien includes)
+ (let* ((ret-ctype (alien-function/return-type alien))
+ (params (alien-function/parameters alien))
+ (ret-var (callout-return-variable params)))
+
+ ;; The second part first.
+ (let ((tos-var (new-variable "tos" params)))
+ (let ((declares
+ (callout-part2-decls tos-var ret-var ret-ctype includes))
+ (restores
+ (callout-restores name tos-var ret-var ret-ctype includes))
+ (return
+ (callout-return tos-var ret-var ret-ctype includes))
+ (name (symbol-name name)))
+ (write-string
+ (string-append "
+SCM
+Scm_continue_"name" (void)
+\{
+ /* Declare. */" declares "
+
+ /* Restore. */" restores "
+
+ /* Return. */" return "
+}"))))
+
+ ;; The first part second.
+ (let ((declares (callout-part1-decls ret-var ret-ctype params includes))
+ (inits (callout-inits ret-ctype params includes))
+ (call (callout-call name ret-var ret-ctype params includes))
+ (saves (callout-saves ret-var ret-ctype includes)))
+ (let ((name (symbol-name name)))
+ (write-string
+ (string-append "
+void
+Scm_"name" (void)
+\{
+ /* Declare. */" declares "
+
+ /* Init. */" inits "
+
+ /* Call. */
+ callout_seal (&Scm_continue_"name");" call "
+
+ /* Save. */
+ callout_unseal (&Scm_continue_"name");" saves "
+
+ callout_continue (&Scm_continue_"name");
+ /* NOTREACHED */
+}
+"))))))
+
+(define (matching-param? string params)
+ (find-matching-item params
+ (lambda (param) (string=? string (symbol-name (car param))))))
+
+(define (new-variable root-name params)
+ ;; Returns a name (string) for a variable that must be distinct from
+ ;; those in the PARAMS alist.
+ (let loop ((n 0))
+ (let ((name (string-append root-name (number->string n))))
+ (if (not (matching-param? name params))
+ name
+ (if (> n 9)
+ (error "Could not generate a unique variable:" root-name)
+ (loop (1+ n)))))))
+
+(define (callout-part2-decls tos-var ret-var ret-ctype includes)
+ ;; Returns a multi-line string declaring the variables to be used in
+ ;; the second part of a callout trampoline. See the Owner's Manual.
+ (let ((ctype (definite-ctype ret-ctype includes))
+ (decl (decl-string ret-ctype)))
+ (string-append "
+ char * "tos-var";"
+ (if (not (ctype/void? ctype)) (string-append "
+ "decl" "ret-var";") "") "
+ SCM "ret-var"s;")))
+
+(define (callout-restores name tos-var ret-var ret-ctype includes)
+ (let* ((ctype (definite-ctype ret-ctype includes))
+ (tramp2 (string-append "&Scm_continue_" (symbol-name name)))
+ (ret-decl (decl-string ret-ctype)))
+ (string-append "
+ "tos-var" = callout_lunseal ("tramp2");"
+ (if (not (ctype/void? ctype)) (string-append "
+ CSTACK_LPOP ("ret-decl", "ret-var", "tos-var");") ""))))
+
+(define (callout-return tos-var ret-var ret-ctype includes)
+ (let ((ctype (definite-ctype ret-ctype includes)))
+ (string-append
+ (if (ctype/void? ctype)
+ (string-append "
+ "ret-var"s = unspecific();")
+ (string-append "
+ "ret-var"s = "(callout-return-converter ctype)" ("ret-var");")) "
+ callout_pop ("tos-var");
+ return ("ret-var"s);")))
+
+(define (callout-part1-decls ret-var ret-ctype params includes)
+ (let ((ctype (definite-ctype ret-ctype includes))
+ (ret-decl (decl-string ret-ctype)))
+ (string-append
+ (if (not (ctype/void? ctype))
+ (string-append "
+ "ret-decl" "ret-var";")
+ "")
+ (apply string-append (let loop ((params params))
+ (if (null? params) '()
+ (cons
+ (let* ((param (car params))
+ (name (symbol-name (car param)))
+ (type (cadr param))
+ (decl (decl-string type)))
+ (string-append "
+ "decl" "name";"))
+ (loop (cdr params)))))))))
+
+(define (callout-inits ret-ctype params includes)
+ ;; Returns a multi-line string in C syntax for the Init section.
+ (let* ((alien-ret-arg? (ctype/pointer? (definite-ctype ret-ctype includes)))
+ (nargs
+ ;; (c-call 1:alien-function 2:ret-alien 3:arg1)
+ ;; (c-call 1:alien-function 2:arg1)
+ (number->string (+ (length params) (if alien-ret-arg? 2 1)))))
+ (string-append "
+ check_number_of_args ("nargs");"
+ (apply string-append
+ (let loop ((params params)
+ (n (if alien-ret-arg? 3 2)))
+ (if (null? params) '()
+ (cons
+ (let* ((param (car params))
+ (name (car param))
+ (ctype (cadr param))
+ (funcast (callout-arg-converter name ctype includes))
+ (name (symbol-name name))
+ (num (number->string n)))
+ (string-append "
+ "name" = "funcast" ("num");"))
+ (loop (cdr params) (1+ n)))))))))
+
+(define (callout-saves ret-var ret-ctype includes)
+ (if (not (ctype/void? (definite-ctype ret-ctype includes)))
+ (string-append "
+ CSTACK_PUSH ("(decl-string ret-ctype)", "ret-var");")
+ ""))
+
+(define (callout-call name ret-var ret-ctype params includes)
+ ;; Returns a multi-line string in C syntax for the Call section.
+ (let ((name (symbol-name name))
+ (args (decorated-string-append
+ "" ", " "" (map (lambda (param) (symbol-name (car param)))
+ params))))
+ (if (not (ctype/void? (definite-ctype ret-ctype includes)))
+ (string-append "
+ "ret-var" = "name" ("args");")
+ (string-append "
+ "name" ("args");"))))
+
+(define (callout-arg-converter name arg-ctype includes)
+ ;; Returns the name of the C function that takes an argument index
+ ;; and returns it as the C type ARG-CTYPE. May have a cast
+ ;; expression at the beginning. Handles args named CALLBACK and ID
+ ;; specially.
+ (let ((ctype (definite-ctype arg-ctype includes))
+ (decl (decl-string arg-ctype)))
+ (cond ((eq? name '|CALLBACK|)
+ (string-append "("decl") arg_alien_entry"))
+ ((eq? name '|ID|)
+ (string-append "("decl") arg_long"))
+ ((ctype/pointer? ctype)
+ (string-append "("decl") arg_pointer"))
+ ((ctype/enum? ctype) "arg_long")
+ ((ctype/basic? ctype)
+ (case ctype
+ ((CHAR SHORT INT LONG) "arg_long")
+ ((UCHAR USHORT UINT ULONG) "arg_ulong")
+ ((FLOAT DOUBLE) "arg_double")
+ (else (error "Unexpected parameter type:" arg-ctype))))
+ (else (error "Unexpected parameter type:" arg-ctype)))))
+
+(define (callout-return-converter ctype)
+ ;; Returns the name of a C function that converts from the definite
+ ;; C type CTYPE to the analogous Scheme object. Note that the
+ ;; pointer converter, pointer_to_scm, returns pointers via c-call's
+ ;; second argument.
+ (cond ((ctype/pointer? ctype) "pointer_to_scm")
+ ((ctype/enum? ctype) "ulong_to_scm")
+ ((ctype/basic? ctype)
+ (case ctype
+ ((CHAR SHORT INT LONG) "long_to_scm")
+ ((UCHAR USHORT UINT ULONG) "ulong_to_scm")
+ ((FLOAT DOUBLE) "double_to_scm")
+ ((VOID) #f)
+ (else (error "Unexpected return type:" ctype))))
+ (else (error "Unexpected return type:" ctype))))
+
+(define (callout-return-variable params)
+ ;; Returns a name (string) for a variable that will hold the return
+ ;; value. Checks for two name collisions with the PARAMS, e.g. ret0
+ ;; and ret0s, the latter being the SCM version of the return value.
+ (let loop ((n 0))
+ (let* ((ns (number->string n))
+ (name1 (string-append "ret" ns))
+ (name2 (string-append "ret" ns "s")))
+ (if (and (not (matching-param? name1 params))
+ (not (matching-param? name2 params)))
+ name1
+ (if (> n 9)
+ (error "Could not generate a unique ret variable.")
+ (loop (1+ n)))))))
+
+(define (decl-string ctype)
+ ;; Returns a string in C syntax declaring the C type CTYPE.
+ ;; E.g. given (* |GtkWidget|), returns "GtkWidget *".
+ (cond ((eq? ctype '*) "void*")
+ ((eq? ctype 'uchar) "unsigned char")
+ ((eq? ctype 'ushort) "unsigned short")
+ ((eq? ctype 'uint) "unsigned int")
+ ((eq? ctype 'ulong) "unsigned long")
+ ((symbol? ctype) (symbol-name ctype))
+ ((ctype/pointer? ctype)
+ (string-append (decl-string (ctype-pointer/target-type ctype))
+ " *"))
+ ((ctype/const? ctype)
+ (string-append "const "
+ (decl-string (ctype-const/qualified-type ctype))))
+ ((ctype/struct-name? ctype)
+ (string-append "struct " (symbol-name (ctype-struct/name ctype))))
+ ((ctype/union-name? ctype)
+ (string-append "union " (symbol-name (ctype-union/name ctype))))
+ ((ctype/enum-name? ctype)
+ (string-append "enum " (symbol-name (ctype-enum/name ctype))))
+ (else
+ (error "Could not generate a C type declaration:" ctype))))
+\f
+
+;;; Callback Trampolines
+
+(define (gen-callback-trampolines includes)
+ (for-each
+ (lambda (name.alienf)
+ (with-simple-restart 'CONTINUE "Continue generating callback trampolines."
+ (lambda ()
+ (bind-condition-handler
+ (list condition-type:simple-error)
+ (lambda (condition)
+ (let ((restart (find-restart 'CONTINUE condition))
+ (msg (access-condition condition 'MESSAGE))
+ (irr (access-condition condition 'IRRITANTS)))
+ (apply warn msg irr)
+ (if restart
+ (invoke-restart restart))))
+ (lambda ()
+ (gen-callback-trampoline (car name.alienf) (cdr name.alienf)
+ includes))))))
+ (reverse (c-includes/callbacks includes))))
+
+(define (gen-callback-trampoline name alien includes)
+ (let ((ret-ctype (alien-function/return-type alien))
+ (params (alien-function/parameters alien)))
+
+ ;; The second part first.
+ (let ((args-var (new-variable "arglist" params))
+ (tos-var (new-variable "tos" params)))
+ (let ((declares (callback-decls params))
+ (restores (callback-restores params tos-var))
+ (constructs (callback-conses params args-var includes))
+ (name (symbol-name name)))
+ (write-string
+ (string-append "
+static void
+Scm_kernel_"name" (void)
+\{
+ /* Declare. */"declares"
+ SCM "args-var";
+ char * "tos-var";
+
+ /* Init. */
+ "tos-var" = callback_lunseal (&Scm_kernel_"name");"restores"
+
+ /* Construct. */
+ "args-var" = empty_list();"constructs"
+ callback_run_handler ((int)ID, "args-var");
+
+ callback_return ("tos-var");
+}"))))
+
+ ;; The first part second.
+ (let ((arglist (arglist params))
+ (saves (callback-saves params))
+ (return (callback-return ret-ctype includes))
+ (ret-decl (decl-string ret-ctype))
+ (name (symbol-name name)))
+ (write-string
+ (string-append
+ "
+"ret-decl"
+Scm_"name" ("arglist")
+\{"saves"
+ callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_"name");"return"
+}
+")))))
+
+(define (callback-decls params)
+ ;; Returns a multi-line string declaring the variables to be used in
+ ;; the second (inner, kernel) part of a callback trampoline.
+ (apply string-append (map (lambda (param)
+ (let ((decl (decl-string (cadr param)))
+ (name (symbol-name (car param))))
+ (string-append "
+ "decl" "name";")))
+ params)))
+
+(define (callback-restores params tos-var)
+ ;; Returns a multi-line string setting the params from the C data stack.
+ (apply string-append (map (lambda (param)
+ (let ((name (symbol-name (car param)))
+ (decl (decl-string (cadr param))))
+ (string-append "
+ CSTACK_LPOP ("decl", "name", "tos-var");")))
+ params)))
+
+(define (callback-conses params args-var includes)
+ ;; Returns a multi-line string constructing the arglist.
+ (apply string-append
+ (map (lambda (param)
+ (let ((name (car param))
+ (ctype (cadr param)))
+ (if (eq? name '|ID|)
+ ""
+ (let ((name (symbol-name name)))
+ (let ((construction
+ (callback-arg-cons name ctype includes)))
+ (string-append "
+ "args-var" = cons ("construction", "args-var");"))))))
+ (reverse params))))
+
+(define (arglist params)
+ (decorated-string-append
+ "" ", " "" ;prefix, infix, suffix
+ (map (lambda (param)
+ (string-append (decl-string (cadr param))
+ " " (symbol-name (car param))))
+ params)))
+
+(define (callback-saves params)
+ (apply string-append
+ (map (lambda (param)
+ (let ((name (symbol-name (car param)))
+ (ctype (cadr param)))
+ (string-append "
+ CSTACK_PUSH ("(decl-string ctype)", "name");")))
+ (reverse params))))
+
+(define (callback-return ret-type includes)
+ ;; Returns a multi-line string that returns from a callback
+ ;; trampoline with a value of type RET-TYPE, converted from
+ ;; val_register.
+ (let ((funcast (callback-return-converter ret-type includes)))
+ (if (not funcast) "
+ return;"
+ (string-append "
+ return ("funcast" ());"))))
+
+(define (callback-arg-cons arg-name arg-ctype includes)
+ ;; Returns a function call that applies the appropriate Scheme
+ ;; constructor to the ARG-CTYPE variable ARG-NAME.
+ (let ((ctype (definite-ctype arg-ctype includes)))
+ (if (ctype/pointer? ctype)
+ (string-append "cons_alien((void*)"arg-name")")
+ (let ((func (callout-return-converter ctype)))
+ (string-append func"("arg-name")")))))
+
+(define (callback-return-converter ret-type includes)
+ ;; Returns the name of the C function that takes no arguments and
+ ;; returns the interpreter's VAL register as the C type RET-CTYPE.
+ (let ((ctype (definite-ctype ret-type includes)))
+ (cond ((ctype/pointer? ctype)
+ (string-append "("(decl-string ret-type)")pointer_value"))
+ ((ctype/enum? ctype) "long_value")
+ ((ctype/void? ctype) #f)
+ ((ctype/basic? ctype)
+ (case ctype
+ ((CHAR SHORT INT LONG) "long_value")
+ ((UCHAR USHORT UINT ULONG) "ulong_value")
+ ((FLOAT DOUBLE) "double_value")
+ (else (error "Unexpected return type:" ctype))))
+ (else (error "Unexpected return type:" ctype)))))
+\f
+
+;;; Groveler
+
+(define (gen-groveler pathname prefix includes)
+ (with-output-to-file pathname
+ (lambda ()
+ (write-string
+ (string-append
+ "/* -*-C-*- */
+
+/* Prefix */
+"prefix"
+/* End Prefix */
+" (basics-grovel-func) (enums-grovel-func includes)))
+ (flush-output)
+ (let* ((structs (gen-struct-grovel-funcs includes))
+ (unions (gen-union-grovel-funcs includes)))
+ (let ((library (c-includes/library includes)))
+ (write-string
+ (string-append "
+int
+main (void)
+\{
+ FILE * out = fopen (\""library"-const.scm\", \"w\");
+ if (out == NULL) {
+ perror (\"could not open "library"-const.scm\");
+ return 1;
+ }
+ fprintf (out, \"'( ;; "library" constants\\n\");
+ fprintf (out, \" ( ;; enum member values\\n\");
+ grovel_enums(out);
+ fprintf (out, \" )\\n\");
+ fprintf (out, \" ( ;; struct values\\n\");
+ grovel_basics(out);"))
+ (for-each (lambda (name) (write-string (string-append "
+ "name" (out);"))) structs)
+ (for-each (lambda (name) (write-string (string-append "
+ "name" (out);"))) unions)
+ (write-string
+ (string-append "
+ fprintf (out, \" ))\\n\");
+ if (fclose (out)) {
+ perror (\"could not close "library"-const.scm\");
+ return 1;
+ }
+ return 0;
+}
+")))))))
+
+(define (basics-grovel-func)
+ (string-append "
+void
+grovel_basics (FILE * out)
+\{"
+ (apply string-append
+ (map (lambda (entry)
+ (let* ((name (car entry))
+ (decl (decl-string name))
+ (name (symbol-name name)))
+ (string-append "
+ fprintf (out, \" ((sizeof "name") . %d)\\n\", sizeof ("decl"));")))
+ peek-poke-primitives))
+ "
+\}
+"))
+
+(define (enums-grovel-func includes)
+ (string-append
+ "
+void
+grovel_enums (FILE * out)
+\{"
+ (apply string-append
+ (map (lambda (constant)
+ (let ((name (symbol-name (car constant))))
+ (string-append "
+ fprintf (out, \" (|"name"| . %ld)\\n\", ((long)"name"));")))
+ (c-includes/enum-constants includes)))
+ "
+\}
+"))
+
+(define (gen-struct-grovel-funcs includes)
+ ;; Returns the names of the generated functions.
+ (append-map*!
+ (map (lambda (name.info)
+ ;; The named structs, top-level OR internal.
+ (let ((name (list 'STRUCT (car name.info))))
+ (gen-struct-union-grovel-func name includes)))
+ (c-includes/structs includes))
+ (lambda (name.info)
+ ;; Typedefs giving names to struct types.
+ (let* ((name (car name.info))
+ (ctype (definite-ctype name includes)))
+ (if (ctype/struct? ctype)
+ (list (gen-struct-union-grovel-func name includes))
+ '())))
+ (c-includes/type-names includes)))
+
+(define (gen-union-grovel-funcs includes)
+ ;; Returns the names of the generated functions.
+ (append-map*!
+ (map (lambda (name.info)
+ ;; The named unions, top-level OR internal.
+ (let ((name (list 'UNION (car name.info))))
+ (gen-struct-union-grovel-func name includes)))
+ (c-includes/unions includes))
+ (lambda (name.info)
+ ;; Typedefs giving names to union types.
+ (let* ((name (car name.info))
+ (ctype (definite-ctype name includes)))
+ (if (ctype/union? ctype)
+ (list (gen-struct-union-grovel-func name includes))
+ '())))
+ (c-includes/type-names includes)))
+
+(define (gen-struct-union-grovel-func name includes)
+ ;; Generate C code for a grovel_NAME function.
+ (let ((fname (cond ((ctype/struct-name? name)
+ (string-append "grovel_struct_"
+ (symbol-name (ctype-struct/name name))))
+ ((ctype/union-name? name)
+ (string-append "grovel_union_"
+ (symbol-name (ctype-union/name name))))
+ ((symbol? name)
+ (string-append "grovel_type_" (symbol-name name)))
+ (else (error "Unexpected name:" name))))
+ (ctype (definite-ctype name includes))
+ (decl (decl-string name))
+ (_ (lambda args (for-each write-string args))))
+ (let ((key (list 'SIZEOF name)))
+ (_ "
+void
+"fname" (FILE * out)
+\{
+ "decl" S;
+ fprintf (out, \" (")(write key)(_" . %d)\\n\", sizeof ("decl"));"))
+ (for-each-member-path
+ ctype includes
+ (lambda (path brief-type)
+ (let ((path (decorated-string-append
+ "" "." "" (map symbol-name path)))
+ (key (cons* 'OFFSET name path)))
+ (_ "
+ fprintf (out, \" (")(write key)(_" %d . ")(write brief-type)(_")\\n\", (char*)&(S."path") - (char*)&S);"))))
+ (_ "
+\}
+")
+ fname))
+
+(define (for-each-member-path ctype includes receiver)
+ ;; Calls RECEIVER with a path and an abbreviated type for each
+ ;; member (and nested member) of the struct or union CTYPE (a C
+ ;; struct or union type). Each path is a list of member names
+ ;; (symbols) -- one name for immediate members, multiple names for
+ ;; nested members. An abbreviated type is a Ctype, but is 'ENUM if
+ ;; the actual type is (ENUM ...).
+
+ (let ((type (ctype-definition ctype includes)))
+ (cond ((ctype/struct-defn? type)
+ (let ((stack (list ctype)))
+ (for-each (lambda (name.type)
+ (for-each-member-path*
+ name.type stack includes receiver))
+ (ctype-struct-defn/members type))))
+ ((ctype/union-defn? type)
+ (let ((stack (list ctype)))
+ (for-each (lambda (name.type)
+ (for-each-member-path*
+ name.type stack includes receiver))
+ (ctype-union-defn/members type))))
+ (else
+ (error "Unexpected Ctype to for-each-member-path:" ctype)))))
+
+(define (for-each-member-path* name.type stack includes receiver)
+ (let ((name (car name.type))
+ (type (cdr name.type)))
+ (let ((ctype (ctype-definition type includes)))
+ (if (member ctype stack)
+ (error "Circular definition of C type:" (car (last-pair stack))))
+ (cond ((or (ctype/basic? ctype)
+ (ctype/pointer? ctype)
+ (ctype/array? ctype))
+ (receiver (list name) type))
+ ((ctype/enum? ctype)
+ (receiver (list name) 'ENUM))
+ ((ctype/struct-defn? ctype)
+ (receiver (list name) type)
+ (let ((new-stack (cons type stack)))
+ (for-each (lambda (name.type)
+ (for-each-member-path*
+ name.type new-stack includes
+ (lambda (path type)
+ (receiver (cons name path) type))))
+ (ctype-struct-defn/members ctype))))
+ ((ctype/union-defn? ctype)
+ (receiver (list name) type)
+ (let ((new-stack (cons type stack)))
+ (for-each (lambda (name.type)
+ (for-each-member-path*
+ name.type new-stack includes
+ (lambda (path type)
+ (receiver (cons name path) type))))
+ (ctype-union-defn/members ctype))))
+ (else (error "Unexpected C type from ctype-definition:" ctype))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Load the FFI system. |#
+
+(with-loader-base-uri (system-library-uri "ffi/")
+ (lambda ()
+ (load-package-set "ffi")))
+(add-subsystem-identification! "FFI" '(0 1))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+C declarations for prhello.scm. |#
+
+
+(typedef gint int)
+(typedef guint uint)
+(typedef gchar char)
+(typedef gboolean gint)
+(typedef gpointer (* mumble))
+
+(extern void
+ gtk_init
+ (argc (* int))
+ (argv (* (* (* char)))))
+
+(extern (* GtkWidget)
+ gtk_window_new
+ (type GtkWindowType))
+
+(typedef GtkWindowType
+ (enum
+ (GTK_WINDOW_TOPLEVEL)
+ (GTK_WINDOW_POPUP)))
+
+(extern (* GtkWidget)
+ gtk_button_new)
+
+(extern (* GtkWidget)
+ gtk_label_new
+ (str (* (const char))))
+
+(extern void
+ gtk_container_add
+ (container (* GtkContainer))
+ (widget (* GtkWidget)))
+
+(extern void
+ gtk_window_set_title
+ (window (* GtkWindow))
+ (title (* (const gchar))))
+
+(extern void
+ gtk_container_set_border_width
+ (container (* GtkContainer))
+ (border_width guint))
+
+(extern void
+ gtk_widget_show_all
+ (widget (* GtkWidget)))
+
+(extern void
+ g_signal_connect
+ (object (* GtkObject))
+ (name (* gchar))
+ (CALLBACK GtkSignalFunc)
+ (ID gpointer))
+
+(typedef GtkSignalFunc (* mumble))
+
+(callback gboolean
+ delete_event
+ (window (* GtkWidget))
+ (event (* GdkEventAny))
+ (ID gpointer))
+
+(callback void
+ clicked
+ (widget (* GtkWidget))
+ (ID gpointer))
+
+(extern void
+ gtk_widget_destroy
+ (widget (* GtkWidget)))
+
+(extern (* (const gchar))
+ gtk_label_get_text
+ (label (* GtkLabel)))
+
+(extern void
+ gtk_label_set_text
+ (label (* GtkLabel))
+ (str (* (const char))))
+
+(extern void gtk_main)
+(extern void gtk_main_quit)
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+This is Havoc Pennington's Hello World example from GGAD, in the raw
+FFI. Note that no arrangements have been made to de-register the
+callbacks. |#
+
+(declare (usual-integrations))
+
+(C-include "prhello")
+
+(define (hello)
+ (C-call "gtk_init" 0 null-alien)
+ (let ((window (let ((alien (make-alien '|GtkWidget|)))
+ (C-call "gtk_window_new" alien
+ (C-enum "GTK_WINDOW_TOPLEVEL"))
+ (if (alien-null? alien) (error "Could not create window."))
+ alien))
+ (button (let ((alien (make-alien '|GtkWidget|)))
+ (C-call "gtk_button_new" alien)
+ (if (alien-null? alien) (error "Could not create button."))
+ alien))
+ (label (let ((alien (make-alien '|GtkWidget|)))
+ (C-call "gtk_label_new" alien "Hello, World!")
+ (if (alien-null? alien) (error "Could not create label."))
+ alien)))
+ (C-call "gtk_container_add" button label)
+ (C-call "gtk_container_add" window button)
+ (C-call "gtk_window_set_title" window "Hello")
+ (C-call "gtk_container_set_border_width" button 10)
+ (let ((counter 0))
+ (C-call "g_signal_connect" window "delete_event"
+ (C-callback "delete_event") ;trampoline
+ (C-callback ;callback ID
+ (lambda (w e)
+ (outf-console ";Delete me "(- 2 counter)" times.\n")
+ (set! counter (1+ counter))
+ ;; Three or more is the charm.
+ (if (> counter 2)
+ (begin
+ (C-call "gtk_main_quit")
+ 0)
+ 1))))
+ (C-call "g_signal_connect" button "clicked"
+ (C-callback "clicked") ;trampoline
+ (C-callback ;callback ID
+ (lambda (w)
+ (let ((gstring (make-alien '(* |gchar|))))
+ (C-call "gtk_label_get_text" gstring label)
+ (let ((text (c-peek-cstring gstring)))
+ (C-call "gtk_label_set_text" label
+ (list->string (reverse! (string->list text))))))
+ unspecific))))
+ (C-call "gtk_widget_show_all" window)
+ (C-call "gtk_main")
+ window))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Syntax Expanders
+;;; package: (ffi syntax)
+
+
+;;; C-include Syntax
+
+(define-syntax C-include
+ ;; (C-include "library") ===> #f
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (call-with-destructured-c-include-form
+ form
+ (lambda (library)
+ (let ((ienv (syntactic-environment->environment usage-env)))
+ (if (and (environment-bound? ienv 'C-INCLUDES)
+ (environment-assigned? ienv 'C-INCLUDES))
+ (let ((value (environment-lookup ienv 'C-INCLUDES))
+ (err (lambda (msg val)
+ (error (string-append
+ "C-includes is already bound, " msg) val))))
+ (if (c-includes? value)
+ (if (string=? (c-includes/library value) library)
+ #f
+ (err "to a different library:"
+ (c-includes/library value)))
+ (err "but not to a c-include structure:" value)))
+ (begin
+ (environment-define ienv 'C-INCLUDES (load-c-includes library))
+ #f))))))))
+
+(define (call-with-destructured-c-include-form form receiver)
+ ;; Calls RECEIVER with the library.
+ (if (null? (cdr form)) (serror form "a library name is required"))
+ (let ((library (cadr form)))
+ (if (not (string? library))
+ (serror form "the 1st arg must be a string"))
+ (if (not (null? (cddr form)))
+ (serror form "too many args"))
+ (receiver library)))
+
+(define (load-c-includes library)
+ (let* ((lib (merge-pathnames
+ library (system-library-directory-pathname "lib")))
+ (name (pathname-name lib))
+ (const (pathname-new-name lib (string-append name "-const")))
+ (types (pathname-new-name lib (string-append name "-types")))
+ (includes (fasload types))
+ (comment (fasload const))
+ (enums.struct-values
+ (if (comment? comment) (comment-expression comment)
+ (error:wrong-type-datum comment "a fasl comment"))))
+ (warn-new-cdecls includes)
+ (set-c-includes/enum-values! includes (car enums.struct-values))
+ (set-c-includes/struct-values! includes (cadr enums.struct-values))
+ includes))
+
+(define (warn-new-cdecls includes)
+ (for-each
+ (lambda (file.modtime)
+ (let ((read-modtime (cdr file.modtime))
+ (this-modtime (file-modification-time (car file.modtime))))
+ (if (and this-modtime (< read-modtime this-modtime))
+ (warn "new source file:" (car file.modtime)))))
+ (c-includes/files includes)))
+\f
+
+;;; C-> and C->= Syntaxes
+
+(define-syntax C->
+ ;; (C-> event "GdkEvent any type")
+ ;; ===> (#[primitive c-peek-uint] event 14)
+ ;; (C-> event "GdkEvent any window" window)
+ ;; ===> (#[primitive c-peek-pointer] event 4 window)
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (expand-c->-syntax #f form usage-env))))
+
+(define-syntax C->=
+ ;; (C->= event "GdkEvent any type" (C-enum "GDK_MAP"))
+ ;; ===> (#[primitive c-poke-uint] event 14)
+ ;; (C->= event "GdkEvent any window" window)
+ ;; ===> (#[primitive c-poke-pointer] event 4 window)
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (expand-c->-syntax #t form usage-env))))
+
+(define (expand-c->-syntax poke? whole-form usage-env)
+ (call-with-destructured-c->-form
+ whole-form
+ (lambda (alien-form type-member-spec value-form)
+ (let ((includes (find-c-includes usage-env))
+ (alien-form (close-syntax alien-form usage-env))
+ (value-form (and value-form (close-syntax value-form usage-env))))
+ (call-with-initial-ctype
+ type-member-spec whole-form
+ (lambda (ctype member-spec)
+ (let ((type (ctype-definition ctype includes)))
+ (cond
+ ((or (ctype/basic? type)
+ (ctype/pointer? type)
+ (ctype/array? type)
+ (ctype/enum-defn? type))
+ (if (null? member-spec)
+ (if poke?
+ (expand-poke type alien-form 0 value-form whole-form)
+ (expand-peek type alien-form 0 value-form whole-form))
+ (let ((meta-type (cond ((ctype/basic? type) "basic")
+ ((ctype/pointer? type) "pointer")
+ ((ctype/array? type) "array")
+ ((ctype/enum-defn? type) "enum")
+ (else ""))))
+ (serror whole-form meta-type " types have no members"))))
+ ((or (ctype/struct-defn? type)
+ (ctype/union-defn? type))
+ (if (null? member-spec)
+ (serror whole-form "cannot peek a whole struct")
+ (let ((entry (assoc (cons* 'OFFSET ctype member-spec)
+ (c-includes/struct-values includes))))
+ (if (not entry) (serror whole-form "no such member"))
+ (let ((offset (cadr entry))
+ (type (cddr entry)))
+ (let ((ctype (ctype-definition type includes)))
+ (if poke?
+ (expand-poke ctype alien-form offset
+ value-form whole-form)
+ (expand-peek ctype alien-form offset
+ value-form whole-form)))))))
+ (poke?
+ (serror whole-form "cannot poke C type " ctype))
+ (else
+ (serror whole-form "cannot peek C type " ctype))))))))))
+
+(define (expand-poke ctype alien-form offset value-form whole-form)
+ (if (not value-form) (serror whole-form "missing value (3rd) arg"))
+ (cond ((ctype/basic? ctype)
+ (let ((prim (or (ctype/primitive-modifier ctype)
+ (serror whole-form "cannot poke basic type " ctype))))
+ `(,prim ,alien-form ,offset ,value-form)))
+ ((ctype/pointer? ctype)
+ (let ((prim (ucode-primitive c-poke-pointer 3)))
+ `(,prim ,alien-form ,offset ,value-form)))
+ ((ctype/array? ctype)
+ (serror whole-form "cannot poke a whole array"))
+ ((or (ctype/enum? ctype) (eq? ctype 'ENUM))
+ (let ((prim (ucode-primitive c-poke-uint 3)))
+ `(,prim ,alien-form ,offset ,value-form)))
+ (else (error "unexpected C type for poking" ctype))))
+
+(define (expand-peek ctype alien-form offset value-form whole-form)
+ (cond ((ctype/basic? ctype)
+ (if value-form (serror whole-form "ignoring extra (3rd) arg"))
+ (let ((prim (or (ctype/primitive-accessor ctype)
+ (serror whole-form "cannot peek basic type " ctype))))
+ `(,prim ,alien-form ,offset)))
+ ((ctype/pointer? ctype)
+ `(,(ucode-primitive c-peek-pointer 3)
+ ,alien-form ,offset ,(or value-form '(MAKE-ALIEN))))
+ ((ctype/array? ctype)
+ (if value-form
+ `(LET ((VALUE ,value-form))
+ (COPY-ALIEN-ADDRESS! VALUE ,alien-form)
+ (ALIEN-BYTE-INCREMENT! VALUE ,offset)
+ VALUE)
+ `(ALIEN-BYTE-INCREMENT ,alien-form ,offset)))
+ ((or (ctype/enum? ctype) (eq? ctype 'ENUM))
+ `(,(ucode-primitive c-peek-uint 2) ,alien-form ,offset))
+ (else (error "unexpected C type for peeking" ctype))))
+
+(define (call-with-destructured-c->-form form receiver)
+ ;; Calls RECEIVER with ALIEN, SPEC and VALUE (or #f) as in these forms:
+ ;;
+ ;; (C-> ALIEN SPEC) VALUE = #f
+ ;; (C-> ALIEN SPEC* VALUE) SPEC* specifies a pointer-type member
+ ;; (C->= ALIEN SPEC VALUE)
+ ;;
+ (let ((len (length form)))
+ (if (< len 3) (serror form "too few args"))
+ (if (> len 4) (serror form "too many args"))
+ (let ((alien-form (cadr form))
+ (type-member-spec (caddr form))
+ (value-form (and (= 4 len) (cadddr form))))
+ (if (not (string? type-member-spec))
+ (serror form "2nd arg must be a string"))
+ (let ((type-member-spec (map string->symbol
+ (burst-string type-member-spec #\space #t))))
+ (if (null? type-member-spec)
+ (serror form "2nd arg is an empty string"))
+ (receiver alien-form type-member-spec value-form)))))
+\f
+
+;;; C-enum Syntax
+
+(define-syntax C-enum
+ ;; (C-enum "GDK_MAP")
+ ;; ===> 14
+ ;; (C-enum "GdkEventType" 14)
+ ;; ===> GDK_MAP
+ ;; (C-enum "GdkEventType" FORM)
+ ;; ===> (C-enum-name FORM '|GdkEventType|
+ ;; '((|GDK_NOTHING| . -1) (|GDK_DELETE| . 0)...))
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (call-with-destructured-c-enum-form
+ form
+ (lambda (name value-form)
+ (let* ((includes (find-c-includes usage-env)))
+ (if (not value-form)
+ (lookup-enum-value name form includes)
+ (if (integer? value-form)
+ (c-enum-name value-form name
+ (c-enum-constant-values name form includes))
+ (let ((value (close-syntax value-form usage-env))
+ (constants (c-enum-constant-values name form includes)))
+ `(C-ENUM-NAME ,value ',name ',constants))))))))))
+
+(define (lookup-enum-value name whole-form includes)
+ (let ((entry (assq name (c-includes/enum-values includes))))
+ (if (not entry)
+ (serror whole-form "constant not declared")
+ (cdr entry))))
+
+(define (c-enum-constant-values name form includes)
+ (let ((defn (ctype-definition name includes))
+ (vals (c-includes/enum-values includes)))
+ (if (ctype/enum-defn? defn)
+ (let loop ((consts (ctype-enum-defn/constants defn)))
+ (if (pair? consts)
+ (let* ((name (caar consts))
+ (entry (or (assq name vals)
+ (error "no value for enum constant" name))))
+ (cons entry (loop (cdr consts))))
+ '()))
+ (serror form "not an enum type"))))
+
+(define (call-with-destructured-c-enum-form form receiver)
+ (let ((len (length form)))
+ (if (< len 2) (serror form "too few args"))
+ (if (> len 3) (serror form "too many args"))
+ (let ((type-str (cadr form))
+ (value-form (and (pair? (cddr form)) (caddr form))))
+ (if (not (string? type-str))
+ (serror form "1st arg must be a string"))
+ (let ((words (burst-string type-str #\space #t)))
+ (if (null? words)
+ (serror form "1st arg is an empty string"))
+ (let ((name (cond ((and (string=? "enum" (car words))
+ (not (null? (cdr words)))
+ (null? (cddr words)))
+ `(ENUM ,(string->symbol (cadr words))))
+ ((null? (cdr words))
+ (string->symbol (car words)))
+ (else (serror form "not an enum type name")))))
+ (if (and value-form (string? value-form))
+ (serror form "2nd arg cannot be a string"))
+ (receiver name value-form))))))
+\f
+
+;;; C-sizeof and C-offset Syntaxes
+
+(define-syntax C-sizeof
+ ;; (C-sizeof "GdkColor") ===> 10
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (expand-c-info-syntax 'SIZEOF form usage-env))))
+
+(define-syntax C-offset
+ ;; (C-offset "GdkColor green") ===> 6
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (expand-c-info-syntax 'OFFSET form usage-env))))
+
+(define (expand-c-info-syntax which form usage-env)
+ ;; WHICH can be SIZEOF or OFFSET.
+ (let ((len (length form)))
+ (if (< len 2) (serror form "too few args"))
+ (if (> len 2) (serror form "too many args"))
+ (let ((str (cadr form)))
+ (if (not (string? str)) (serror form "arg must be a string"))
+ (let ((spec (map string->symbol (burst-string str #\space #t))))
+ (if (null? spec) (serror form "arg is an empty string"))
+ (c-info which spec form usage-env)))))
+
+(define (c-info which spec form usage-env)
+ ;; Returns the offset or sizeof for SPEC.
+ (let* ((includes (find-c-includes usage-env))
+ (btype.members
+ (call-with-initial-ctype
+ spec form
+ (lambda (ctype member-spec)
+ (let ((defn (ctype-definition ctype includes)))
+ (if (and (eq? which 'OFFSET) (null? member-spec))
+ (serror form "no member specified"))
+ (if (and (eq? which 'OFFSET)
+ (not (or (ctype/struct-defn? defn)
+ (ctype/union-defn? defn))))
+ (serror form "not a struct or union type"))
+ (if (and (not (eq? which 'OFFSET)) (not (null? member-spec)))
+ (if (null? (cdr member-spec))
+ (serror form "no member name allowed")
+ (serror form "no member names allowed")))
+ (cond ((ctype/basic? defn)
+ (cons defn '()))
+ ((ctype/pointer? defn)
+ (cons '* '()))
+ ((or (ctype/struct-defn? defn)
+ (ctype/union-defn? defn))
+ (cons ctype member-spec))
+ (else
+ (serror form "unimplemented")))))))
+ (entry (assoc (cons which btype.members)
+ (c-includes/struct-values includes))))
+ (if entry
+ (if (eq? 'OFFSET which) (cadr entry) (cdr entry))
+ (if (eq? 'OFFSET which)
+ (serror form "unknown member")
+ (serror form "unknown C type " btype.members)))))
+
+(define (call-with-initial-ctype spec form receiver)
+ ;; Given SPEC, a list of symbols, calls RECEIVER with a ctype and
+ ;; member spec (the list of names that followed the C type spec)
+ ;;
+ ;; For example RECEIVER is called with
+ ;;
+ ;; (* (|struct| |addrinfo|)) and (|ai_socktype|)
+ ;;
+ ;; when SPEC is (* |struct| |addrinfo| |ai_socktype|).
+ (let ((type-name (car spec))
+ (member-spec (cdr spec)))
+ (cond ((memq type-name '(STRUCT UNION ENUM))
+ (if (null? member-spec)
+ (serror form "incomplete C type specification")
+ (receiver (list type-name (car member-spec))
+ (cdr member-spec))))
+ ((eq? type-name '*)
+ (if (null? member-spec)
+ (receiver '* '())
+ ;; Recursively strip prefix pointer op.
+ (call-with-initial-ctype
+ member-spec form
+ (lambda (target-ctype member-spec)
+ (receiver (list '* target-ctype)
+ member-spec)))))
+ (else
+ (receiver type-name member-spec)))))
+\f
+
+;;; C-array-loc and -loc! Syntaxes
+
+(define-syntax C-array-loc
+ ;; (C-array-loc ALIEN "element type" INDEX)
+ ;; ===>
+ ;; (alien-byte-increment ALIEN (* (C-sizeof "element type") INDEX))
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (expand-c-array-loc-syntax #f form usage-env))))
+
+(define-syntax C-array-loc!
+ ;; (C-array-loc! ALIEN "element type" INDEX)
+ ;; ===>
+ ;; (alien-byte-increment! ALIEN (* (C-sizeof "element type") INDEX))
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (expand-c-array-loc-syntax #t form usage-env))))
+
+(define (expand-c-array-loc-syntax bang? form usage-env)
+ (call-with-destructured-C-array-loc-form
+ form
+ (lambda (alien-form str index-form)
+ (let ((spec (map string->symbol (burst-string str #\space #t))))
+ (if (null? spec) (serror form "2nd arg is an empty string"))
+ (let ((alien-form (close-syntax alien-form usage-env))
+ (sizeof (c-info `SIZEOF spec form usage-env))
+ (index-form (close-syntax index-form usage-env))
+ (proc (if bang? 'ALIEN-BYTE-INCREMENT! 'ALIEN-BYTE-INCREMENT)))
+ `(,proc ,alien-form (* ,sizeof ,index-form)))))))
+
+(define (call-with-destructured-C-array-loc-form form receiver)
+ (let ((len (length form)))
+ (if (< len 4) (serror form "too few args"))
+ (if (> len 4) (serror form "too many args"))
+ (let ((alien-form (cadr form))
+ (type (if (string? (caddr form))
+ (caddr form)
+ (serror form "the 2nd arg must be a string")))
+ (index-form (cadddr form)))
+ (receiver alien-form type index-form))))
+\f
+
+;;; C-call Syntax
+
+(define-syntax C-call
+ ;; (C-call "gtk_label_new" alien "Hello, World!")
+ ;; ===>
+ ;; (call-alien #[alien-function 33 gtk_label_new] alien "Hello, World!")
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (call-with-destructured-C-call-form
+ form
+ (lambda (func-name arg-forms)
+ (let* ((includes (find-c-includes usage-env))
+ (callouts (c-includes/callouts includes))
+ (alien (let ((entry (assq func-name callouts)))
+ (if (pair? entry)
+ (cdr entry)
+ (begin
+ (warn "no declaration of C function:" func-name)
+ func-name)))))
+ `(CALL-ALIEN ,alien
+ . ,(map (lambda (form) (close-syntax form usage-env))
+ arg-forms))))))))
+
+(define (call-with-destructured-C-call-form form receiver)
+ ;; Calls RECEIVER with the optional return-alien-form, func-name
+ ;; (as a symbol), and the arg-forms.
+ (if (not (pair? (cdr form))) (serror form "no function name"))
+ (let ((name (cadr form))
+ (args (cddr form)))
+ (if (not (string? name)) (serror form "first arg is not a string"))
+ (receiver (string->symbol name) args)))
+\f
+
+;;; C-callback Syntax
+
+(define-syntax C-callback
+ ;; (C-callback "clicked") ===> #[alien-function "clicked"]
+ ;; and
+ ;; (C-callback clicked) ===> (register-c-callback clicked)
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (call-with-destructured-c-callback-form form
+ (lambda (obj)
+ (if (string? obj)
+ (let* ((c-includes (find-c-includes usage-env))
+ (callbacks (c-includes/callbacks c-includes))
+ (name (string->symbol obj)))
+ (let ((entry (assq name callbacks)))
+ (if (pair? entry) (cdr entry)
+ (serror form "C function not declared"))))
+ (let ((value-form (close-syntax obj usage-env)))
+ `(REGISTER-C-CALLBACK ,value-form))))))))
+
+(define (call-with-destructured-c-callback-form form receiver)
+ ;; Calls RECEIVER with the only subform.
+ (let ((len (length form)))
+ (if (< len 2) (serror form "too few args"))
+ (if (> len 2) (serror form "too many args"))
+ (receiver (cadr form))))
+\f
+
+;;; Utilities
+
+(define (find-c-includes env)
+ ;; Returns the c-includes structure bound to 'C-INCLUDES in ENV.
+ (guarantee-syntactic-environment env 'find-c-includes)
+ (let ((ienv (syntactic-environment->environment env)))
+ (if (and (environment-bound? ienv 'C-INCLUDES)
+ (environment-assigned? ienv 'C-INCLUDES))
+ (let ((includes (environment-lookup ienv 'C-INCLUDES)))
+ (if (c-includes? includes)
+ includes
+ (error "C-includes is not bound to a c-includes structure:"
+ includes)))
+ (error "No C types have been included."))))
+
+(define condition-type:serror
+ (make-condition-type
+ 'syntaxer-error
+ condition-type:error
+ '(FORM MESSAGE)
+ (lambda (condition port)
+ (write-string "Syntax error: " port)
+ (write-string (access-condition condition 'MESSAGE) port)
+ (write-string " in: " port)
+ (write (access-condition condition 'FORM) port)
+ (write-char #\. port))))
+
+(define serror
+ (let ((signaller (condition-signaller condition-type:serror '(FORM MESSAGE)
+ standard-error-handler)))
+ (named-lambda (serror form message . args)
+ (signaller form
+ (apply string-append
+ (map (lambda (obj)
+ (if (string? obj) obj (write-to-string obj)))
+ (cons message args)))))))
\ No newline at end of file
const char * OS_Name;
const char * OS_Variant;
struct obstack scratch_obstack;
+struct obstack ffi_obstack;
void * initial_C_stack_pointer;
static char * reload_saved_string;
static unsigned int reload_saved_string_length;
OS2_initialize_early ();
#endif
obstack_init (&scratch_obstack);
+ obstack_init (&ffi_obstack);
dstack_initialize ();
transaction_initialize ();
reload_saved_string = 0;
static void
Do_Enter_Interpreter (void)
{
- Interpret ();
+ Interpret (0);
outf_fatal ("\nThe interpreter returned to top level!\n");
Microcode_Termination (TERM_EXIT);
}
SCHEME_OBJECT
Re_Enter_Interpreter (void)
{
- Interpret ();
+ Interpret (0);
return (GET_VAL);
}
\f
STATIC_LIBS=${MODULE_LIBS}${STATIC_LIBS}
else
STATIC_LIBS=
- OPTIONAL_BASES="${OPTIONAL_BASES} pruxdld"
+ OPTIONAL_BASES="${OPTIONAL_BASES} pruxdld pruxffi"
AC_DEFINE([UX_DLD_ENABLED], [1],
[Define to 1 if unix dynamic loading support is enabled.])
fi
#define PRIM_APPLY_INTERRUPT -9
#define PRIM_APPLY_ERROR -10
#define PRIM_NO_TRAP_POP_RETURN -11
+#define PRIM_RETURN_TO_C -12
+#define PRIM_ABORT_TO_C -13
#define ABORT_NAME_TABLE \
{ \
/* -8 */ "TOUCH", \
/* -9 */ "APPLY-INTERRUPT", \
/* -10 */ "REENTER", \
- /* -11 */ "NO-TRAP-POP-RETURN" \
+ /* -11 */ "NO-TRAP-POP-RETURN", \
+ /* -12 */ "RETURN-TO-C", \
+ /* -13 */ "ABORT-TO-C" \
}
/* Some numbers of parameters which mean something special */
extern const char * OS_Name;
extern const char * OS_Variant;
extern struct obstack scratch_obstack;
+extern struct obstack ffi_obstack;
extern unsigned long n_heap_blocks;
extern unsigned long n_constant_blocks;
extern void initialize_primitives (void);
extern SCHEME_OBJECT make_primitive (const char *, int);
+extern SCHEME_OBJECT find_primitive_cname (char *, bool, bool, int);
extern SCHEME_OBJECT find_primitive (SCHEME_OBJECT, bool, bool, int);
\f
/* Interpreter utilities */
extern void canonicalize_primitive_context (void);
extern void back_out_of_primitive (void);
-extern void Interpret (void);
+extern void Interpret (int pop_return_p);
extern void Do_Micro_Error (long, bool);
extern void Translate_To_Point (SCHEME_OBJECT);
extern void Stack_Death (void) NORETURN;
#define GC_WABBIT_DESCRIPTOR 0x40
-/* 4 extra slots for expansion and debugging. */
+#define CALLBACK_HANDLER 0x41
+
+/* 3 extra slots for expansion and debugging. */
#define N_FIXED_OBJECTS 0x45
long prim_apply_error_code;
\f
void
-Interpret (void)
+Interpret (int pop_return_p)
{
long dispatch_code;
struct interpreter_state_s new_state;
switch (dispatch_code)
{
- case 0:
- break;
+ case 0: /* first time */
+ if (pop_return_p)
+ goto pop_return; /* continue */
+ else
+ break; /* fall into eval */
case PRIM_APPLY:
PROCEED_AFTER_PRIMITIVE ();
PROCEED_AFTER_PRIMITIVE ();
goto pop_return;
+ case PRIM_RETURN_TO_C:
+ PROCEED_AFTER_PRIMITIVE ();
+ unbind_interpreter_state (interpreter_state);
+ return;
+
case PRIM_NO_TRAP_POP_RETURN:
PROCEED_AFTER_PRIMITIVE ();
goto pop_return_non_trapping;
back_out_of_primitive ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
+ case PRIM_ABORT_TO_C:
+ back_out_of_primitive ();
+ unbind_interpreter_state (interpreter_state);
+ return;
+
case ERR_ARG_1_WRONG_TYPE:
back_out_of_primitive ();
Do_Micro_Error (ERR_ARG_1_WRONG_TYPE, true);
$(INSTALL_DATA) $$p $(DESTDIR)$(AUXDIR)/.; \
fi; \
done
+ $(INSTALL_DATA) pruxffi.h $(DESTDIR)$(AUXDIR)/mit-scheme.h
install-include:
$(mkinstalldirs) $(DESTDIR)$(AUXDIR)
"prmhash"
"prpgsql"
"pruxdld"
+"pruxffi"
"svm1-interp"
"termcap"
"terminfo"
}
SCHEME_OBJECT
-find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity)
+find_primitive_cname (char * name, bool intern_p, bool allow_p, int arity)
{
- tree_node prim
- = (tree_lookup (prim_procedure_tree, (STRING_POINTER (sname))));
+ tree_node prim = (tree_lookup (prim_procedure_tree, name));
if (prim != 0)
{
SCHEME_OBJECT primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
return (SHARP_F);
{
- size_t n_bytes = ((STRING_LENGTH (sname)) + 1);
+ size_t n_bytes = ((strlen (name)) + 1);
char * cname = (OS_malloc (n_bytes));
- memcpy (cname, (STRING_POINTER (sname)), n_bytes);
+ memcpy (cname, name, n_bytes);
{
SCHEME_OBJECT primitive
= (declare_primitive (cname,
}
}
}
+
+SCHEME_OBJECT
+find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity)
+{
+ return (find_primitive_cname (STRING_POINTER (sname),
+ intern_p, allow_p, arity));
+}
\f
/* These are used by fasdump to renumber primitives on the way out.
Only those primitives actually referenced by the object being
{
SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
- VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen")));
+ VECTOR_SET (v, 1, (char_pointer_to_string ("dlsym")));
VECTOR_SET (v, 2, (char_pointer_to_string (error_string)));
error_with_argument (v);
}
--- /dev/null
+/* -*-C-*-
+
+$Id: $
+
+Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Un*x primitives for an FFI. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "bignmint.h"
+#include "history.h"
+#include "pruxffi.h"
+/* Using SCM instead of SCHEME_OBJECT here, hoping to ensure that
+ these types always match. */
+
+/* Alien Addresses */
+
+#define HALF_WORD_SHIFT ((sizeof (void*) * CHAR_BIT) / 2)
+#define HALF_WORD_MASK ((1 << HALF_WORD_SHIFT) - 1)
+#define ARG_RECORD(argument_number) \
+ ((RECORD_P (ARG_REF (argument_number))) \
+ ? (ARG_REF (argument_number)) \
+ : ((error_wrong_type_arg (argument_number)), ((SCM) 0)))
+
+int
+is_alien (SCM alien)
+{
+ if (RECORD_P (alien) && VECTOR_LENGTH (alien) == 4)
+ {
+ SCM high = VECTOR_REF (alien, 1);
+ SCM low = VECTOR_REF (alien, 2);
+ if (UNSIGNED_FIXNUM_P (high) && UNSIGNED_FIXNUM_P (low))
+ return (1);
+ }
+ return (0);
+}
+
+void*
+alien_address (SCM alien)
+{
+ ulong high = FIXNUM_TO_ULONG (VECTOR_REF (alien, 1));
+ ulong low = FIXNUM_TO_ULONG (VECTOR_REF (alien, 2));
+ return (void*)((high << HALF_WORD_SHIFT) + low);
+}
+
+void
+set_alien_address (SCM alien, const void* ptr)
+{
+ ulong addr = (ulong) ptr;
+ VECTOR_SET (alien, 1, ULONG_TO_FIXNUM (addr >> HALF_WORD_SHIFT));
+ VECTOR_SET (alien, 2, ULONG_TO_FIXNUM (addr & HALF_WORD_MASK));
+}
+
+SCM
+arg_alien (int argn)
+{
+ SCM alien = ARG_REF (argn);
+ if (is_alien (alien))
+ return (alien);
+ error_wrong_type_arg (argn);
+ /* NOTREACHED */
+ return ((SCM)0);
+}
+
+void*
+arg_address (int argn)
+{
+ SCM alien = ARG_REF (argn);
+ if (is_alien (alien))
+ return (alien_address (alien));
+ error_wrong_type_arg (argn);
+ /* NOTREACHED */
+ return ((SCM)0);
+}
+\f
+
+/* Peek the Basic Types */
+
+DEFINE_PRIMITIVE ("C-PEEK-CHAR", Prim_peek_char, 2, 2, 0)
+{
+ /* Return the C char at the address ALIEN+OFFSET. */
+
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ char* ptr = (char*)(addr+offset);
+ char value = *ptr;
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM ((long)value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-UCHAR", Prim_peek_uchar, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ unsigned char * ptr = (unsigned char*)(addr+offset);
+ unsigned char value = *ptr;
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM ((ulong)value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-SHORT", Prim_peek_short, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ short* ptr = (short*)(addr+offset);
+ short value = *ptr;
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM ((long)value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-USHORT", Prim_peek_ushort, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ ushort* ptr = (ushort*)(addr+offset);
+ ushort value = *ptr;
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM ((ulong)value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-INT", Prim_peek_int, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ int* ptr = (int*)(addr+offset);
+ int value = *ptr;
+ PRIMITIVE_RETURN (long_to_integer ((long)value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-UINT", Prim_peek_uint, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ uint* ptr = (uint*)(addr+offset);
+ uint value = *ptr;
+ PRIMITIVE_RETURN (ulong_to_integer ((ulong)value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-LONG", Prim_peek_long, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ long* ptr = (long*)(addr+offset);
+ long value = *ptr;
+ PRIMITIVE_RETURN (long_to_integer (value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-ULONG", Prim_peek_ulong, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ ulong* ptr = (ulong*)(addr+offset);
+ ulong value = *ptr;
+ PRIMITIVE_RETURN (ulong_to_integer (value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-FLOAT", Prim_peek_float, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ float* ptr = (float*)(addr+offset);
+ float value = *ptr;
+ PRIMITIVE_RETURN (double_to_flonum ((double)value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-DOUBLE", Prim_peek_double, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ double* ptr = (double*)(addr+offset);
+ double value = *ptr;
+ PRIMITIVE_RETURN (double_to_flonum (value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-POINTER", Prim_peek_pointer, 3, 3, 0)
+{
+ /* Read the pointer at ALIEN+OFFSET and set ALIEN2 (perhaps the
+ same as ALIEN) to point to the same address. */
+
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ SCM alien = ARG_RECORD (3);
+ void** ptr = (void**)(addr+offset);
+ void* value = *ptr;
+ set_alien_address (alien, value);
+ PRIMITIVE_RETURN (alien);
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-CSTRING", Prim_peek_cstring, 2, 2, 0)
+{
+ /* Return a Scheme string containing the characters in a C string
+ that starts at the address ALIEN+OFFSET. */
+
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ char* ptr = (char*)(addr+offset);
+ PRIMITIVE_RETURN (char_pointer_to_string (ptr));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-CSTRING!", Prim_peek_cstring_bang, 2, 2, 0)
+{
+ /* Return a Scheme string containing the characters in a C string
+ that starts at the address ALIEN+OFFSET. Set ALIEN to the
+ address of the C char after the string's null terminator. */
+
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ char* ptr = (char*)(addr+offset);
+ SCM str = char_pointer_to_string (ptr);
+ set_alien_address (ARG_REF (1), ptr + strlen (ptr) + 1);
+ PRIMITIVE_RETURN (str);
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP", Prim_peek_cstringp, 2, 2, 0)
+{
+ /* Follow the pointer at the address ALIEN+OFFSET to a C string.
+ Copy the C string into the heap and return the new Scheme
+ string. */
+
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ char** ptr = (char**)(addr+offset);
+ char* value = *ptr;
+ PRIMITIVE_RETURN (char_pointer_to_string (value));
+ }
+}
+
+DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP!", Prim_peek_cstringp_bang, 2, 2, 0)
+{
+ /* Follow the pointer at the address ALIEN+OFFSET to a C string.
+ Set ALIEN to the address of the char pointer after ALIEN+OFFSET.
+ Copy the C string into the heap and return the new Scheme
+ string. */
+
+ PRIMITIVE_HEADER (2);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ char** ptr = (char**)(addr+offset);
+ char* value = *ptr;
+ SCM val = char_pointer_to_string (value);
+ set_alien_address (ARG_REF (1), ptr + 1); /* No more aborts! */
+ PRIMITIVE_RETURN (val);
+ }
+}
+\f
+
+/* Poke the Basic Types */
+
+DEFINE_PRIMITIVE ("C-POKE-CHAR", Prim_poke_char, 3, 3, 0)
+{
+ /* Set the C char at address ALIEN+OFFSET to VALUE (an integer). */
+
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ char* ptr = (char*)(addr+offset);
+ *ptr = arg_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-UCHAR", Prim_poke_uchar, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ unsigned char* ptr = (unsigned char*)(addr+offset);
+ *ptr = arg_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-SHORT", Prim_poke_short, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ short* ptr = (short*)(addr+offset);
+ *ptr = arg_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-USHORT", Prim_poke_ushort, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ ushort* ptr = (ushort*)(addr+offset);
+ *ptr = arg_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-INT", Prim_poke_int, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ int* ptr = (int*)(addr+offset);
+ *ptr = arg_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-UINT", Prim_poke_uint, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ uint* ptr = (uint*)(addr+offset);
+ *ptr = arg_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-LONG", Prim_poke_long, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ long* ptr = (long*)(addr+offset);
+ *ptr = arg_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-ULONG", Prim_poke_ulong, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ ulong* ptr = (ulong*)(addr+offset);
+ *ptr = arg_ulong_integer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-FLOAT", Prim_poke_float, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ float* ptr = (float*)(addr+offset);
+ *ptr = arg_real_number (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-DOUBLE", Prim_poke_double, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = (char*) arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ double* ptr = (double*)(addr+offset);
+ *ptr = arg_real_number (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-POINTER", Prim_poke_pointer, 3, 3, 0)
+{
+ /* Set the pointer at address ALIEN+OFFSET to ADDRESS (an alien,
+ string, xstring or 0 for NULL). */
+
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ void** ptr = (void**)(addr+offset);
+ *ptr = arg_pointer (3);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-POINTER!", Prim_poke_pointer_bang, 3, 3, 0)
+{
+ /* Set the pointer at address ALIEN+OFFSET to ADDRESS (an alien,
+ string, xstring or 0 for NULL). Set ALIEN to the address of the
+ pointer after ALIEN+OFFSET. */
+
+ PRIMITIVE_HEADER (3);
+ {
+ char* addr = arg_address (1);
+ uint offset = UNSIGNED_FIXNUM_ARG (2);
+ void** ptr = (void**)(addr+offset);
+ *ptr = arg_pointer (3);
+ set_alien_address (ARG_REF (1), ptr + 1);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("C-POKE-STRING", Prim_poke_string, 3, 3, 0)
+{
+ /* Copy into the C string at address ALIEN+OFFSET the Scheme STRING.
+ Assume STRING fits. Null terminate the C string. */
+
+ PRIMITIVE_HEADER (3);
+ {
+ char* address, * scan;
+ int offset, length;
+ SCM string;
+
+ address = arg_address (1);
+ offset = UNSIGNED_FIXNUM_ARG (2);
+ CHECK_ARG (3, STRING_P);
+ string = ARG_REF (3);
+ length = STRING_LENGTH (string);
+ scan = STRING_POINTER (string);
+ strncpy (address + offset, scan, length+1);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+
+DEFINE_PRIMITIVE ("C-POKE-STRING!", Prim_poke_string_bang, 3, 3, 0)
+{
+ /* Copy into the C string at address ALIEN+OFFSET the Scheme STRING.
+ Assume STRING fits. Null terminate the C string. Set ALIEN to
+ the address of the C char following the NULL terminator. */
+
+ PRIMITIVE_HEADER (3);
+ {
+ char* address, * scan;
+ int offset, length;
+ SCM string;
+
+ address = arg_address (1);
+ offset = UNSIGNED_FIXNUM_ARG (2);
+ CHECK_ARG (3, STRING_P);
+ string = ARG_REF (3);
+ length = STRING_LENGTH (string);
+ scan = STRING_POINTER (string);
+ strncpy (address + offset, scan, length+1);
+ set_alien_address (ARG_REF (1), address + offset + length+1);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+\f
+
+/* Malloc/Free. */
+
+DEFINE_PRIMITIVE ("C-MALLOC", Prim_c_malloc, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ {
+ SCM alien = arg_alien (1);
+ int size = arg_ulong_integer (2);
+ void* mem = malloc (size);
+ set_alien_address (alien, mem);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+
+DEFINE_PRIMITIVE ("C-FREE", Prim_c_free, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ {
+ void* addr = arg_address (1);
+ if (addr != NULL)
+ free (addr);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+\f
+
+/* The CStack */
+
+char*
+cstack_top (void)
+{
+ return (ffi_obstack.next_free);
+}
+
+void
+cstack_push (void* addr, int bytes)
+{
+ obstack_grow ((&ffi_obstack), addr, bytes);
+}
+
+char*
+cstack_lpop (char* tos, int bytes)
+{
+ tos = tos - bytes;
+ if (tos < ffi_obstack.object_base)
+ {
+ outf_error ("\ninternal error: C stack exhausted\n");
+ outf_error ("\tCould not pop %d bytes.\n", bytes);
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+ return (tos);
+}
+
+void
+cstack_pop (char* tos)
+{
+ if (tos < ffi_obstack.object_base)
+ {
+ outf_error ("\ninternal error: C stack over-popped.\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+ (&ffi_obstack)->next_free = tos;
+}
+
+/* Number CStack frames, to detect slips. */
+int cstack_depth = 0;
+\f
+
+/* Callouts */
+
+DEFINE_PRIMITIVE ("C-CALL", Prim_c_call, 1, LEXPR, 0)
+{
+ /* All the smarts are in the trampolines. */
+
+ PRIMITIVE_HEADER (LEXPR);
+ canonicalize_primitive_context ();
+ {
+ CalloutTrampOut tramp;
+
+ tramp = (CalloutTrampOut) arg_alien_entry (1);
+ tramp ();
+ /* NOTREACHED */
+ outf_error ("\ninternal error: Callout part1 trampoline returned.\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ /* really NOTREACHED */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+
+static SCM c_call_continue = SHARP_F;
+
+void
+callout_seal (CalloutTrampIn tramp)
+{
+ /* Used in a callout part1 trampoline. Arrange for subsequent
+ aborts to start part2.
+
+ Seal the CStack, substitute the C-CALL-CONTINUE primitive for
+ the C-CALL primitive, and back out. The tramp can then execute
+ the toolkit function safely, even if there is a callback. */
+
+ if (c_call_continue == SHARP_F)
+ {
+ c_call_continue
+ = find_primitive_cname ("C-CALL-CONTINUE",
+ false, false, LEXPR_PRIMITIVE_ARITY);
+ if (c_call_continue == SHARP_F)
+ {
+ outf_error ("\nNo C-CALL-CONTINUE primitive!\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+ }
+ cstack_depth += 1;
+ CSTACK_PUSH (int, cstack_depth);
+ CSTACK_PUSH (CalloutTrampIn, tramp);
+
+ /* Back out of C-CALL-CONTINUE. */
+ SET_PRIMITIVE (c_call_continue);
+ back_out_of_primitive ();
+ /* Ready for Interpret(1). */
+}
+
+void
+callout_unseal (CalloutTrampIn expected)
+{
+ /* Used by a callout part1 trampoline to strip the CStack's frame
+ header (tramp, depth) before pushing return values. */
+
+ char* tos;
+ CalloutTrampIn found;
+ int depth;
+
+ tos = cstack_top ();
+ CSTACK_LPOP (CalloutTrampIn, found, tos);
+ CSTACK_LPOP (int, depth, tos);
+ if (found != expected || depth != cstack_depth)
+ {
+ outf_error ("\ninternal error: slipped in 1st part of callout\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+ cstack_pop (tos);
+}
+
+void
+callout_continue (CalloutTrampIn tramp)
+{
+ /* Re-seal the CStack frame over the C results (again, pushing the
+ cstack_depth and callout-part2) and abort. Restart as
+ C-CALL-CONTINUE and run callout-part2. */
+
+ CSTACK_PUSH (int, cstack_depth);
+ CSTACK_PUSH (CalloutTrampIn, tramp);
+
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
+ /* NOTREACHED */
+}
+
+DEFINE_PRIMITIVE ("C-CALL-CONTINUE", Prim_c_call_continue, 1, LEXPR, 0)
+{
+ /* (Re)Run the callout trampoline part 2 (CalloutTrampIn). */
+
+ PRIMITIVE_HEADER (LEXPR);
+ {
+ char* tos;
+ CalloutTrampIn tramp;
+ int depth;
+ SCM val;
+
+ tos = cstack_top ();
+ CSTACK_LPOP (CalloutTrampIn, tramp, tos);
+ CSTACK_LPOP (int, depth, tos);
+ if (depth != cstack_depth)
+ {
+ outf_error ("\ninternal error: slipped in 2nd part of callout\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+ val = tramp ();
+ PRIMITIVE_RETURN (val);
+ }
+}
+
+char*
+callout_lunseal (CalloutTrampIn expected)
+{
+ /* Used by a callout part2 trampoline to strip the CStack's frame
+ header (tramp, depth) before lpopping return value(s). */
+
+ char* tos;
+ CalloutTrampIn found;
+ int depth;
+
+ tos = cstack_top ();
+ CSTACK_LPOP (CalloutTrampIn, found, tos);
+ CSTACK_LPOP (int, depth, tos);
+ if (depth != cstack_depth || found != expected)
+ {
+ outf_error ("\ninternal error: slipped in 1st part of callout\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+ return (tos);
+}
+
+void
+callout_pop (char* tos)
+{
+ /* Used by a callout part2 trampoline just before returning. */
+
+ cstack_depth -= 1;
+ cstack_pop (tos);
+}
+\f
+
+/* Callbacks */
+
+static SCM run_callback = SHARP_F;
+static SCM return_to_c = SHARP_F;
+
+void
+callback_run_kernel (int callback_id, CallbackKernel kernel)
+{
+ /* Used by callback trampolines.
+
+ Expect the args on the CStack. Push a couple primitive apply
+ frames on the Scheme stack and seal the CStack. Then call
+ Interpret(). Cannot abort. */
+
+ long int_mask;
+
+ if (run_callback == SHARP_F)
+ {
+ run_callback = find_primitive_cname ("RUN-CALLBACK", false, false, 0);
+ return_to_c = find_primitive_cname ("RETURN-TO-C", false, false, 0);
+ if (run_callback == SHARP_F || return_to_c == SHARP_F)
+ {
+ outf_error
+ ("\nWarning: punted callback #%d. Missing primitives!\n",
+ callback_id);
+ outf_flush_error ();
+ SET_VAL (FIXNUM_ZERO);
+ return;
+ }
+ }
+
+ /* Need to push 2 each of prim+header+continuation. */
+ if (! CAN_PUSH_P (2*(1+1+CONTINUATION_SIZE)))
+ {
+ outf_error
+ ("\nWarning: punted callback #%d. No room on stack!\n", callback_id);
+ outf_flush_error ();
+ SET_VAL (FIXNUM_ZERO);
+ return;
+ }
+
+ cstack_depth += 1;
+ CSTACK_PUSH (int, cstack_depth);
+ CSTACK_PUSH (CallbackKernel, kernel);
+
+ STACK_PUSH (return_to_c);
+ PUSH_APPLY_FRAME_HEADER (0);
+ SET_RC (RC_INTERNAL_APPLY);
+ SAVE_CONT();
+ STACK_PUSH (run_callback);
+ PUSH_APPLY_FRAME_HEADER (0);
+ SAVE_CONT();
+
+ /* Turn off thread switching. */
+ int_mask = GET_INT_MASK;
+ SET_INTERRUPT_MASK (int_mask & ~INT_Timer);
+ Interpret (1);
+ SET_INTERRUPT_MASK (int_mask);
+
+ cstack_depth -= 1;
+}
+
+DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0)
+{
+ /* All the smarts are in the kernel. */
+
+ PRIMITIVE_HEADER (0);
+ {
+ char* tos;
+ CallbackKernel kernel;
+ int depth;
+
+ tos = cstack_top ();
+ CSTACK_LPOP (CallbackKernel, kernel, tos);
+ CSTACK_LPOP (int, depth, tos);
+ if (depth != cstack_depth)
+ {
+ outf_error ("\nWarning: C data stack slipped in run-callback!\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+
+ kernel ();
+ /* NOTREACHED */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+
+DEFINE_PRIMITIVE ("RETURN-TO-C", Prim_return_to_c, 0, 0, 0)
+{
+ /* Callbacks are possible while stopped. The PRIM_RETURN_TO_C abort
+ expects this primitive to clean up its stack frame. */
+
+ PRIMITIVE_HEADER (0);
+ canonicalize_primitive_context ();
+ {
+ SCM primitive;
+ long nargs;
+
+ primitive = GET_PRIMITIVE;
+ assert (PRIMITIVE_P (primitive));
+ nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
+ POP_PRIMITIVE_FRAME (nargs);
+ SET_EXP (SHARP_F);
+ PRIMITIVE_ABORT (PRIM_RETURN_TO_C);
+ /* NOTREACHED */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+
+char*
+callback_lunseal (CallbackKernel expected)
+{
+ /* Used by a callback kernel to strip the CStack's frame header
+ (kernel, depth) before lpopping arguments. */
+
+ char* tos;
+ CallbackKernel found;
+ int depth;
+
+ tos = cstack_top ();
+ CSTACK_LPOP (CallbackKernel, found, tos);
+ CSTACK_LPOP (int, depth, tos);
+ if (depth != cstack_depth || found != expected)
+ {
+ outf_error ("\ninternal error: slipped in callback kernel\n");
+ outf_flush_error ();
+ signal_error_from_primitive (ERR_EXTERNAL_RETURN);
+ }
+ return (tos);
+}
+
+static SCM valid_callback_handler (void);
+static SCM valid_callback_id (int id);
+
+void
+callback_run_handler (int callback_id, SCM arglist)
+{
+ /* Similar to setup_interrupt [utils.c]. Used by callback kernels,
+ inside the interpreter. Thus it MAY GC abort.
+
+ Push a Scheme callback handler apply frame. This leaves the
+ interpreter ready to tail-call the Scheme procedure. (The
+ RUN-CALLBACK primitive apply frame is already gone.) The
+ trampoline should abort with PRIM_APPLY. */
+
+ SCM handler, fixnum_id;
+
+ handler = valid_callback_handler ();
+ fixnum_id = valid_callback_id (callback_id);
+
+ stop_history ();
+ /* preserve_interrupt_mask ();
+
+ The above statement appears in setup_interrupt. In this case,
+ something similar is done in callback_run_kernel, BEFORE
+ re-entering the interpreter. (The "BEFORE" part is
+ important!) */
+
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
+ STACK_PUSH (arglist);
+ STACK_PUSH (fixnum_id);
+ STACK_PUSH (handler);
+ PUSH_APPLY_FRAME_HEADER (2);
+ Pushed ();
+ /* Turn off interrupts: */
+ /* SET_INTERRUPT_MASK (interrupt_mask);
+
+ The above statement (from setup_interrupt) must move to
+ callback_run_kernel. */
+}
+
+static SCM
+valid_callback_handler (void)
+{
+ /* Validate the Scheme callback handler procedure. */
+
+ SCM handler;
+
+ handler = (VECTOR_REF (fixed_objects, CALLBACK_HANDLER));
+ if (! interpreter_applicable_p (handler))
+ {
+ outf_error ("\nWarning: bogus callback handler: 0x%x.\n", (uint)handler);
+ outf_flush_error ();
+ Do_Micro_Error (ERR_INAPPLICABLE_OBJECT, true);
+ abort_to_interpreter (PRIM_APPLY);
+ /* NOTREACHED */
+ }
+ return (handler);
+}
+
+static SCM
+valid_callback_id (int id)
+{
+ /* Validate the callback ID and convert to a fixnum. */
+
+ if (ULONG_TO_FIXNUM_P (id))
+ return (ULONG_TO_FIXNUM (id));
+ signal_error_from_primitive (ERR_ARG_1_BAD_RANGE);
+ /* NOTREACHED */
+ return (FIXNUM_ZERO);
+}
+
+void
+callback_return (char* tos)
+{
+ cstack_pop (tos);
+ PRIMITIVE_ABORT (PRIM_APPLY);
+}
+\f
+
+/* Converters */
+
+long
+arg_long (int argn)
+{
+ return (arg_integer (argn));
+}
+
+ulong
+arg_ulong (int argn)
+{
+ return (arg_ulong_integer (argn));
+}
+
+double
+arg_double (int argn)
+{
+ /* Convert the object to a double. Like arg_real_number. */
+
+ return (arg_real_number (argn));
+}
+
+void*
+arg_alien_entry (int argn)
+{
+ /* Expect an alien-function. Return its address. */
+
+ SCM alienf = VECTOR_ARG (argn);
+ int length = VECTOR_LENGTH (alienf);
+ if (length < 3)
+ error_wrong_type_arg (argn);
+ return (alien_address (alienf));
+}
+
+void*
+arg_pointer (int argn)
+{
+ /* Accept an alien, string, xstring handle (positive integer),
+ or zero (for a NULL pointer). */
+
+ SCM arg = ARG_REF (argn);
+ if (integer_zero_p (arg))
+ return ((void*)0);
+ if (STRING_P (arg))
+ return ((void*) (STRING_POINTER (arg)));
+ if ((INTEGER_P (arg)) && (integer_to_ulong_p (arg)))
+ {
+ unsigned char* result = lookup_external_string (arg, NULL);
+ if (result == 0)
+ error_wrong_type_arg (argn);
+ return ((void*) result);
+ }
+ if (is_alien (arg))
+ return (alien_address (arg));
+
+ error_wrong_type_arg (argn);
+ /*NOTREACHED*/
+ return ((void*)0);
+}
+
+SCM
+long_to_scm (const long i)
+{
+ return (long_to_integer (i));
+}
+
+SCM
+ulong_to_scm (const ulong i)
+{
+ return (ulong_to_integer (i));
+}
+
+SCM
+double_to_scm (const double d)
+{
+ return (double_to_flonum (d));
+}
+
+SCM
+pointer_to_scm (const void* p)
+{
+ /* Return a pointer from a callout. Expect the first real argument
+ (the 2nd) to be either #F or an alien. */
+
+ SCM arg = ARG_REF (2);
+ if (arg == SHARP_F)
+ return (UNSPECIFIC);
+ if (is_alien (arg))
+ {
+ set_alien_address (arg, p);
+ return (arg);
+ }
+
+ error_wrong_type_arg (2);
+ /* NOTREACHED */
+ return (SHARP_F);
+}
+
+SCM
+cons_alien (const void* addr)
+{
+ /* Construct an alien. Used by callback kernels to construct
+ arguments for the Scheme callback-handler, or part2 of callouts
+ returning a new alien. Note that these should be fixed up on the
+ Scheme side with the record type. */
+
+ SCM alien;
+ Primitive_GC_If_Needed (5);
+ alien = (MAKE_POINTER_OBJECT (TC_RECORD, Free));
+ (*Free++) = MAKE_OBJECT (TC_MANIFEST_VECTOR, 4);
+ (*Free++) = SHARP_F;
+ (*Free++) = FIXNUM_ZERO;
+ (*Free++) = FIXNUM_ZERO;
+ (*Free++) = SHARP_F;
+ set_alien_address (alien, addr);
+ return (alien);
+}
+
+long
+long_value (void)
+{
+ /* Convert VAL to a long. Accept integers AND characters. Like
+ arg_integer otherwise. */
+
+ SCM value = GET_VAL;
+ if (CHARACTER_P (value))
+ return (CHAR_TO_ASCII (value));
+ if (! (INTEGER_P (value)))
+ {
+ /* error_wrong_type_arg (1); Not inside the interpreter here. */
+ outf_error ("\nWarning: Callback did not return an integer!\n");
+ outf_flush_error ();
+ return (0);
+ }
+ if (! (integer_to_long_p (value)))
+ {
+ /* error_bad_range_arg (1); */
+ outf_error
+ ("\nWarning: Callback returned an integer larger than a C long!\n");
+ outf_flush_error ();
+ return (0);
+ }
+ return (integer_to_long (value));
+}
+
+ulong
+ulong_value (void)
+{
+ /* Convert VAL to an unsigned long. Accept integers AND characters.
+ Like arg_integer otherwise. */
+
+ SCM value = GET_VAL;
+ if (CHARACTER_P (value))
+ return (CHAR_TO_ASCII (value));
+ if (! (INTEGER_P (value)))
+ {
+ /* error_wrong_type_arg (1); Not inside the interpreter here. */
+ outf_error ("\nWarning: Callback did not return an integer!\n");
+ outf_flush_error ();
+ return (0);
+ }
+ if (! (integer_to_ulong_p (value)))
+ {
+ /* error_bad_range_arg (1); */
+ outf_error
+ ("\nWarning: Callback returned an integer larger than a C ulong!\n");
+ outf_flush_error ();
+ return (0);
+ }
+ return (integer_to_ulong (value));
+}
+
+double
+double_value (void)
+{
+ /* Convert VAL to a double. Like arg_real_number. */
+
+ SCM value = GET_VAL;
+
+ if (! REAL_P (value))
+ {
+ /* error_wrong_type_arg (1); Not inside the interpreter here. */
+ outf_error ("\nWarning: Callback did not return a real.\n");
+ outf_flush_error ();
+ return (0.0);
+ }
+ if (! (real_number_to_double_p (value)))
+ {
+ /* error_bad_range_arg (1); */
+ outf_error
+ ("\nWarning: Callback returned a real larger than a C double!\n");
+ outf_flush_error ();
+ return (0.0);
+ }
+ return (real_number_to_double (value));
+}
+
+void*
+pointer_value (void)
+{
+ SCM value = GET_VAL;
+
+ if (integer_zero_p (value))
+ return (NULL);
+ /* NOT allowing a Scheme string (heap pointer!) into the toolkit. */
+ if ((INTEGER_P (value)) && (integer_to_ulong_p (value)))
+ {
+ unsigned char* result = lookup_external_string (value, NULL);
+ if (result == 0)
+ {
+ outf_error ("\nWarning: Callback returned a bogus xstring.\n");
+ outf_flush_error ();
+ return (NULL);
+ }
+ return ((void*) result);
+ }
+ if (is_alien (value))
+ return (alien_address (value));
+
+ outf_error ("\nWarning: Callback did not return a pointer.\n");
+ outf_flush_error ();
+ return (NULL);
+}
+\f
+
+/* Utilities */
+
+
+void
+check_number_of_args (int num)
+{
+ if (GET_LEXPR_ACTUALS < num)
+ {
+ signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+}
+
+SCM
+unspecific (void)
+{
+ return (UNSPECIFIC);
+}
+
+SCM
+empty_list (void)
+{
+ return (EMPTY_LIST);
+}
+
+DEFINE_PRIMITIVE ("OUTF-CONSOLE", Prim_outf_console, 1, 1, 0)
+{
+ /* To avoid the normal i/o system when debugging a callback. */
+
+ PRIMITIVE_HEADER (1);
+ {
+ SCM arg = ARG_REF (1);
+ if (STRING_P (arg))
+ {
+ char* string = ((char*) STRING_LOC (arg, 0));
+ outf_console ("%s", string);
+ outf_flush_console ();
+ }
+ else
+ {
+ error_wrong_type_arg (1);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Id: $
+
+Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Headers for the FFI (foreign function interface). */
+
+/* This file declares all of the C functions needed by a shim. It is
+ installed as mit-scheme.h and represents the interface between the
+ shims and the machine. It should not include any other headers,
+ and should minimize dependencies on the exact configuration of the
+ machine. Thus it declares teensy functions like empty_list(). */
+
+/* This is redundant, but avoids the need for object.h, config.h, types.h... */
+typedef unsigned long SCM;
+
+extern char* cstack_top (void);
+extern void cstack_push (void * addr, int bytes);
+extern char* cstack_lpop (char* tos, int bytes);
+extern void cstack_pop (char* tos);
+
+#define CSTACK_PUSH(TYPE,VAR) \
+ cstack_push (((void *)(&VAR)), sizeof (TYPE));
+
+/* "Local" CStack pops keep the top-of-stack in a local variable
+ (TOS). Thus after an abort the trampoline can start again from the
+ undisturbed top of the obstack. */
+#define CSTACK_LPOP(TYPE,VAR,TOS) \
+ TOS = cstack_lpop (TOS, sizeof (TYPE)); \
+ VAR = *(TYPE *)TOS;
+
+typedef void (*CalloutTrampOut)(void);
+typedef SCM (*CalloutTrampIn)(void);
+extern void callout_seal (CalloutTrampIn tramp);
+extern void callout_unseal (CalloutTrampIn expected);
+extern void callout_continue (CalloutTrampIn tramp);
+extern char* callout_lunseal (CalloutTrampIn expected);
+extern void callout_pop (char* tos);
+
+typedef void (*CallbackKernel)(void);
+extern void callback_run_kernel (int callback_id, CallbackKernel kernel);
+extern char* callback_lunseal (CallbackKernel expected);
+extern void callback_run_handler (int callback_id, SCM arglist);
+extern void callback_return (char* tos);
+
+/* Converters. */
+
+extern long arg_long (int argn);
+extern unsigned long arg_ulong (int argn);
+extern double arg_double (int argn);
+extern void* arg_alien_entry (int argn);
+extern void* arg_pointer (int argn);
+
+extern SCM long_to_scm (const long i);
+extern SCM ulong_to_scm (const unsigned long i);
+extern SCM double_to_scm (const double d);
+extern SCM pointer_to_scm (const void* p);
+
+extern SCM cons_alien (const void* p);
+
+extern long long_value (void);
+extern unsigned long ulong_value (void);
+extern double double_value (void);
+extern void* pointer_value (void);
+
+/* Utilities: */
+
+extern void check_number_of_args (int num);
+extern SCM unspecific (void);
+extern SCM empty_list (void);
+
+#ifndef MIT_SCHEME /* Do not include in the microcode, just shims. */
+extern SCM cons (SCM car, SCM cdr);
+/* For debugging messages from shim code. */
+extern void outf_error (const char *, ...);
+extern void outf_flush_error (void);
+#endif
PC-Sample/UFO-Table ;3E
COMPILED-CODE-BKPT-HANDLER ;3F
GC-WABBIT-DESCWIPTOR ;40
+ CALLBACK-HANDLER ;41
))
\f
;;; [] Types
("equals" (runtime equality))
("error" (runtime error-handler))
("events" (runtime event-distributor))
+ ("ffi" (runtime ffi))
("fileio" (runtime file-i/o-port))
("fixart" (runtime fixnum-arithmetic))
("format" (runtime format))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Aliens and Alien Functions
+;;; package: (runtime ffi)
+
+(declare (usual-integrations))
+\f
+
+;;; Aliens
+
+(define-structure (alien (constructor %make-alien)
+ (conc-name %alien/)
+ (copier copy-alien)
+ (predicate alien?))
+ ;; Two fixnums.
+ (high-bits 0) (low-bits 0)
+ ;; A symbol or list.
+ ctype)
+
+(set-record-type-unparser-method! rtd:alien
+ (standard-unparser-method
+ 'alien
+ (lambda (alien port)
+ (write-char #\space port)
+ (write (%alien/ctype alien) port)
+ (write-string " 0x" port)
+ (write-string (alien/address-string alien) port))))
+
+(define-integrable alien/ctype %alien/ctype)
+
+(define-integrable set-alien/ctype! set-%alien/ctype!)
+
+(define (alien/address-string alien)
+ ;; Returns a string of length 8, e.g. "081adc60".
+ (let ((high (%alien/high-bits alien)))
+ (if (eq? high #f) "< null >"
+ (let ((low (%alien/low-bits alien))
+ (4hex (lambda (n)
+ (string-pad-left (number->string n 16) 4 #\0))))
+ (string-append (4hex high) (4hex low))))))
+
+(define (make-alien #!optional ctype)
+ (let ((ctype (if (default-object? ctype) #f ctype)))
+ (%make-alien 0 0 ctype)))
+
+(define-integrable (alien/address alien)
+ (+ (* (%alien/high-bits alien) #x10000)
+ (%alien/low-bits alien)))
+
+(define-integrable (copy-alien-address! alien source)
+ (if (not (eq? alien source))
+ (begin
+ (set-%alien/high-bits! alien (%alien/high-bits source))
+ (set-%alien/low-bits! alien (%alien/low-bits source)))))
+
+(define-integrable (alien-null? alien)
+ (and (fix:zero? (%alien/high-bits alien))
+ (fix:zero? (%alien/low-bits alien))))
+
+(define-integrable (alien-null! alien)
+ (set-%alien/high-bits! alien 0)
+ (set-%alien/low-bits! alien 0))
+
+(define null-alien (make-alien '|void|))
+
+(define-integrable (alien=? alien1 alien2)
+ (and (fix:= (%alien/high-bits alien1) (%alien/high-bits alien2))
+ (fix:= (%alien/low-bits alien1) (%alien/low-bits alien2))))
+
+(define (alien-hash alien modulus)
+ ;; Appropriate for hash table construction (as is alien=?).
+ (remainder (fix:xor (%alien/high-bits alien)
+ (%alien/low-bits alien)) modulus))
+
+(define (alien-byte-increment alien offset #!optional ctype)
+ ;; Returns a new alien - a copy of ALIEN - whose address is OFFSET
+ ;; bytes from ALIEN's. If CTYPE is specified, the type slot of the
+ ;; new alien is set.
+ (let ((new (copy-alien alien)))
+ (alien-byte-increment! new offset)
+ (if (not (default-object? ctype))
+ (set-%alien/ctype! new ctype))
+ new))
+
+(define (alien-byte-increment! alien increment #!optional ctype)
+ ;; This procedure returns ALIEN after modifying it to have an
+ ;; address INCREMENT bytes away from its previous address. If CTYPE
+ ;; is specified, the type slot of ALIEN is set.
+ (let ((quotient.remainder (fix:divide increment #x10000)))
+ (let ((new-high (fix:+ (%alien/high-bits alien)
+ (integer-divide-quotient quotient.remainder)))
+ (new-low (fix:+ (%alien/low-bits alien)
+ (integer-divide-remainder quotient.remainder))))
+ (cond ((fix:negative? new-high)
+ (error:bad-range-argument increment 'alien-byte-increment!))
+ ((fix:negative? new-low)
+ (if (fix:zero? new-high)
+ (error:bad-range-argument increment 'alien-byte-increment!)
+ (begin
+ (set-%alien/low-bits! alien (fix:+ new-low #x10000))
+ (set-%alien/high-bits! alien (fix:-1+ new-high)))))
+ ((fix:>= new-low #x10000)
+ (set-%alien/low-bits! alien (fix:- new-low #x10000))
+ (set-%alien/high-bits! alien (fix:1+ new-high)))
+ (else
+ (set-%alien/low-bits! alien new-low)
+ (set-%alien/high-bits! alien new-high)))))
+ (if (not (default-object? ctype))
+ (set-%alien/ctype! alien ctype))
+ alien)
+
+(define (guarantee-alien operator object #!optional ctype)
+ (let loop ((object object))
+ (if (and (alien? object)
+ (or (default-object? ctype)
+ (equal? (%alien/ctype object) ctype)))
+ object
+ (loop
+ (call-with-current-continuation
+ (lambda (continuation)
+ (with-restart
+ 'USE-VALUE ;name
+ "Continue with an alien." ;reporter
+ continuation ;effector
+ (lambda () ;interactor
+ (values
+ (prompt-for-evaluated-expression
+ "New alien (an expression to be evaluated)")))
+ (lambda () ;thunk
+ (error:wrong-type-argument
+ object "an alien" operator)))))))))
+\f
+
+;;; Alien Functions
+
+(define-structure (alien-function
+ (constructor %make-alien-function)
+ (conc-name %alien-function/)
+ (predicate alien-function?)
+ ;; To be fasdump/loadable.
+ (type vector) (named 'alien-function)
+ (print-procedure
+ (standard-unparser-method 'ALIEN-FUNCTION
+ (lambda (alienf port)
+ (write-char #\space port)
+ (write-string (%alien-function/name alienf)
+ port)))))
+
+ ;; C function entry address as two fixnums.
+ high-bits low-bits
+
+ ;; String: name of trampoline. (Starts with "Scm_".)
+ name
+
+ ;; String: name of shim. (WithOUT "-shim.so" on the end.)
+ library
+
+ ;; Caseful symbol or list, e.g. (* |GtkWidget|).
+ return-type
+
+ ;; Alist of parameter names * types, e.g. ((widget (* |GtkWidget|))...)
+ parameters
+
+ ;; Filename from which the EXTERN declaration was read.
+ filename
+
+ ;; Band ID
+ band-id)
+
+(define (make-alien-function name library return-type params filename)
+ (%make-alien-function 0 0 (string-append "Scm_" name)
+ library return-type params filename #f))
+
+(define-integrable alien-function/return-type %alien-function/return-type)
+
+(define-integrable alien-function/parameters %alien-function/parameters)
+
+(define-integrable alien-function/filename %alien-function/filename)
+
+(define-integrable (alien-function/name alienf)
+ (string-tail (%alien-function/name alienf) 4))
+
+(define (%set-alien-function/address! alienf address)
+ (let ((qr (integer-divide address #x10000)))
+ (set-%alien-function/high-bits! alienf (integer-divide-quotient qr))
+ (set-%alien-function/low-bits! alienf (integer-divide-remainder qr))))
+
+(define band-id)
+
+(define (reset-alien-functions!)
+ (set! band-id (list (get-universal-time))))
+
+(define (alien-function-cache! afunc)
+ (if (eq? band-id (%alien-function/band-id afunc))
+ unspecific
+ (let* ((library (%alien-function/library afunc))
+ (name (%alien-function/name afunc))
+ (pathname (merge-pathnames
+ (pathname-new-type (string-append library "-shim") "so")
+ (system-library-directory-pathname "lib")))
+ (handle (or (find-dld-handle
+ (lambda (h)
+ (pathname=? pathname (dld-handle-pathname h))))
+ (dld-load-file pathname)))
+ (address (dld-lookup-symbol handle name)))
+ (if address
+ (%set-alien-function/address! afunc address)
+ (error:bad-range-argument afunc 'alien-function-cache!))
+ (set-%alien-function/band-id! afunc band-id))))
+
+(define (c-peek-cstring alien)
+ ((ucode-primitive c-peek-cstring 2) alien 0))
+
+(define (c-peek-cstring! alien)
+ ((ucode-primitive c-peek-cstring! 2) alien 0))
+
+(define (c-peek-cstringp alien)
+ ((ucode-primitive c-peek-cstringp 2) alien 0))
+
+(define (c-peek-cstringp! alien)
+ ((ucode-primitive c-peek-cstringp! 2) alien 0))
+
+(define (c-poke-pointer dest alien)
+ ;; Sets the pointer at the alien DEST to point to the ALIEN.
+ ((ucode-primitive c-poke-pointer 3) dest 0 alien))
+
+(define (c-poke-pointer! dest alien)
+ ;; Like c-poke-pointer, but increments DEST by a pointer width.
+ ((ucode-primitive c-poke-pointer! 3) dest 0 alien))
+
+(define (c-poke-string alien string)
+ ;; Copy STRING to the bytes at the ALIEN address.
+ (guarantee-string string 'C-POKE-STRING)
+ ((ucode-primitive c-poke-string 3) alien 0 string))
+
+(define (c-poke-string! alien string)
+ ;; Like c-poke-string, but increments ALIEN by the null-terminated
+ ;; STRING length.
+ (guarantee-string string 'C-POKE-STRING)
+ ((ucode-primitive c-poke-string! 3) alien 0 string))
+
+(define (c-enum-name value enum-name constants)
+ enum-name
+ (let loop ((consts constants))
+ (if (null? consts)
+ (error:bad-range-argument value 'c-enum-name)
+ (let ((name.value (car consts)))
+ (if (= value (cdr name.value))
+ (car name.value)
+ (loop (cdr consts)))))))
+
+(define (call-alien alien-function . args)
+ (if (not (alien-function? alien-function))
+ (error:bad-range-argument alien-function 'call-alien))
+ (alien-function-cache! alien-function)
+ (for-each
+ (lambda (arg)
+ (if (alien-function? arg)
+ (alien-function-cache! arg)))
+ args)
+ (without-timer-interrupts
+ (lambda ()
+ (call-alien* alien-function args))))
+
+(define (call-alien* alien-function args)
+ (let ((old-top calloutback-stack))
+ (if-tracing
+ (outf-console ";"(tindent)"=> "alien-function" "args"\n")
+ (set! calloutback-stack (cons (cons* alien-function args) old-top)))
+ (let ((value (apply (ucode-primitive c-call) alien-function args)))
+ (if-tracing
+ (assert (eq? old-top (cdr calloutback-stack))
+ "call-alien: freak stack "calloutback-stack"\n")
+ (set! calloutback-stack old-top)
+ (outf-console ";"(tindent)"<= "value"\n"))
+ value)))
+\f
+
+;;; Malloc/Free
+
+;; Weak alist of: ( malloc alien X copy for the finalizer )...
+(define malloced-aliens '())
+
+(define (finalize-malloced-aliens)
+ (let loop ((aliens malloced-aliens)
+ (prev #f))
+ (if (pair? aliens)
+ (if (weak-pair/car? (car aliens))
+ (loop (cdr aliens) aliens)
+ (let ((copy (weak-cdr (car aliens)))
+ (next (cdr aliens)))
+ (if prev
+ (set-cdr! prev next)
+ (set! malloced-aliens next))
+ (if (not (alien-null? copy))
+ (begin
+ ((ucode-primitive c-free 1) copy)
+ (alien-null! copy)))
+ (loop next prev))))))
+
+(define (reset-malloced-aliens!)
+ (let loop ((aliens malloced-aliens))
+ (if (pair? aliens)
+ (let ((alien (weak-car (car aliens)))
+ (copy (weak-cdr (car aliens))))
+ (if alien (alien-null! alien))
+ (alien-null! copy)
+ (loop (cdr aliens)))))
+ (set! malloced-aliens '()))
+
+(define (malloc size ctype)
+ ;; Add copy to finalizer BEFORE calling malloc.
+ (let ((alien (make-alien ctype))
+ (copy (make-alien ctype)))
+ (set! malloced-aliens (cons (weak-cons alien copy) malloced-aliens))
+ ((ucode-primitive c-malloc 2) copy size)
+ ;; Even an interrupt here will not leak a byte.
+ (copy-alien-address! alien copy)
+ alien))
+
+(define (free alien)
+ (if (not (alien? alien))
+ (warn "Cannot free a non-alien:" alien)
+ (let ((weak (weak-assq alien malloced-aliens)))
+ (if (not weak)
+ (warn "Cannot free an alien that was not malloced:" alien)
+ (let ((copy (weak-cdr weak)))
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? copy))
+ (begin
+ (alien-null! copy)
+ ((ucode-primitive c-free 1) copy)
+ (alien-null! alien))))))))))
+
+(define (weak-assq obj alist)
+ (let loop ((alist alist))
+ (if (null? alist) #f
+ (let* ((entry (car alist))
+ (key (weak-car entry)))
+ (if (eq? obj key) entry
+ (loop (cdr alist)))))))
+\f
+
+;;; Callback support
+
+(define registered-callbacks)
+(define first-free-id)
+
+(define (reset-callbacks!)
+ (set! registered-callbacks (make-vector 100 #f))
+ (set! first-free-id 1))
+
+(define (register-c-callback procedure)
+ (if (not (procedure? procedure))
+ (error:wrong-type-argument procedure "a procedure" 'register-c-callback))
+ (without-interrupts
+ (lambda ()
+ (let ((id first-free-id))
+ (set! first-free-id (next-free-id (1+ id)))
+ (vector-set! registered-callbacks id procedure)
+ id))))
+
+(define (next-free-id id)
+ (let ((len (vector-length registered-callbacks)))
+ (let next-id ((id id))
+ (cond ((= id len)
+ (set! registered-callbacks
+ (vector-grow registered-callbacks (* 2 len)))
+ (next-free-id id))
+ ((not (vector-ref registered-callbacks id)) id)
+ ;; When not recycling ids, the above is always true.
+ ;; There is no need for the next-id loop.
+ (else (next-id (1+ id)))))))
+
+(define (de-register-c-callback id)
+ (vector-set! registered-callbacks id #f)
+ ;; Uncomment to recycle ids.
+ ;;(if (< id first-free-id)
+ ;; (set! first-free-id id))
+ )
+
+(define (normalize-aliens! args)
+ ;; Any vectors among ARGS are assumed to be freshly-consed aliens
+ ;; without their record-type. Fix them.
+ (let ((tag (record-type-dispatch-tag rtd:alien)))
+ (let loop ((args args))
+ (if (null? args)
+ unspecific
+ (let ((arg (car args)))
+ (if (%record? arg) (%record-set! arg 0 tag))
+ (loop (cdr args)))))))
+
+(define (callback-handler id args)
+ ;; Installed in the fixed-objects-vector, this procedure is called
+ ;; by a callback trampoline, which ensures that timer interrupts are
+ ;; masked until the interpreter returns a value.
+
+ (if (not (< id (vector-length registered-callbacks)))
+ (error:bad-range-argument id 'apply-callback))
+ (let ((procedure (vector-ref registered-callbacks id)))
+ (if (not procedure)
+ (error:bad-range-argument id 'apply-callback))
+ (normalize-aliens! args)
+ (let ((old-top calloutback-stack))
+ (if-tracing
+ (outf-console ";"(tindent)"=>> "procedure" "args"\n")
+ (set! calloutback-stack (cons (cons procedure args) old-top)))
+ (let ((value (apply-callback-proc procedure args)))
+ (if-tracing
+ (assert (and (pair? calloutback-stack)
+ (eq? old-top (cdr calloutback-stack)))
+ "callback-handler: freak stack "calloutback-stack"\n")
+ (set! calloutback-stack old-top)
+ (outf-console ";"(tindent)"<<= "value"\n"))
+ value))))
+
+(define (apply-callback-proc procedure args)
+ (call-with-current-continuation
+ (lambda (return)
+ (with-restart
+ 'USE-VALUE ;name
+ "Return a value from the callback." ;reporter
+ return ;effector
+ (lambda () ;interactor
+ (values (prompt-for-evaluated-expression
+ "Value to return from callback")))
+ (lambda () ;thunk
+ (let ((done? #f))
+ (if (not done?)
+ (begin
+ (set! done? #t)
+ (apply procedure args))
+ (let loop ()
+ (error "Cannot return from a callback more than once.")
+ (loop)))))))))
+
+;; For callback debugging...
+(define (outf-console . objects)
+ ((ucode-primitive outf-console)
+ (apply string-append
+ (map (lambda (o) (if (string? o) o (write-to-string o)))
+ objects))))
+
+(define (initialize-callbacks!)
+ (vector-set! (get-fixed-objects-vector) #x41 callback-handler))
+\f
+
+(define calloutback-stack '())
+
+(define tracing? #f)
+
+(define (reset-package!)
+ (reset-alien-functions!)
+ (reset-malloced-aliens!)
+ (reset-callbacks!)
+ (set! tracing? #f)
+ (set! calloutback-stack '()))
+
+(define (initialize-package!)
+ (reset-package!)
+ (initialize-callbacks!)
+ (add-event-receiver! event:after-restore reset-package!)
+ unspecific)
+
+(define-syntax if-tracing
+ (syntax-rules ()
+ ((_ . BODY)
+ (if tracing? ((lambda () . BODY))))))
+
+(define-syntax assert
+ (syntax-rules ()
+ ((_ TEST . MSG)
+ (if (not TEST) (error "Failed assert:" . MSG)))))
+
+(define-syntax trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if tracing? ((lambda () (outf-console . MSG)))))))
+
+(define (tindent)
+ (make-string (* 2 (length calloutback-stack)) #\space))
\ No newline at end of file
(RUNTIME HTTP-SYNTAX)
(RUNTIME HTTP-CLIENT)
(RUNTIME HTML-FORM-CODEC)
- (RUNTIME WIN32-REGISTRY)))
+ (RUNTIME WIN32-REGISTRY)
+ (RUNTIME FFI)))
\f
(let ((obj (file->object "site" #t #f)))
(if obj
directory-channel/descriptor)
(initialization (initialize-package!)))
+(define-package (runtime ffi)
+ (parent (runtime))
+ (files "ffi")
+ (export ()
+ make-alien
+ copy-alien
+ alien/ctype
+ set-alien/ctype!
+ alien?
+ alien-null?
+ alien-null!
+ alien/address-string
+ null-alien
+ alien=?
+ alien-hash
+ copy-alien-address!
+ alien-function?
+ alien-function/name
+ alien-byte-increment
+ alien-byte-increment!
+ guarantee-alien
+ c-peek-cstring
+ c-peek-cstring!
+ c-peek-cstringp
+ c-peek-cstringp!
+ c-poke-pointer
+ c-poke-pointer!
+ c-poke-string
+ c-poke-string!
+ c-enum-name
+ call-alien
+ malloc
+ free
+ register-c-callback
+ de-register-c-callback
+ outf-console)
+ (import (runtime thread)
+ without-timer-interrupts)
+ (initialization (initialize-package!)))
+
(define-package (runtime program-copier)
(files "prgcop")
(parent (runtime))
(define (allow-preempt-current-thread)
(set-thread/execution-state! (current-thread) 'RUNNING))
+(define (without-timer-interrupts thunk)
+ (let* ((old-mask
+ ((ucode-primitive disable-interrupts! 1) interrupt-bit/timer))
+ (value (thunk)))
+ (set-interrupt-enables! old-mask)
+ value))
+
(define (thread-timer-interrupt-handler)
(set! next-scheduled-timeout #f)
(set-interrupt-enables! interrupt-mask/gc-ok)
projects / mit-scheme.git / commitdiff