* src/etc/Clean.sh (maintainer-clean): Clean up src/*/TAGS.
* src/ffi/Clean.sh (maintainer-clean): Clean up prhello-const*.
* src/ffi/ffi.cbf, src/ffi/ffi.sf: Separate syntaxing and compiling.
Temporarily hacked to load the (runtime ffi) package when necessary.
Replaces compile.scm.
* src/ffi/make.scm: Replaces load.scm.
* src/ffi/compile.scm, src/ffi/load.scm: Replaced by ffi.sf, ffi.cbf
and make.scm.
-# $Id: Makefile.in,v 1.17 2008/01/30 20:06:10 cph Exp $
-#
--# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
--# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- # 2005, 2006, 2007, 2008, 2009 Massachusetts Institute of
- # Technology
-# 2005, 2006, 2007, 2008 Massachusetts Institute of Technology
++# Copyright (C) 2010 Massachusetts Institute of Technology
#
# This file is part of MIT/GNU Scheme.
#
AC_CONFIG_SRCDIR([ref-manual/scheme.texinfo])
AC_COPYRIGHT(
--[Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009 Massachusetts Institute of Technology
- 2006, 2007, 2008 Massachusetts Institute of Technology
++[Copyright (C) 2010 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
--- /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
++TEXINFO_ROOT = ffi
+ TARGET_ROOT = mit-scheme-ffi
+
+ include $(top_srcdir)/make-common
--- /dev/null
-@comment $Id: $
+ \input texinfo @c -*-Texinfo-*-
-Copyright @copyright{} 2006, 2007, 2008, 2009 Matthew Birkholz
+ @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}.
+
-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.
++Copyright @copyright{} 2010 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
+
-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.
++This FFI provides Scheme syntax for calling C functions and accessing
++C data. The functions and data structures are 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 compiled and linked to the C toolkit, producing 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
-(C-> alien "* mumble" alien)
++needed at syntax time. The compiled @file{-shim.so} file is used at
++run time, dynamically loaded into the Scheme machine. @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
-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.
++(C-> alien "GtkWidget style" alien)
+ @end smallexample
+
+ The above syntax is understood to say ``The data at this @code{alien}
-optional prefix. It reads the @file{@i{library}.cdecl} file and
-writes two @file{.c} files. The prefix is included at the top of
++address is a GtkWidget. Load its @code{style} member (an alien
++address), into @code{alien} (clobbering @code{alien}'s old address).''
+
+ 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
-installing a shim for the example ``Hello, World!'' program.
++optional preamble. It reads the @file{@i{library}.cdecl} file and
++writes two @file{.c} files. The preamble 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
- $(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/.
++installing a shim for the example ``Hello, World!'' program. They can
++be found in @file{src/ffi/Makefile}
+
+ @example
+ @comment INCLUDE ../../src/ffi/Makefile-fragment FROM /^install-example:/ TO END
+ @verbatim
+ install-example: build-example
- | mit-scheme --batch-mode
++ $(INSTALL_DATA) prhello-types.bin ../lib/.
++ $(INSTALL_DATA) prhello-const.bin ../lib/.
++ $(INSTALL_DATA) prhello-shim.so ../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>")') \
-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:
++ | ../microcode/scheme --library ../lib --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
+
-You might also syntax the Scheme code first. The syntactic
-transformers of the FFI will again be needed.
++To run the example:
+
+ @smallexample
+ @verbatim
++ cd src/ffi/
++ make install-example
++ ../microcode/scheme --library ../lib
+ (load-option 'FFI)
+ (load "prhello.scm")
+ (hello)
+ @end verbatim
+ @end smallexample
+
- (cf "prhello.scm")
++You might also syntax the Scheme code first, as in the following
++script. The syntactic transformers of the FFI are needed here.
+
+ @smallexample
+ @verbatim
++ ../microcode/scheme --library ../lib --batch-mode <<EOF
+ (load-option 'FFI)
-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.
++ (sf "prhello.scm")
++ EOF
+ @end verbatim
+ @end smallexample
+
++The resulting @file{prhello.bin} file can be loaded and run with just
++the FFI-enhanced runtime. The FFI option is not needed.
+
+ @smallexample
+ @verbatim
++ ../microcode/scheme --library ../lib
+ (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
all: @ALL_TARGET@
all-native: compile-microcode
- @$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" --compiler
- @$(top_srcdir)/etc/compile.sh mit-scheme-native --compiler --batch-mode
++ @$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" \
++ --compiler --batch-mode
+ $(MAKE) build-bands
+
+all-svm: microcode/svm1-defns.h
+ $(MAKE) compile-microcode
+ @$(top_srcdir)/etc/compile-svm.sh "$(MIT_SCHEME_EXE)"
$(MAKE) build-bands
+microcode/svm1-defns.h: compiler/machines/svm/assembler-rules.scm \
+ compiler/machines/svm/machine.scm \
+ compiler/machines/svm/assembler-compiler.scm \
+ compiler/machines/svm/assembler-runtime.scm \
+ compiler/machines/svm/compile-assembler.scm
+ ( cd compiler/machines/svm/ \
+ && $(MIT_SCHEME_EXE) --batch-mode --load compile-assembler \
+ </dev/null )
+ cp compiler/machines/svm/svm1-defns.h microcode/svm1-defns.h
+
all-liarc:
- @$(top_srcdir)/etc/c-compile.sh mit-scheme-c --compiler --batch-mode
+ @$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" --compiler
$(MAKE) compile-liarc-bundles build-bands
+macosx-app: stamp_macosx-app
+
+stamp_macosx-app: all
+ etc/macosx/make-app.sh
+ echo "done" > $@
+
compile-microcode:
(cd microcode && $(MAKE) all)
maybe_link lib/include ../microcode
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}"
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
++ 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
maybe_rm Makefile.in
maybe_rm Makefile-bundle
fi
++ maybe_rm TAGS
fi
for KEYWORD in ${KEYWORDS}; do
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 --batch-mode <<EOF
+run_cmd ${HOST_SCHEME_EXE} --batch-mode --heap 4000 <<EOF
(begin
(load "etc/utilities")
(generate-c-bundles (quote (${BUNDLES})) "${MDIR}"))
--- /dev/null
--- /dev/null
++prhello-const
++prhello-const.c
++prhello-const.scm
++prhello-shim.c
--- /dev/null
--- /dev/null
++#!/bin/sh
++
++set -e
++
++if [ ${#} -ne 1 ]; then
++ echo "usage: ${0} <command>"
++ exit 1
++fi
++
++../etc/Clean.sh "${1}"
++. ../etc/functions.sh
++
++maybe_rm prhello-const prhello-const.scm
--- /dev/null
-# $Id: $
+ #-*-Makefile-*-
- $(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/.
+ # 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
- | mit-scheme --batch-mode
++ $(INSTALL_DATA) prhello-types.bin ../lib/.
++ $(INSTALL_DATA) prhello-const.bin ../lib/.
++ $(INSTALL_DATA) prhello-shim.so ../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>")') \
++ | ../microcode/scheme --library ../lib --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
-$Id: $
-
-Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+ #| -*-Scheme-*-
+
++Copyright (C) 2010 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)))))))))
--- /dev/null
-$Id: $
-
-Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+ #| -*-Scheme-*-
+
++Copyright (C) 2010 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)))))
--- /dev/null
-$Id: $
-
+ #| -*- Scheme -*-
+
+ FFI buffer packaging info |#
+
+ (standard-scheme-find-file-initialization
+ '#(
+ ("ctypes" (ffi))
+ ("cdecls" (ffi))
+ ("syntax" (ffi))
+ ("generator" (ffi generate))))
--- /dev/null
--- /dev/null
++#| -*-Scheme-*-
++
++Compile the FFI system. |#
++
++(fluid-let ((compiler:coalescing-constant-warnings? #f))
++ (compile-directory "."))
--- /dev/null
-$Id: $
-
+ #| -*-Scheme-*-
+
+ 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)
++ (import (runtime syntax environment)
++ syntactic-environment->environment)
+ (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))
--- /dev/null
--- /dev/null
++#| -*-Scheme-*-
++
++Syntax the FFI system. |#
++
++(load-option 'CREF)
++
++;; Temporary hack, until (runtime ffi) is in the released version.
++(if (not (name->package '(RUNTIME FFI)))
++ (let ((path (package-set-pathname "../runtime/runtime")))
++ (if (not (file-exists? path))
++ (cref/generate-trivial-constructor "../runtime/runtime"))
++ (eval `(for-each-vector-element
++ (package-file/descriptions (fasload ,path))
++ (lambda (description)
++ (if (equal? (package-description/name description) '(RUNTIME FFI))
++ (begin
++ (construct-normal-package-from-description description)
++ (create-links-from-description description)
++ (load "../runtime/ffi" (->environment '(RUNTIME FFI))
++ 'ignored #t)))))
++ (->environment '(PACKAGE)))))
++
++(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 esp. ucode-primitive in (ffi).
++ (if (not (name->package '(FFI)))
++ (let ((path (package-set-pathname "ffi")))
++ (if (not (file-exists? path))
++ (cref/generate-trivial-constructor "ffi"))
++ (construct-packages-from-file (fasload path))))
++
++ ;; Syntax everything 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))))
--- /dev/null
-$Id: $
-
-Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+ #| -*-Scheme-*-
+
++Copyright (C) 2010 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))))))
--- /dev/null
-$Id: $
-
-Load the FFI system. |#
+ #| -*-Scheme-*-
+
++Build the FFI system. |#
+
+ (with-loader-base-uri (system-library-uri "ffi/")
+ (lambda ()
+ (load-package-set "ffi")))
+ (add-subsystem-identification! "FFI" '(0 1))
--- /dev/null
-
+ #| -*-Scheme-*-
+
+ C declarations for prhello.scm. |#
+
-(extern void gtk_main_quit)
+ (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
-$Id: $
-
+ #| -*-Scheme-*-
+
+ 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))
--- /dev/null
-$Id: $
-
-Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+ #| -*-Scheme-*-
+
- (let* ((lib (merge-pathnames
- library (system-library-directory-pathname "lib")))
++Copyright (C) 2010 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)
- 'syntaxer-error
++ (let* ((lib (merge-pathnames library (system-library-directory-pathname)))
+ (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
- (write-string "Syntax error: " port)
++ 'ffi-syntaxer-error
+ condition-type:error
+ '(FORM MESSAGE)
+ (lambda (condition port)
++ (write-string "FFI 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)))))))
fi
if test "x${x_libraries}" != x; then
FOO=-L`echo ${x_libraries} | sed -e "s/:/ -L/g"`
- LIBS="${LIBS} ${FOO}"
+ LDFLAGS="${LDFLAGS} ${FOO}"
fi
- LIBS="${LIBS} -lX11"
- OPTIONAL_BASES="${OPTIONAL_BASES} x11base x11term x11graph x11color"
+ MODULE_LIBS="-lX11 ${MODULE_LIBS}"
+ MODULE_BASES="${MODULE_BASES} prx11"
+ MODULE_AUX_BASES="${MODULE_AUX_BASES} x11base x11color x11graph x11term"
+fi
+
+dnl Check for dynamic loader support.
+AC_CHECK_FUNC([dlopen],
+ [],
+ [
+ AC_CHECK_LIB([dl], [dlopen],
+ [
+ AC_DEFINE([HAVE_LIBDL], [1],
+ [Define to 1 if you have the `dl' library (-ldl).])
+ LIBS="-ldl ${LIBS}"
+ ],
+ [
+ if test ${mit_scheme_native_code} = c; then
+ AC_MSG_ERROR(
+ [--enable-native-code=c requires dynamic loader support])
+ fi
+ ])
+ ])
- 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.])
+
+if test ${enable_valgrind_mode} != no; then
+ SCHEME_DEFS="${SCHEME_DEFS} -DVALGRIND_MODE"
+ M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1"
fi
-AC_MSG_CHECKING([for native-code support])
OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl"
-GC_HEAD_FILES="gccode.h cmpgc.h cmpintmd-config.h cmpintmd.h"
-SCM_ARCH=none
-ENC_WARNP=no
-
-case ${enable_native_code} in
-yes)
- case ${host_cpu} in
- alpha*)
- SCM_ARCH=alpha
- ;;
- hppa*)
- SCM_ARCH=hppa
- GC_HEAD_FILES="${GC_HEAD_FILES} hppacach.h"
- ;;
- i?86)
- SCM_ARCH=i386
- ;;
- # x86_64)
- # SCM_ARCH=i386
- # CFLAGS="${CFLAGS} -m32"
- # LDFLAGS="${LDFLAGS} -m32"
- # ;;
- m68k|m680?0)
- SCM_ARCH=mc68k
- ;;
- mips*)
- SCM_ARCH=mips
- ;;
- vax)
- SCM_ARCH=vax
- ;;
- esac
- ;;
-c)
- SCM_ARCH=c
- ;;
-svm)
- SCM_ARCH=svm1
- ;;
-no|none)
- ;;
-*)
- dnl This is not quite right, because the compiler and microcode
- dnl disagree abou what some architectures should be called, such as
- dnl bobcat vs mc68k or spectrum versus hppa. I don't know what the
- dnl state of Scheme on these architectures is, however, so at least
- dnl this will flag an error if you try to use them.
- if test -f "cmpauxmd/${enable_native_code}.m4"; then
- SCM_ARCH="${enable_native_code}"
- else
- ENC_WARNP=yes
- fi
- ;;
-esac
-case ${SCM_ARCH} in
+case ${mit_scheme_native_code} in
none)
- AC_MSG_RESULT([no])
;;
c)
- AC_MSG_RESULT([yes, using portable C code])
AC_CONFIG_LINKS([cmpauxmd.c:cmpauxmd/c.c])
AC_CONFIG_FILES([liarc-cc], [chmod +x liarc-cc])
AC_CONFIG_FILES([liarc-ld], [chmod +x liarc-ld])
#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
+\f
+#define FIXED_OBJECTS_NAMES \
+{ \
+ /* 0x00 */ "non-object", \
+ /* 0x01 */ "system-interrupt-vector", \
+ /* 0x02 */ "system-error-vector", \
+ /* 0x03 */ "obarray", \
+ /* 0x04 */ "microcode-types-vector", \
+ /* 0x05 */ "microcode-returns-vector", \
+ /* 0x06 */ "interrupt-mask-vector", \
+ /* 0x07 */ "microcode-errors-vector", \
+ /* 0x08 */ "microcode-identification-vector", \
+ /* 0x09 */ "system-call-names", \
+ /* 0x0A */ "system-call-errors", \
+ /* 0x0B */ "gc-daemon", \
+ /* 0x0C */ "trap-handler", \
+ /* 0x0D */ "edwin-auto-save", \
+ /* 0x0E */ "stepper-state", \
+ /* 0x0F */ "microcode-fixed-objects-slots", \
+ /* 0x10 */ "files-to-delete", \
+ /* 0x11 */ "state-space-tag", \
+ /* 0x12 */ "state-point-tag", \
+ /* 0x13 */ "dummy-history", \
+ /* 0x14 */ "bignum-one", \
+ /* 0x15 */ 0, \
+ /* 0x16 */ "microcode-terminations-vector", \
+ /* 0x17 */ "microcode-terminations-procedures", \
+ /* 0x18 */ 0, \
+ /* 0x19 */ 0, \
+ /* 0x1A */ 0, \
+ /* 0x1B */ 0, \
+ /* 0x1C */ 0, \
+ /* 0x1D */ "error-procedure", \
+ /* 0x1E */ 0, \
+ /* 0x1F */ 0, \
+ /* 0x20 */ "compiler-error-procedure", \
+ /* 0x21 */ 0, \
+ /* 0x22 */ "state-space-root", \
+ /* 0x23 */ "primitive-profiling-table", \
+ /* 0x24 */ "generic-trampoline-zero?", \
+ /* 0x25 */ "generic-trampoline-positive?", \
+ /* 0x26 */ "generic-trampoline-negative?", \
+ /* 0x27 */ "generic-trampoline-add-1", \
+ /* 0x28 */ "generic-trampoline-subtract-1", \
+ /* 0x29 */ "generic-trampoline-equal?", \
+ /* 0x2A */ "generic-trampoline-less?", \
+ /* 0x2B */ "generic-trampoline-greater?", \
+ /* 0x2C */ "generic-trampoline-add", \
+ /* 0x2D */ "generic-trampoline-subtract", \
+ /* 0x2E */ "generic-trampoline-multiply", \
+ /* 0x2F */ "generic-trampoline-divide", \
+ /* 0x30 */ "generic-trampoline-quotient", \
+ /* 0x31 */ "generic-trampoline-remainder", \
+ /* 0x32 */ "generic-trampoline-modulo", \
+ /* 0x33 */ "arity-dispatcher-tag", \
+ /* 0x34 */ "pc-sample/builtin-table" \
+ /* 0x35 */ "pc-sample/utility-table", \
+ /* 0x36 */ "pc-sample/primitive-table", \
+ /* 0x37 */ "pc-sample/code-block-table", \
+ /* 0x38 */ "pc-sample/purified-code-block-block-buffer", \
+ /* 0x39 */ "pc-sample/purified-code-block-offset-buffer", \
+ /* 0x3A */ "pc-sample/heathen-code-block-block-buffer", \
+ /* 0x3B */ "pc-sample/heathen-code-block-offset-buffer", \
+ /* 0x3C */ "pc-sample/interp-proc-buffer", \
+ /* 0x3D */ "pc-sample/prob-comp-table", \
+ /* 0x3E */ "pc-sample/ufo-table", \
+ /* 0x3F */ "compiled-code-bkpt-handler", \
+ /* 0x40 */ "gc-wabbit-descwiptor", \
+ /* 0x41 */ 0, \
+ /* 0x42 */ 0, \
+ /* 0x43 */ 0, \
+ /* 0x44 */ 0, \
+ /* 0x45 */ 0 \
+}
tags: TAGS
TAGS:
etags -r '/^DEF[A-Z0-9_]*[ \t]*(\("[^"]+"\|[a-zA-Z_][a-zA-Z0-9_]*\)/' \
++ *.[ch] */*.[ch] \
++ || etags \
++ --regex-C='/^DEF[A-Z0-9_]*[ \t]*\(("[^"]+"|[a-zA-Z_][a-zA-Z0-9_]+)/\1/'\
*.[ch] */*.[ch]
mostlyclean:
"prmhash"
"prpgsql"
"pruxdld"
+ "pruxffi"
+"prx11"
"svm1-interp"
"termcap"
"terminfo"
--- /dev/null
-$Id: $
-
-Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+ /* -*-C-*-
+
++Copyright (C) 2010 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. */
+
+ 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();
+ Interpret (1);
+ 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)
+ {
+ /* 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 ();
+
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
+ STACK_PUSH (arglist);
+ STACK_PUSH (fixnum_id);
+ STACK_PUSH (handler);
+ PUSH_APPLY_FRAME_HEADER (2);
+ Pushed ();
+ }
+
+ 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
-$Id: $
-
-Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+ /* -*-C-*-
+
++Copyright (C) 2010 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
--- /dev/null
-$Id: $
-
-Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz
+ #| -*-Scheme-*-
+
- (system-library-directory-pathname "lib")))
++Copyright (C) 2010 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")
- (let ((value (apply (ucode-primitive c-call) alien-function args)))
++ (system-library-directory-pathname)))
+ (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-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)))
- ((ucode-primitive outf-console)
++ (let ((value (apply (ucode-primitive c-call -1) 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 c-free )...
+ (define malloced-aliens '())
+
+ (define (free-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 malloced-aliens BEFORE calling malloc.
+ (let ((alien (make-alien ctype))
+ (copy (make-alien ctype)))
+ (let ((entry (weak-cons alien copy)))
+ (without-interrupts
+ (lambda ()
+ (set! malloced-aliens (cons entry 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? alien))
+ (begin
+ (alien-null! alien)
+ ((ucode-primitive c-free 1) copy)
+ (alien-null! copy))))))))))
+
+ (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. The callout should have already masked
+ ;; all but the GC interrupts.
+
+ (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 1)
+ (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 trace? #f)
+
+ (define (reset-package!)
+ (reset-alien-functions!)
+ (reset-malloced-aliens!)
+ (reset-callbacks!)
+ (set! trace? #f)
+ (set! calloutback-stack '()))
+
+ (define (initialize-package!)
+ (reset-package!)
+ (initialize-callbacks!)
+ (add-event-receiver! event:after-restore reset-package!)
+ (add-gc-daemon! free-malloced-aliens)
+ unspecific)
+
+ (define-syntax if-tracing
+ (syntax-rules ()
+ ((_ . BODY)
+ (if trace? ((lambda () . BODY))))))
+
+ (define-syntax assert
+ (syntax-rules ()
+ ((_ TEST . MSG)
+ (if (not TEST) (error "Failed assert:" . MSG)))))
+
+ (define-syntax trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if trace? ((lambda () (outf-console . MSG)))))))
+
+ (define (tindent)
+ (make-string (* 2 (length calloutback-stack)) #\space))
(RUNTIME HTTP-SYNTAX)
(RUNTIME HTTP-CLIENT)
(RUNTIME HTML-FORM-CODEC)
- (OPTIONAL (RUNTIME WIN32-REGISTRY))))
- (RUNTIME WIN32-REGISTRY)
- (RUNTIME FFI)))
++ (OPTIONAL (RUNTIME WIN32-REGISTRY))
++ (OPTIONAL (RUNTIME FFI))))
\f
(let ((obj (file->object "site" #t #f)))
(if obj
projects / mit-scheme.git / commitdiff