summaryrefslogtreecommitdiffstats
path: root/plug-ins/script-fu/tinyscheme
diff options
context:
space:
mode:
Diffstat (limited to 'plug-ins/script-fu/tinyscheme')
-rw-r--r--plug-ins/script-fu/tinyscheme/BUILDING139
-rw-r--r--plug-ins/script-fu/tinyscheme/CHANGES326
-rw-r--r--plug-ins/script-fu/tinyscheme/COPYING31
-rw-r--r--plug-ins/script-fu/tinyscheme/Makefile.am26
-rw-r--r--plug-ins/script-fu/tinyscheme/Makefile.in923
-rw-r--r--plug-ins/script-fu/tinyscheme/Manual.txt452
-rw-r--r--plug-ins/script-fu/tinyscheme/MiniSCHEMETribute.txt88
-rw-r--r--plug-ins/script-fu/tinyscheme/README14
-rw-r--r--plug-ins/script-fu/tinyscheme/hack.txt233
-rw-r--r--plug-ins/script-fu/tinyscheme/opdefines.h195
-rw-r--r--plug-ins/script-fu/tinyscheme/scheme-private.h227
-rw-r--r--plug-ins/script-fu/tinyscheme/scheme.c5357
-rw-r--r--plug-ins/script-fu/tinyscheme/scheme.h273
13 files changed, 8284 insertions, 0 deletions
diff --git a/plug-ins/script-fu/tinyscheme/BUILDING b/plug-ins/script-fu/tinyscheme/BUILDING
new file mode 100644
index 0000000..5c00236
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/BUILDING
@@ -0,0 +1,139 @@
+ Building TinyScheme
+ -------------------
+
+The included makefile includes logic for Linux, Solaris and Win32, and can
+readily serve as an example for other OSes, especially Unixes. There are
+a lot of compile-time flags in TinyScheme (preprocessor defines) that can trim
+unwanted features. See next section. 'make all' and 'make clean' function as
+expected.
+
+Autoconfing TinyScheme was once proposed, but the distribution would not be
+so small anymore. There are few platform dependencies in TinyScheme, and in
+general compiles out of the box.
+
+ Customizing
+ -----------
+
+ The following symbols are defined to default values in scheme.h.
+ Use the -D flag of cc to set to either 1 or 0.
+
+ STANDALONE
+ Define this to produce a standalone interpreter.
+
+ USE_MATH
+ Includes math routines.
+
+ USE_CHAR_CLASSIFIERS
+ Includes character classifier procedures.
+
+ USE_ASCII_NAMES
+ Enable extended character notation based on ASCII names.
+
+ USE_STRING_PORTS
+ Enables string ports.
+
+ USE_ERROR_HOOK
+ To force system errors through user-defined error handling.
+ (see "Error handling")
+
+ USE_TRACING
+ To enable use of TRACING.
+
+ USE_COLON_HOOK
+ Enable use of qualified identifiers. (see "Colon Qualifiers - Packages")
+ Defining this as 0 has the rather drastic consequence that any code using
+ packages will stop working, and will have to be modified. It should only
+ be used if you *absolutely* need to use '::' in identifiers.
+
+ USE_STRCASECMP
+ Defines stricmp as strcasecmp, for Unix.
+
+ STDIO_ADDS_CR
+ Informs TinyScheme that stdio translates "\n" to "\r\n". For DOS/Windows.
+
+ USE_DL
+ Enables dynamically loaded routines. If you define this symbol, you
+ should also include dynload.c in your compile.
+
+ USE_PLIST
+ Enables property lists (not Standard Scheme stuff). Off by default.
+
+ USE_NO_FEATURES
+ Shortcut to disable USE_MATH, USE_CHAR_CLASSIFIERS, USE_ASCII_NAMES,
+ USE_STRING_PORTS, USE_ERROR_HOOK, USE_TRACING, USE_COLON_HOOK,
+ USE_DL.
+
+ USE_SCHEME_STACK
+ Enables 'cons' stack (the alternative is a faster calling scheme, which
+ breaks continuations). Undefine it if you don't care about strict compatibility
+ but you do care about faster execution.
+
+
+ OS-X tip
+ --------
+ I don't have access to OS-X, but Brian Maher submitted the following tip:
+
+[1] Download and install fink (I installed fink in
+/usr/local/fink)
+[2] Install the 'dlcompat' package using fink as such:
+> fink install dlcompat
+[3] Make the following changes to the
+tinyscheme-1.32.tar.gz
+
+diff -r tinyscheme-1.32/dynload.c
+tinyscheme-1.32-new/dynload.c
+24c24
+< #define SUN_DL
+---
+>
+Only in tinyscheme-1.32-new/: dynload.o
+Only in tinyscheme-1.32-new/: libtinyscheme.a Only in tinyscheme-1.32-new/: libtinyscheme.so diff -r tinyscheme-1.32/makefile tinyscheme-1.32-new/makefile
+33,34c33,43
+< LD = gcc
+< LDFLAGS = -shared
+---
+> #LD = gcc
+> #LDFLAGS = -shared
+> #DEBUG=-g -Wno-char-subscripts -O
+> #SYS_LIBS= -ldl
+> #PLATFORM_FEATURES= -DSUN_DL=1
+>
+> # Mac OS X
+> CC = gcc
+> CFLAGS = -I/usr/local/fink/include
+> LD = gcc
+> LDFLAGS = -L/usr/local/fink/lib
+37c46
+< PLATFORM_FEATURES= -DSUN_DL=1
+---
+> PLATFORM_FEATURES= -DSUN_DL=1 -DOSX
+60c69
+< $(CC) -I. -c $(DEBUG) $(FEATURES)
+$(DL_FLAGS) $<
+---
+> $(CC) $(CFLAGS) -I. -c $(DEBUG)
+$(FEATURES) $(DL_FLAGS) $<
+66c75
+< $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS)
+---
+> $(CC) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS)
+$(SYS_LIBS)
+Only in tinyscheme-1.32-new/: scheme
+diff -r tinyscheme-1.32/scheme.c
+tinyscheme-1.32-new/scheme.c
+60,61c60,61
+< #ifndef macintosh
+< # include <malloc.h>
+---
+> #ifdef OSX
+> /* Do nothing */
+62a63,65
+> # ifndef macintosh
+> # include <malloc.h>
+> # else
+77c80,81
+< #endif /* macintosh */
+---
+> # endif /* macintosh */
+> #endif /* !OSX */
+Only in tinyscheme-1.32-new/: scheme.o
diff --git a/plug-ins/script-fu/tinyscheme/CHANGES b/plug-ins/script-fu/tinyscheme/CHANGES
new file mode 100644
index 0000000..2f7a33a
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/CHANGES
@@ -0,0 +1,326 @@
+Change Log
+----------
+
+Version 1.41
+ Bugs fixed:
+ #3020389 - Added makefile section for Mac OS X (SL)
+ #3286135 - Fixed num_mod routine which caused errors in use of modulo
+ #3290232 - Corrected version number shown on startup (GM)
+ #3394882 - Added missing #if in opdefines.h around get and put (DC)
+ #3395547 - Fix for the modulo procedure (DC)
+ #3400290 - Optimized append to make it an O(n) operation (DC)
+ #3493926 - Corrected flag used when building shared files on OSX (J)
+
+ R5RS related changes:
+ #2866196 - Parser does not handle delimiters correctly
+ #3395548 - Add a decimal point to inexact numbers in atom2str (DC)
+ #3399331 - Make min/max return inexact when any argument is inexact
+ #3399332 - Compatibility fix for expt.
+ #3399335 - Optional radix for string->number and number->string (DC)
+ #3400202 - Append with one argument should not return a list (DC)
+ #3400284 - Compatibility fix for integer?
+
+ Other changes:
+ - Added flags to makefile for MinGW/MSYS (TC)
+ - Moved variable declarations to avoid warnings with some compilers
+ - Don't print space after initial #( when printing vectors.
+ - Minor optimization for is_nonneg().
+ - No need to round integers in OP_ROUND (#3400284)
+ - Fixes to code that reports line number with error (RC)
+
+ Contributors:
+ Kevin Cozens, Gordon McNutt, Doug Currie, Sean Long, Tim Cas, Joey,
+ and Richard Copley, and CMarinier.
+
+Version 1.40
+ Bugs fixed:
+ #1964950 - Stop core dumps due to bad syntax in LET (and variants)
+ #2826594 - allow reverse to work on empty list (Tony Garnock-Jones)
+ Potential problem of arglist to foreign calls being wrongly GC'ed.
+ Fixed bug that read could loop forever (tehom).
+
+ API changes:
+ Exposed is_list and list_length.
+ Added scheme_register_foreign_func_list and declarations for it (tehom)
+ Defined *compile-hook* (tehom)
+
+ Other changes:
+ Updated is_list and list_length to handle circular lists.
+ Nested calling thru C has been made now safer (tehom)
+ Peter Michaux cleaned up port_rep_from_file
+ Added unwind-protect (tehom)
+ Some cleanups to in/outport and Eval_Cycle by Peter Michaux
+ Report error line number (Mostly by Sanel Zukan, back-compatibility by Tehom)
+
+ Contributors:
+ Kevin Cozens, Dimitrios Souflis, Tom Breton, Peter Michaux, Sanel Zukan,
+ and Tony Garnock-Jones.
+
+Version 1.39
+ Bugs fixed:
+ Fix for the load bug
+ Fixed parsing of octal coded characters. Fixes bug #1818018.
+ Added tests for when mk_vector is out of memory. Can't rely on sc->sink.
+ Fix for bug #1794369
+ Finished feature-request 1599947: scheme_apply0 etc return values.
+ Partly provided feature-request 1599947: Expose list_length, eqv, etc
+ Provided feature-request 1599945, Scheme->C->Scheme calling.
+ Fix for bug 1593861 (behavior of is_integer)
+ Fix for bug 1589711
+ Error checking of binding spec syntax in LET and LETREC. The bad syntax
+ was causing a segmentation fault in Linux. Complete fixes for bug #1817986.
+ Error checking of binding spec syntax in LET*
+ Bad syntax was causing core dump in Linux.
+ Fix for nasty gc bug
+
+ R5RS changes:
+ R5RS requires numbers to be of equal value AND of the same type (ie. both
+ exact or inexact) in order to return #t from eqv?. R5RS compliance fix.
+ String output ports now conform to SRFI-6
+
+ Other changes:
+ Drew Yao fixed buffer overflow problems in mk_sharp_const.
+ put OP_T0LVL in charge of reacting to EOF
+ file_push checks array bounds (patch from Ray Lehtiniemi)
+ Changed to always use snprintf (Patch due to Ramiro bsd1628)
+ Updated usage information using text from the Manual.txt file.
+
+Version 1.38
+ Interim release until the rewrite, mostly incorporating modifications
+ from Kevin Cozens. Small addition for Cygwin in the makefile, and
+ modifications by Andrew Guenther for Apple platforms.
+
+Version 1.37
+ Joe Buehler submitted reserve_cells.
+
+Version 1.36
+ Joe Buehler fixed a patch in the allocator.
+ Alexander Shendi moved the comment handling in the scanner, which
+ fixed an obscure bug for which Mike E had provided a patch as well.
+ Kevin Cozens has submitted some fixes and modifications which have
+ not been incorporated yet in their entirety.
+
+Version 1.35
+ Todd Showalter discovered that the number of free cells reported
+ after GC was incorrect, which could also cause unnecessary allocations.
+
+Version 1.34
+ Long missing version. Lots of bugfixes have accumulated in my email, so
+ I had to start using them. In this version, Keenan Pepper has submitted
+ a bugfix for the string comparison library procedure, Wouter Boeke
+ modified some code that was casting to the wrong type and crashed on
+ some machines, "SheppardCo" submitted a replacement "modulo" code and
+ Scott Fenton submitted lots of corrections that shut up some compiler
+ warnings. Brian Maher submitted instructions on how to build on OS-X.
+ I have to dig deeper into my mailbox and find earlier emails, too.
+
+Version 1.33
+ Charles Hayden fixed a nasty GC bug of the new stack frame, while in
+ the process of porting TinyScheme to C++. He also submitted other
+ changes, and other people also had comments or requests, but the GC
+ bug was so important that this version is put through the door to
+ correct it.
+
+Version 1.32
+ Stephen Gildea put some quality time on TinyScheme again, and made
+ a whole lot of changes to the interpreter that made it noticeably
+ faster.
+
+Version 1.31
+ Patches to the hastily-done version 1.30. Stephen Gildea fixed
+ some things done wrongly, and Richard Russo fixed the makefile
+ for building on Windows. Property lists (heritage from MiniScheme)
+ are now optional and have disappeared from the interface. They
+ should be considered as deprecated.
+
+Version 1.30
+ After many months, I followed Preston Bannister's advice of
+ using macros and a single source text to keep the enums and the
+ dispatch table in sync, and I used his contributed "opdefines.h".
+ Timothy Downs contributed a helpful function, "scheme_call".
+ Stephen Gildea contributed new versions of the makefile and
+ practically all other sources. He created a built-in STRING-APPEND,
+ and fixed a lot of other bugs.
+ Ruhi Bloodworth reported fixes necessary for OS X and a small
+ bug in dynload.c.
+
+Version 1.29
+ The previous version contained a lot of corrections, but there
+ were a lot more that still wait on a sheet of paper lost in a
+ carton someplace after my house move... Manuel Heras-Gilsanz
+ noticed this and resent his own contribution, which relies on
+ another bugfix that v.1.28 was missing: a problem with string
+ output, that this version fixes. I hope other people will take
+ the time to resend their contributions, if they didn't make it
+ to v.1.28.
+
+Version 1.28
+ Many people have contacted me with bugfixes or remarks in
+ the three months I was inactive. A lot of them spotted that
+ scheme_deinit crashed while reporting gc results. They suggested
+ that sc->outport be set to NIL in scheme_deinit, which I did.
+ Dennis Taylor remarked that OP_VALUEPRINT reset sc->value instead
+ of preserving it. He submitted a modification which I adopted
+ partially. David Hovemeyer sent me many little changes, that you
+ will find in version 1.28, and Partice Stoessel modified the
+ float reader to conform to R5RS.
+
+Version 1.27
+ Version 1.27 is the successor of 1.25. Bug fixes only, but I had to
+ release them so that everybody can profit. 'Backchar' tried to write
+ back to the string, which obviously didn't work for const strings.
+ 'Substring' didn't check for crossed start and end indices. Defines
+ changed to restore the ability to compile under MSVC.
+
+Version 1.26
+ Version 1.26 was never released. I changed a lot of things, in fact
+ too much, even the garbage collector, and hell broke loose. I'll
+ try a more gradual approach next time.
+
+Version 1.25
+ Types have been homogenized to be able to accommodate a different
+ representation. Plus, promises are no longer closures. Unfortunately,
+ I discovered that continuations and force/delay do not pass the SCM
+ test (and never did)... However, on the bright side, what little
+ modifications I did had a large impact on the footprint:
+ USE_NO_FEATURES now produces an object file of 63960 bytes on Linux!
+
+Version 1.24
+ SCM tests now pass again after change in atom2str.
+
+Version 1.23
+ Finally I managed to mess it up with my version control. Version
+ 1.22 actually lacked some of the things I have been fixing in the
+ meantime. This should be considered as a complete replacement for
+ 1.22.
+
+Version 1.22
+ The new ports had a bug in LOAD. MK_CLOSURE is introduced.
+ Shawn Wagner inquired about string->number and number->string.
+ I added string->atom and atom->string and defined the number
+ functions from them. Doing that, I fixed WRITE applied to symbols
+ (it didn't quote them). Unfortunately, minimum build is now
+ slightly larger than 64k... I postpone action because Jason's idea
+ might solve it elegantly.
+
+Version 1.21
+ Jason Felice submitted a radically different datatype representation
+ which he had implemented. While discussing its pros and cons, it
+ became apparent that the current implementation of ports suffered
+ from a grave fault: ports were not garbage-collected. I changed the
+ ports to be heap-allocated, which enabled the use of string ports
+ for loading. Jason also fixed errors in the garbage collection of
+ vectors. USE_VERBATIM is gone. "ssp_compiler.c" has a better solution
+ on HTML generation. A bug involving backslash notation in strings
+ has been fixed. '-c' flag now executes next argument as a stream of
+ Scheme commands. Foreign functions are now also heap allocated,
+ and scheme_define is used to define everything.
+
+Version 1.20
+ Tracing has been added. The toplevel loop has been slightly
+ rearranged. Backquote reading for vector templates has been
+ sanitized. Symbol interning is now correct. Arithmetic functions
+ have been corrected. APPLY, MAP, FOR-EACH, numeric comparison
+ functions fixed. String reader/writer understands \xAA notation.
+
+Version 1.19
+ Carriage Return now delimits identifiers. DOS-formatted Scheme files
+ can be used by Unix. Random number generator added to library.
+ Fixed some glitches of the new type-checking scheme. Fixed erroneous
+ (append '() 'a) behavior. Will continue with r4rstest.scm to
+ fix errors.
+
+Version 1.18
+ The FFI has been extended. USE_VERBOSE_GC has gone. Anyone wanting
+ the same functionality can put (gcverbose #t) in init.scm.
+ print-width was removed, along with three corresponding op-codes.
+ Extended character constants with ASCII names were added.
+ mk_counted_string paves the way for full support of binary strings.
+ As much as possible of the type-checking chores were delegated
+ to the inner loop, thus reducing the code size to less than 4200 loc!
+
+Version 1.17
+ Dynamically-loaded extensions are more fully integrated.
+ TinyScheme is now distributed under the BSD open-source license.
+
+Version 1.16
+ Dynamically-loaded extensions introduced (USE_DL).
+ Santeri Paavolainen found a race condition: When a cons is executed,
+ and each of the two arguments is a constructing function, GC could
+ happen before all arguments are evaluated and cons() is called, and
+ the evaluated arguments would all be reclaimed!
+ Fortunately, such a case was rare in the code, although it is
+ a pitfall in new code and code in foreign functions. Currently, only
+ one such case remains, when COLON_HOOK is defined.
+
+Version 1.15
+ David Gould also contributed some changes that speed up operation.
+ Kirk Zurell fixed HASPROP.
+ The Garbage Collection didn't collect all the garbage...fixed.
+
+Version 1.14
+ Unfortunately, after Andre fixed the GC it became obvious that the
+ algorithm was too slow... Fortunately, David Gould found a way to
+ speed it up.
+
+Version 1.13
+ Silly bug involving division by zero resolved by Roland Kaufman.
+ Macintoch support from Shmulik Regev.
+ Float parser bug fixed by Alexander Shendi.
+ GC bug from Andru Luvisi.
+
+Version 1.12
+ Cis* incorrectly called isalpha() instead of isascii()
+ Added USE_CHAR_CLASSIFIERS, USE_STRING_PORTS.
+
+Version 1.11
+ BSDI defines isnumber... changed all similar functions to is_*
+ EXPT now has correct definition. Added FLOOR,CEILING,TRUNCATE
+ and ROUND, courtesy of Bengt Kleberg. Preprocessor symbols now
+ have values 1 or 0, and can be set as compiler defines (proposed
+ by Andy Ganor *months* ago). 'prompt' and 'InitFile' can now be
+ defined during compilation, too.
+
+Version 1.10
+ Another bug when file ends with comment!
+ Added DEFINE-MACRO in init.scm, courtesy of Andy Gaynor.
+
+Version 1.09
+ Removed bug when READ met EOF. lcm.
+
+Version 1.08
+ quotient,remainder and modulo. gcd.
+
+Version 1.07
+ '=>' in cond now exists
+ list? now checks for circularity
+ some reader bugs removed
+ Reader is more consistent wrt vectors
+ Quote and Quasiquote work with vectors
+
+Version 1.06
+ #! is now skipped
+ generic-assoc bug removed
+ strings are now managed differently, hack.txt is removed
+ various delicate points fixed
+
+Version 1.05
+ Support for scripts, *args*, "-1" option.
+ Various R5RS procedures.
+ *sharp-hook*
+ Handles unmatched parentheses.
+ New architecture for procedures.
+
+Version 1.04
+ Added missing T_ATOM bits...
+ Added vectors
+ Free-list is sorted by address, since vectors need consecutive cells.
+ (quit <exitcode>) for use with scripts
+
+Version 1.03 (26 Aug 1998):
+ Extended .h with useful functions for FFI
+ Library: with-input-* etc.
+ Finished R5RS I/O, added string ports.
+
+Version 1.02 (25 Aug 1998):
+ First part of R5RS I/O.
diff --git a/plug-ins/script-fu/tinyscheme/COPYING b/plug-ins/script-fu/tinyscheme/COPYING
new file mode 100644
index 0000000..a6c49a2
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/COPYING
@@ -0,0 +1,31 @@
+ LICENSE TERMS
+
+Copyright (c) 2000, Dimitrios Souflis
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+Neither the name of Dimitrios Souflis nor the names of the
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/plug-ins/script-fu/tinyscheme/Makefile.am b/plug-ins/script-fu/tinyscheme/Makefile.am
new file mode 100644
index 0000000..49ce643
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/Makefile.am
@@ -0,0 +1,26 @@
+## Process this file with automake to produce Makefile.in
+
+AM_CFLAGS = \
+ -DSTANDALONE=0 \
+ -DUSE_INTERFACE=1 \
+ -DUSE_MATH=1 \
+ -DUSE_ASCII_NAMES=0 \
+ -DUSE_STRLWR=0 \
+ -I$(top_srcdir) \
+ $(GLIB_CFLAGS)
+
+noinst_LIBRARIES = libtinyscheme.a
+
+libtinyscheme_a_SOURCES = \
+ scheme.c \
+ opdefines.h \
+ scheme-private.h \
+ scheme.h
+
+EXTRA_DIST = \
+ BUILDING \
+ CHANGES \
+ COPYING \
+ hack.txt \
+ Manual.txt \
+ MiniSCHEMETribute.txt
diff --git a/plug-ins/script-fu/tinyscheme/Makefile.in b/plug-ins/script-fu/tinyscheme/Makefile.in
new file mode 100644
index 0000000..f9b848c
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/Makefile.in
@@ -0,0 +1,923 @@
+# Makefile.in generated by automake 1.16.2 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994-2020 Free Software Foundation, Inc.
+
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+VPATH = @srcdir@
+am__is_gnu_make = { \
+ if test -z '$(MAKELEVEL)'; then \
+ false; \
+ elif test -n '$(MAKE_HOST)'; then \
+ true; \
+ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \
+ true; \
+ else \
+ false; \
+ fi; \
+}
+am__make_running_with_option = \
+ case $${target_option-} in \
+ ?) ;; \
+ *) echo "am__make_running_with_option: internal error: invalid" \
+ "target option '$${target_option-}' specified" >&2; \
+ exit 1;; \
+ esac; \
+ has_opt=no; \
+ sane_makeflags=$$MAKEFLAGS; \
+ if $(am__is_gnu_make); then \
+ sane_makeflags=$$MFLAGS; \
+ else \
+ case $$MAKEFLAGS in \
+ *\\[\ \ ]*) \
+ bs=\\; \
+ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \
+ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \
+ esac; \
+ fi; \
+ skip_next=no; \
+ strip_trailopt () \
+ { \
+ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \
+ }; \
+ for flg in $$sane_makeflags; do \
+ test $$skip_next = yes && { skip_next=no; continue; }; \
+ case $$flg in \
+ *=*|--*) continue;; \
+ -*I) strip_trailopt 'I'; skip_next=yes;; \
+ -*I?*) strip_trailopt 'I';; \
+ -*O) strip_trailopt 'O'; skip_next=yes;; \
+ -*O?*) strip_trailopt 'O';; \
+ -*l) strip_trailopt 'l'; skip_next=yes;; \
+ -*l?*) strip_trailopt 'l';; \
+ -[dEDm]) skip_next=yes;; \
+ -[JT]) skip_next=yes;; \
+ esac; \
+ case $$flg in \
+ *$$target_option*) has_opt=yes; break;; \
+ esac; \
+ done; \
+ test $$has_opt = yes
+am__make_dryrun = (target_option=n; $(am__make_running_with_option))
+am__make_keepgoing = (target_option=k; $(am__make_running_with_option))
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+subdir = plug-ins/script-fu/tinyscheme
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4macros/gtk-doc.m4 \
+ $(top_srcdir)/m4macros/intltool.m4 \
+ $(top_srcdir)/m4macros/libtool.m4 \
+ $(top_srcdir)/m4macros/ltoptions.m4 \
+ $(top_srcdir)/m4macros/ltsugar.m4 \
+ $(top_srcdir)/m4macros/ltversion.m4 \
+ $(top_srcdir)/m4macros/lt~obsolete.m4 \
+ $(top_srcdir)/acinclude.m4 $(top_srcdir)/m4macros/alsa.m4 \
+ $(top_srcdir)/m4macros/ax_compare_version.m4 \
+ $(top_srcdir)/m4macros/ax_cxx_compile_stdcxx.m4 \
+ $(top_srcdir)/m4macros/ax_gcc_func_attribute.m4 \
+ $(top_srcdir)/m4macros/ax_prog_cc_for_build.m4 \
+ $(top_srcdir)/m4macros/ax_prog_perl_version.m4 \
+ $(top_srcdir)/m4macros/detectcflags.m4 \
+ $(top_srcdir)/m4macros/pythondev.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON)
+mkinstalldirs = $(install_sh) -d
+CONFIG_HEADER = $(top_builddir)/config.h
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+LIBRARIES = $(noinst_LIBRARIES)
+ARFLAGS = cru
+AM_V_AR = $(am__v_AR_@AM_V@)
+am__v_AR_ = $(am__v_AR_@AM_DEFAULT_V@)
+am__v_AR_0 = @echo " AR " $@;
+am__v_AR_1 =
+libtinyscheme_a_AR = $(AR) $(ARFLAGS)
+libtinyscheme_a_LIBADD =
+am_libtinyscheme_a_OBJECTS = scheme.$(OBJEXT)
+libtinyscheme_a_OBJECTS = $(am_libtinyscheme_a_OBJECTS)
+AM_V_P = $(am__v_P_@AM_V@)
+am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
+am__v_P_0 = false
+am__v_P_1 = :
+AM_V_GEN = $(am__v_GEN_@AM_V@)
+am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
+am__v_GEN_0 = @echo " GEN " $@;
+am__v_GEN_1 =
+AM_V_at = $(am__v_at_@AM_V@)
+am__v_at_ = $(am__v_at_@AM_DEFAULT_V@)
+am__v_at_0 = @
+am__v_at_1 =
+DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)
+depcomp = $(SHELL) $(top_srcdir)/depcomp
+am__maybe_remake_depfiles = depfiles
+am__depfiles_remade = ./$(DEPDIR)/scheme.Po
+am__mv = mv -f
+COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
+AM_V_lt = $(am__v_lt_@AM_V@)
+am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
+am__v_lt_0 = --silent
+am__v_lt_1 =
+LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \
+ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \
+ $(AM_CFLAGS) $(CFLAGS)
+AM_V_CC = $(am__v_CC_@AM_V@)
+am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@)
+am__v_CC_0 = @echo " CC " $@;
+am__v_CC_1 =
+CCLD = $(CC)
+LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
+ $(AM_LDFLAGS) $(LDFLAGS) -o $@
+AM_V_CCLD = $(am__v_CCLD_@AM_V@)
+am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@)
+am__v_CCLD_0 = @echo " CCLD " $@;
+am__v_CCLD_1 =
+SOURCES = $(libtinyscheme_a_SOURCES)
+DIST_SOURCES = $(libtinyscheme_a_SOURCES)
+am__can_run_installinfo = \
+ case $$AM_UPDATE_INFO_DIR in \
+ n|no|NO) false;; \
+ *) (install-info --version) >/dev/null 2>&1;; \
+ esac
+am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP)
+# Read a list of newline-separated strings from the standard input,
+# and print each of them once, without duplicates. Input order is
+# *not* preserved.
+am__uniquify_input = $(AWK) '\
+ BEGIN { nonempty = 0; } \
+ { items[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in items) print i; }; } \
+'
+# Make sure the list of sources is unique. This is necessary because,
+# e.g., the same source file might be shared among _SOURCES variables
+# for different programs/libraries.
+am__define_uniq_tagged_files = \
+ list='$(am__tagged_files)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | $(am__uniquify_input)`
+ETAGS = etags
+CTAGS = ctags
+am__DIST_COMMON = $(srcdir)/Makefile.in $(top_srcdir)/depcomp COPYING \
+ README
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+AA_LIBS = @AA_LIBS@
+ACLOCAL = @ACLOCAL@
+ALLOCA = @ALLOCA@
+ALL_LINGUAS = @ALL_LINGUAS@
+ALSA_CFLAGS = @ALSA_CFLAGS@
+ALSA_LIBS = @ALSA_LIBS@
+ALTIVEC_EXTRA_CFLAGS = @ALTIVEC_EXTRA_CFLAGS@
+AMTAR = @AMTAR@
+AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
+APPSTREAM_UTIL = @APPSTREAM_UTIL@
+AR = @AR@
+AS = @AS@
+ATK_CFLAGS = @ATK_CFLAGS@
+ATK_LIBS = @ATK_LIBS@
+ATK_REQUIRED_VERSION = @ATK_REQUIRED_VERSION@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+BABL_CFLAGS = @BABL_CFLAGS@
+BABL_LIBS = @BABL_LIBS@
+BABL_REQUIRED_VERSION = @BABL_REQUIRED_VERSION@
+BUG_REPORT_URL = @BUG_REPORT_URL@
+BUILD_EXEEXT = @BUILD_EXEEXT@
+BUILD_OBJEXT = @BUILD_OBJEXT@
+BZIP2_LIBS = @BZIP2_LIBS@
+CAIRO_CFLAGS = @CAIRO_CFLAGS@
+CAIRO_LIBS = @CAIRO_LIBS@
+CAIRO_PDF_CFLAGS = @CAIRO_PDF_CFLAGS@
+CAIRO_PDF_LIBS = @CAIRO_PDF_LIBS@
+CAIRO_PDF_REQUIRED_VERSION = @CAIRO_PDF_REQUIRED_VERSION@
+CAIRO_REQUIRED_VERSION = @CAIRO_REQUIRED_VERSION@
+CATALOGS = @CATALOGS@
+CATOBJEXT = @CATOBJEXT@
+CC = @CC@
+CCAS = @CCAS@
+CCASDEPMODE = @CCASDEPMODE@
+CCASFLAGS = @CCASFLAGS@
+CCDEPMODE = @CCDEPMODE@
+CC_FOR_BUILD = @CC_FOR_BUILD@
+CC_VERSION = @CC_VERSION@
+CFLAGS = @CFLAGS@
+CFLAGS_FOR_BUILD = @CFLAGS_FOR_BUILD@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CPPFLAGS_FOR_BUILD = @CPPFLAGS_FOR_BUILD@
+CPP_FOR_BUILD = @CPP_FOR_BUILD@
+CXX = @CXX@
+CXXCPP = @CXXCPP@
+CXXDEPMODE = @CXXDEPMODE@
+CXXFLAGS = @CXXFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DATADIRNAME = @DATADIRNAME@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DESKTOP_DATADIR = @DESKTOP_DATADIR@
+DESKTOP_FILE_VALIDATE = @DESKTOP_FILE_VALIDATE@
+DLLTOOL = @DLLTOOL@
+DOC_SHOOTER = @DOC_SHOOTER@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+FGREP = @FGREP@
+FILE_AA = @FILE_AA@
+FILE_EXR = @FILE_EXR@
+FILE_HEIF = @FILE_HEIF@
+FILE_JP2_LOAD = @FILE_JP2_LOAD@
+FILE_MNG = @FILE_MNG@
+FILE_PDF_SAVE = @FILE_PDF_SAVE@
+FILE_PS = @FILE_PS@
+FILE_WMF = @FILE_WMF@
+FILE_XMC = @FILE_XMC@
+FILE_XPM = @FILE_XPM@
+FONTCONFIG_CFLAGS = @FONTCONFIG_CFLAGS@
+FONTCONFIG_LIBS = @FONTCONFIG_LIBS@
+FONTCONFIG_REQUIRED_VERSION = @FONTCONFIG_REQUIRED_VERSION@
+FREETYPE2_REQUIRED_VERSION = @FREETYPE2_REQUIRED_VERSION@
+FREETYPE_CFLAGS = @FREETYPE_CFLAGS@
+FREETYPE_LIBS = @FREETYPE_LIBS@
+GDBUS_CODEGEN = @GDBUS_CODEGEN@
+GDK_PIXBUF_CFLAGS = @GDK_PIXBUF_CFLAGS@
+GDK_PIXBUF_CSOURCE = @GDK_PIXBUF_CSOURCE@
+GDK_PIXBUF_LIBS = @GDK_PIXBUF_LIBS@
+GDK_PIXBUF_REQUIRED_VERSION = @GDK_PIXBUF_REQUIRED_VERSION@
+GEGL = @GEGL@
+GEGL_CFLAGS = @GEGL_CFLAGS@
+GEGL_LIBS = @GEGL_LIBS@
+GEGL_MAJOR_MINOR_VERSION = @GEGL_MAJOR_MINOR_VERSION@
+GEGL_REQUIRED_VERSION = @GEGL_REQUIRED_VERSION@
+GETTEXT_PACKAGE = @GETTEXT_PACKAGE@
+GEXIV2_CFLAGS = @GEXIV2_CFLAGS@
+GEXIV2_LIBS = @GEXIV2_LIBS@
+GEXIV2_REQUIRED_VERSION = @GEXIV2_REQUIRED_VERSION@
+GIMP_API_VERSION = @GIMP_API_VERSION@
+GIMP_APP_VERSION = @GIMP_APP_VERSION@
+GIMP_BINARY_AGE = @GIMP_BINARY_AGE@
+GIMP_COMMAND = @GIMP_COMMAND@
+GIMP_DATA_VERSION = @GIMP_DATA_VERSION@
+GIMP_FULL_NAME = @GIMP_FULL_NAME@
+GIMP_INTERFACE_AGE = @GIMP_INTERFACE_AGE@
+GIMP_MAJOR_VERSION = @GIMP_MAJOR_VERSION@
+GIMP_MICRO_VERSION = @GIMP_MICRO_VERSION@
+GIMP_MINOR_VERSION = @GIMP_MINOR_VERSION@
+GIMP_MKENUMS = @GIMP_MKENUMS@
+GIMP_MODULES = @GIMP_MODULES@
+GIMP_PACKAGE_REVISION = @GIMP_PACKAGE_REVISION@
+GIMP_PKGCONFIG_VERSION = @GIMP_PKGCONFIG_VERSION@
+GIMP_PLUGINS = @GIMP_PLUGINS@
+GIMP_PLUGIN_VERSION = @GIMP_PLUGIN_VERSION@
+GIMP_REAL_VERSION = @GIMP_REAL_VERSION@
+GIMP_SYSCONF_VERSION = @GIMP_SYSCONF_VERSION@
+GIMP_TOOL_VERSION = @GIMP_TOOL_VERSION@
+GIMP_UNSTABLE = @GIMP_UNSTABLE@
+GIMP_USER_VERSION = @GIMP_USER_VERSION@
+GIMP_VERSION = @GIMP_VERSION@
+GIO_CFLAGS = @GIO_CFLAGS@
+GIO_LIBS = @GIO_LIBS@
+GIO_UNIX_CFLAGS = @GIO_UNIX_CFLAGS@
+GIO_UNIX_LIBS = @GIO_UNIX_LIBS@
+GIO_WINDOWS_CFLAGS = @GIO_WINDOWS_CFLAGS@
+GIO_WINDOWS_LIBS = @GIO_WINDOWS_LIBS@
+GLIB_CFLAGS = @GLIB_CFLAGS@
+GLIB_COMPILE_RESOURCES = @GLIB_COMPILE_RESOURCES@
+GLIB_GENMARSHAL = @GLIB_GENMARSHAL@
+GLIB_LIBS = @GLIB_LIBS@
+GLIB_MKENUMS = @GLIB_MKENUMS@
+GLIB_REQUIRED_VERSION = @GLIB_REQUIRED_VERSION@
+GMODULE_NO_EXPORT_CFLAGS = @GMODULE_NO_EXPORT_CFLAGS@
+GMODULE_NO_EXPORT_LIBS = @GMODULE_NO_EXPORT_LIBS@
+GMOFILES = @GMOFILES@
+GMSGFMT = @GMSGFMT@
+GOBJECT_QUERY = @GOBJECT_QUERY@
+GREP = @GREP@
+GS_LIBS = @GS_LIBS@
+GTKDOC_CHECK = @GTKDOC_CHECK@
+GTKDOC_CHECK_PATH = @GTKDOC_CHECK_PATH@
+GTKDOC_DEPS_CFLAGS = @GTKDOC_DEPS_CFLAGS@
+GTKDOC_DEPS_LIBS = @GTKDOC_DEPS_LIBS@
+GTKDOC_MKPDF = @GTKDOC_MKPDF@
+GTKDOC_REBASE = @GTKDOC_REBASE@
+GTK_CFLAGS = @GTK_CFLAGS@
+GTK_LIBS = @GTK_LIBS@
+GTK_MAC_INTEGRATION_CFLAGS = @GTK_MAC_INTEGRATION_CFLAGS@
+GTK_MAC_INTEGRATION_LIBS = @GTK_MAC_INTEGRATION_LIBS@
+GTK_REQUIRED_VERSION = @GTK_REQUIRED_VERSION@
+GTK_UPDATE_ICON_CACHE = @GTK_UPDATE_ICON_CACHE@
+GUDEV_CFLAGS = @GUDEV_CFLAGS@
+GUDEV_LIBS = @GUDEV_LIBS@
+HARFBUZZ_CFLAGS = @HARFBUZZ_CFLAGS@
+HARFBUZZ_LIBS = @HARFBUZZ_LIBS@
+HARFBUZZ_REQUIRED_VERSION = @HARFBUZZ_REQUIRED_VERSION@
+HAVE_CXX14 = @HAVE_CXX14@
+HAVE_FINITE = @HAVE_FINITE@
+HAVE_ISFINITE = @HAVE_ISFINITE@
+HAVE_VFORK = @HAVE_VFORK@
+HOST_GLIB_COMPILE_RESOURCES = @HOST_GLIB_COMPILE_RESOURCES@
+HTML_DIR = @HTML_DIR@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+INSTOBJEXT = @INSTOBJEXT@
+INTLLIBS = @INTLLIBS@
+INTLTOOL_EXTRACT = @INTLTOOL_EXTRACT@
+INTLTOOL_MERGE = @INTLTOOL_MERGE@
+INTLTOOL_PERL = @INTLTOOL_PERL@
+INTLTOOL_REQUIRED_VERSION = @INTLTOOL_REQUIRED_VERSION@
+INTLTOOL_UPDATE = @INTLTOOL_UPDATE@
+INTLTOOL_V_MERGE = @INTLTOOL_V_MERGE@
+INTLTOOL_V_MERGE_OPTIONS = @INTLTOOL_V_MERGE_OPTIONS@
+INTLTOOL__v_MERGE_ = @INTLTOOL__v_MERGE_@
+INTLTOOL__v_MERGE_0 = @INTLTOOL__v_MERGE_0@
+INTL_MACOSX_LIBS = @INTL_MACOSX_LIBS@
+ISO_CODES_LOCALEDIR = @ISO_CODES_LOCALEDIR@
+ISO_CODES_LOCATION = @ISO_CODES_LOCATION@
+JPEG_LIBS = @JPEG_LIBS@
+JSON_GLIB_CFLAGS = @JSON_GLIB_CFLAGS@
+JSON_GLIB_LIBS = @JSON_GLIB_LIBS@
+LCMS_CFLAGS = @LCMS_CFLAGS@
+LCMS_LIBS = @LCMS_LIBS@
+LCMS_REQUIRED_VERSION = @LCMS_REQUIRED_VERSION@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LDFLAGS_FOR_BUILD = @LDFLAGS_FOR_BUILD@
+LIBBACKTRACE_LIBS = @LIBBACKTRACE_LIBS@
+LIBHEIF_CFLAGS = @LIBHEIF_CFLAGS@
+LIBHEIF_LIBS = @LIBHEIF_LIBS@
+LIBHEIF_REQUIRED_VERSION = @LIBHEIF_REQUIRED_VERSION@
+LIBLZMA_REQUIRED_VERSION = @LIBLZMA_REQUIRED_VERSION@
+LIBMYPAINT_CFLAGS = @LIBMYPAINT_CFLAGS@
+LIBMYPAINT_LIBS = @LIBMYPAINT_LIBS@
+LIBMYPAINT_REQUIRED_VERSION = @LIBMYPAINT_REQUIRED_VERSION@
+LIBOBJS = @LIBOBJS@
+LIBPNG_REQUIRED_VERSION = @LIBPNG_REQUIRED_VERSION@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIBUNWIND_CFLAGS = @LIBUNWIND_CFLAGS@
+LIBUNWIND_LIBS = @LIBUNWIND_LIBS@
+LIBUNWIND_REQUIRED_VERSION = @LIBUNWIND_REQUIRED_VERSION@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+LT_CURRENT_MINUS_AGE = @LT_CURRENT_MINUS_AGE@
+LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@
+LT_VERSION_INFO = @LT_VERSION_INFO@
+LZMA_CFLAGS = @LZMA_CFLAGS@
+LZMA_LIBS = @LZMA_LIBS@
+MAIL = @MAIL@
+MAINT = @MAINT@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MIME_INFO_CFLAGS = @MIME_INFO_CFLAGS@
+MIME_INFO_LIBS = @MIME_INFO_LIBS@
+MIME_TYPES = @MIME_TYPES@
+MKDIR_P = @MKDIR_P@
+MKINSTALLDIRS = @MKINSTALLDIRS@
+MMX_EXTRA_CFLAGS = @MMX_EXTRA_CFLAGS@
+MNG_CFLAGS = @MNG_CFLAGS@
+MNG_LIBS = @MNG_LIBS@
+MSGFMT = @MSGFMT@
+MSGFMT_OPTS = @MSGFMT_OPTS@
+MSGMERGE = @MSGMERGE@
+MYPAINT_BRUSHES_CFLAGS = @MYPAINT_BRUSHES_CFLAGS@
+MYPAINT_BRUSHES_LIBS = @MYPAINT_BRUSHES_LIBS@
+NATIVE_GLIB_CFLAGS = @NATIVE_GLIB_CFLAGS@
+NATIVE_GLIB_LIBS = @NATIVE_GLIB_LIBS@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OPENEXR_CFLAGS = @OPENEXR_CFLAGS@
+OPENEXR_LIBS = @OPENEXR_LIBS@
+OPENEXR_REQUIRED_VERSION = @OPENEXR_REQUIRED_VERSION@
+OPENJPEG_CFLAGS = @OPENJPEG_CFLAGS@
+OPENJPEG_LIBS = @OPENJPEG_LIBS@
+OPENJPEG_REQUIRED_VERSION = @OPENJPEG_REQUIRED_VERSION@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PANGOCAIRO_CFLAGS = @PANGOCAIRO_CFLAGS@
+PANGOCAIRO_LIBS = @PANGOCAIRO_LIBS@
+PANGOCAIRO_REQUIRED_VERSION = @PANGOCAIRO_REQUIRED_VERSION@
+PATHSEP = @PATHSEP@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+PERL = @PERL@
+PERL_REQUIRED_VERSION = @PERL_REQUIRED_VERSION@
+PERL_VERSION = @PERL_VERSION@
+PKG_CONFIG = @PKG_CONFIG@
+PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@
+PKG_CONFIG_PATH = @PKG_CONFIG_PATH@
+PNG_CFLAGS = @PNG_CFLAGS@
+PNG_LIBS = @PNG_LIBS@
+POFILES = @POFILES@
+POPPLER_CFLAGS = @POPPLER_CFLAGS@
+POPPLER_DATA_CFLAGS = @POPPLER_DATA_CFLAGS@
+POPPLER_DATA_LIBS = @POPPLER_DATA_LIBS@
+POPPLER_DATA_REQUIRED_VERSION = @POPPLER_DATA_REQUIRED_VERSION@
+POPPLER_LIBS = @POPPLER_LIBS@
+POPPLER_REQUIRED_VERSION = @POPPLER_REQUIRED_VERSION@
+POSUB = @POSUB@
+PO_IN_DATADIR_FALSE = @PO_IN_DATADIR_FALSE@
+PO_IN_DATADIR_TRUE = @PO_IN_DATADIR_TRUE@
+PYBIN_PATH = @PYBIN_PATH@
+PYCAIRO_CFLAGS = @PYCAIRO_CFLAGS@
+PYCAIRO_LIBS = @PYCAIRO_LIBS@
+PYGIMP_EXTRA_CFLAGS = @PYGIMP_EXTRA_CFLAGS@
+PYGTK_CFLAGS = @PYGTK_CFLAGS@
+PYGTK_CODEGEN = @PYGTK_CODEGEN@
+PYGTK_DEFSDIR = @PYGTK_DEFSDIR@
+PYGTK_LIBS = @PYGTK_LIBS@
+PYLINK_LIBS = @PYLINK_LIBS@
+PYTHON = @PYTHON@
+PYTHON2_REQUIRED_VERSION = @PYTHON2_REQUIRED_VERSION@
+PYTHON_EXEC_PREFIX = @PYTHON_EXEC_PREFIX@
+PYTHON_INCLUDES = @PYTHON_INCLUDES@
+PYTHON_PLATFORM = @PYTHON_PLATFORM@
+PYTHON_PREFIX = @PYTHON_PREFIX@
+PYTHON_VERSION = @PYTHON_VERSION@
+RANLIB = @RANLIB@
+RSVG_REQUIRED_VERSION = @RSVG_REQUIRED_VERSION@
+RT_LIBS = @RT_LIBS@
+SCREENSHOT_LIBS = @SCREENSHOT_LIBS@
+SED = @SED@
+SENDMAIL = @SENDMAIL@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+SOCKET_LIBS = @SOCKET_LIBS@
+SSE2_EXTRA_CFLAGS = @SSE2_EXTRA_CFLAGS@
+SSE4_1_EXTRA_CFLAGS = @SSE4_1_EXTRA_CFLAGS@
+SSE_EXTRA_CFLAGS = @SSE_EXTRA_CFLAGS@
+STRIP = @STRIP@
+SVG_CFLAGS = @SVG_CFLAGS@
+SVG_LIBS = @SVG_LIBS@
+SYMPREFIX = @SYMPREFIX@
+TIFF_LIBS = @TIFF_LIBS@
+USE_NLS = @USE_NLS@
+VERSION = @VERSION@
+WEBKIT_CFLAGS = @WEBKIT_CFLAGS@
+WEBKIT_LIBS = @WEBKIT_LIBS@
+WEBKIT_REQUIRED_VERSION = @WEBKIT_REQUIRED_VERSION@
+WEBPDEMUX_CFLAGS = @WEBPDEMUX_CFLAGS@
+WEBPDEMUX_LIBS = @WEBPDEMUX_LIBS@
+WEBPMUX_CFLAGS = @WEBPMUX_CFLAGS@
+WEBPMUX_LIBS = @WEBPMUX_LIBS@
+WEBP_CFLAGS = @WEBP_CFLAGS@
+WEBP_LIBS = @WEBP_LIBS@
+WEBP_REQUIRED_VERSION = @WEBP_REQUIRED_VERSION@
+WEB_PAGE = @WEB_PAGE@
+WIN32_LARGE_ADDRESS_AWARE = @WIN32_LARGE_ADDRESS_AWARE@
+WINDRES = @WINDRES@
+WMF_CFLAGS = @WMF_CFLAGS@
+WMF_CONFIG = @WMF_CONFIG@
+WMF_LIBS = @WMF_LIBS@
+WMF_REQUIRED_VERSION = @WMF_REQUIRED_VERSION@
+XDG_EMAIL = @XDG_EMAIL@
+XFIXES_CFLAGS = @XFIXES_CFLAGS@
+XFIXES_LIBS = @XFIXES_LIBS@
+XGETTEXT = @XGETTEXT@
+XGETTEXT_REQUIRED_VERSION = @XGETTEXT_REQUIRED_VERSION@
+XMC_CFLAGS = @XMC_CFLAGS@
+XMC_LIBS = @XMC_LIBS@
+XMKMF = @XMKMF@
+XMLLINT = @XMLLINT@
+XMU_LIBS = @XMU_LIBS@
+XPM_LIBS = @XPM_LIBS@
+XSLTPROC = @XSLTPROC@
+XVFB_RUN = @XVFB_RUN@
+X_CFLAGS = @X_CFLAGS@
+X_EXTRA_LIBS = @X_EXTRA_LIBS@
+X_LIBS = @X_LIBS@
+X_PRE_LIBS = @X_PRE_LIBS@
+Z_LIBS = @Z_LIBS@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_CC_FOR_BUILD = @ac_ct_CC_FOR_BUILD@
+ac_ct_CXX = @ac_ct_CXX@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+gimpdatadir = @gimpdatadir@
+gimpdir = @gimpdir@
+gimplocaledir = @gimplocaledir@
+gimpplugindir = @gimpplugindir@
+gimpsysconfdir = @gimpsysconfdir@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+intltool__v_merge_options_ = @intltool__v_merge_options_@
+intltool__v_merge_options_0 = @intltool__v_merge_options_0@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+mandir = @mandir@
+manpage_gimpdir = @manpage_gimpdir@
+mkdir_p = @mkdir_p@
+ms_librarian = @ms_librarian@
+mypaint_brushes_dir = @mypaint_brushes_dir@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+pkgpyexecdir = @pkgpyexecdir@
+pkgpythondir = @pkgpythondir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+pyexecdir = @pyexecdir@
+pythondir = @pythondir@
+runstatedir = @runstatedir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+AM_CFLAGS = \
+ -DSTANDALONE=0 \
+ -DUSE_INTERFACE=1 \
+ -DUSE_MATH=1 \
+ -DUSE_ASCII_NAMES=0 \
+ -DUSE_STRLWR=0 \
+ -I$(top_srcdir) \
+ $(GLIB_CFLAGS)
+
+noinst_LIBRARIES = libtinyscheme.a
+libtinyscheme_a_SOURCES = \
+ scheme.c \
+ opdefines.h \
+ scheme-private.h \
+ scheme.h
+
+EXTRA_DIST = \
+ BUILDING \
+ CHANGES \
+ COPYING \
+ hack.txt \
+ Manual.txt \
+ MiniSCHEMETribute.txt
+
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .c .lo .o .obj
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu plug-ins/script-fu/tinyscheme/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu plug-ins/script-fu/tinyscheme/Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \
+ esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+
+clean-noinstLIBRARIES:
+ -test -z "$(noinst_LIBRARIES)" || rm -f $(noinst_LIBRARIES)
+
+libtinyscheme.a: $(libtinyscheme_a_OBJECTS) $(libtinyscheme_a_DEPENDENCIES) $(EXTRA_libtinyscheme_a_DEPENDENCIES)
+ $(AM_V_at)-rm -f libtinyscheme.a
+ $(AM_V_AR)$(libtinyscheme_a_AR) libtinyscheme.a $(libtinyscheme_a_OBJECTS) $(libtinyscheme_a_LIBADD)
+ $(AM_V_at)$(RANLIB) libtinyscheme.a
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/scheme.Po@am__quote@ # am--include-marker
+
+$(am__depfiles_remade):
+ @$(MKDIR_P) $(@D)
+ @echo '# dummy' >$@-t && $(am__mv) $@-t $@
+
+am--depfiles: $(am__depfiles_remade)
+
+.c.o:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $<
+
+.c.obj:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'`
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'`
+
+.c.lo:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(LTCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $<
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+
+ID: $(am__tagged_files)
+ $(am__define_uniq_tagged_files); mkid -fID $$unique
+tags: tags-am
+TAGS: tags
+
+tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files)
+ set x; \
+ here=`pwd`; \
+ $(am__define_uniq_tagged_files); \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: ctags-am
+
+CTAGS: ctags
+ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files)
+ $(am__define_uniq_tagged_files); \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+cscopelist: cscopelist-am
+
+cscopelist-am: $(am__tagged_files)
+ list='$(am__tagged_files)'; \
+ case "$(srcdir)" in \
+ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \
+ *) sdir=$(subdir)/$(srcdir) ;; \
+ esac; \
+ for i in $$list; do \
+ if test -f "$$i"; then \
+ echo "$(subdir)/$$i"; \
+ else \
+ echo "$$sdir/$$i"; \
+ fi; \
+ done >> $(top_builddir)/cscope.files
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(BUILT_SOURCES)
+ $(MAKE) $(AM_MAKEFLAGS) distdir-am
+
+distdir-am: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-am
+all-am: Makefile $(LIBRARIES)
+installdirs:
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ if test -z '$(STRIP)'; then \
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ install; \
+ else \
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \
+ fi
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-noinstLIBRARIES \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f ./$(DEPDIR)/scheme.Po
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am:
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am:
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f ./$(DEPDIR)/scheme.Po
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am:
+
+.MAKE: install-am install-strip
+
+.PHONY: CTAGS GTAGS TAGS all all-am am--depfiles check check-am clean \
+ clean-generic clean-libtool clean-noinstLIBRARIES \
+ cscopelist-am ctags ctags-am distclean distclean-compile \
+ distclean-generic distclean-libtool distclean-tags distdir dvi \
+ dvi-am html html-am info info-am install install-am \
+ install-data install-data-am install-dvi install-dvi-am \
+ install-exec install-exec-am install-html install-html-am \
+ install-info install-info-am install-man install-pdf \
+ install-pdf-am install-ps install-ps-am install-strip \
+ installcheck installcheck-am installdirs maintainer-clean \
+ maintainer-clean-generic mostlyclean mostlyclean-compile \
+ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \
+ tags tags-am uninstall uninstall-am
+
+.PRECIOUS: Makefile
+
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/plug-ins/script-fu/tinyscheme/Manual.txt b/plug-ins/script-fu/tinyscheme/Manual.txt
new file mode 100644
index 0000000..7ef62e9
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/Manual.txt
@@ -0,0 +1,452 @@
+
+
+ TinySCHEME Version 1.41
+
+ "Safe if used as prescribed"
+ -- Philip K. Dick, "Ubik"
+
+This software is open source, covered by a BSD-style license.
+Please read accompanying file COPYING.
+-------------------------------------------------------------------------------
+
+ This Scheme interpreter is based on MiniSCHEME version 0.85k4
+ (see miniscm.tar.gz in the Scheme Repository)
+ Original credits in file MiniSCHEMETribute.txt.
+
+ D. Souflis (dsouflis@acm.org)
+
+-------------------------------------------------------------------------------
+ What is TinyScheme?
+ -------------------
+
+ TinyScheme is a lightweight Scheme interpreter that implements as large
+ a subset of R5RS as was possible without getting very large and
+ complicated. It is meant to be used as an embedded scripting interpreter
+ for other programs. As such, it does not offer IDEs or extensive toolkits
+ although it does sport a small top-level loop, included conditionally.
+ A lot of functionality in TinyScheme is included conditionally, to allow
+ developers freedom in balancing features and footprint.
+
+ As an embedded interpreter, it allows multiple interpreter states to
+ coexist in the same program, without any interference between them.
+ Programmatically, foreign functions in C can be added and values
+ can be defined in the Scheme environment. Being a quite small program,
+ it is easy to comprehend, get to grips with, and use.
+
+ Known bugs
+ ----------
+
+ TinyScheme is known to misbehave when memory is exhausted.
+
+
+ Things that keep missing, or that need fixing
+ ---------------------------------------------
+
+ There are no hygienic macros. No rational or
+ complex numbers. No unwind-protect and call-with-values.
+
+ Maybe (a subset of) SLIB will work with TinySCHEME...
+
+ Decent debugging facilities are missing. Only tracing is supported
+ natively.
+
+
+ Scheme Reference
+ ----------------
+
+ If something seems to be missing, please refer to the code and
+ "init.scm", since some are library functions. Refer to the MiniSCHEME
+ readme as a last resort.
+
+ Environments
+ (interaction-environment)
+ See R5RS. In TinySCHEME, immutable list of association lists.
+
+ (current-environment)
+ The environment in effect at the time of the call. An example of its
+ use and its utility can be found in the sample code that implements
+ packages in "init.scm":
+
+ (macro (package form)
+ `(apply (lambda ()
+ ,@(cdr form)
+ (current-environment))))
+
+ The environment containing the (local) definitions inside the closure
+ is returned as an immutable value.
+
+ (defined? <symbol>) (defined? <symbol> <environment>)
+ Checks whether the given symbol is defined in the current (or given)
+ environment.
+
+ Symbols
+ (gensym)
+ Returns a new interned symbol each time. Will probably move to the
+ library when string->symbol is implemented.
+
+ Directives
+ (gc)
+ Performs garbage collection immediately.
+
+ (gcverbose) (gcverbose <bool>)
+ The argument (defaulting to #t) controls whether GC produces
+ visible outcome.
+
+ (quit) (quit <num>)
+ Stops the interpreter and sets the 'retcode' internal field (defaults
+ to 0). When standalone, 'retcode' is returned as exit code to the OS.
+
+ (tracing <num>)
+ 1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1).
+
+ Mathematical functions
+ Since rationals and complexes are absent, the respective functions
+ are also missing.
+ Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling,
+ trunc, round and also sqrt and expt when USE_MATH=1.
+ Number-theoretical quotient, remainder and modulo, gcd, lcm.
+ Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?,
+ exact->inexact. inexact->exact is a core function.
+
+ Type predicates
+ boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?,
+ char?,port?,input-port?,output-port?,procedure?,pair?,environment?',
+ vector?. Also closure?, macro?.
+
+ Types
+ Types supported:
+
+ Numbers (integers and reals)
+ Symbols
+ Pairs
+ Strings
+ Characters
+ Ports
+ Eof object
+ Environments
+ Vectors
+
+ Literals
+ String literals can contain escaped quotes \" as usual, but also
+ \n, \r, \t, \xDD (hex representations) and \DDD (octal representations).
+ Note also that it is possible to include literal newlines in string
+ literals, e.g.
+
+ (define s "String with newline here
+ and here
+ that can function like a HERE-string")
+
+ Character literals contain #\space and #\newline and are supplemented
+ with #\return and #\tab, with obvious meanings. Hex character
+ representations are allowed (e.g. #\x20 is #\space).
+ When USE_ASCII_NAMES is defined, various control characters can be
+ referred to by their ASCII name.
+ 0 #\nul 17 #\dc1
+ 1 #\soh 18 #\dc2
+ 2 #\stx 19 #\dc3
+ 3 #\etx 20 #\dc4
+ 4 #\eot 21 #\nak
+ 5 #\enq 22 #\syn
+ 6 #\ack 23 #\etv
+ 7 #\bel 24 #\can
+ 8 #\bs 25 #\em
+ 9 #\ht 26 #\sub
+ 10 #\lf 27 #\esc
+ 11 #\vt 28 #\fs
+ 12 #\ff 29 #\gs
+ 13 #\cr 30 #\rs
+ 14 #\so 31 #\us
+ 15 #\si
+ 16 #\dle 127 #\del
+
+ Numeric literals support #x #o #b and #d. Flonums are currently read only
+ in decimal notation. Full grammar will be supported soon.
+
+ Quote, quasiquote etc.
+ As usual.
+
+ Immutable values
+ Immutable pairs cannot be modified by set-car! and set-cdr!.
+ Immutable strings cannot be modified via string-set!
+
+ I/O
+ As per R5RS, plus String Ports (see below).
+ current-input-port, current-output-port,
+ close-input-port, close-output-port, input-port?, output-port?,
+ open-input-file, open-output-file.
+ read, write, display, newline, write-char, read-char, peek-char.
+ char-ready? returns #t only for string ports, because there is no
+ portable way in stdio to determine if a character is available.
+ Also open-input-output-file, set-input-port, set-output-port (not R5RS)
+ Library: call-with-input-file, call-with-output-file,
+ with-input-from-file, with-output-from-file and
+ with-input-output-from-to-files, close-port and input-output-port?
+ (not R5RS).
+ String Ports: open-input-string, open-output-string, get-output-string,
+ open-input-output-string. Strings can be used with I/O routines.
+
+ Vectors
+ make-vector, vector, vector-length, vector-ref, vector-set!, list->vector,
+ vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS)
+
+ Strings
+ string, make-string, list->string, string-length, string-ref, string-set!,
+ substring, string->list, string-fill!, string-append, string-copy.
+ string=?, string<?, string>?, string>?, string<=?, string>=?.
+ (No string-ci*? yet). string->number, number->string. Also atom->string,
+ string->atom (not R5RS).
+
+ Symbols
+ symbol->string, string->symbol
+
+ Characters
+ integer->char, char->integer.
+ char=?, char<?, char>?, char<=?, char>=?.
+ (No char-ci*?)
+
+ Pairs & Lists
+ cons, car, cdr, list, length, map, for-each, foldr, list-tail,
+ list-ref, last-pair, reverse, append.
+ Also member, memq, memv, based on generic-member, assoc, assq, assv
+ based on generic-assoc.
+
+ Streams
+ head, tail, cons-stream
+
+ Control features
+ Apart from procedure?, also macro? and closure?
+ map, for-each, force, delay, call-with-current-continuation (or call/cc),
+ eval, apply. 'Forcing' a value that is not a promise produces the value.
+ There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in
+ the presence of continuations would require support from the abstract
+ machine itself.
+
+ Property lists
+ TinyScheme inherited from MiniScheme property lists for symbols.
+ put, get.
+
+ Dynamically-loaded extensions
+ (load-extension <filename without extension>)
+ Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use
+ of the ld.so.conf file or the LD_RUN_PATH system variable in order to place
+ the library in a directory other than the current one. Please refer to the
+ appropriate 'man' page.
+
+ Esoteric procedures
+ (oblist)
+ Returns the oblist, an immutable list of all the symbols.
+
+ (macro-expand <form>)
+ Returns the expanded form of the macro call denoted by the argument
+
+ (define-with-return (<procname> <args>...) <body>)
+ Like plain 'define', but makes the continuation available as 'return'
+ inside the procedure. Handy for imperative programs.
+
+ (new-segment <num>)
+ Allocates more memory segments.
+
+ defined?
+ See "Environments"
+
+ (get-closure-code <closure>)
+ Gets the code as scheme data.
+
+ (make-closure <code> <environment>)
+ Makes a new closure in the given environment.
+
+ Obsolete procedures
+ (print-width <object>)
+
+ Programmer's Reference
+ ----------------------
+
+ The interpreter state is initialized with "scheme_init".
+ Custom memory allocation routines can be installed with an alternate
+ initialization function: "scheme_init_custom_alloc".
+ Files can be loaded with "scheme_load_file". Strings containing Scheme
+ code can be loaded with "scheme_load_string". It is a good idea to
+ "scheme_load" init.scm before anything else.
+
+ External data for keeping external state (of use to foreign functions)
+ can be installed with "scheme_set_external_data".
+ Foreign functions are installed with "assign_foreign". Additional
+ definitions can be added to the interpreter state, with "scheme_define"
+ (this is the way HTTP header data and HTML form data are passed to the
+ Scheme script in the Altera SQL Server). If you wish to define the
+ foreign function in a specific environment (to enhance modularity),
+ use "assign_foreign_env".
+
+ The procedure "scheme_apply0" has been added with persistent scripts in
+ mind. Persistent scripts are loaded once, and every time they are needed
+ to produce HTTP output, appropriate data are passed through global
+ definitions and function "main" is called to do the job. One could
+ add easily "scheme_apply1" etc.
+
+ The interpreter state should be deinitialized with "scheme_deinit".
+
+ DLLs containing foreign functions should define a function named
+ init_<base-name>. E.g. foo.dll should define init_foo, and bar.so
+ should define init_bar. This function should assign_foreign any foreign
+ function contained in the DLL.
+
+ The first dynamically loaded extension available for TinyScheme is
+ a regular expression library. Although it's by no means an
+ established standard, this library is supposed to be installed in
+ a directory mirroring its name under the TinyScheme location.
+
+
+ Foreign Functions
+ -----------------
+
+ The user can add foreign functions in C. For example, a function
+ that squares its argument:
+
+ pointer square(scheme *sc, pointer args) {
+ if(args!=sc->NIL) {
+ if(sc->isnumber(sc->pair_car(args))) {
+ double v=sc->rvalue(sc->pair_car(args));
+ return sc->mk_real(sc,v*v);
+ }
+ }
+ return sc->NIL;
+ }
+
+ Foreign functions are now defined as closures:
+
+ sc->interface->scheme_define(
+ sc,
+ sc->global_env,
+ sc->interface->mk_symbol(sc,"square"),
+ sc->interface->mk_foreign_func(sc, square));
+
+
+ Foreign functions can use the external data in the "scheme" struct
+ to implement any kind of external state.
+
+ External data are set with the following function:
+ void scheme_set_external_data(scheme *sc, void *p);
+
+ As of v.1.17, the canonical way for a foreign function in a DLL to
+ manipulate Scheme data is using the function pointers in sc->interface.
+
+ Standalone
+ ----------
+
+ Usage: tinyscheme -?
+ or: tinyscheme [<file1> <file2> ...]
+ followed by
+ -1 <file> [<arg1> <arg2> ...]
+ -c <Scheme commands> [<arg1> <arg2> ...]
+ assuming that the executable is named tinyscheme.
+
+ Use - in the place of a filename to denote stdin.
+ The -1 flag is meant for #! usage in shell scripts. If you specify
+ #! /somewhere/tinyscheme -1
+ then tinyscheme will be called to process the file. For example, the
+ following script echoes the Scheme list of its arguments.
+
+ #! /somewhere/tinyscheme -1
+ (display *args*)
+
+ The -c flag permits execution of arbitrary Scheme code.
+
+
+ Error Handling
+ --------------
+
+ Errors are recovered from without damage. The user can install his
+ own handler for system errors, by defining *error-hook*. Defining
+ to '() gives the default behavior, which is equivalent to "error".
+ USE_ERROR_HOOK must be defined.
+
+ A simple exception handling mechanism can be found in "init.scm".
+ A new syntactic form is introduced:
+
+ (catch <expr returned exceptionally>
+ <expr1> <expr2> ... <exprN>)
+
+ "Catch" establishes a scope spanning multiple call-frames
+ until another "catch" is encountered.
+
+ Exceptions are thrown with:
+
+ (throw "message")
+
+ If used outside a (catch ...), reverts to (error "message").
+
+ Example of use:
+
+ (define (foo x) (write x) (newline) (/ x 0))
+
+ (catch (begin (display "Error!\n") 0)
+ (write "Before foo ... ")
+ (foo 5)
+ (write "After foo"))
+
+ The exception mechanism can be used even by system errors, by
+
+ (define *error-hook* throw)
+
+ which makes use of the error hook described above.
+
+ If necessary, the user can devise his own exception mechanism with
+ tagged exceptions etc.
+
+
+ Reader extensions
+ -----------------
+
+ When encountering an unknown character after '#', the user-specified
+ procedure *sharp-hook* (if any), is called to read the expression.
+ This can be used to extend the reader to handle user-defined constants
+ or whatever. It should be a procedure without arguments, reading from
+ the current input port (which will be the load-port).
+
+
+ Colon Qualifiers - Packages
+ ---------------------------
+
+ When USE_COLON_HOOK=1:
+ The lexer now recognizes the construction <qualifier>::<symbol> and
+ transforms it in the following manner (T is the transformation function):
+
+ T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>)
+
+ where <qualifier> is a symbol not containing any double-colons.
+
+ As the definition is recursive, qualifiers can be nested.
+ The user can define his own *colon-hook*, to handle qualified names.
+ By default, "init.scm" defines *colon-hook* as EVAL. Consequently,
+ the qualifier must denote a Scheme environment, such as one returned
+ by (interaction-environment). "Init.scm" defines a new syntantic form,
+ PACKAGE, as a simple example. It is used like this:
+
+ (define toto
+ (package
+ (define foo 1)
+ (define bar +)))
+
+ foo ==> Error, "foo" undefined
+ (eval 'foo) ==> Error, "foo" undefined
+ (eval 'foo toto) ==> 1
+ toto::foo ==> 1
+ ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3
+ (toto::bar 2 toto::foo) ==> 3
+ (eval (bar 2 foo) toto) ==> 3
+
+ If the user installs another package infrastructure, he must define
+ a new 'package' procedure or macro to retain compatibility with supplied
+ code.
+
+ Note: Older versions used ':' as a qualifier. Unfortunately, the use
+ of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially
+ precludes its use as a real qualifier.
+
+
+
+
+
+
+
+
diff --git a/plug-ins/script-fu/tinyscheme/MiniSCHEMETribute.txt b/plug-ins/script-fu/tinyscheme/MiniSCHEMETribute.txt
new file mode 100644
index 0000000..185f0ec
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/MiniSCHEMETribute.txt
@@ -0,0 +1,88 @@
+ TinyScheme would not exist if it wasn't for MiniScheme. I had just
+ written the HTTP server for Ovrimos SQL Server, and I was lamenting the
+ lack of a scripting language. Server-side Javascript would have been the
+ preferred solution, had there been a Javascript interpreter I could
+ lay my hands on. But there weren't. Perl would have been another solution,
+ but it was probably ten times bigger that the program it was supposed to
+ be embedded in. There would also be thorny licencing issues.
+
+ So, the obvious thing to do was find a truly small interpreter. Forth
+ was a language I had once quasi-implemented, but the difficulty of
+ handling dynamic data and the weirdness of the language put me off. I then
+ looked around for a LISP interpreter, the next thing I knew was easy to
+ implement. Alas, the LeLisp I knew from my days in UPMC (Universite Pierre
+ et Marie Curie) had given way to Common Lisp, a megalith of a language!
+ Then my search lead me to Scheme, a language I knew was very orthogonal
+ and clean. When I found Mini-Scheme, a single C file of some 2400 loc, I
+ fell in love with it! What if it lacked floating-point numbers and
+ strings! The rest, as they say, is history.
+
+ Below are the original credits. Don't email Akira KIDA, the address has
+ changed.
+
+ ---------- Mini-Scheme Interpreter Version 0.85 ----------
+
+ coded by Atsushi Moriwaki (11/5/1989)
+
+ E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
+
+ THIS SOFTWARE IS IN THE PUBLIC DOMAIN
+ ------------------------------------
+ This software is completely free to copy, modify and/or re-distribute.
+ But I would appreciate it if you left my name on the code as the author.
+
+ This version has been modified by R.C. Secrist.
+
+ Mini-Scheme is now maintained by Akira KIDA.
+
+ This is a revised and modified version by Akira KIDA.
+ current version is 0.85k4 (15 May 1994)
+
+ Please send suggestions, bug reports and/or requests to:
+ <SDI00379@niftyserve.or.jp>
+
+
+ Features compared to MiniSCHEME
+ -------------------------------
+
+ All code is now reentrant. Interpreter state is held in a 'scheme'
+ struct, and many interpreters can coexist in the same program, possibly
+ in different threads. The user can specify user-defined memory allocation
+ primitives. (see "Programmer's Reference")
+
+ The reader is more consistent.
+
+ Strings, characters and flonums are supported. (see "Types")
+
+ Files being loaded can be nested up to some depth.
+
+ R5RS I/O is there, plus String Ports. (see "Scheme Reference","I/O")
+
+ Vectors exist.
+
+ As a standalone application, it supports command-line arguments.
+ (see "Standalone")
+
+ Running out of memory is now handled.
+
+ The user can add foreign functions in C. (see "Foreign Functions")
+
+ The code has been changed slightly, core functions have been moved
+ to the library, behavior has been aligned with R5RS etc.
+
+ Support has been added for user-defined error recovery.
+ (see "Error Handling")
+
+ Support has been added for modular programming.
+ (see "Colon Qualifiers - Packages")
+
+ To enable this, EVAL has changed internally, and can
+ now take two arguments, as per R5RS. Environments are supported.
+ (see "Colon Qualifiers - Packages")
+
+ Promises are now evaluated once only.
+
+ (macro (foo form) ...) is now equivalent to (macro foo (lambda(form) ...))
+
+ The reader can be extended using new #-expressions
+ (see "Reader extensions")
diff --git a/plug-ins/script-fu/tinyscheme/README b/plug-ins/script-fu/tinyscheme/README
new file mode 100644
index 0000000..4411119
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/README
@@ -0,0 +1,14 @@
+This directory contains a version of TinyScheme which has been modified
+to support UTF-8 coded strings. The strings stored in a data cell are
+expected to be in UTF-8 format. This allows the continued use of gchar
+pointers to pass around the strings. Processing the strings will require
+conversion to unicode at times depending on the specific operation that
+needs to be done on the UTF-8 coded strings.
+
+The string length value stored in a data cell is the length in bytes of that
+string including the terminating NUL.
+
+Routines that want a string length for a UTF-8 coded string will be passed
+the number of characters and not the number of bytes. If the number of bytes
+is needed, the normal call to strlen() will work.
+
diff --git a/plug-ins/script-fu/tinyscheme/hack.txt b/plug-ins/script-fu/tinyscheme/hack.txt
new file mode 100644
index 0000000..6aba7a7
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/hack.txt
@@ -0,0 +1,233 @@
+
+ How to hack TinyScheme
+ ----------------------
+
+ TinyScheme is easy to learn and modify. It is structured like a
+ meta-interpreter, only it is written in C. All data are Scheme
+ objects, which facilitates both understanding/modifying the
+ code and reifying the interpreter workings.
+
+ In place of a dry description, we will pace through the addition
+ of a useful new datatype: garbage-collected memory blocks.
+ The interface will be:
+
+ (make-block <n> [<fill>]) makes a new block of the specified size
+ optionally filling it with a specified byte
+ (block? <obj>)
+ (block-length <block>)
+ (block-ref <block> <index>) retrieves byte at location
+ (block-set! <block> <index> <byte>) modifies byte at location
+
+ In the sequel, lines that begin with '>' denote lines to add to the
+ code. Lines that begin with '|' are just citations of existing code.
+ Lines that begin with X are deleted.
+
+ First of all, we need to assign a typeid to our new type. Typeids
+ in TinyScheme are small integers declared in an enum, very close to
+ the top of scheme.c; it begins with T_STRING. Add a new one before the
+ end, call it T_MEMBLOCK. Adjust T_LAST_SYSTEM_TYPE.
+
+| T_ENVIRONMENT=14,
+X T_LAST_SYSTEM_TYPE=14
+> T_MEMBLOCK=15,
+> T_LAST_SYSTEM_TYPE=15
+| };
+
+ Then, some helper macros would be useful. Go to where is_string() and
+ the rest are defined and define:
+
+> int is_memblock(pointer p) { return (type(p)==T_MEMBLOCK); }
+
+ This actually is a function, because it is meant to be exported by
+ scheme.h. If no foreign function will ever manipulate a memory block,
+ you can instead define it as a macro
+
+> #define is_memblock(p) (type(p)==T_MEMBLOCK)
+
+ Then we make space for the new type in the main data structure:
+ struct cell. As it happens, the _string part of the union _object
+ (that is used to hold character strings) has two fields that suit us:
+
+| struct {
+| char *_svalue;
+| int _keynum;
+| } _string;
+
+ We can use _svalue to hold the actual pointer and _keynum to hold its
+ length. If we couldn't reuse existing fields, we could always add other
+ alternatives in union _object.
+
+ We then proceed to write the function that actually makes a new block.
+ For conformance reasons, we name it mk_memblock
+
+> static pointer mk_memblock(scheme *sc, int len, char fill) {
+> pointer x;
+> char *p=(char*)sc->malloc(len);
+>
+> if(p==0) {
+> return sc->NIL;
+> }
+> x = get_cell(sc, sc->NIL, sc->NIL);
+>
+> typeflag(x) = T_MEMBLOCK|T_ATOM;
+> strvalue(x)=p;
+> keynum(x)=len;
+> memset(p,fill,len);
+> return (x);
+> }
+
+ The memory used by the MEMBLOCK will have to be freed when the cell
+ is reclaimed during garbage collection. There is a placeholder for
+ that staff, function finalize_cell(), currently handling strings only.
+
+| static void finalize_cell(scheme *sc, pointer a) {
+| if(is_string(a)) {
+| sc->free(strvalue(a));
+> else if(is_memblock(a)) {
+> sc->free(strvalue(a));
+| } else if(is_port(a)) {
+
+ There are no MEMBLOCK literals, so we don't concern ourselves with
+ the READER part (yet!). We must cater to the PRINTER, though. We
+ add one case more in atom2str().
+
+| } else if (is_foreign(l)) {
+| p = sc->strbuff;
+| snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
+> } else if (ismemblock(l)) {
+> p = "#<MEMBLOCK>";
+| } else if (is_continuation(l)) {
+| p = "#<CONTINUATION>";
+| } else {
+
+ Whenever a MEMBLOCK is displayed, it will look like that.
+
+ Now, we must add the interface functions: constructor, predicate,
+ accessor, modifier. We must in fact create new op-codes for the
+ virtual machine underlying TinyScheme. Since version 1.30, TinyScheme
+ uses macros and a single source text to keep the enums and the
+ dispatch table in sync. That's where the op-codes are declared. Note
+ that the opdefines.h file uses unusually long lines to accommodate
+ all the information; adjust your editor to handle this. The file has
+ six columns: A to Z. they contain:
+ - Column A is the name of a routine to handle the scheme function.
+ - Column B is the name the scheme function.
+ - Columns C and D are the minimum and maximum number of arguments
+ that are accepted by the scheme function.
+ - Column E is a set of flags that are used when the interpreter
+ verifies that the passed parameters are of the correct type.
+ - Column F is used to create a set of enums. The enum is used in a
+ switch in the routine listed in column A to get to the code that
+ does the work needed for the scheme function.
+ For reasons of cohesion, we add the new op-codes right after those
+ for vectors:
+
+| _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET )
+> _OP_DEF(opexe_2, "make-block", 1, 2, TST_NATURAL TST_CHAR, OP_MKBLOCK )
+> _OP_DEF(opexe_2, "block-length", 1, 1, T_MEMBLOCK, OP_BLOCKLEN )
+> _OP_DEF(opexe_2, "block-ref", 2, 2, T_MEMBLOCK TST_NATURAL, OP_BLOCKREF )
+> _OP_DEF(opexe_2, "block-set!", 1, 1, T_MEMBLOCK TST_NATURAL TST_CHAR, OP_BLOCKSET )
+| _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT )
+
+ We add the predicate along the other predicates:
+
+| _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP )
+> _OP_DEF(opexe_3, "block?", 1, 1, TST_ANY, OP_BLOCKP )
+| _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ )
+
+ All that remains is to write the actual processing in opexe_2, right
+ after OP_VECSET.
+
+> case OP_MKBLOCK: { /* make-block */
+> int fill=0;
+> int len;
+>
+> if(!isnumber(car(sc->args))) {
+> Error_1(sc,"make-block: not a number:",car(sc->args));
+> }
+> len=ivalue(car(sc->args));
+> if(len<=0) {
+> Error_1(sc,"make-block: not positive:",car(sc->args));
+> }
+>
+> if(cdr(sc->args)!=sc->NIL) {
+> if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) {
+> Error_1(sc,"make-block: not a positive number:",cadr(sc->args));
+> }
+> fill=charvalue(cadr(sc->args))%255;
+> }
+> s_return(sc,mk_memblock(sc,len,(char)fill));
+> }
+>
+> case OP_BLOCKLEN: /* block-length */
+> if(!ismemblock(car(sc->args))) {
+> Error_1(sc,"block-length: not a memory block:",car(sc->args));
+> }
+> s_return(sc,mk_integer(sc,keynum(car(sc->args))));
+>
+> case OP_BLOCKREF: { /* block-ref */
+> char *str;
+> int index;
+>
+> if(!ismemblock(car(sc->args))) {
+> Error_1(sc,"block-ref: not a memory block:",car(sc->args));
+> }
+> str=strvalue(car(sc->args));
+>
+> if(cdr(sc->args)==sc->NIL) {
+> Error_0(sc,"block-ref: needs two arguments");
+> }
+> if(!isnumber(cadr(sc->args))) {
+> Error_1(sc,"block-ref: not a number:",cadr(sc->args));
+> }
+> index=ivalue(cadr(sc->args));
+>
+> if(index<0 || index>=keynum(car(sc->args))) {
+> Error_1(sc,"block-ref: out of bounds:",cadr(sc->args));
+> }
+>
+> s_return(sc,mk_integer(sc,str[index]));
+> }
+>
+> case OP_BLOCKSET: { /* block-set! */
+> char *str;
+> int index;
+> int c;
+>
+> if(!ismemblock(car(sc->args))) {
+> Error_1(sc,"block-set!: not a memory block:",car(sc->args));
+> }
+> if(isimmutable(car(sc->args))) {
+> Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args));
+> }
+> str=strvalue(car(sc->args));
+>
+> if(cdr(sc->args)==sc->NIL) {
+> Error_0(sc,"block-set!: needs three arguments");
+> }
+> if(!isnumber(cadr(sc->args))) {
+> Error_1(sc,"block-set!: not a number:",cadr(sc->args));
+> }
+> index=ivalue(cadr(sc->args));
+> if(index<0 || index>=keynum(car(sc->args))) {
+> Error_1(sc,"block-set!: out of bounds:",cadr(sc->args));
+> }
+>
+> if(cddr(sc->args)==sc->NIL) {
+> Error_0(sc,"block-set!: needs three arguments");
+> }
+> if(!isinteger(caddr(sc->args))) {
+> Error_1(sc,"block-set!: not an integer:",caddr(sc->args));
+> }
+> c=ivalue(caddr(sc->args))%255;
+>
+> str[index]=(char)c;
+> s_return(sc,car(sc->args));
+> }
+
+ Same for the predicate in opexe_3.
+
+| case OP_VECTORP: /* vector? */
+| s_retbool(isvector(car(sc->args)));
+> case OP_BLOCKP: /* block? */
+> s_retbool(ismemblock(car(sc->args)));
diff --git a/plug-ins/script-fu/tinyscheme/opdefines.h b/plug-ins/script-fu/tinyscheme/opdefines.h
new file mode 100644
index 0000000..ceb4d0e
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/opdefines.h
@@ -0,0 +1,195 @@
+ _OP_DEF(opexe_0, "load", 1, 1, TST_STRING, OP_LOAD )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T0LVL )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T1LVL )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_READ_INTERNAL )
+ _OP_DEF(opexe_0, "gensym", 0, 0, 0, OP_GENSYM )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_VALUEPRINT )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_EVAL )
+#if USE_TRACING
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL )
+#endif
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY )
+#if USE_TRACING
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY )
+ _OP_DEF(opexe_0, "tracing", 1, 1, TST_NATURAL, OP_TRACING )
+#endif
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DOMACRO )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA1 )
+ _OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_QUOTE )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF1 )
+ _OP_DEF(opexe_0, "defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_BEGIN )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF0 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF1 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET0 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET1 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2 )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0AST )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1AST )
+ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2AST )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET0REC )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET1REC )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET2REC )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND0 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND1 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_DELAY )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND0 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND1 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR0 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR1 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C0STREAM )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C1STREAM )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO0 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO1 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE0 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE1 )
+ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE2 )
+ _OP_DEF(opexe_1, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL )
+ _OP_DEF(opexe_1, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY )
+ _OP_DEF(opexe_1, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION )
+#if USE_MATH
+ _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX )
+ _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP )
+ _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG )
+ _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN )
+ _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS )
+ _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN )
+ _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN )
+ _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS )
+ _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN )
+ _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT )
+ _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT )
+ _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR )
+ _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING )
+ _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE )
+ _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND )
+#endif
+ _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD )
+ _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB )
+ _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL )
+ _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV )
+ _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV )
+ _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM )
+ _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD )
+ _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR )
+ _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR )
+ _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS )
+ _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR )
+ _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR )
+ _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT )
+ _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR )
+ _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE )
+ _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE )
+ _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR )
+ _OP_DEF(opexe_2, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR )
+ _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM )
+ _OP_DEF(opexe_2, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM )
+ _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING )
+ _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN )
+ _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF )
+ _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET )
+ _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND )
+ _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR )
+ _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR )
+ _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR )
+ _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN )
+ _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF )
+ _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET )
+ _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT )
+ _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP )
+ _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP )
+ _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP )
+ _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ )
+ _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS )
+ _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE )
+ _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ )
+ _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ )
+ _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP )
+ _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP )
+ _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP )
+ _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP )
+ _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP )
+ _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP )
+#if USE_CHAR_CLASSIFIERS
+ _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP )
+ _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP )
+ _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP )
+ _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP )
+ _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP )
+#endif
+ _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP )
+ _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP )
+ _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP )
+ _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP )
+ _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP )
+ _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP )
+ _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP )
+ _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP )
+ _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ )
+ _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV )
+ _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE )
+ _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED )
+ _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE )
+ _OP_DEF(opexe_4, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR )
+ _OP_DEF(opexe_4, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY )
+ _OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE )
+ _OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0 )
+ _OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1 )
+ _OP_DEF(opexe_4, "reverse", 1, 1, TST_LIST, OP_REVERSE )
+ _OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR )
+ _OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE, OP_APPEND )
+#if USE_PLIST
+ _OP_DEF(opexe_4, "put", 3, 3, TST_NONE, OP_PUT )
+ _OP_DEF(opexe_4, "get", 2, 2, TST_NONE, OP_GET )
+#endif
+ _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT )
+ _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC )
+ _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB )
+ _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT )
+ _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST )
+ _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT )
+ _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT )
+ _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE )
+ _OP_DEF(opexe_4, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE )
+ _OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE )
+#if USE_STRING_PORTS
+ _OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING )
+ _OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING )
+ _OP_DEF(opexe_4, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING )
+ _OP_DEF(opexe_4, "get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING )
+#endif
+ _OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT )
+ _OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT )
+ _OP_DEF(opexe_4, "interaction-environment", 0, 0, 0, OP_INT_ENV )
+ _OP_DEF(opexe_4, "current-environment", 0, 0, 0, OP_CURR_ENV )
+ _OP_DEF(opexe_5, "read", 0, 1, TST_INPORT, OP_READ )
+ _OP_DEF(opexe_5, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR )
+ _OP_DEF(opexe_5, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR )
+ _OP_DEF(opexe_5, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY )
+ _OP_DEF(opexe_5, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT )
+ _OP_DEF(opexe_5, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDSEXPR )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDLIST )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDDOT )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQUOTE )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTE )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTEVEC )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUNQUOTE )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUQTSP )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDVEC )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P0LIST )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P1LIST )
+ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_PVECFROM )
+ _OP_DEF(opexe_6, "length", 1, 1, TST_LIST, OP_LIST_LENGTH )
+ _OP_DEF(opexe_6, "assq", 2, 2, TST_NONE, OP_ASSQ )
+ _OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE )
+ _OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP )
+ _OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP )
+#undef _OP_DEF
diff --git a/plug-ins/script-fu/tinyscheme/scheme-private.h b/plug-ins/script-fu/tinyscheme/scheme-private.h
new file mode 100644
index 0000000..89840c2
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/scheme-private.h
@@ -0,0 +1,227 @@
+/* scheme-private.h */
+
+#ifndef _SCHEME_PRIVATE_H
+#define _SCHEME_PRIVATE_H
+
+#include "scheme.h"
+/*------------------ Ugly internals -----------------------------------*/
+/*------------------ Of interest only to FFI users --------------------*/
+
+enum scheme_port_kind {
+ port_free=0,
+ port_file=1,
+ port_string=2,
+ port_srfi6=4,
+ port_input=16,
+ port_output=32,
+ port_saw_EOF=64
+};
+
+typedef struct port {
+ unsigned char kind;
+ union {
+ struct {
+ FILE *file;
+ int closeit;
+#if SHOW_ERROR_LINE
+ int curr_line;
+ char *filename;
+#endif
+ } stdio;
+ struct {
+ char *start;
+ char *past_the_end;
+ char *curr;
+ } string;
+ } rep;
+} port;
+
+/* cell structure */
+struct cell {
+ unsigned int _flag;
+ union {
+ struct {
+ char *_svalue;
+ int _length;
+ } _string;
+ num _number;
+ port *_port;
+ foreign_func _ff;
+ struct {
+ struct cell *_car;
+ struct cell *_cdr;
+ } _cons;
+ } _object;
+};
+
+struct scheme {
+/* arrays for segments */
+func_alloc malloc;
+func_dealloc free;
+
+/* return code */
+int retcode;
+int tracing;
+
+
+#ifndef CELL_SEGSIZE
+#define CELL_SEGSIZE 25000 /* # of cells in one segment */
+#endif
+#ifndef CELL_NSEGMENT
+#define CELL_NSEGMENT 50 /* # of segments for cells */
+#endif
+char *alloc_seg[CELL_NSEGMENT];
+pointer cell_seg[CELL_NSEGMENT];
+int last_cell_seg;
+
+/* We use 5 registers. */
+pointer args; /* register for arguments of function */
+pointer envir; /* stack register for current environment */
+pointer code; /* register for current code */
+pointer dump; /* stack register for next evaluation */
+pointer foreign_error; /* used for foreign functions to signal an error */
+
+int interactive_repl; /* are we in an interactive REPL? */
+int print_output; /* set to 1 to print results and error messages */
+
+struct cell _sink;
+pointer sink; /* when mem. alloc. fails */
+struct cell _NIL;
+pointer NIL; /* special cell representing empty cell */
+struct cell _HASHT;
+pointer T; /* special cell representing #t */
+struct cell _HASHF;
+pointer F; /* special cell representing #f */
+struct cell _EOF_OBJ;
+pointer EOF_OBJ; /* special cell representing end-of-file object */
+pointer oblist; /* pointer to symbol table */
+pointer global_env; /* pointer to global environment */
+
+pointer c_nest; /* stack for nested calls from C */
+
+/* global pointers to special symbols */
+pointer LAMBDA; /* pointer to syntax lambda */
+pointer QUOTE; /* pointer to syntax quote */
+
+pointer QQUOTE; /* pointer to symbol quasiquote */
+pointer UNQUOTE; /* pointer to symbol unquote */
+pointer UNQUOTESP; /* pointer to symbol unquote-splicing */
+pointer FEED_TO; /* => */
+pointer COLON_HOOK; /* *colon-hook* */
+pointer ERROR_HOOK; /* *error-hook* */
+pointer SHARP_HOOK; /* *sharp-hook* */
+pointer COMPILE_HOOK; /* *compile-hook* */
+
+pointer free_cell; /* pointer to top of free cells */
+long fcells; /* # of free cells */
+
+pointer inport;
+pointer outport;
+pointer save_inport;
+pointer loadport;
+
+#ifndef MAXFIL
+#define MAXFIL 64
+#endif
+port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */
+int nesting_stack[MAXFIL];
+int file_i;
+int nesting;
+
+char gc_verbose; /* if gc_verbose is not zero, print gc status */
+char no_memory; /* Whether mem. alloc. has failed */
+
+#ifndef LINESIZE
+#define LINESIZE 1024
+#endif
+char linebuff[LINESIZE];
+#ifndef STRBUFFSIZE
+#define STRBUFFSIZE 1024
+#endif
+char strbuff[STRBUFFSIZE];
+
+FILE *tmpfp;
+int tok;
+int print_flag;
+pointer value;
+int op;
+
+void *ext_data; /* For the benefit of foreign functions */
+long gensym_cnt;
+
+struct scheme_interface *vptr;
+void *dump_base; /* pointer to base of allocated dump stack */
+int dump_size; /* number of frames allocated for dump stack */
+
+gunichar backchar[2];
+int bc_flag;
+};
+
+/* operator code */
+enum scheme_opcodes {
+#define _OP_DEF(A,B,C,D,E,OP) OP,
+#include "opdefines.h"
+ OP_MAXDEFINED
+};
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define cons(sc,a,b) _cons(sc,a,b,0)
+#define immutable_cons(sc,a,b) _cons(sc,a,b,1)
+
+int is_string(pointer p);
+char *string_value(pointer p);
+int is_number(pointer p);
+num nvalue(pointer p);
+long ivalue(pointer p);
+double rvalue(pointer p);
+int is_integer(pointer p);
+int is_real(pointer p);
+int is_character(pointer p);
+int string_length(pointer p);
+gunichar charvalue(pointer p);
+int is_vector(pointer p);
+
+int is_port(pointer p);
+int is_inport(pointer p);
+int is_outport(pointer p);
+
+int is_pair(pointer p);
+pointer pair_car(pointer p);
+pointer pair_cdr(pointer p);
+pointer set_car(pointer p, pointer q);
+pointer set_cdr(pointer p, pointer q);
+
+int is_symbol(pointer p);
+char *symname(pointer p);
+char *symkey(pointer p);
+int hasprop(pointer p);
+
+int is_syntax(pointer p);
+int is_proc(pointer p);
+int is_foreign(pointer p);
+char *syntaxname(pointer p);
+int is_closure(pointer p);
+int is_macro(pointer p);
+pointer closure_code(pointer p);
+pointer closure_env(pointer p);
+
+int is_continuation(pointer p);
+int is_promise(pointer p);
+int is_environment(pointer p);
+int is_immutable(pointer p);
+void setimmutable(pointer p);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
diff --git a/plug-ins/script-fu/tinyscheme/scheme.c b/plug-ins/script-fu/tinyscheme/scheme.c
new file mode 100644
index 0000000..ccd4475
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/scheme.c
@@ -0,0 +1,5357 @@
+/* T I N Y S C H E M E 1 . 4 1
+ * Dimitrios Souflis (dsouflis@acm.org)
+ * Based on MiniScheme (original credits follow)
+ * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
+ * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
+ * (MINISCM) This version has been modified by R.C. Secrist.
+ * (MINISCM)
+ * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
+ * (MINISCM)
+ * (MINISCM) This is a revised and modified version by Akira KIDA.
+ * (MINISCM) current version is 0.85k4 (15 May 1994)
+ *
+ */
+
+/* ******** READ THE FOLLOWING BEFORE MODIFYING THIS FILE! ******** */
+/* This copy of TinyScheme has been modified to support UTF-8 coded */
+/* character strings. As a result, the length of a string in bytes */
+/* may not be the same as the length of a string in characters. You */
+/* must keep this in mind at all times while making any changes to */
+/* the routines in this file and when adding new features. */
+/* */
+/* UTF-8 modifications made by Kevin Cozens (kcozens@interlog.com) */
+/* **************************************************************** */
+
+#include "config.h"
+
+#define _SCHEME_SOURCE
+#if HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+#ifdef WIN32
+# include <io.h>
+#endif
+#ifdef WIN32
+#define snprintf _snprintf
+#endif
+#if USE_DL
+# include "dynload.h"
+#endif
+#if USE_MATH
+# include <math.h>
+#endif
+
+#include <limits.h>
+#include <float.h>
+#include <ctype.h>
+#include <string.h>
+
+#include "../script-fu-intl.h"
+
+#include "scheme-private.h"
+
+#if !STANDALONE
+static ts_output_func ts_output_handler = NULL;
+static gpointer ts_output_data = NULL;
+
+void
+ts_register_output_func (ts_output_func func,
+ gpointer user_data)
+{
+ ts_output_handler = func;
+ ts_output_data = user_data;
+}
+
+/* len is length of 'string' in bytes or -1 for null terminated strings */
+void
+ts_output_string (TsOutputType type,
+ const char *string,
+ int len)
+{
+ if (len < 0)
+ len = strlen (string);
+
+ if (ts_output_handler && len > 0)
+ (* ts_output_handler) (type, string, len, ts_output_data);
+}
+#endif
+
+/* Used for documentation purposes, to signal functions in 'interface' */
+#define INTERFACE
+
+#define TOK_EOF (-1)
+#define TOK_LPAREN 0
+#define TOK_RPAREN 1
+#define TOK_DOT 2
+#define TOK_ATOM 3
+#define TOK_QUOTE 4
+#define TOK_COMMENT 5
+#define TOK_DQUOTE 6
+#define TOK_BQUOTE 7
+#define TOK_COMMA 8
+#define TOK_ATMARK 9
+#define TOK_SHARP 10
+#define TOK_SHARP_CONST 11
+#define TOK_VEC 12
+#define TOK_USCORE 13
+
+#define BACKQUOTE '`'
+#define DELIMITERS "()\";\f\t\v\n\r "
+
+/*
+ * Basic memory allocation units
+ */
+
+#define banner "TinyScheme 1.41 (with UTF-8 support)"
+
+#include <string.h>
+#include <stdlib.h>
+
+#define stricmp utf8_stricmp
+
+static int utf8_stricmp(const char *s1, const char *s2)
+{
+ char *s1a, *s2a;
+ int result;
+
+ s1a = g_utf8_casefold(s1, -1);
+ s2a = g_utf8_casefold(s2, -1);
+
+ result = g_utf8_collate(s1a, s2a);
+
+ g_free(s1a);
+ g_free(s2a);
+ return result;
+}
+
+#define min(a, b) ((a) <= (b) ? (a) : (b))
+
+#if USE_STRLWR
+/*
+#error FIXME: Can't just use g_utf8_strdown since it allocates a new string
+#define strlwr(s) g_utf8_strdown(s, -1)
+*/
+#else
+#define strlwr(s) s
+#endif
+
+#ifndef prompt
+# define prompt "ts> "
+#endif
+
+#ifndef InitFile
+# define InitFile "init.scm"
+#endif
+
+#ifndef FIRST_CELLSEGS
+# define FIRST_CELLSEGS 3
+#endif
+
+enum scheme_types {
+ T_STRING=1,
+ T_NUMBER=2,
+ T_SYMBOL=3,
+ T_PROC=4,
+ T_PAIR=5,
+ T_CLOSURE=6,
+ T_CONTINUATION=7,
+ T_FOREIGN=8,
+ T_CHARACTER=9,
+ T_PORT=10,
+ T_VECTOR=11,
+ T_MACRO=12,
+ T_PROMISE=13,
+ T_ENVIRONMENT=14,
+ T_LAST_SYSTEM_TYPE=14
+};
+
+/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
+#define ADJ 32
+#define TYPE_BITS 5
+#define T_MASKTYPE 31 /* 0000000000011111 */
+#define T_SYNTAX 4096 /* 0001000000000000 */
+#define T_IMMUTABLE 8192 /* 0010000000000000 */
+#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */
+#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */
+#define MARK 32768 /* 1000000000000000 */
+#define UNMARK 32767 /* 0111111111111111 */
+
+static num num_add(num a, num b);
+static num num_mul(num a, num b);
+static num num_div(num a, num b);
+static num num_intdiv(num a, num b);
+static num num_sub(num a, num b);
+static num num_rem(num a, num b);
+static num num_mod(num a, num b);
+static int num_eq(num a, num b);
+static int num_gt(num a, num b);
+static int num_ge(num a, num b);
+static int num_lt(num a, num b);
+static int num_le(num a, num b);
+
+#if USE_MATH
+static double round_per_R5RS(double x);
+#endif
+static int is_zero_double(double x);
+static INLINE int num_is_integer(pointer p) {
+ return ((p)->_object._number.is_fixnum);
+}
+
+static num num_zero;
+static num num_one;
+
+/* macros for cell operations */
+#define typeflag(p) ((p)->_flag)
+#define type(p) (typeflag(p)&T_MASKTYPE)
+
+INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
+#define strvalue(p) ((p)->_object._string._svalue)
+#define strlength(p) ((p)->_object._string._length)
+
+INTERFACE static int is_list(scheme *sc, pointer a);
+INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
+INTERFACE static void fill_vector(pointer vec, pointer obj);
+INTERFACE static pointer vector_elem(pointer vec, int ielem);
+INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
+INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
+INTERFACE INLINE int is_integer(pointer p) {
+ if (!is_number(p))
+ return 0;
+ if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
+ return 1;
+ return 0;
+}
+
+INTERFACE INLINE int is_real(pointer p) {
+ return is_number(p) && (!(p)->_object._number.is_fixnum);
+}
+
+INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
+INTERFACE INLINE int string_length(pointer p) { return strlength(p); }
+INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
+INLINE num nvalue(pointer p) { return ((p)->_object._number); }
+INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
+INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
+#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue)
+#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue)
+#define set_num_integer(p) (p)->_object._number.is_fixnum=1;
+#define set_num_real(p) (p)->_object._number.is_fixnum=0;
+INTERFACE gunichar charvalue(pointer p) { return (gunichar)ivalue_unchecked(p); }
+
+INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); }
+INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; }
+INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
+
+INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); }
+#define car(p) ((p)->_object._cons._car)
+#define cdr(p) ((p)->_object._cons._cdr)
+INTERFACE pointer pair_car(pointer p) { return car(p); }
+INTERFACE pointer pair_cdr(pointer p) { return cdr(p); }
+INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
+INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
+
+INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
+INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
+#if USE_PLIST
+SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); }
+#define symprop(p) cdr(p)
+#endif
+
+INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
+INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
+INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
+INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
+#define procnum(p) ivalue(p)
+static const char *procname(pointer x);
+
+INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
+INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); }
+INTERFACE INLINE pointer closure_code(pointer p) { return car(p); }
+INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); }
+
+INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); }
+#define cont_dump(p) cdr(p)
+
+/* To do: promise should be forced ONCE only */
+INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
+
+INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
+#define setenvironment(p) typeflag(p) = T_ENVIRONMENT
+
+#define is_atom(p) (typeflag(p)&T_ATOM)
+#define setatom(p) typeflag(p) |= T_ATOM
+#define clratom(p) typeflag(p) &= CLRATOM
+
+#define is_mark(p) (typeflag(p)&MARK)
+#define setmark(p) typeflag(p) |= MARK
+#define clrmark(p) typeflag(p) &= UNMARK
+
+INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
+/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/
+INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
+
+#define caar(p) car(car(p))
+#define cadr(p) car(cdr(p))
+#define cdar(p) cdr(car(p))
+#define cddr(p) cdr(cdr(p))
+#define cadar(p) car(cdr(car(p)))
+#define caddr(p) car(cdr(cdr(p)))
+#define cdaar(p) cdr(car(car(p)))
+#define cadaar(p) car(cdr(car(car(p))))
+#define cadddr(p) car(cdr(cdr(cdr(p))))
+#define cddddr(p) cdr(cdr(cdr(cdr(p))))
+
+#if USE_CHAR_CLASSIFIERS
+static INLINE int Cisalpha(gunichar c) { return g_unichar_isalpha(c); }
+static INLINE int Cisdigit(gunichar c) { return g_unichar_isdigit(c); }
+static INLINE int Cisspace(gunichar c) { return g_unichar_isspace(c); }
+static INLINE int Cisupper(gunichar c) { return g_unichar_isupper(c); }
+static INLINE int Cislower(gunichar c) { return g_unichar_islower(c); }
+#endif
+
+#if USE_ASCII_NAMES
+static const char *charnames[32]={
+ "nul",
+ "soh",
+ "stx",
+ "etx",
+ "eot",
+ "enq",
+ "ack",
+ "bel",
+ "bs",
+ "ht",
+ "lf",
+ "vt",
+ "ff",
+ "cr",
+ "so",
+ "si",
+ "dle",
+ "dc1",
+ "dc2",
+ "dc3",
+ "dc4",
+ "nak",
+ "syn",
+ "etb",
+ "can",
+ "em",
+ "sub",
+ "esc",
+ "fs",
+ "gs",
+ "rs",
+ "us"
+};
+
+static int is_ascii_name(const char *name, int *pc) {
+ int i;
+ for(i=0; i<32; i++) {
+ if(stricmp(name,charnames[i])==0) {
+ *pc=i;
+ return 1;
+ }
+ }
+ if(stricmp(name,"del")==0) {
+ *pc=127;
+ return 1;
+ }
+ return 0;
+}
+
+#endif
+
+/* Number of bytes expected AFTER lead byte of UTF-8 character. */
+static const char utf8_length[64] =
+{
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 0xc0-0xcf */
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 0xd0-0xdf */
+ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /* 0xe0-0xef */
+ 3,3,3,3,3,3,3,3,4,4,4,4,5,5,0,0 /* 0xf0-0xff */
+};
+
+static int file_push(scheme *sc, const char *fname);
+static void file_pop(scheme *sc);
+static int file_interactive(scheme *sc);
+static INLINE int is_one_of(char *s, gunichar c);
+static int alloc_cellseg(scheme *sc, int n);
+static long binary_decode(const char *s);
+static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
+static pointer _get_cell(scheme *sc, pointer a, pointer b);
+static pointer reserve_cells(scheme *sc, int n);
+static pointer get_consecutive_cells(scheme *sc, int n);
+static pointer find_consecutive_cells(scheme *sc, int n);
+static void finalize_cell(scheme *sc, pointer a);
+static int count_consecutive_cells(pointer x, int needed);
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
+static pointer mk_number(scheme *sc, num n);
+static char *store_string(scheme *sc, int len, const char *str, gunichar fill);
+static pointer mk_vector(scheme *sc, int len);
+static pointer mk_atom(scheme *sc, char *q);
+static pointer mk_sharp_const(scheme *sc, char *name);
+static pointer mk_port(scheme *sc, port *p);
+static pointer port_from_filename(scheme *sc, const char *fn, int prop);
+static pointer port_from_file(scheme *sc, FILE *, int prop);
+static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
+static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
+static port *port_rep_from_file(scheme *sc, FILE *, int prop);
+static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
+static void port_close(scheme *sc, pointer p, int flag);
+static void mark(pointer a);
+static void gc(scheme *sc, pointer a, pointer b);
+static gunichar basic_inchar(port *pt);
+static gunichar inchar(scheme *sc);
+static void backchar(scheme *sc, gunichar c);
+static char *readstr_upto(scheme *sc, char *delim);
+static pointer readstrexp(scheme *sc);
+static INLINE int skipspace(scheme *sc);
+static int token(scheme *sc);
+static void printslashstring(scheme *sc, char *s, int len);
+static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
+static void printatom(scheme *sc, pointer l, int f);
+static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
+static pointer mk_closure(scheme *sc, pointer c, pointer e);
+static pointer mk_continuation(scheme *sc, pointer d);
+static pointer reverse(scheme *sc, pointer a);
+static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
+static pointer revappend(scheme *sc, pointer a, pointer b);
+int list_length(scheme *sc, pointer a);
+int eqv(pointer a, pointer b);
+
+static INLINE void dump_stack_mark(scheme *);
+static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
+static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
+static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
+static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
+static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
+static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
+static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
+static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
+static void assign_syntax(scheme *sc, char *name);
+static int syntaxnum(pointer p);
+static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
+scheme *scheme_init_new(void);
+
+#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
+#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
+
+static num num_add(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue+b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_mul(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue*b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_div(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue/b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_intdiv(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue/b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_sub(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue-b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_rem(num a, num b) {
+ num ret;
+ long e1, e2, res;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ e1=num_ivalue(a);
+ e2=num_ivalue(b);
+ res=e1%e2;
+ /* remainder should have same sign as first operand */
+ if (res > 0) {
+ if (e1 < 0) {
+ res -= labs(e2);
+ }
+ } else if (res < 0) {
+ if (e1 > 0) {
+ res += labs(e2);
+ }
+ }
+ ret.value.ivalue=res;
+ return ret;
+}
+
+static num num_mod(num a, num b) {
+ num ret;
+ long e1, e2, res;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ e1=num_ivalue(a);
+ e2=num_ivalue(b);
+ res=e1%e2;
+ /* modulo should have same sign as second operand */
+ if ((res < 0) != (e2 < 0) && res) { /* if their sign is different... */
+ res+=e2;
+ }
+ ret.value.ivalue=res;
+ return ret;
+}
+
+static int num_eq(num a, num b) {
+ int ret;
+ int is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(is_fixnum) {
+ ret= a.value.ivalue==b.value.ivalue;
+ } else {
+ ret=num_rvalue(a)==num_rvalue(b);
+ }
+ return ret;
+}
+
+
+static int num_gt(num a, num b) {
+ int ret;
+ int is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(is_fixnum) {
+ ret= a.value.ivalue>b.value.ivalue;
+ } else {
+ ret=num_rvalue(a)>num_rvalue(b);
+ }
+ return ret;
+}
+
+static int num_ge(num a, num b) {
+ return !num_lt(a,b);
+}
+
+static int num_lt(num a, num b) {
+ int ret;
+ int is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(is_fixnum) {
+ ret= a.value.ivalue<b.value.ivalue;
+ } else {
+ ret=num_rvalue(a)<num_rvalue(b);
+ }
+ return ret;
+}
+
+static int num_le(num a, num b) {
+ return !num_gt(a,b);
+}
+
+#if USE_MATH
+/* Round to nearest. Round to even if midway */
+static double round_per_R5RS(double x) {
+ double fl=floor(x);
+ double ce=ceil(x);
+ double dfl=x-fl;
+ double dce=ce-x;
+ if(dfl>dce) {
+ return ce;
+ } else if(dfl<dce) {
+ return fl;
+ } else {
+ if(fmod(fl,2.0)==0.0) { /* I imagine this holds */
+ return fl;
+ } else {
+ return ce;
+ }
+ }
+}
+#endif
+
+static int is_zero_double(double x) {
+ return x<DBL_MIN && x>-DBL_MIN;
+}
+
+static long binary_decode(const char *s) {
+ long x=0;
+
+ while(*s!=0 && (*s=='1' || *s=='0')) {
+ x<<=1;
+ x+=*s-'0';
+ s++;
+ }
+
+ return x;
+}
+
+/* allocate new cell segment */
+static int alloc_cellseg(scheme *sc, int n) {
+ pointer newp;
+ pointer last;
+ pointer p;
+ char *cp;
+ long i;
+ int k;
+ int adj=ADJ;
+
+ if(adj<sizeof(struct cell)) {
+ adj=sizeof(struct cell);
+ }
+
+ for (k = 0; k < n; k++) {
+ if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
+ return k;
+ cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
+ if (cp == 0)
+ return k;
+ i = ++sc->last_cell_seg ;
+ sc->alloc_seg[i] = cp;
+ /* adjust in TYPE_BITS-bit boundary */
+ if(((unsigned long)cp)%adj!=0) {
+ cp=(char*)(adj*((unsigned long)cp/adj+1));
+ }
+ /* insert new segment in address order */
+ newp=(pointer)cp;
+ sc->cell_seg[i] = newp;
+ while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
+ p = sc->cell_seg[i];
+ sc->cell_seg[i] = sc->cell_seg[i - 1];
+ sc->cell_seg[--i] = p;
+ }
+ sc->fcells += CELL_SEGSIZE;
+ last = newp + CELL_SEGSIZE - 1;
+ for (p = newp; p <= last; p++) {
+ typeflag(p) = 0;
+ cdr(p) = p + 1;
+ car(p) = sc->NIL;
+ }
+ /* insert new cells in address order on free list */
+ if (sc->free_cell == sc->NIL || p < sc->free_cell) {
+ cdr(last) = sc->free_cell;
+ sc->free_cell = newp;
+ } else {
+ p = sc->free_cell;
+ while (cdr(p) != sc->NIL && newp > cdr(p))
+ p = cdr(p);
+ cdr(last) = cdr(p);
+ cdr(p) = newp;
+ }
+ }
+ return n;
+}
+
+static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
+ if (sc->free_cell != sc->NIL) {
+ pointer x = sc->free_cell;
+ sc->free_cell = cdr(x);
+ --sc->fcells;
+ return (x);
+ }
+ return _get_cell (sc, a, b);
+}
+
+
+/* get new cell. parameter a, b is marked by gc. */
+static pointer _get_cell(scheme *sc, pointer a, pointer b) {
+ pointer x;
+
+ if(sc->no_memory) {
+ return sc->sink;
+ }
+
+ if (sc->free_cell == sc->NIL) {
+ const int min_to_be_recovered = sc->last_cell_seg*8;
+ gc(sc,a, b);
+ if (sc->fcells < min_to_be_recovered
+ || sc->free_cell == sc->NIL) {
+ /* if only a few recovered, get more to avoid fruitless gc's */
+ if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
+ sc->no_memory=1;
+ return sc->sink;
+ }
+ }
+ }
+ x = sc->free_cell;
+ sc->free_cell = cdr(x);
+ --sc->fcells;
+ return (x);
+}
+
+/* make sure that there is a given number of cells free */
+static pointer reserve_cells(scheme *sc, int n) {
+ if(sc->no_memory) {
+ return sc->NIL;
+ }
+
+ /* Are there enough cells available? */
+ if (sc->fcells < n) {
+ /* If not, try gc'ing some */
+ gc(sc, sc->NIL, sc->NIL);
+ if (sc->fcells < n) {
+ /* If there still aren't, try getting more heap */
+ if (!alloc_cellseg(sc,1)) {
+ sc->no_memory=1;
+ return sc->NIL;
+ }
+ }
+ if (sc->fcells < n) {
+ /* If all fail, report failure */
+ sc->no_memory=1;
+ return sc->NIL;
+ }
+ }
+ return (sc->T);
+}
+
+static pointer get_consecutive_cells(scheme *sc, int n) {
+ pointer x;
+
+ if(sc->no_memory) { return sc->sink; }
+
+ /* Are there any cells available? */
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If not, try gc'ing some */
+ gc(sc, sc->NIL, sc->NIL);
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If there still aren't, try getting more heap */
+ if (!alloc_cellseg(sc,1))
+ {
+ sc->no_memory=1;
+ return sc->sink;
+ }
+
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If all fail, report failure */
+ sc->no_memory=1;
+ return sc->sink;
+}
+
+static int count_consecutive_cells(pointer x, int needed) {
+ int n=1;
+ while(cdr(x)==x+1) {
+ x=cdr(x);
+ n++;
+ if(n>needed) return n;
+ }
+ return n;
+}
+
+static pointer find_consecutive_cells(scheme *sc, int n) {
+ pointer *pp;
+ int cnt;
+
+ pp=&sc->free_cell;
+ while(*pp!=sc->NIL) {
+ cnt=count_consecutive_cells(*pp,n);
+ if(cnt>=n) {
+ pointer x=*pp;
+ *pp=cdr(*pp+n-1);
+ sc->fcells -= n;
+ return x;
+ }
+ pp=&cdr(*pp+cnt-1);
+ }
+ return sc->NIL;
+}
+
+/* To retain recent allocs before interpreter knows about them -
+ Tehom */
+
+static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
+{
+ pointer holder = get_cell_x(sc, recent, extra);
+ typeflag(holder) = T_PAIR | T_IMMUTABLE;
+ car(holder) = recent;
+ cdr(holder) = car(sc->sink);
+ car(sc->sink) = holder;
+}
+
+
+static pointer get_cell(scheme *sc, pointer a, pointer b)
+{
+ pointer cell = get_cell_x(sc, a, b);
+ /* For right now, include "a" and "b" in "cell" so that gc doesn't
+ think they are garbage. */
+ /* Tentatively record it as a pair so gc understands it. */
+ typeflag(cell) = T_PAIR;
+ car(cell) = a;
+ cdr(cell) = b;
+ push_recent_alloc(sc, cell, sc->NIL);
+ return cell;
+}
+
+static pointer get_vector_object(scheme *sc, int len, pointer init)
+{
+ pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
+ if(sc->no_memory) { return sc->sink; }
+ /* Record it as a vector so that gc understands it. */
+ typeflag(cells) = (T_VECTOR | T_ATOM);
+ ivalue_unchecked(cells)=len;
+ set_num_integer(cells);
+ fill_vector(cells,init);
+ push_recent_alloc(sc, cells, sc->NIL);
+ return cells;
+}
+
+static INLINE void ok_to_freely_gc(scheme *sc)
+{
+ car(sc->sink) = sc->NIL;
+}
+
+
+#if defined TSGRIND
+static void check_cell_alloced(pointer p, int expect_alloced)
+{
+ /* Can't use putstr(sc,str) because callers have no access to
+ sc. */
+ if(typeflag(p) & !expect_alloced)
+ {
+ fprintf(stderr,"Cell is already allocated!\n");
+ }
+ if(!(typeflag(p)) & expect_alloced)
+ {
+ fprintf(stderr,"Cell is not allocated!\n");
+ }
+}
+static void check_range_alloced(pointer p, int n, int expect_alloced)
+{
+ int i;
+ for(i = 0;i<n;i++)
+ { (void)check_cell_alloced(p+i,expect_alloced); }
+}
+
+#endif
+
+/* Medium level cell allocation */
+
+/* get new cons cell */
+pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
+ pointer x = get_cell(sc,a, b);
+
+ typeflag(x) = T_PAIR;
+ if(immutable) {
+ setimmutable(x);
+ }
+ car(x) = a;
+ cdr(x) = b;
+ return (x);
+}
+
+/* ========== oblist implementation ========== */
+
+#ifndef USE_OBJECT_LIST
+
+static int hash_fn(const char *key, int table_size);
+
+static pointer oblist_initial_value(scheme *sc)
+{
+ return mk_vector(sc, 461); /* probably should be bigger */
+}
+
+/* returns the new symbol */
+static pointer oblist_add_by_name(scheme *sc, const char *name)
+{
+ pointer x;
+ int location;
+
+ x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
+ typeflag(x) = T_SYMBOL;
+ setimmutable(car(x));
+
+ location = hash_fn(name, ivalue_unchecked(sc->oblist));
+ set_vector_elem(sc->oblist, location,
+ immutable_cons(sc, x, vector_elem(sc->oblist, location)));
+ return x;
+}
+
+static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
+{
+ int location;
+ pointer x;
+ char *s;
+
+ location = hash_fn(name, ivalue_unchecked(sc->oblist));
+ for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
+ s = symname(car(x));
+ /* case-insensitive, per R5RS section 2. */
+ if(stricmp(name, s) == 0) {
+ return car(x);
+ }
+ }
+ return sc->NIL;
+}
+
+static pointer oblist_all_symbols(scheme *sc)
+{
+ int i;
+ pointer x;
+ pointer ob_list = sc->NIL;
+
+ for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
+ for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
+ ob_list = cons(sc, x, ob_list);
+ }
+ }
+ return ob_list;
+}
+
+#else
+
+static pointer oblist_initial_value(scheme *sc)
+{
+ return sc->NIL;
+}
+
+static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
+{
+ pointer x;
+ char *s;
+
+ for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
+ s = symname(car(x));
+ /* case-insensitive, per R5RS section 2. */
+ if(stricmp(name, s) == 0) {
+ return car(x);
+ }
+ }
+ return sc->NIL;
+}
+
+/* returns the new symbol */
+static pointer oblist_add_by_name(scheme *sc, const char *name)
+{
+ pointer x;
+
+ x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
+ typeflag(x) = T_SYMBOL;
+ setimmutable(car(x));
+ sc->oblist = immutable_cons(sc, x, sc->oblist);
+ return x;
+}
+
+static pointer oblist_all_symbols(scheme *sc)
+{
+ return sc->oblist;
+}
+
+#endif
+
+static pointer mk_port(scheme *sc, port *p) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+ typeflag(x) = T_PORT|T_ATOM;
+ x->_object._port=p;
+ return (x);
+}
+
+pointer mk_foreign_func(scheme *sc, foreign_func f) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_FOREIGN | T_ATOM);
+ x->_object._ff=f;
+ return (x);
+}
+
+INTERFACE pointer mk_character(scheme *sc, gunichar c) {
+ pointer x = get_cell(sc,sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_CHARACTER | T_ATOM);
+ ivalue_unchecked(x)= c;
+ set_num_integer(x);
+ return (x);
+}
+
+/* get number atom (integer) */
+INTERFACE pointer mk_integer(scheme *sc, long num) {
+ pointer x = get_cell(sc,sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_NUMBER | T_ATOM);
+ ivalue_unchecked(x)= num;
+ set_num_integer(x);
+ return (x);
+}
+
+INTERFACE pointer mk_real(scheme *sc, double n) {
+ pointer x = get_cell(sc,sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_NUMBER | T_ATOM);
+ rvalue_unchecked(x)= n;
+ set_num_real(x);
+ return (x);
+}
+
+static pointer mk_number(scheme *sc, num n) {
+ if(n.is_fixnum) {
+ return mk_integer(sc,n.value.ivalue);
+ } else {
+ return mk_real(sc,n.value.rvalue);
+ }
+}
+
+pointer foreign_error (scheme *sc, const char *s, pointer a) {
+ sc->foreign_error = cons (sc, mk_string (sc, s), a);
+ return sc->T;
+}
+
+/* char_cnt is length of string in chars. */
+/* str points to a NUL terminated string. */
+/* Only uses fill_char if str is NULL. */
+/* This routine automatically adds 1 byte */
+/* to allow space for terminating NUL. */
+static char *store_string(scheme *sc, int char_cnt,
+ const char *str, gunichar fill) {
+ int len;
+ int i;
+ gchar utf8[7];
+ gchar *q;
+ gchar *q2;
+
+ if(str!=0) {
+ q2 = g_utf8_offset_to_pointer(str, (long)char_cnt);
+ (void)g_utf8_validate(str, -1, (const gchar **)&q);
+ if (q <= q2)
+ len = q - str;
+ else
+ len = q2 - str;
+ q=(gchar*)sc->malloc(len+1);
+ } else {
+ len = g_unichar_to_utf8(fill, utf8);
+ q=(gchar*)sc->malloc(char_cnt*len+1);
+ }
+
+ if(q==0) {
+ sc->no_memory=1;
+ return sc->strbuff;
+ }
+ if(str!=0) {
+ memcpy(q, str, len);
+ q[len]=0;
+ } else {
+ q2 = q;
+ for (i = 0; i < char_cnt; ++i)
+ {
+ memcpy(q2, utf8, len);
+ q2 += len;
+ }
+ *q2=0;
+ }
+ return (q);
+}
+
+/* get new string */
+INTERFACE pointer mk_string(scheme *sc, const char *str) {
+ return mk_counted_string(sc,str,g_utf8_strlen(str, -1));
+}
+
+/* str points to a NUL terminated string. */
+/* len is the length of str in characters */
+INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_STRING | T_ATOM);
+ strvalue(x) = store_string(sc,len,str,0);
+ strlength(x) = len;
+ return (x);
+}
+
+/* len is the length for the empty string in characters */
+INTERFACE pointer mk_empty_string(scheme *sc, int len, gunichar fill) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_STRING | T_ATOM);
+ strvalue(x) = store_string(sc,len,0,fill);
+ strlength(x) = len;
+ return (x);
+}
+
+INTERFACE static pointer mk_vector(scheme *sc, int len)
+{ return get_vector_object(sc,len,sc->NIL); }
+
+INTERFACE static void fill_vector(pointer vec, pointer obj) {
+ int i;
+ int num=ivalue(vec)/2+ivalue(vec)%2;
+ for(i=0; i<num; i++) {
+ typeflag(vec+1+i) = T_PAIR;
+ setimmutable(vec+1+i);
+ car(vec+1+i)=obj;
+ cdr(vec+1+i)=obj;
+ }
+}
+
+INTERFACE static pointer vector_elem(pointer vec, int ielem) {
+ int n=ielem/2;
+ if(ielem%2==0) {
+ return car(vec+1+n);
+ } else {
+ return cdr(vec+1+n);
+ }
+}
+
+INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
+ int n=ielem/2;
+ if(ielem%2==0) {
+ return car(vec+1+n)=a;
+ } else {
+ return cdr(vec+1+n)=a;
+ }
+}
+
+/* get new symbol */
+INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
+ pointer x;
+
+ /* first check oblist */
+ x = oblist_find_by_name(sc, name);
+ if (x != sc->NIL) {
+ return (x);
+ } else {
+ x = oblist_add_by_name(sc, name);
+ return (x);
+ }
+}
+
+INTERFACE pointer gensym(scheme *sc) {
+ pointer x;
+ char name[40];
+
+ for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
+ snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
+
+ /* first check oblist */
+ x = oblist_find_by_name(sc, name);
+
+ if (x != sc->NIL) {
+ continue;
+ } else {
+ x = oblist_add_by_name(sc, name);
+ return (x);
+ }
+ }
+
+ return sc->NIL;
+}
+
+/* make symbol or number atom from string */
+static pointer mk_atom(scheme *sc, char *q) {
+ char c, *p;
+ int has_dec_point=0;
+ int has_fp_exp = 0;
+
+#if USE_COLON_HOOK
+ if((p=strstr(q,"::"))!=0) {
+ *p=0;
+ return cons(sc, sc->COLON_HOOK,
+ cons(sc,
+ cons(sc,
+ sc->QUOTE,
+ cons(sc, mk_atom(sc,p+2), sc->NIL)),
+ cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
+ }
+#endif
+
+ p = q;
+ c = *p++;
+ if ((c == '+') || (c == '-')) {
+ c = *p++;
+ if (c == '.') {
+ has_dec_point=1;
+ c = *p++;
+ }
+ if (!isdigit(c)) {
+ return (mk_symbol(sc, strlwr(q)));
+ }
+ } else if (c == '.') {
+ has_dec_point=1;
+ c = *p++;
+ if (!isdigit(c)) {
+ return (mk_symbol(sc, strlwr(q)));
+ }
+ } else if (!isdigit(c)) {
+ return (mk_symbol(sc, strlwr(q)));
+ }
+
+ for ( ; (c = *p) != 0; ++p) {
+ if (!isdigit(c)) {
+ if(c=='.') {
+ if(!has_dec_point) {
+ has_dec_point=1;
+ continue;
+ }
+ }
+ else if ((c == 'e') || (c == 'E')) {
+ if(!has_fp_exp) {
+ has_dec_point = 1; /* decimal point illegal
+ from now on */
+ p++;
+ if ((*p == '-') || (*p == '+') || isdigit(*p)) {
+ continue;
+ }
+ }
+ }
+ return (mk_symbol(sc, strlwr(q)));
+ }
+ }
+ if(has_dec_point) {
+ return mk_real(sc,g_ascii_strtod(q,NULL));
+ }
+ return (mk_integer(sc, atol(q)));
+}
+
+/* make constant */
+static pointer mk_sharp_const(scheme *sc, char *name) {
+ long x;
+ char tmp[STRBUFFSIZE];
+
+ if (!strcmp(name, "t"))
+ return (sc->T);
+ else if (!strcmp(name, "f"))
+ return (sc->F);
+ else if (*name == 'o') {/* #o (octal) */
+ snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
+ sscanf(tmp, "%lo", (long unsigned *)&x);
+ return (mk_integer(sc, x));
+ } else if (*name == 'd') { /* #d (decimal) */
+ sscanf(name+1, "%ld", (long int *)&x);
+ return (mk_integer(sc, x));
+ } else if (*name == 'x') { /* #x (hex) */
+ snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
+ sscanf(tmp, "%lx", (long unsigned *)&x);
+ return (mk_integer(sc, x));
+ } else if (*name == 'b') { /* #b (binary) */
+ x = binary_decode(name+1);
+ return (mk_integer(sc, x));
+ } else if (*name == '\\') { /* #\w (character) */
+ gunichar c=0;
+ if(stricmp(name+1,"space")==0) {
+ c=' ';
+ } else if(stricmp(name+1,"newline")==0) {
+ c='\n';
+ } else if(stricmp(name+1,"return")==0) {
+ c='\r';
+ } else if(stricmp(name+1,"tab")==0) {
+ c='\t';
+ } else if(name[1]=='x' && name[2]!=0) {
+ int c1=0;
+ if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
+ c=c1;
+ } else {
+ return sc->NIL;
+ }
+#if USE_ASCII_NAMES
+ } else if(is_ascii_name(name+1,&c)) {
+ /* nothing */
+#endif
+ } else if(name[2]==0) {
+ c=name[1];
+ } else {
+ return sc->NIL;
+ }
+ return mk_character(sc,c);
+ } else
+ return (sc->NIL);
+}
+
+/* ========== garbage collector ========== */
+
+/*--
+ * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
+ * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
+ * for marking.
+ */
+static void mark(pointer a) {
+ pointer t, q, p;
+
+ t = (pointer) 0;
+ p = a;
+E2: setmark(p);
+ if(is_vector(p)) {
+ int i;
+ int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
+ for(i=0; i<num; i++) {
+ /* Vector cells will be treated like ordinary cells */
+ mark(p+1+i);
+ }
+ }
+ if (is_atom(p))
+ goto E6;
+ /* E4: down car */
+ q = car(p);
+ if (q && !is_mark(q)) {
+ setatom(p); /* a note that we have moved car */
+ car(p) = t;
+ t = p;
+ p = q;
+ goto E2;
+ }
+ E5: q = cdr(p); /* down cdr */
+ if (q && !is_mark(q)) {
+ cdr(p) = t;
+ t = p;
+ p = q;
+ goto E2;
+ }
+E6: /* up. Undo the link switching from steps E4 and E5. */
+ if (!t)
+ return;
+ q = t;
+ if (is_atom(q)) {
+ clratom(q);
+ t = car(q);
+ car(q) = p;
+ p = q;
+ goto E5;
+ } else {
+ t = cdr(q);
+ cdr(q) = p;
+ p = q;
+ goto E6;
+ }
+}
+
+/* garbage collection. parameter a, b is marked. */
+static void gc(scheme *sc, pointer a, pointer b) {
+ pointer p;
+ int i;
+
+ if(sc->gc_verbose) {
+ putstr(sc, "gc...");
+ }
+
+ /* mark system globals */
+ mark(sc->oblist);
+ mark(sc->global_env);
+
+ /* mark current registers */
+ mark(sc->args);
+ mark(sc->envir);
+ mark(sc->code);
+ dump_stack_mark(sc);
+ mark(sc->value);
+ mark(sc->inport);
+ mark(sc->save_inport);
+ mark(sc->outport);
+ mark(sc->loadport);
+
+ /* Mark recent objects the interpreter doesn't know about yet. */
+ mark(car(sc->sink));
+ /* Mark any older stuff above nested C calls */
+ mark(sc->c_nest);
+
+ /* mark variables a, b */
+ mark(a);
+ mark(b);
+
+ /* garbage collect */
+ clrmark(sc->NIL);
+ sc->fcells = 0;
+ sc->free_cell = sc->NIL;
+ /* free-list is kept sorted by address so as to maintain consecutive
+ ranges, if possible, for use with vectors. Here we scan the cells
+ (which are also kept sorted by address) downwards to build the
+ free-list in sorted order.
+ */
+ for (i = sc->last_cell_seg; i >= 0; i--) {
+ p = sc->cell_seg[i] + CELL_SEGSIZE;
+ while (--p >= sc->cell_seg[i]) {
+ if (is_mark(p)) {
+ clrmark(p);
+ } else {
+ /* reclaim cell */
+ if (typeflag(p) != 0) {
+ finalize_cell(sc, p);
+ typeflag(p) = 0;
+ car(p) = sc->NIL;
+ }
+ ++sc->fcells;
+ cdr(p) = sc->free_cell;
+ sc->free_cell = p;
+ }
+ }
+ }
+
+ if (sc->gc_verbose) {
+ char msg[80];
+ snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
+ putstr(sc,msg);
+ }
+}
+
+static void finalize_cell(scheme *sc, pointer a) {
+ if(is_string(a)) {
+ sc->free(strvalue(a));
+ } else if(is_port(a)) {
+ if(a->_object._port->kind&port_file
+ && a->_object._port->rep.stdio.closeit) {
+ port_close(sc,a,port_input|port_output);
+ }
+ sc->free(a->_object._port);
+ }
+}
+
+/* ========== Routines for Reading ========== */
+
+static int file_push(scheme *sc, const char *fname) {
+ FILE *fin = NULL;
+ if (sc->file_i == MAXFIL-1)
+ return 0;
+
+ fin=g_fopen(fname,"rb");
+ if(fin!=0) {
+ sc->file_i++;
+ sc->load_stack[sc->file_i].kind=port_file|port_input;
+ sc->load_stack[sc->file_i].rep.stdio.file=fin;
+ sc->load_stack[sc->file_i].rep.stdio.closeit=1;
+ sc->nesting_stack[sc->file_i]=0;
+ sc->loadport->_object._port=sc->load_stack+sc->file_i;
+
+#if SHOW_ERROR_LINE
+ sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
+ if(fname)
+ sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
+#endif
+ }
+ return fin!=0;
+}
+
+static void file_pop(scheme *sc) {
+ if(sc->file_i != 0) {
+ sc->nesting=sc->nesting_stack[sc->file_i];
+ port_close(sc,sc->loadport,port_input);
+ sc->file_i--;
+ sc->loadport->_object._port=sc->load_stack+sc->file_i;
+ }
+}
+
+static int file_interactive(scheme *sc) {
+ return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
+ && sc->inport->_object._port->kind&port_file;
+}
+
+static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
+ FILE *f;
+ char *rw;
+ port *pt;
+ if(prop==(port_input|port_output)) {
+ rw="a+b";
+ } else if(prop==port_output) {
+ rw="wb";
+ } else {
+ rw="rb";
+ }
+ f=g_fopen(fn,rw);
+ if(f==0) {
+ return 0;
+ }
+ pt=port_rep_from_file(sc,f,prop);
+ pt->rep.stdio.closeit=1;
+
+#if SHOW_ERROR_LINE
+ if(fn)
+ pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
+
+ pt->rep.stdio.curr_line = 0;
+#endif
+ return pt;
+}
+
+static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
+ port *pt;
+ pt=port_rep_from_filename(sc,fn,prop);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
+{
+ port *pt;
+
+ pt = (port *)sc->malloc(sizeof *pt);
+ if (pt == NULL) {
+ return NULL;
+ }
+ pt->kind = port_file | prop;
+ pt->rep.stdio.file = f;
+ pt->rep.stdio.closeit = 0;
+ return pt;
+}
+
+static pointer port_from_file(scheme *sc, FILE *f, int prop) {
+ port *pt;
+ pt=port_rep_from_file(sc,f,prop);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
+ port *pt;
+ pt=(port*)sc->malloc(sizeof(port));
+ if(pt==0) {
+ return 0;
+ }
+ pt->kind=port_string|prop;
+ pt->rep.string.start=start;
+ pt->rep.string.curr=start;
+ pt->rep.string.past_the_end=past_the_end;
+ return pt;
+}
+
+static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
+ port *pt;
+ pt=port_rep_from_string(sc,start,past_the_end,prop);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+#define BLOCK_SIZE 256
+
+static port *port_rep_from_scratch(scheme *sc) {
+ port *pt;
+ char *start;
+ pt=(port*)sc->malloc(sizeof(port));
+ if(pt==0) {
+ return 0;
+ }
+ start=sc->malloc(BLOCK_SIZE);
+ if(start==0) {
+ return 0;
+ }
+ memset(start,' ',BLOCK_SIZE-1);
+ start[BLOCK_SIZE-1]='\0';
+ pt->kind=port_string|port_output|port_srfi6;
+ pt->rep.string.start=start;
+ pt->rep.string.curr=start;
+ pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
+ return pt;
+}
+
+static pointer port_from_scratch(scheme *sc) {
+ port *pt;
+ pt=port_rep_from_scratch(sc);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+static void port_close(scheme *sc, pointer p, int flag) {
+ port *pt=p->_object._port;
+ pt->kind&=~flag;
+ if((pt->kind & (port_input|port_output))==0) {
+ if(pt->kind&port_file) {
+
+#if SHOW_ERROR_LINE
+ /* Cleanup is here so (close-*-port) functions could work too */
+ pt->rep.stdio.curr_line = 0;
+
+ if(pt->rep.stdio.filename)
+ sc->free(pt->rep.stdio.filename);
+#endif
+
+ fclose(pt->rep.stdio.file);
+ }
+ pt->kind=port_free;
+ }
+}
+
+/* This routine will ignore byte sequences that are not valid UTF-8 */
+static gunichar basic_inchar(port *pt) {
+ if(pt->kind & port_file) {
+ int c;
+
+ c = fgetc(pt->rep.stdio.file);
+
+ while (TRUE)
+ {
+ if (c == EOF) return EOF;
+
+ if (c <= 0x7f)
+ return (gunichar) c;
+
+ /* Is this byte an invalid lead per RFC-3629? */
+ if (c < 0xc2 || c > 0xf4)
+ {
+ /* Ignore invalid lead byte and get the next character */
+ c = fgetc(pt->rep.stdio.file);
+ }
+ else /* Byte is valid lead */
+ {
+ unsigned char utf8[7];
+ int len;
+ int i;
+
+ utf8[0] = c; /* Save the lead byte */
+
+ len = utf8_length[c & 0x3F];
+ for (i = 1; i <= len; i++)
+ {
+ c = fgetc(pt->rep.stdio.file);
+
+ /* Stop reading if this is not a continuation character */
+ if ((c & 0xc0) != 0x80)
+ break;
+
+ utf8[i] = c;
+ }
+
+ if (i > len) /* Read the expected number of bytes? */
+ {
+ return g_utf8_get_char_validated ((char *) utf8,
+ sizeof(utf8));
+ }
+
+ /* Not enough continuation characters so ignore and restart */
+ }
+ } /* end of while (TRUE) */
+ } else {
+ gunichar c;
+ int len;
+
+ while (TRUE)
+ {
+ /* Found NUL or at end of input buffer? */
+ if (*pt->rep.string.curr == 0 ||
+ pt->rep.string.curr == pt->rep.string.past_the_end) {
+ return EOF;
+ }
+
+ len = pt->rep.string.past_the_end - pt->rep.string.curr;
+ c = g_utf8_get_char_validated(pt->rep.string.curr, len);
+
+ if (c != (gunichar) -1 &&
+ c != (gunichar) -2) /* Valid UTF-8 character? */
+ {
+ len = g_unichar_to_utf8(c, NULL); /* Length of UTF-8 sequence */
+ pt->rep.string.curr += len;
+ return c;
+ }
+
+ /* Look for next valid UTF-8 character in buffer */
+ pt->rep.string.curr = g_utf8_find_next_char(pt->rep.string.curr,
+ pt->rep.string.past_the_end);
+ } /* end of while (TRUE) */
+ }
+}
+
+/* get new character from input file */
+static gunichar inchar(scheme *sc) {
+ gunichar c;
+ port *pt;
+
+ pt = sc->inport->_object._port;
+ if(pt->kind & port_saw_EOF)
+ { return(EOF); }
+ if(pt->kind&port_file)
+ {
+ if (sc->bc_flag)
+ c = sc->backchar[--sc->bc_flag];
+ else
+ c = basic_inchar(pt);
+ }
+ else
+ c = basic_inchar(pt);
+ if(c == EOF && sc->inport == sc->loadport) {
+ /* Instead, set port_saw_EOF */
+ pt->kind |= port_saw_EOF;
+
+ /* file_pop(sc); */
+ return EOF;
+ /* NOTREACHED */
+ }
+ return c;
+}
+
+/* back character to input buffer */
+static void backchar(scheme *sc, gunichar c) {
+ port *pt;
+ gint charlen;
+
+ if(c==EOF) return;
+ charlen = g_unichar_to_utf8(c, NULL);
+ pt=sc->inport->_object._port;
+ if(pt->kind&port_file) {
+ if (sc->bc_flag < 2)
+ sc->backchar[sc->bc_flag++] = c;
+ } else {
+ if(pt->rep.string.curr!=pt->rep.string.start) {
+ if(pt->rep.string.curr-pt->rep.string.start >= charlen)
+ pt->rep.string.curr -= charlen;
+ else
+ pt->rep.string.curr = pt->rep.string.start;
+ }
+ }
+}
+
+static int realloc_port_string(scheme *sc, port *p)
+{
+ char *start=p->rep.string.start;
+ size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
+ char *str=sc->malloc(new_size);
+ if(str) {
+ memset(str,' ',new_size-1);
+ str[new_size-1]='\0';
+ strcpy(str,start);
+ p->rep.string.start=str;
+ p->rep.string.past_the_end=str+new_size-1;
+ p->rep.string.curr-=start-str;
+ sc->free(start);
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+/* len is number of UTF-8 characters in string pointed to by chars */
+static void putchars(scheme *sc, const char *chars, int char_cnt) {
+ int free_bytes; /* Space remaining in buffer (in bytes) */
+ int l;
+ port *pt=sc->outport->_object._port;
+
+ if (char_cnt <= 0)
+ return;
+
+ /* Get length of 'chars' in bytes */
+ char_cnt = g_utf8_offset_to_pointer(chars, (long)char_cnt) - chars;
+
+ if(pt->kind&port_file) {
+#if STANDALONE
+ fwrite(chars,1,char_cnt,pt->rep.stdio.file);
+ fflush(pt->rep.stdio.file);
+#else
+ /* If output is still directed to stdout (the default) it should be */
+ /* safe to redirect it to the registered output routine. */
+ if (pt->rep.stdio.file == stdout)
+ ts_output_string (TS_OUTPUT_NORMAL, chars, char_cnt);
+ else {
+ fwrite(chars,1,char_cnt,pt->rep.stdio.file);
+ fflush(pt->rep.stdio.file);
+ }
+#endif
+ } else {
+ if (pt->rep.string.past_the_end != pt->rep.string.curr)
+ {
+ free_bytes = pt->rep.string.past_the_end - pt->rep.string.curr;
+ l = min(char_cnt, free_bytes);
+ memcpy(pt->rep.string.curr, chars, l);
+ pt->rep.string.curr += l;
+ }
+ else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt))
+ {
+ free_bytes = pt->rep.string.past_the_end - pt->rep.string.curr;
+ l = min(char_cnt, free_bytes);
+ memcpy(pt->rep.string.curr, chars, char_cnt);
+ pt->rep.string.curr += l;
+ }
+ }
+}
+
+INTERFACE void putcharacter(scheme *sc, gunichar c) {
+ char utf8[7];
+
+ (void)g_unichar_to_utf8(c, utf8);
+ putchars(sc, utf8, 1);
+}
+
+INTERFACE void putstr(scheme *sc, const char *s) {
+ putchars(sc, s, g_utf8_strlen(s, -1));
+}
+
+/* read characters up to delimiter, but cater to character constants */
+static char *readstr_upto(scheme *sc, char *delim) {
+ char *p = sc->strbuff;
+ gunichar c = 0;
+ gunichar c_prev = 0;
+ int len = 0;
+
+ do {
+ c_prev = c;
+ c = inchar(sc);
+ len = g_unichar_to_utf8(c, p);
+ p += len;
+ } while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
+ (c && !is_one_of(delim, c)));
+
+ if(p == sc->strbuff+2 && c_prev == '\\')
+ *p = '\0';
+ else
+ {
+ backchar(sc,c); /* put back the delimiter */
+ p[-len] = '\0';
+ }
+ return sc->strbuff;
+}
+
+/* read string expression "xxx...xxx" */
+static pointer readstrexp(scheme *sc) {
+ char *p = sc->strbuff;
+ gunichar c;
+ int c1=0;
+ int len;
+ enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
+
+ for (;;) {
+ c=inchar(sc);
+ if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
+ return sc->F;
+ }
+ switch(state) {
+ case st_ok:
+ switch(c) {
+ case '\\':
+ state=st_bsl;
+ break;
+ case '"':
+ *p=0;
+ return mk_counted_string(sc,sc->strbuff,
+ g_utf8_strlen(sc->strbuff, sizeof(sc->strbuff)));
+ default:
+ len = g_unichar_to_utf8(c, p);
+ p += len;
+ break;
+ }
+ break;
+ case st_bsl:
+ switch(c) {
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ state=st_oct1;
+ c1=g_unichar_digit_value(c);
+ break;
+ case 'x':
+ case 'X':
+ state=st_x1;
+ c1=0;
+ break;
+ case 'n':
+ *p++='\n';
+ state=st_ok;
+ break;
+ case 't':
+ *p++='\t';
+ state=st_ok;
+ break;
+ case 'r':
+ *p++='\r';
+ state=st_ok;
+ break;
+ case '"':
+ *p++='"';
+ state=st_ok;
+ break;
+ default:
+ len = g_unichar_to_utf8(c, p);
+ p += len;
+ state=st_ok;
+ break;
+ }
+ break;
+ case st_x1:
+ case st_x2:
+ if (!g_unichar_isxdigit(c))
+ return sc->F;
+ c1=(c1<<4)+g_unichar_xdigit_value(c);
+ if(state==st_x1)
+ state=st_x2;
+ else {
+ *p++=c1;
+ state=st_ok;
+ }
+ break;
+ case st_oct1: /* State when handling second octal digit */
+ case st_oct2: /* State when handling third octal digit */
+ if (!g_unichar_isdigit(c) || g_unichar_digit_value(c) > 7)
+ {
+ *p++=c1;
+ backchar(sc, c);
+ state=st_ok;
+ }
+ else
+ {
+ /* Is value of three character octal too big for a byte? */
+ if (state==st_oct2 && c1 >= 32)
+ return sc->F;
+
+ c1=(c1<<3)+g_unichar_digit_value(c);
+
+ if (state == st_oct1)
+ state=st_oct2;
+ else
+ {
+ *p++=c1;
+ state=st_ok;
+ }
+ }
+ break;
+ }
+ }
+}
+
+/* check c is in chars */
+static INLINE int is_one_of(char *s, gunichar c) {
+ if (c==EOF)
+ return 1;
+
+ if (g_utf8_strchr(s, -1, c) != NULL)
+ return (1);
+
+ return (0);
+}
+
+/* skip white characters */
+static INLINE int skipspace(scheme *sc) {
+ gunichar c;
+ int curr_line = 0;
+ do {
+ c=inchar(sc);
+#if SHOW_ERROR_LINE
+ if(c=='\n')
+ curr_line++;
+#endif
+ } while (g_unichar_isspace(c));
+
+/* record it */
+#if SHOW_ERROR_LINE
+ if (sc->load_stack[sc->file_i].kind & port_file)
+ sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
+#endif
+
+ if(c!=EOF) {
+ backchar(sc,c);
+ return 1;
+ }
+ else
+ { return EOF; }
+}
+
+/* get token */
+static int token(scheme *sc) {
+ gunichar c;
+ c = skipspace(sc);
+ if(c == EOF) { return (TOK_EOF); }
+ switch (c=inchar(sc)) {
+ case EOF:
+ return (TOK_EOF);
+ case '(':
+ return (TOK_LPAREN);
+ case ')':
+ return (TOK_RPAREN);
+ case '.':
+ c=inchar(sc);
+ if(is_one_of(" \n\t",c)) {
+ return (TOK_DOT);
+ } else {
+ backchar(sc,c);
+ backchar(sc,'.');
+ return TOK_ATOM;
+ }
+ case '\'':
+ return (TOK_QUOTE);
+ case ';':
+ while ((c=inchar(sc)) != '\n' && c!=EOF)
+ ;
+
+#if SHOW_ERROR_LINE
+ if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
+ sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+#endif
+
+ if(c == EOF)
+ { return (TOK_EOF); }
+ else
+ { return (token(sc));}
+ case '"':
+ return (TOK_DQUOTE);
+ case '_':
+ if ((c=inchar(sc)) == '"')
+ return (TOK_USCORE);
+ backchar(sc,c);
+ return (TOK_ATOM);
+ case BACKQUOTE:
+ return (TOK_BQUOTE);
+ case ',':
+ if ((c=inchar(sc)) == '@') {
+ return (TOK_ATMARK);
+ } else {
+ backchar(sc,c);
+ return (TOK_COMMA);
+ }
+ case '#':
+ c=inchar(sc);
+ if (c == '(') {
+ return (TOK_VEC);
+ } else if(c == '!') {
+ while ((c=inchar(sc)) != '\n' && c!=EOF)
+ ;
+
+#if SHOW_ERROR_LINE
+ if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
+ sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+#endif
+
+ if(c == EOF)
+ { return (TOK_EOF); }
+ else
+ { return (token(sc));}
+ } else {
+ backchar(sc,c);
+ if(is_one_of(" tfodxb\\",c)) {
+ return TOK_SHARP_CONST;
+ } else {
+ return (TOK_SHARP);
+ }
+ }
+ default:
+ backchar(sc,c);
+ return (TOK_ATOM);
+ }
+}
+
+/* ========== Routines for Printing ========== */
+#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
+
+static void printslashstring(scheme *sc, char *p, int len) {
+ int i;
+ gunichar c;
+ char *s=(char*)p;
+
+ putcharacter(sc,'"');
+ for (i=0; i<len; i++) {
+ c = g_utf8_get_char(s);
+ /* Is a check for a value of 0xff still valid in UTF8?? ~~~~~ */
+ if(c==0xff || c=='"' || c<' ' || c=='\\') {
+ putcharacter(sc,'\\');
+ switch(c) {
+ case '"':
+ putcharacter(sc,'"');
+ break;
+ case '\n':
+ putcharacter(sc,'n');
+ break;
+ case '\t':
+ putcharacter(sc,'t');
+ break;
+ case '\r':
+ putcharacter(sc,'r');
+ break;
+ case '\\':
+ putcharacter(sc,'\\');
+ break;
+ default: {
+ /* This still needs work ~~~~~ */
+ int d=c/16;
+ putcharacter(sc,'x');
+ if(d<10) {
+ putcharacter(sc,d+'0');
+ } else {
+ putcharacter(sc,d-10+'A');
+ }
+ d=c%16;
+ if(d<10) {
+ putcharacter(sc,d+'0');
+ } else {
+ putcharacter(sc,d-10+'A');
+ }
+ }
+ }
+ } else {
+ putcharacter(sc,c);
+ }
+ s = g_utf8_next_char(s);
+ }
+ putcharacter(sc,'"');
+}
+
+
+/* print atoms */
+static void printatom(scheme *sc, pointer l, int f) {
+ char *p;
+ int len;
+ atom2str(sc,l,f,&p,&len);
+ putchars(sc,p,len);
+}
+
+
+/* Uses internal buffer unless string pointer is already available */
+static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
+ char *p;
+
+ if (l == sc->NIL) {
+ p = "()";
+ } else if (l == sc->T) {
+ p = "#t";
+ } else if (l == sc->F) {
+ p = "#f";
+ } else if (l == sc->EOF_OBJ) {
+ p = "#<EOF>";
+ } else if (is_port(l)) {
+ p = "#<PORT>";
+ } else if (is_number(l)) {
+ p = sc->strbuff;
+ if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
+ if(num_is_integer(l)) {
+ snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
+ } else {
+ snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
+ /* r5rs says there must be a '.' (unless 'e'?) */
+ f = strcspn(p, ".e");
+ if (p[f] == 0) {
+ p[f] = '.'; /* not found, so add '.0' at the end */
+ p[f+1] = '0';
+ p[f+2] = 0;
+ }
+ }
+ } else {
+ long v = ivalue(l);
+ if (f == 16) {
+ if (v >= 0)
+ snprintf(p, STRBUFFSIZE, "%lx", v);
+ else
+ snprintf(p, STRBUFFSIZE, "-%lx", -v);
+ } else if (f == 8) {
+ if (v >= 0)
+ snprintf(p, STRBUFFSIZE, "%lo", v);
+ else
+ snprintf(p, STRBUFFSIZE, "-%lo", -v);
+ } else if (f == 2) {
+ unsigned long b = (v < 0) ? -v : v;
+ p = &p[STRBUFFSIZE-1];
+ *p = 0;
+ do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
+ if (v < 0) *--p = '-';
+ }
+ }
+ } else if (is_string(l)) {
+ if (!f) {
+ p = strvalue(l);
+ } else { /* Hack, uses the fact that printing is needed */
+ *pp=sc->strbuff;
+ *plen=0;
+ printslashstring(sc, strvalue(l),
+ g_utf8_strlen(strvalue(l), -1));
+ return;
+ }
+ } else if (is_character(l)) {
+ gunichar c=charvalue(l);
+ p = sc->strbuff;
+ if (!f) {
+ int len = g_unichar_to_utf8(c, p);
+ p[len]=0;
+ } else {
+ switch(c) {
+ case ' ':
+ p = "#\\space";
+ break;
+ case '\n':
+ p = "#\\newline";
+ break;
+ case '\r':
+ p = "#\\return";
+ break;
+ case '\t':
+ p = "#\\tab";
+ break;
+ default:
+#if USE_ASCII_NAMES
+ if(c==127) {
+ p = "#\\del";
+ break;
+ } else if(c<32) {
+ snprintf(p,STRBUFFSIZE, "#\\%s", charnames[c]);
+ break;
+ }
+#else
+ if(c<32) {
+ snprintf(p,STRBUFFSIZE,"#\\x%x",c);
+ break;
+ }
+#endif
+ snprintf(p,STRBUFFSIZE,"#\\%c",c);
+ break;
+ }
+ }
+ } else if (is_symbol(l)) {
+ p = symname(l);
+ } else if (is_proc(l)) {
+ p = sc->strbuff;
+ snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>",
+ procname(l),procnum(l));
+ } else if (is_macro(l)) {
+ p = "#<MACRO>";
+ } else if (is_closure(l)) {
+ p = "#<CLOSURE>";
+ } else if (is_promise(l)) {
+ p = "#<PROMISE>";
+ } else if (is_foreign(l)) {
+ p = sc->strbuff;
+ snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
+ } else if (is_continuation(l)) {
+ p = "#<CONTINUATION>";
+ } else {
+ p = "#<ERROR>";
+ }
+ *pp=p;
+ *plen=g_utf8_strlen(p, -1);
+}
+/* ========== Routines for Evaluation Cycle ========== */
+
+/* make closure. c is code. e is environment */
+static pointer mk_closure(scheme *sc, pointer c, pointer e) {
+ pointer x = get_cell(sc, c, e);
+
+ typeflag(x) = T_CLOSURE;
+ car(x) = c;
+ cdr(x) = e;
+ return (x);
+}
+
+/* make continuation. */
+static pointer mk_continuation(scheme *sc, pointer d) {
+ pointer x = get_cell(sc, sc->NIL, d);
+
+ typeflag(x) = T_CONTINUATION;
+ cont_dump(x) = d;
+ return (x);
+}
+
+static pointer list_star(scheme *sc, pointer d) {
+ pointer p, q;
+ if(cdr(d)==sc->NIL) {
+ return car(d);
+ }
+ p=cons(sc,car(d),cdr(d));
+ q=p;
+ while(cdr(cdr(p))!=sc->NIL) {
+ d=cons(sc,car(p),cdr(p));
+ if(cdr(cdr(p))!=sc->NIL) {
+ p=cdr(d);
+ }
+ }
+ cdr(p)=car(cdr(p));
+ return q;
+}
+
+/* reverse list -- produce new list */
+static pointer reverse(scheme *sc, pointer a) {
+/* a must be checked by gc */
+ pointer p = sc->NIL;
+
+ for ( ; is_pair(a); a = cdr(a)) {
+ p = cons(sc, car(a), p);
+ }
+ return (p);
+}
+
+/* reverse list --- in-place */
+static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
+ pointer p = list, result = term, q;
+
+ while (p != sc->NIL) {
+ q = cdr(p);
+ cdr(p) = result;
+ result = p;
+ p = q;
+ }
+ return (result);
+}
+
+/* append list -- produce new list */
+static pointer revappend(scheme *sc, pointer a, pointer b) {
+ pointer result = a;
+ pointer p = b;
+
+ while (is_pair(p)) {
+ result = cons(sc, car(p), result);
+ p = cdr(p);
+ }
+
+ if (p == sc->NIL) {
+ return result;
+ }
+
+ return sc->F; /* signal an error */
+}
+
+/* equivalence of atoms */
+int eqv(pointer a, pointer b) {
+ if (is_string(a)) {
+ if (is_string(b))
+ return (strvalue(a) == strvalue(b));
+ else
+ return (0);
+ } else if (is_number(a)) {
+ if (is_number(b)) {
+ if (num_is_integer(a) == num_is_integer(b))
+ return num_eq(nvalue(a),nvalue(b));
+ }
+ return (0);
+ } else if (is_character(a)) {
+ if (is_character(b))
+ return charvalue(a)==charvalue(b);
+ else
+ return (0);
+ } else if (is_port(a)) {
+ if (is_port(b))
+ return a==b;
+ else
+ return (0);
+ } else if (is_proc(a)) {
+ if (is_proc(b))
+ return procnum(a)==procnum(b);
+ else
+ return (0);
+ } else {
+ return (a == b);
+ }
+}
+
+/* true or false value macro */
+/* () is #t in R5RS */
+#define is_true(p) ((p) != sc->F)
+#define is_false(p) ((p) == sc->F)
+
+/* ========== Environment implementation ========== */
+
+#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
+
+static int hash_fn(const char *key, int table_size)
+{
+ unsigned int hashed = 0;
+ const char *c;
+ int bits_per_int = sizeof(unsigned int)*8;
+
+ for (c = key; *c; c++) {
+ /* letters have about 5 bits in them */
+ hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
+ hashed ^= *c;
+ }
+ return hashed % table_size;
+}
+#endif
+
+#ifndef USE_ALIST_ENV
+
+/*
+ * In this implementation, each frame of the environment may be
+ * a hash table: a vector of alists hashed by variable name.
+ * In practice, we use a vector only for the initial frame;
+ * subsequent frames are too small and transient for the lookup
+ * speed to out-weigh the cost of making a new vector.
+ */
+
+static void new_frame_in_env(scheme *sc, pointer old_env)
+{
+ pointer new_frame;
+
+ /* The interaction-environment has about 300 variables in it. */
+ if (old_env == sc->NIL) {
+ new_frame = mk_vector(sc, 461);
+ } else {
+ new_frame = sc->NIL;
+ }
+
+ sc->envir = immutable_cons(sc, new_frame, old_env);
+ setenvironment(sc->envir);
+}
+
+static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
+ pointer variable, pointer value)
+{
+ pointer slot = immutable_cons(sc, variable, value);
+
+ if (is_vector(car(env))) {
+ int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
+
+ set_vector_elem(car(env), location,
+ immutable_cons(sc, slot, vector_elem(car(env), location)));
+ } else {
+ car(env) = immutable_cons(sc, slot, car(env));
+ }
+}
+
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+{
+ pointer x,y;
+ int location;
+
+ for (x = env; x != sc->NIL; x = cdr(x)) {
+ if (is_vector(car(x))) {
+ location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
+ y = vector_elem(car(x), location);
+ } else {
+ y = car(x);
+ }
+ for ( ; y != sc->NIL; y = cdr(y)) {
+ if (caar(y) == hdl) {
+ break;
+ }
+ }
+ if (y != sc->NIL) {
+ break;
+ }
+ if(!all) {
+ return sc->NIL;
+ }
+ }
+ if (x != sc->NIL) {
+ return car(y);
+ }
+ return sc->NIL;
+}
+
+#else /* USE_ALIST_ENV */
+
+static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
+{
+ sc->envir = immutable_cons(sc, sc->NIL, old_env);
+ setenvironment(sc->envir);
+}
+
+static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
+ pointer variable, pointer value)
+{
+ car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
+}
+
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+{
+ pointer x,y;
+ for (x = env; x != sc->NIL; x = cdr(x)) {
+ for (y = car(x); y != sc->NIL; y = cdr(y)) {
+ if (caar(y) == hdl) {
+ break;
+ }
+ }
+ if (y != sc->NIL) {
+ break;
+ }
+ if(!all) {
+ return sc->NIL;
+ }
+ }
+ if (x != sc->NIL) {
+ return car(y);
+ }
+ return sc->NIL;
+}
+
+#endif /* USE_ALIST_ENV else */
+
+static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
+{
+ new_slot_spec_in_env(sc, sc->envir, variable, value);
+}
+
+static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
+{
+ cdr(slot) = value;
+}
+
+static INLINE pointer slot_value_in_env(pointer slot)
+{
+ return cdr(slot);
+}
+
+/* ========== Evaluation Cycle ========== */
+
+
+static pointer _Error_1(scheme *sc, const char *s, pointer a) {
+ const char *str = s;
+#if USE_ERROR_HOOK
+ pointer x;
+ pointer hdl=sc->ERROR_HOOK;
+#endif
+
+#if SHOW_ERROR_LINE
+ char sbuf[STRBUFFSIZE];
+
+ /* make sure error is not in REPL */
+ if (sc->load_stack[sc->file_i].kind & port_file &&
+ sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
+ int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
+ const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+
+ /* should never happen */
+ if(!fname) fname = "<unknown>";
+
+ /* we started from 0 */
+ ln++;
+ snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
+
+ str = (const char*)sbuf;
+ }
+#endif
+
+#if USE_ERROR_HOOK
+ x=find_slot_in_env(sc,sc->envir,hdl,1);
+ if (x != sc->NIL) {
+ if(a!=0) {
+ sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
+ } else {
+ sc->code = sc->NIL;
+ }
+ sc->code = cons(sc, mk_string(sc, str), sc->code);
+ setimmutable(car(sc->code));
+ sc->code = cons(sc, slot_value_in_env(x), sc->code);
+ sc->op = (int)OP_EVAL;
+ return sc->T;
+ }
+#endif
+
+ if(a!=0) {
+ sc->args = cons(sc, (a), sc->NIL);
+ } else {
+ sc->args = sc->NIL;
+ }
+ sc->args = cons(sc, mk_string(sc, str), sc->args);
+ setimmutable(car(sc->args));
+ sc->op = (int)OP_ERR0;
+ return sc->T;
+}
+#define Error_1(sc,s,a) return _Error_1(sc,s,a)
+#define Error_0(sc,s) return _Error_1(sc,s,0)
+
+/* Too small to turn into function */
+# define BEGIN do {
+# define END } while (0)
+#define s_goto(sc,a) BEGIN \
+ sc->op = (int)(a); \
+ return sc->T; END
+
+#define s_return(sc,a) return _s_return(sc,a)
+
+#ifndef USE_SCHEME_STACK
+
+/* this structure holds all the interpreter's registers */
+struct dump_stack_frame {
+ enum scheme_opcodes op;
+ pointer args;
+ pointer envir;
+ pointer code;
+};
+
+#define STACK_GROWTH 3
+
+static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
+{
+ int nframes = (int)sc->dump;
+ struct dump_stack_frame *next_frame;
+
+ /* enough room for the next frame? */
+ if (nframes >= sc->dump_size) {
+ sc->dump_size += STACK_GROWTH;
+ /* alas there is no sc->realloc */
+ sc->dump_base = realloc(sc->dump_base,
+ sizeof(struct dump_stack_frame) * sc->dump_size);
+ }
+ next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
+ next_frame->op = op;
+ next_frame->args = args;
+ next_frame->envir = sc->envir;
+ next_frame->code = code;
+ sc->dump = (pointer)(nframes+1);
+}
+
+static pointer _s_return(scheme *sc, pointer a)
+{
+ int nframes = (int)sc->dump;
+ struct dump_stack_frame *frame;
+
+ sc->value = (a);
+ if (nframes <= 0) {
+ return sc->NIL;
+ }
+ nframes--;
+ frame = (struct dump_stack_frame *)sc->dump_base + nframes;
+ sc->op = frame->op;
+ sc->args = frame->args;
+ sc->envir = frame->envir;
+ sc->code = frame->code;
+ sc->dump = (pointer)nframes;
+ return sc->T;
+}
+
+static INLINE void dump_stack_reset(scheme *sc)
+{
+ /* in this implementation, sc->dump is the number of frames on the stack */
+ sc->dump = (pointer)0;
+}
+
+static INLINE void dump_stack_initialize(scheme *sc)
+{
+ sc->dump_size = 0;
+ sc->dump_base = NULL;
+ dump_stack_reset(sc);
+}
+
+static void dump_stack_free(scheme *sc)
+{
+ free(sc->dump_base);
+ sc->dump_base = NULL;
+ sc->dump = (pointer)0;
+ sc->dump_size = 0;
+}
+
+static INLINE void dump_stack_mark(scheme *sc)
+{
+ int nframes = (int)sc->dump;
+ int i;
+ for(i=0; i<nframes; i++) {
+ struct dump_stack_frame *frame;
+ frame = (struct dump_stack_frame *)sc->dump_base + i;
+ mark(frame->args);
+ mark(frame->envir);
+ mark(frame->code);
+ }
+}
+
+#else
+
+static INLINE void dump_stack_reset(scheme *sc)
+{
+ sc->dump = sc->NIL;
+}
+
+static INLINE void dump_stack_initialize(scheme *sc)
+{
+ dump_stack_reset(sc);
+}
+
+static void dump_stack_free(scheme *sc)
+{
+ sc->dump = sc->NIL;
+}
+
+static pointer _s_return(scheme *sc, pointer a) {
+ sc->value = (a);
+ if(sc->dump==sc->NIL) return sc->NIL;
+ sc->op = ivalue(car(sc->dump));
+ sc->args = cadr(sc->dump);
+ sc->envir = caddr(sc->dump);
+ sc->code = cadddr(sc->dump);
+ sc->dump = cddddr(sc->dump);
+ return sc->T;
+}
+
+static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
+ sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
+ sc->dump = cons(sc, (args), sc->dump);
+ sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
+}
+
+static INLINE void dump_stack_mark(scheme *sc)
+{
+ mark(sc->dump);
+}
+#endif
+
+#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
+
+static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
+ pointer x, y;
+
+ switch (op) {
+ case OP_LOAD: /* load */
+ if(file_interactive(sc)) {
+ fprintf(sc->outport->_object._port->rep.stdio.file,
+ "Loading %s\n", strvalue(car(sc->args)));
+ }
+ if (!file_push(sc,strvalue(car(sc->args)))) {
+ Error_1(sc,"unable to open", car(sc->args));
+ }
+ else
+ {
+ sc->args = mk_integer(sc,sc->file_i);
+ s_goto(sc,OP_T0LVL);
+ }
+
+ case OP_T0LVL: /* top level */
+ /* If we reached the end of file, this loop is done. */
+ if(sc->loadport->_object._port->kind & port_saw_EOF)
+ {
+ if(sc->file_i == 0)
+ {
+ sc->args=sc->NIL;
+ s_goto(sc,OP_QUIT);
+ }
+ else
+ {
+ file_pop(sc);
+ s_return(sc,sc->value);
+ }
+ /* NOTREACHED */
+ }
+
+ /* If interactive, be nice to user. */
+ if(file_interactive(sc))
+ {
+ sc->envir = sc->global_env;
+ dump_stack_reset(sc);
+ putstr(sc,"\n");
+ putstr(sc,prompt);
+ }
+
+ /* Set up another iteration of REPL */
+ sc->nesting=0;
+ sc->save_inport=sc->inport;
+ sc->inport = sc->loadport;
+ s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
+ s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
+ s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
+ s_goto(sc,OP_READ_INTERNAL);
+
+ case OP_T1LVL: /* top level */
+ sc->code = sc->value;
+ sc->inport=sc->save_inport;
+ s_goto(sc,OP_EVAL);
+
+ case OP_READ_INTERNAL: /* internal read */
+ sc->tok = token(sc);
+ if(sc->tok==TOK_EOF)
+ { s_return(sc,sc->EOF_OBJ); }
+ s_goto(sc,OP_RDSEXPR);
+
+ case OP_GENSYM:
+ s_return(sc, gensym(sc));
+
+ case OP_VALUEPRINT: /* print evaluation result */
+ /* OP_VALUEPRINT is always pushed, because when changing from
+ non-interactive to interactive mode, it needs to be
+ already on the stack */
+ if(sc->tracing) {
+ putstr(sc,"\nGives: ");
+ }
+ if(file_interactive(sc) || sc->print_output) {
+ sc->print_flag = 1;
+ sc->args = sc->value;
+ s_goto(sc,OP_P0LIST);
+ } else {
+ s_return(sc,sc->value);
+ }
+
+ case OP_EVAL: /* main part of evaluation */
+#if USE_TRACING
+ if(sc->tracing) {
+ /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
+ s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
+ sc->args=sc->code;
+ putstr(sc,"\nEval: ");
+ s_goto(sc,OP_P0LIST);
+ }
+ /* fall through */
+ case OP_REAL_EVAL:
+#endif
+ if (is_symbol(sc->code)) { /* symbol */
+ x=find_slot_in_env(sc,sc->envir,sc->code,1);
+ if (x != sc->NIL) {
+ s_return(sc,slot_value_in_env(x));
+ } else {
+ Error_1(sc,"eval: unbound variable:", sc->code);
+ }
+ } else if (is_pair(sc->code)) {
+ if (is_syntax(x = car(sc->code))) { /* SYNTAX */
+ sc->code = cdr(sc->code);
+ s_goto(sc,syntaxnum(x));
+ } else {/* first, eval top element and eval arguments */
+ s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
+ /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+ }
+ } else {
+ s_return(sc,sc->code);
+ }
+
+ case OP_E0ARGS: /* eval arguments */
+ if (is_macro(sc->value)) { /* macro expansion */
+ s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
+ sc->args = cons(sc,sc->code, sc->NIL);
+ sc->code = sc->value;
+ s_goto(sc,OP_APPLY);
+ } else {
+ sc->code = cdr(sc->code);
+ s_goto(sc,OP_E1ARGS);
+ }
+
+ case OP_E1ARGS: /* eval arguments */
+ sc->args = cons(sc, sc->value, sc->args);
+ if (is_pair(sc->code)) { /* continue */
+ s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
+ sc->code = car(sc->code);
+ sc->args = sc->NIL;
+ s_goto(sc,OP_EVAL);
+ } else { /* end */
+ sc->args = reverse_in_place(sc, sc->NIL, sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ s_goto(sc,OP_APPLY);
+ }
+
+#if USE_TRACING
+ case OP_TRACING: {
+ int tr=sc->tracing;
+ sc->tracing=ivalue(car(sc->args));
+ s_return(sc,mk_integer(sc,tr));
+ }
+#endif
+
+ case OP_APPLY: /* apply 'code' to 'args' */
+#if USE_TRACING
+ if(sc->tracing) {
+ s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
+ sc->print_flag = 1;
+ /* sc->args=cons(sc,sc->code,sc->args);*/
+ putstr(sc,"\nApply to: ");
+ s_goto(sc,OP_P0LIST);
+ }
+ /* fall through */
+ case OP_REAL_APPLY:
+#endif
+ if (is_proc(sc->code)) {
+ s_goto(sc,procnum(sc->code)); /* PROCEDURE */
+ } else if (is_foreign(sc->code))
+ {
+ /* Keep nested calls from GC'ing the arglist */
+ push_recent_alloc(sc,sc->args,sc->NIL);
+ sc->foreign_error = sc->NIL;
+ x=sc->code->_object._ff(sc,sc->args);
+ if (sc->foreign_error == sc->NIL) {
+ s_return(sc,x);
+ } else {
+ x = sc->foreign_error;
+ sc->foreign_error = sc->NIL;
+ Error_1 (sc, string_value (car (x)), cdr (x));
+ }
+ } else if (is_closure(sc->code) || is_macro(sc->code)
+ || is_promise(sc->code)) { /* CLOSURE */
+ /* Should not accept promise */
+ /* make environment */
+ new_frame_in_env(sc, closure_env(sc->code));
+ for (x = car(closure_code(sc->code)), y = sc->args;
+ is_pair(x); x = cdr(x), y = cdr(y)) {
+ if (y == sc->NIL) {
+ Error_0(sc,"not enough arguments");
+ } else {
+ new_slot_in_env(sc, car(x), car(y));
+ }
+ }
+ if (x == sc->NIL) {
+ /*--
+ * if (y != sc->NIL) {
+ * Error_0(sc,"too many arguments");
+ * }
+ */
+ } else if (is_symbol(x))
+ new_slot_in_env(sc, x, y);
+ else {
+ Error_1(sc,"syntax error in closure: not a symbol:", x);
+ }
+ sc->code = cdr(closure_code(sc->code));
+ sc->args = sc->NIL;
+ s_goto(sc,OP_BEGIN);
+ } else if (is_continuation(sc->code)) { /* CONTINUATION */
+ sc->dump = cont_dump(sc->code);
+ s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
+ } else {
+ Error_0(sc,"illegal function");
+ }
+
+ case OP_DOMACRO: /* do macro */
+ sc->code = sc->value;
+ s_goto(sc,OP_EVAL);
+
+#if 1
+ case OP_LAMBDA: /* lambda */
+ /* If the hook is defined, apply it to sc->code, otherwise
+ set sc->value fall thru */
+ {
+ pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
+ if(f==sc->NIL) {
+ sc->value = sc->code;
+ /* Fallthru */
+ } else {
+ s_save(sc,OP_LAMBDA1,sc->args,sc->code);
+ sc->args=cons(sc,sc->code,sc->NIL);
+ sc->code=slot_value_in_env(f);
+ s_goto(sc,OP_APPLY);
+ }
+ }
+
+ case OP_LAMBDA1:
+ s_return(sc,mk_closure(sc, sc->value, sc->envir));
+
+#else
+ case OP_LAMBDA: /* lambda */
+ s_return(sc,mk_closure(sc, sc->code, sc->envir));
+
+#endif
+
+ case OP_MKCLOSURE: /* make-closure */
+ x=car(sc->args);
+ if(car(x)==sc->LAMBDA) {
+ x=cdr(x);
+ }
+ if(cdr(sc->args)==sc->NIL) {
+ y=sc->envir;
+ } else {
+ y=cadr(sc->args);
+ }
+ s_return(sc,mk_closure(sc, x, y));
+
+ case OP_QUOTE: /* quote */
+ s_return(sc,car(sc->code));
+
+ case OP_DEF0: /* define */
+ if(is_immutable(car(sc->code)))
+ Error_1(sc,"define: unable to alter immutable", car(sc->code));
+
+ if (is_pair(car(sc->code))) {
+ x = caar(sc->code);
+ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+ } else {
+ x = car(sc->code);
+ sc->code = cadr(sc->code);
+ }
+ if (!is_symbol(x)) {
+ Error_0(sc,"variable is not a symbol");
+ }
+ s_save(sc,OP_DEF1, sc->NIL, x);
+ s_goto(sc,OP_EVAL);
+
+ case OP_DEF1: /* define */
+ x=find_slot_in_env(sc,sc->envir,sc->code,0);
+ if (x != sc->NIL) {
+ set_slot_in_env(sc, x, sc->value);
+ } else {
+ new_slot_in_env(sc, sc->code, sc->value);
+ }
+ s_return(sc,sc->code);
+
+
+ case OP_DEFP: /* defined? */
+ x=sc->envir;
+ if(cdr(sc->args)!=sc->NIL) {
+ x=cadr(sc->args);
+ }
+ s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
+
+ case OP_SET0: /* set! */
+ if(is_immutable(car(sc->code)))
+ Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
+ s_save(sc,OP_SET1, sc->NIL, car(sc->code));
+ sc->code = cadr(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_SET1: /* set! */
+ y=find_slot_in_env(sc,sc->envir,sc->code,1);
+ if (y != sc->NIL) {
+ set_slot_in_env(sc, y, sc->value);
+ s_return(sc,sc->value);
+ } else {
+ Error_1(sc,"set!: unbound variable:", sc->code);
+ }
+
+ case OP_BEGIN: /* begin */
+ if (!is_pair(sc->code)) {
+ s_return(sc,sc->code);
+ }
+ if (cdr(sc->code) != sc->NIL) {
+ s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
+ }
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_IF0: /* if */
+ s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_IF1: /* if */
+ if (is_true(sc->value))
+ sc->code = car(sc->code);
+ else
+ sc->code = cadr(sc->code); /* (if #f 1) ==> () because
+ * car(sc->NIL) = sc->NIL */
+ s_goto(sc,OP_EVAL);
+
+ case OP_LET0: /* let */
+ sc->args = sc->NIL;
+ sc->value = sc->code;
+ sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
+ s_goto(sc,OP_LET1);
+
+ case OP_LET1: /* let (calculate parameters) */
+ sc->args = cons(sc, sc->value, sc->args);
+ if (is_pair(sc->code)) { /* continue */
+ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+ Error_1(sc, "Bad syntax of binding spec in let :", car(sc->code));
+ }
+ s_save(sc,OP_LET1, sc->args, cdr(sc->code));
+ sc->code = cadar(sc->code);
+ sc->args = sc->NIL;
+ s_goto(sc,OP_EVAL);
+ } else { /* end */
+ sc->args = reverse_in_place(sc, sc->NIL, sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ s_goto(sc,OP_LET2);
+ }
+
+ case OP_LET2: /* let */
+ new_frame_in_env(sc, sc->envir);
+ for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
+ y != sc->NIL; x = cdr(x), y = cdr(y)) {
+ new_slot_in_env(sc, caar(x), car(y));
+ }
+ if (is_symbol(car(sc->code))) { /* named let */
+ for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
+ if (!is_pair(x))
+ Error_1(sc, "Bad syntax of binding in let :", x);
+ if (!is_list(sc, car(x)))
+ Error_1(sc, "Bad syntax of binding in let :", car(x));
+ sc->args = cons(sc, caar(x), sc->args);
+ }
+ x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
+ new_slot_in_env(sc, car(sc->code), x);
+ sc->code = cddr(sc->code);
+ sc->args = sc->NIL;
+ } else {
+ sc->code = cdr(sc->code);
+ sc->args = sc->NIL;
+ }
+ s_goto(sc,OP_BEGIN);
+
+ case OP_LET0AST: /* let* */
+ if (car(sc->code) == sc->NIL) {
+ new_frame_in_env(sc, sc->envir);
+ sc->code = cdr(sc->code);
+ s_goto(sc,OP_BEGIN);
+ }
+ if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
+ Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
+ }
+ s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
+ sc->code = cadaar(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_LET1AST: /* let* (make new frame) */
+ new_frame_in_env(sc, sc->envir);
+ s_goto(sc,OP_LET2AST);
+
+ case OP_LET2AST: /* let* (calculate parameters) */
+ new_slot_in_env(sc, caar(sc->code), sc->value);
+ sc->code = cdr(sc->code);
+ if (is_pair(sc->code)) { /* continue */
+ s_save(sc,OP_LET2AST, sc->args, sc->code);
+ sc->code = cadar(sc->code);
+ sc->args = sc->NIL;
+ s_goto(sc,OP_EVAL);
+ } else { /* end */
+ sc->code = sc->args;
+ sc->args = sc->NIL;
+ s_goto(sc,OP_BEGIN);
+ }
+ default:
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
+ Error_0(sc,sc->strbuff);
+ }
+ return sc->T;
+}
+
+static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
+ pointer x, y;
+
+ switch (op) {
+ case OP_LET0REC: /* letrec */
+ new_frame_in_env(sc, sc->envir);
+ sc->args = sc->NIL;
+ sc->value = sc->code;
+ sc->code = car(sc->code);
+ s_goto(sc,OP_LET1REC);
+
+ case OP_LET1REC: /* letrec (calculate parameters) */
+ sc->args = cons(sc, sc->value, sc->args);
+ if (is_pair(sc->code)) { /* continue */
+ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+ Error_1(sc,"Bad syntax of binding spec in letrec :",car(sc->code));
+ }
+ s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
+ sc->code = cadar(sc->code);
+ sc->args = sc->NIL;
+ s_goto(sc,OP_EVAL);
+ } else { /* end */
+ sc->args = reverse_in_place(sc, sc->NIL, sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ s_goto(sc,OP_LET2REC);
+ }
+
+ case OP_LET2REC: /* letrec */
+ for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
+ new_slot_in_env(sc, caar(x), car(y));
+ }
+ sc->code = cdr(sc->code);
+ sc->args = sc->NIL;
+ s_goto(sc,OP_BEGIN);
+
+ case OP_COND0: /* cond */
+ if (!is_pair(sc->code)) {
+ Error_0(sc,"syntax error in cond");
+ }
+ s_save(sc,OP_COND1, sc->NIL, sc->code);
+ sc->code = caar(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_COND1: /* cond */
+ if (is_true(sc->value)) {
+ if ((sc->code = cdar(sc->code)) == sc->NIL) {
+ s_return(sc,sc->value);
+ }
+ if(!sc->code) {
+ Error_0(sc,"syntax error in cond");
+ }
+ if(car(sc->code)==sc->FEED_TO) {
+ if(!is_pair(cdr(sc->code))) {
+ Error_0(sc,"syntax error in cond");
+ }
+ x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
+ sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
+ s_goto(sc,OP_EVAL);
+ }
+ s_goto(sc,OP_BEGIN);
+ } else {
+ if ((sc->code = cdr(sc->code)) == sc->NIL) {
+ s_return(sc,sc->NIL);
+ } else {
+ s_save(sc,OP_COND1, sc->NIL, sc->code);
+ sc->code = caar(sc->code);
+ s_goto(sc,OP_EVAL);
+ }
+ }
+
+ case OP_DELAY: /* delay */
+ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
+ typeflag(x)=T_PROMISE;
+ s_return(sc,x);
+
+ case OP_AND0: /* and */
+ if (sc->code == sc->NIL) {
+ s_return(sc,sc->T);
+ }
+ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_AND1: /* and */
+ if (is_false(sc->value)) {
+ s_return(sc,sc->value);
+ } else if (sc->code == sc->NIL) {
+ s_return(sc,sc->value);
+ } else {
+ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+ }
+
+ case OP_OR0: /* or */
+ if (sc->code == sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_OR1: /* or */
+ if (is_true(sc->value)) {
+ s_return(sc,sc->value);
+ } else if (sc->code == sc->NIL) {
+ s_return(sc,sc->value);
+ } else {
+ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+ }
+
+ case OP_C0STREAM: /* cons-stream */
+ s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_C1STREAM: /* cons-stream */
+ sc->args = sc->value; /* save sc->value to register sc->args for gc */
+ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
+ typeflag(x)=T_PROMISE;
+ s_return(sc,cons(sc, sc->args, x));
+
+ case OP_MACRO0: /* macro */
+ if (is_pair(car(sc->code))) {
+ x = caar(sc->code);
+ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+ } else {
+ x = car(sc->code);
+ sc->code = cadr(sc->code);
+ }
+ if (!is_symbol(x)) {
+ Error_0(sc,"variable is not a symbol");
+ }
+ s_save(sc,OP_MACRO1, sc->NIL, x);
+ s_goto(sc,OP_EVAL);
+
+ case OP_MACRO1: /* macro */
+ typeflag(sc->value) = T_MACRO;
+ x = find_slot_in_env(sc, sc->envir, sc->code, 0);
+ if (x != sc->NIL) {
+ set_slot_in_env(sc, x, sc->value);
+ } else {
+ new_slot_in_env(sc, sc->code, sc->value);
+ }
+ s_return(sc,sc->code);
+
+ case OP_CASE0: /* case */
+ s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_goto(sc,OP_EVAL);
+
+ case OP_CASE1: /* case */
+ for (x = sc->code; x != sc->NIL; x = cdr(x)) {
+ if (!is_pair(y = caar(x))) {
+ break;
+ }
+ for ( ; y != sc->NIL; y = cdr(y)) {
+ if (eqv(car(y), sc->value)) {
+ break;
+ }
+ }
+ if (y != sc->NIL) {
+ break;
+ }
+ }
+ if (x != sc->NIL) {
+ if (is_pair(caar(x))) {
+ sc->code = cdar(x);
+ s_goto(sc,OP_BEGIN);
+ } else {/* else */
+ s_save(sc,OP_CASE2, sc->NIL, cdar(x));
+ sc->code = caar(x);
+ s_goto(sc,OP_EVAL);
+ }
+ } else {
+ s_return(sc,sc->NIL);
+ }
+
+ case OP_CASE2: /* case */
+ if (is_true(sc->value)) {
+ s_goto(sc,OP_BEGIN);
+ } else {
+ s_return(sc,sc->NIL);
+ }
+
+ case OP_PAPPLY: /* apply */
+ sc->code = car(sc->args);
+ sc->args = list_star(sc,cdr(sc->args));
+ /*sc->args = cadr(sc->args);*/
+ s_goto(sc,OP_APPLY);
+
+ case OP_PEVAL: /* eval */
+ if(cdr(sc->args)!=sc->NIL) {
+ sc->envir=cadr(sc->args);
+ }
+ sc->code = car(sc->args);
+ s_goto(sc,OP_EVAL);
+
+ case OP_CONTINUATION: /* call-with-current-continuation */
+ sc->code = car(sc->args);
+ sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
+ s_goto(sc,OP_APPLY);
+
+ default:
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
+ Error_0(sc,sc->strbuff);
+ }
+ return sc->T;
+}
+
+static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
+ pointer x;
+ num v;
+#if USE_MATH
+ double dd;
+#endif
+
+ switch (op) {
+#if USE_MATH
+ case OP_INEX2EX: /* inexact->exact */
+ x=car(sc->args);
+ if(num_is_integer(x)) {
+ s_return(sc,x);
+ } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
+ s_return(sc,mk_integer(sc,ivalue(x)));
+ } else {
+ Error_1(sc,"inexact->exact: not integral:",x);
+ }
+
+ case OP_EXP:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, exp(rvalue(x))));
+
+ case OP_LOG:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, log(rvalue(x))));
+
+ case OP_SIN:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, sin(rvalue(x))));
+
+ case OP_COS:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, cos(rvalue(x))));
+
+ case OP_TAN:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, tan(rvalue(x))));
+
+ case OP_ASIN:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, asin(rvalue(x))));
+
+ case OP_ACOS:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, acos(rvalue(x))));
+
+ case OP_ATAN:
+ x=car(sc->args);
+ if(cdr(sc->args)==sc->NIL) {
+ s_return(sc, mk_real(sc, atan(rvalue(x))));
+ } else {
+ pointer y=cadr(sc->args);
+ s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
+ }
+
+ case OP_SQRT:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, sqrt(rvalue(x))));
+
+ case OP_EXPT: {
+ double result;
+ int real_result=1;
+ pointer y=cadr(sc->args);
+ x=car(sc->args);
+ if (num_is_integer(x) && num_is_integer(y))
+ real_result=0;
+ /* This 'if' is an R5RS compatibility fix. */
+ /* NOTE: Remove this 'if' fix for R6RS. */
+ if (rvalue(x) == 0 && rvalue(y) < 0) {
+ result = 0.0;
+ } else {
+ result = pow(rvalue(x),rvalue(y));
+ }
+ /* Before returning integer result make sure we can. */
+ /* If the test fails, result is too big for integer. */
+ if (!real_result)
+ {
+ long result_as_long = (long)result;
+ if (result != (double)result_as_long)
+ real_result = 1;
+ }
+ if (real_result) {
+ s_return(sc, mk_real(sc, result));
+ } else {
+ s_return(sc, mk_integer(sc, result));
+ }
+ }
+
+ case OP_FLOOR:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, floor(rvalue(x))));
+
+ case OP_CEILING:
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, ceil(rvalue(x))));
+
+ case OP_TRUNCATE : {
+ double rvalue_of_x ;
+ x=car(sc->args);
+ rvalue_of_x = rvalue(x) ;
+ if (rvalue_of_x > 0) {
+ s_return(sc, mk_real(sc, floor(rvalue_of_x)));
+ } else {
+ s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
+ }
+ }
+
+ case OP_ROUND:
+ x=car(sc->args);
+ if (num_is_integer(x))
+ s_return(sc, x);
+ s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
+#endif
+
+ case OP_ADD: /* + */
+ v=num_zero;
+ for (x = sc->args; x != sc->NIL; x = cdr(x)) {
+ v=num_add(v,nvalue(car(x)));
+ }
+ s_return(sc,mk_number(sc, v));
+
+ case OP_MUL: /* * */
+ v=num_one;
+ for (x = sc->args; x != sc->NIL; x = cdr(x)) {
+ v=num_mul(v,nvalue(car(x)));
+ }
+ s_return(sc,mk_number(sc, v));
+
+ case OP_SUB: /* - */
+ if(cdr(sc->args)==sc->NIL) {
+ x=sc->args;
+ v=num_zero;
+ } else {
+ x = cdr(sc->args);
+ v = nvalue(car(sc->args));
+ }
+ for (; x != sc->NIL; x = cdr(x)) {
+ v=num_sub(v,nvalue(car(x)));
+ }
+ s_return(sc,mk_number(sc, v));
+
+ case OP_DIV: /* / */
+ if(cdr(sc->args)==sc->NIL) {
+ x=sc->args;
+ v=num_one;
+ } else {
+ x = cdr(sc->args);
+ v = nvalue(car(sc->args));
+ }
+ for (; x != sc->NIL; x = cdr(x)) {
+ if (!is_zero_double(rvalue(car(x))))
+ v=num_div(v,nvalue(car(x)));
+ else {
+ Error_0(sc,"/: division by zero");
+ }
+ }
+ s_return(sc,mk_number(sc, v));
+
+ case OP_INTDIV: /* quotient */
+ if(cdr(sc->args)==sc->NIL) {
+ x=sc->args;
+ v=num_one;
+ } else {
+ x = cdr(sc->args);
+ v = nvalue(car(sc->args));
+ }
+ for (; x != sc->NIL; x = cdr(x)) {
+ if (ivalue(car(x)) != 0)
+ v=num_intdiv(v,nvalue(car(x)));
+ else {
+ Error_0(sc,"quotient: division by zero");
+ }
+ }
+ s_return(sc,mk_number(sc, v));
+
+ case OP_REM: /* remainder */
+ v = nvalue(car(sc->args));
+ if (ivalue(cadr(sc->args)) != 0)
+ v=num_rem(v,nvalue(cadr(sc->args)));
+ else {
+ Error_0(sc,"remainder: division by zero");
+ }
+ s_return(sc,mk_number(sc, v));
+
+ case OP_MOD: /* modulo */
+ v = nvalue(car(sc->args));
+ if (ivalue(cadr(sc->args)) != 0)
+ v=num_mod(v,nvalue(cadr(sc->args)));
+ else {
+ Error_0(sc,"modulo: division by zero");
+ }
+ s_return(sc,mk_number(sc, v));
+
+ case OP_CAR: /* car */
+ s_return(sc,caar(sc->args));
+
+ case OP_CDR: /* cdr */
+ s_return(sc,cdar(sc->args));
+
+ case OP_CONS: /* cons */
+ cdr(sc->args) = cadr(sc->args);
+ s_return(sc,sc->args);
+
+ case OP_SETCAR: /* set-car! */
+ if(!is_immutable(car(sc->args))) {
+ caar(sc->args) = cadr(sc->args);
+ s_return(sc,car(sc->args));
+ } else {
+ Error_0(sc,"set-car!: unable to alter immutable pair");
+ }
+
+ case OP_SETCDR: /* set-cdr! */
+ if(!is_immutable(car(sc->args))) {
+ cdar(sc->args) = cadr(sc->args);
+ s_return(sc,car(sc->args));
+ } else {
+ Error_0(sc,"set-cdr!: unable to alter immutable pair");
+ }
+
+ case OP_CHAR2INT: { /* char->integer */
+ gunichar c;
+ c=ivalue(car(sc->args));
+ s_return(sc,mk_integer(sc,c));
+ }
+
+ case OP_INT2CHAR: { /* integer->char */
+ gunichar c;
+ c=(gunichar)ivalue(car(sc->args));
+ s_return(sc,mk_character(sc,c));
+ }
+
+ case OP_CHARUPCASE: {
+ gunichar c;
+ c=(gunichar)ivalue(car(sc->args));
+ c=g_unichar_toupper(c);
+ s_return(sc,mk_character(sc,c));
+ }
+
+ case OP_CHARDNCASE: {
+ gunichar c;
+ c=(gunichar)ivalue(car(sc->args));
+ c=g_unichar_tolower(c);
+ s_return(sc,mk_character(sc,c));
+ }
+
+ case OP_STR2SYM: /* string->symbol */
+ s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
+
+ case OP_STR2ATOM: /* string->atom */ {
+ char *s=strvalue(car(sc->args));
+ long pf = 0;
+ if(cdr(sc->args)!=sc->NIL) {
+ /* we know cadr(sc->args) is a natural number */
+ /* see if it is 2, 8, 10, or 16, or error */
+ pf = ivalue_unchecked(cadr(sc->args));
+ if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
+ /* base is OK */
+ }
+ else {
+ pf = -1;
+ }
+ }
+ if (pf < 0) {
+ Error_1(sc, "string->atom: bad base:", cadr(sc->args));
+ } else if(*s=='#') /* no use of base! */ {
+ s_return(sc, mk_sharp_const(sc, s+1));
+ } else {
+ if (pf == 0 || pf == 10) {
+ s_return(sc, mk_atom(sc, s));
+ }
+ else {
+ char *ep;
+ long iv = strtol(s,&ep,(int )pf);
+ if (*ep == 0) {
+ s_return(sc, mk_integer(sc, iv));
+ }
+ else {
+ s_return(sc, sc->F);
+ }
+ }
+ }
+ }
+
+ case OP_SYM2STR: /* symbol->string */
+ x=mk_string(sc,symname(car(sc->args)));
+ setimmutable(x);
+ s_return(sc,x);
+
+ case OP_ATOM2STR: /* atom->string */ {
+ long pf = 0;
+ x=car(sc->args);
+ if(cdr(sc->args)!=sc->NIL) {
+ /* we know cadr(sc->args) is a natural number */
+ /* see if it is 2, 8, 10, or 16, or error */
+ pf = ivalue_unchecked(cadr(sc->args));
+ if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
+ /* base is OK */
+ }
+ else {
+ pf = -1;
+ }
+ }
+ if (pf < 0) {
+ Error_1(sc, "atom->string: bad base:", cadr(sc->args));
+ } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
+ char *p;
+ int len;
+ atom2str(sc,x,(int )pf,&p,&len);
+ s_return(sc,mk_counted_string(sc,p,len));
+ } else {
+ Error_1(sc, "atom->string: not an atom:", x);
+ }
+ }
+
+ case OP_MKSTRING: { /* make-string */
+ gunichar fill=' ';
+ int len;
+
+ len=ivalue(car(sc->args));
+
+ if(cdr(sc->args)!=sc->NIL) {
+ fill=charvalue(cadr(sc->args));
+ }
+ s_return(sc,mk_empty_string(sc,len,fill));
+ }
+
+ case OP_STRLEN: /* string-length */
+ s_return(sc,mk_integer(sc,g_utf8_strlen(strvalue(car(sc->args)), -1)));
+
+ case OP_STRREF: { /* string-ref */
+ char *str;
+ int index;
+
+ str=strvalue(car(sc->args));
+
+ index=ivalue(cadr(sc->args));
+
+ if(index>=g_utf8_strlen(strvalue(car(sc->args)), -1)) {
+ Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
+ }
+
+ str = g_utf8_offset_to_pointer(str, (long)index);
+ s_return(sc,mk_character(sc, g_utf8_get_char(str)));
+ }
+
+ case OP_STRSET: { /* string-set! */
+ pointer a;
+ char *str;
+ int index;
+ gunichar c;
+ char utf8[7];
+ int utf8_len;
+ int newlen;
+ char *p1, *p2;
+ int p1_len;
+ int p2_len;
+ char *newstr;
+
+ a=car(sc->args);
+ if(is_immutable(a)) {
+ Error_1(sc,"string-set!: unable to alter immutable string:",a);
+ }
+
+ str=strvalue(a);
+ index=ivalue(cadr(sc->args));
+ if(index>=g_utf8_strlen(str, -1)) {
+ Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
+ }
+
+ c=charvalue(caddr(sc->args));
+ utf8_len = g_unichar_to_utf8(c, utf8);
+
+ p1 = g_utf8_offset_to_pointer(str, (long)index);
+ p2 = g_utf8_offset_to_pointer(str, (long)index+1);
+ p1_len = p1-str;
+ p2_len = strlen(p2);
+
+ newlen = p1_len+utf8_len+p2_len;
+ newstr = (char *)sc->malloc(newlen+1);
+ if (newstr == NULL) {
+ sc->no_memory=1;
+ Error_1(sc,"string-set!: No memory to alter string:",car(sc->args));
+ }
+
+ if (p1_len > 0)
+ memcpy(newstr, str, p1_len);
+ memcpy(newstr+p1_len, utf8, utf8_len);
+ if (p2_len > 0)
+ memcpy(newstr+p1_len+utf8_len, p2, p2_len);
+ newstr[newlen] = '\0';
+
+ free(strvalue(a));
+ strvalue(a)=newstr;
+ strlength(a)=g_utf8_strlen(newstr, -1);
+
+ s_return(sc,a);
+ }
+
+ case OP_STRAPPEND: { /* string-append */
+ /* in 1.29 string-append was in Scheme in init.scm but was too slow */
+ int len = 0;
+ pointer car_x;
+ char *newstr;
+ char *pos;
+ char *end;
+
+ /* compute needed length for new string */
+ for (x = sc->args; x != sc->NIL; x = cdr(x)) {
+ car_x = car(x);
+ end = g_utf8_offset_to_pointer(strvalue(car_x), (long)strlength(car_x));
+ len += end - strvalue(car_x);
+ }
+
+ newstr = (char *)sc->malloc(len+1);
+ if (newstr == NULL) {
+ sc->no_memory=1;
+ Error_1(sc,"string-set!: No memory to append strings:",car(sc->args));
+ }
+
+ /* store the contents of the argument strings into the new string */
+ pos = newstr;
+ for (x = sc->args; x != sc->NIL; x = cdr(x)) {
+ car_x = car(x);
+ end = g_utf8_offset_to_pointer(strvalue(car_x), (long)strlength(car_x));
+ len = end - strvalue(car_x);
+ memcpy(pos, strvalue(car_x), len);
+ pos += len;
+ }
+ *pos = '\0';
+
+ car_x = mk_string(sc, newstr);
+ g_free(newstr);
+
+ s_return(sc, car_x);
+ }
+
+ case OP_SUBSTR: { /* substring */
+ char *str;
+ char *beg;
+ char *end;
+ int index0;
+ int index1;
+ int len;
+ pointer x;
+
+ str=strvalue(car(sc->args));
+
+ index0=ivalue(cadr(sc->args));
+
+ if(index0>g_utf8_strlen(str, -1)) {
+ Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
+ }
+
+ if(cddr(sc->args)!=sc->NIL) {
+ index1=ivalue(caddr(sc->args));
+ if(index1>g_utf8_strlen(str, -1) || index1<index0) {
+ Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
+ }
+ } else {
+ index1=g_utf8_strlen(str, -1);
+ }
+
+ /* store the contents of the argument strings into the new string */
+ beg = g_utf8_offset_to_pointer(str, (long)index0);
+ end = g_utf8_offset_to_pointer(str, (long)index1);
+ len=end-beg;
+
+ str = (char *)sc->malloc(len+1);
+ if (str == NULL) {
+ sc->no_memory=1;
+ Error_1(sc,"string-set!: No memory to extract substring:",car(sc->args));
+ }
+
+ memcpy(str, beg, len);
+ str[len] = '\0';
+
+ x = mk_string(sc, str);
+ g_free(str);
+
+ s_return(sc,x);
+ }
+
+ case OP_VECTOR: { /* vector */
+ int i;
+ pointer vec;
+ int len=list_length(sc,sc->args);
+ if(len<0) {
+ Error_1(sc,"vector: not a proper list:",sc->args);
+ }
+ vec=mk_vector(sc,len);
+ if(sc->no_memory) { s_return(sc, sc->sink); }
+ for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
+ set_vector_elem(vec,i,car(x));
+ }
+ s_return(sc,vec);
+ }
+
+ case OP_MKVECTOR: { /* make-vector */
+ pointer fill=sc->NIL;
+ int len;
+ pointer vec;
+
+ len=ivalue(car(sc->args));
+
+ if(cdr(sc->args)!=sc->NIL) {
+ fill=cadr(sc->args);
+ }
+ vec=mk_vector(sc,len);
+ if(sc->no_memory) { s_return(sc, sc->sink); }
+ if(fill!=sc->NIL) {
+ fill_vector(vec,fill);
+ }
+ s_return(sc,vec);
+ }
+
+ case OP_VECLEN: /* vector-length */
+ s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
+
+ case OP_VECREF: { /* vector-ref */
+ int index;
+
+ index=ivalue(cadr(sc->args));
+
+ if(index>=ivalue(car(sc->args))) {
+ Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
+ }
+
+ s_return(sc,vector_elem(car(sc->args),index));
+ }
+
+ case OP_VECSET: { /* vector-set! */
+ int index;
+
+ if(is_immutable(car(sc->args))) {
+ Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
+ }
+
+ index=ivalue(cadr(sc->args));
+ if(index>=ivalue(car(sc->args))) {
+ Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
+ }
+
+ set_vector_elem(car(sc->args),index,caddr(sc->args));
+ s_return(sc,car(sc->args));
+ }
+
+ default:
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
+ Error_0(sc,sc->strbuff);
+ }
+ return sc->T;
+}
+
+static int is_list(scheme *sc, pointer a)
+{ return list_length(sc,a) >= 0; }
+
+/* Result is:
+ proper list: length
+ circular list: -1
+ not even a pair: -2
+ dotted list: -2 minus length before dot
+*/
+int list_length(scheme *sc, pointer p) {
+ int i=0;
+ pointer slow, fast;
+
+ slow = fast = p;
+ while (1)
+ {
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ fast = cdr(fast);
+ ++i;
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ ++i;
+ fast = cdr(fast);
+
+ /* Safe because we would have already returned if `fast'
+ encountered a non-pair. */
+ slow = cdr(slow);
+ if (fast == slow)
+ {
+ /* the fast pointer has looped back around and caught up
+ with the slow pointer, hence the structure is circular,
+ not of finite length, and therefore not a list */
+ return -1;
+ }
+ }
+}
+
+static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
+ pointer x;
+ num v;
+ int (*comp_func)(num,num)=0;
+
+ switch (op) {
+ case OP_NOT: /* not */
+ s_retbool(is_false(car(sc->args)));
+ case OP_BOOLP: /* boolean? */
+ s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
+ case OP_EOFOBJP: /* boolean? */
+ s_retbool(car(sc->args) == sc->EOF_OBJ);
+ case OP_NULLP: /* null? */
+ s_retbool(car(sc->args) == sc->NIL);
+ case OP_NUMEQ: /* = */
+ case OP_LESS: /* < */
+ case OP_GRE: /* > */
+ case OP_LEQ: /* <= */
+ case OP_GEQ: /* >= */
+ switch(op) {
+ case OP_NUMEQ: comp_func=num_eq; break;
+ case OP_LESS: comp_func=num_lt; break;
+ case OP_GRE: comp_func=num_gt; break;
+ case OP_LEQ: comp_func=num_le; break;
+ case OP_GEQ: comp_func=num_ge; break;
+ default: break; /* Quiet the compiler */
+ }
+ x=sc->args;
+ v=nvalue(car(x));
+ x=cdr(x);
+
+ for (; x != sc->NIL; x = cdr(x)) {
+ if(!comp_func(v,nvalue(car(x)))) {
+ s_retbool(0);
+ }
+ v=nvalue(car(x));
+ }
+ s_retbool(1);
+ case OP_SYMBOLP: /* symbol? */
+ s_retbool(is_symbol(car(sc->args)));
+ case OP_NUMBERP: /* number? */
+ s_retbool(is_number(car(sc->args)));
+ case OP_STRINGP: /* string? */
+ s_retbool(is_string(car(sc->args)));
+ case OP_INTEGERP: /* integer? */
+ s_retbool(is_integer(car(sc->args)));
+ case OP_REALP: /* real? */
+ s_retbool(is_number(car(sc->args))); /* All numbers are real */
+ case OP_CHARP: /* char? */
+ s_retbool(is_character(car(sc->args)));
+#if USE_CHAR_CLASSIFIERS
+ case OP_CHARAP: /* char-alphabetic? */
+ s_retbool(Cisalpha(ivalue(car(sc->args))));
+ case OP_CHARNP: /* char-numeric? */
+ s_retbool(Cisdigit(ivalue(car(sc->args))));
+ case OP_CHARWP: /* char-whitespace? */
+ s_retbool(Cisspace(ivalue(car(sc->args))));
+ case OP_CHARUP: /* char-upper-case? */
+ s_retbool(Cisupper(ivalue(car(sc->args))));
+ case OP_CHARLP: /* char-lower-case? */
+ s_retbool(Cislower(ivalue(car(sc->args))));
+#endif
+ case OP_PORTP: /* port? */
+ s_retbool(is_port(car(sc->args)));
+ case OP_INPORTP: /* input-port? */
+ s_retbool(is_inport(car(sc->args)));
+ case OP_OUTPORTP: /* output-port? */
+ s_retbool(is_outport(car(sc->args)));
+ case OP_PROCP: /* procedure? */
+ /*--
+ * continuation should be procedure by the example
+ * (call-with-current-continuation procedure?) ==> #t
+ * in R^3 report sec. 6.9
+ */
+ s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
+ || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
+ case OP_PAIRP: /* pair? */
+ s_retbool(is_pair(car(sc->args)));
+ case OP_LISTP: /* list? */
+ s_retbool(list_length(sc,car(sc->args)) >= 0);
+ case OP_ENVP: /* environment? */
+ s_retbool(is_environment(car(sc->args)));
+ case OP_VECTORP: /* vector? */
+ s_retbool(is_vector(car(sc->args)));
+ case OP_EQ: /* eq? */
+ s_retbool(car(sc->args) == cadr(sc->args));
+ case OP_EQV: /* eqv? */
+ s_retbool(eqv(car(sc->args), cadr(sc->args)));
+ default:
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
+ Error_0(sc,sc->strbuff);
+ }
+ return sc->T;
+}
+
+static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
+ pointer x, y;
+
+ switch (op) {
+ case OP_FORCE: /* force */
+ sc->code = car(sc->args);
+ if (is_promise(sc->code)) {
+ /* Should change type to closure here */
+ s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
+ sc->args = sc->NIL;
+ s_goto(sc,OP_APPLY);
+ } else {
+ s_return(sc,sc->code);
+ }
+
+ case OP_SAVE_FORCED: /* Save forced value replacing promise */
+ memcpy(sc->code,sc->value,sizeof(struct cell));
+ s_return(sc,sc->value);
+
+ case OP_WRITE: /* write */
+ case OP_DISPLAY: /* display */
+ case OP_WRITE_CHAR: /* write-char */
+ if(is_pair(cdr(sc->args))) {
+ if(cadr(sc->args)!=sc->outport) {
+ x=cons(sc,sc->outport,sc->NIL);
+ s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
+ sc->outport=cadr(sc->args);
+ }
+ }
+ sc->args = car(sc->args);
+ if(op==OP_WRITE) {
+ sc->print_flag = 1;
+ } else {
+ sc->print_flag = 0;
+ }
+ s_goto(sc,OP_P0LIST);
+
+ case OP_NEWLINE: /* newline */
+ if(is_pair(sc->args)) {
+ if(car(sc->args)!=sc->outport) {
+ x=cons(sc,sc->outport,sc->NIL);
+ s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
+ sc->outport=car(sc->args);
+ }
+ }
+ putstr(sc, "\n");
+ s_return(sc,sc->T);
+
+ case OP_ERR0: /* error */
+ sc->retcode=-1;
+ if (!is_string(car(sc->args))) {
+ sc->args=cons(sc,mk_string(sc," -- "),sc->args);
+ setimmutable(car(sc->args));
+ }
+ putstr(sc, "Error: ");
+ putstr(sc, strvalue(car(sc->args)));
+ sc->args = cdr(sc->args);
+ s_goto(sc,OP_ERR1);
+
+ case OP_ERR1: /* error */
+ putstr(sc, " ");
+ if (sc->args != sc->NIL) {
+ s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
+ sc->args = car(sc->args);
+ sc->print_flag = 1;
+ s_goto(sc,OP_P0LIST);
+ } else {
+ putstr(sc, "\n");
+ if(sc->interactive_repl) {
+ s_goto(sc,OP_T0LVL);
+ } else {
+ return sc->NIL;
+ }
+ }
+
+ case OP_REVERSE: /* reverse */
+ s_return(sc,reverse(sc, car(sc->args)));
+
+ case OP_LIST_STAR: /* list* */
+ s_return(sc,list_star(sc,sc->args));
+
+ case OP_APPEND: /* append */
+ x = sc->NIL;
+ y = sc->args;
+ if (y == x) {
+ s_return(sc, x);
+ }
+
+ /* cdr() in the while condition is not a typo. If car() */
+ /* is used (append '() 'a) will return the wrong result.*/
+ while (cdr(y) != sc->NIL) {
+ x = revappend(sc, x, car(y));
+ y = cdr(y);
+ if (x == sc->F) {
+ Error_0(sc, "non-list argument to append");
+ }
+ }
+
+ s_return(sc, reverse_in_place(sc, car(y), x));
+
+#if USE_PLIST
+ case OP_PUT: /* put */
+ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
+ Error_0(sc,"illegal use of put");
+ }
+ for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
+ if (caar(x) == y) {
+ break;
+ }
+ }
+ if (x != sc->NIL)
+ cdar(x) = caddr(sc->args);
+ else
+ symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
+ symprop(car(sc->args)));
+ s_return(sc,sc->T);
+
+ case OP_GET: /* get */
+ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
+ Error_0(sc,"illegal use of get");
+ }
+ for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
+ if (caar(x) == y) {
+ break;
+ }
+ }
+ if (x != sc->NIL) {
+ s_return(sc,cdar(x));
+ } else {
+ s_return(sc,sc->NIL);
+ }
+#endif /* USE_PLIST */
+ case OP_QUIT: /* quit */
+ if(is_pair(sc->args)) {
+ sc->retcode=ivalue(car(sc->args));
+ }
+ return (sc->NIL);
+
+ case OP_GC: /* gc */
+ gc(sc, sc->NIL, sc->NIL);
+ s_return(sc,sc->T);
+
+ case OP_GCVERB: /* gc-verbose */
+ { int was = sc->gc_verbose;
+
+ sc->gc_verbose = (car(sc->args) != sc->F);
+ s_retbool(was);
+ }
+
+ case OP_NEWSEGMENT: /* new-segment */
+ if (!is_pair(sc->args) || !is_number(car(sc->args))) {
+ Error_0(sc,"new-segment: argument must be a number");
+ }
+ alloc_cellseg(sc, (int) ivalue(car(sc->args)));
+ s_return(sc,sc->T);
+
+ case OP_OBLIST: /* oblist */
+ s_return(sc, oblist_all_symbols(sc));
+
+ case OP_CURR_INPORT: /* current-input-port */
+ s_return(sc,sc->inport);
+
+ case OP_CURR_OUTPORT: /* current-output-port */
+ s_return(sc,sc->outport);
+
+ case OP_OPEN_INFILE: /* open-input-file */
+ case OP_OPEN_OUTFILE: /* open-output-file */
+ case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
+ int prop=0;
+ pointer p;
+ switch(op) {
+ case OP_OPEN_INFILE: prop=port_input; break;
+ case OP_OPEN_OUTFILE: prop=port_output; break;
+ case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
+ default: break; /* Quiet the compiler */
+ }
+ p=port_from_filename(sc,strvalue(car(sc->args)),prop);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ s_return(sc,p);
+ }
+
+#if USE_STRING_PORTS
+ case OP_OPEN_INSTRING: /* open-input-string */
+ case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
+ int prop=0;
+ pointer p;
+ switch(op) {
+ case OP_OPEN_INSTRING: prop=port_input; break;
+ case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break;
+ default: break; /* Quiet the compiler */
+ }
+ p=port_from_string(sc, strvalue(car(sc->args)),
+ g_utf8_offset_to_pointer(strvalue(car(sc->args)),
+ strlength(car(sc->args))), prop);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ s_return(sc,p);
+ }
+ case OP_OPEN_OUTSTRING: /* open-output-string */ {
+ pointer p;
+ if(car(sc->args)==sc->NIL) {
+ p=port_from_scratch(sc);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ } else {
+ p=port_from_string(sc, strvalue(car(sc->args)),
+ strvalue(car(sc->args))+strlength(car(sc->args)),
+ port_output);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ }
+ s_return(sc,p);
+ }
+ case OP_GET_OUTSTRING: /* get-output-string */ {
+ port *p;
+
+ if ((p=car(sc->args)->_object._port)->kind&port_string) {
+ off_t size;
+ char *str;
+
+ size=p->rep.string.curr-p->rep.string.start+1;
+ str=sc->malloc(size);
+ if(str != NULL) {
+ pointer s;
+
+ memcpy(str,p->rep.string.start,size-1);
+ str[size-1]='\0';
+ s=mk_string(sc,str);
+ sc->free(str);
+ s_return(sc,s);
+ }
+ }
+ s_return(sc,sc->F);
+ }
+#endif
+
+ case OP_CLOSE_INPORT: /* close-input-port */
+ port_close(sc,car(sc->args),port_input);
+ s_return(sc,sc->T);
+
+ case OP_CLOSE_OUTPORT: /* close-output-port */
+ port_close(sc,car(sc->args),port_output);
+ s_return(sc,sc->T);
+
+ case OP_INT_ENV: /* interaction-environment */
+ s_return(sc,sc->global_env);
+
+ case OP_CURR_ENV: /* current-environment */
+ s_return(sc,sc->envir);
+
+ default:
+ sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+ Error_0(sc,sc->strbuff);
+ }
+ return sc->T;
+}
+
+static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
+ pointer x;
+ char *trans_str;
+
+ if(sc->nesting!=0) {
+ int n=sc->nesting;
+ sc->nesting=0;
+ sc->retcode=-1;
+ Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
+ }
+
+ switch (op) {
+ /* ========== reading part ========== */
+ case OP_READ:
+ if(!is_pair(sc->args)) {
+ s_goto(sc,OP_READ_INTERNAL);
+ }
+ if(!is_inport(car(sc->args))) {
+ Error_1(sc,"read: not an input port:",car(sc->args));
+ }
+ if(car(sc->args)==sc->inport) {
+ s_goto(sc,OP_READ_INTERNAL);
+ }
+ x=sc->inport;
+ sc->inport=car(sc->args);
+ x=cons(sc,x,sc->NIL);
+ s_save(sc,OP_SET_INPORT, x, sc->NIL);
+ s_goto(sc,OP_READ_INTERNAL);
+
+ case OP_READ_CHAR: /* read-char */
+ case OP_PEEK_CHAR: /* peek-char */ {
+ gunichar c;
+ if(is_pair(sc->args)) {
+ if(car(sc->args)!=sc->inport) {
+ x=sc->inport;
+ x=cons(sc,x,sc->NIL);
+ s_save(sc,OP_SET_INPORT, x, sc->NIL);
+ sc->inport=car(sc->args);
+ }
+ }
+ c=inchar(sc);
+ if(c==EOF) {
+ s_return(sc,sc->EOF_OBJ);
+ }
+ if(sc->op==OP_PEEK_CHAR) {
+ backchar(sc,c);
+ }
+ s_return(sc,mk_character(sc,c));
+ }
+
+ case OP_CHAR_READY: /* char-ready? */ {
+ pointer p=sc->inport;
+ int res;
+ if(is_pair(sc->args)) {
+ p=car(sc->args);
+ }
+ res=p->_object._port->kind&port_string;
+ s_retbool(res);
+ }
+
+ case OP_SET_INPORT: /* set-input-port */
+ sc->inport=car(sc->args);
+ s_return(sc,sc->value);
+
+ case OP_SET_OUTPORT: /* set-output-port */
+ sc->outport=car(sc->args);
+ s_return(sc,sc->value);
+
+ case OP_RDSEXPR:
+ switch (sc->tok) {
+ case TOK_EOF:
+ s_return(sc,sc->EOF_OBJ);
+ /* NOTREACHED */
+/*
+ * Commented out because we now skip comments in the scanner
+ *
+ case TOK_COMMENT: {
+ gunichar c;
+ while ((c=inchar(sc)) != '\n' && c!=EOF)
+ ;
+ sc->tok = token(sc);
+ s_goto(sc,OP_RDSEXPR);
+ }
+*/
+ case TOK_VEC:
+ s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
+ /* fall through */
+ case TOK_LPAREN:
+ sc->tok = token(sc);
+ if (sc->tok == TOK_RPAREN) {
+ s_return(sc,sc->NIL);
+ } else if (sc->tok == TOK_DOT) {
+ Error_0(sc,"syntax error: illegal dot expression");
+ } else {
+ sc->nesting_stack[sc->file_i]++;
+ s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
+ s_goto(sc,OP_RDSEXPR);
+ }
+ case TOK_QUOTE:
+ s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
+ sc->tok = token(sc);
+ s_goto(sc,OP_RDSEXPR);
+ case TOK_BQUOTE:
+ sc->tok = token(sc);
+ if(sc->tok==TOK_VEC) {
+ s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
+ sc->tok=TOK_LPAREN;
+ s_goto(sc,OP_RDSEXPR);
+ } else {
+ s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
+ }
+ s_goto(sc,OP_RDSEXPR);
+ case TOK_COMMA:
+ s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
+ sc->tok = token(sc);
+ s_goto(sc,OP_RDSEXPR);
+ case TOK_ATMARK:
+ s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
+ sc->tok = token(sc);
+ s_goto(sc,OP_RDSEXPR);
+ case TOK_ATOM:
+ s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
+ case TOK_DQUOTE:
+ x=readstrexp(sc);
+ if(x==sc->F) {
+ Error_0(sc,"Error reading string");
+ }
+ setimmutable(x);
+ s_return(sc,x);
+ case TOK_USCORE:
+ x=readstrexp(sc);
+ if(x==sc->F) {
+ Error_0(sc,"Error reading string");
+ }
+ trans_str = gettext (strvalue (x));
+ if (trans_str != strvalue(x)) {
+ sc->free(strvalue(x));
+ strlength(x) = g_utf8_strlen(trans_str, -1);
+ strvalue(x) = store_string(sc, strlength(x), trans_str, 0);
+ }
+ setimmutable(x);
+ s_return(sc,x);
+ case TOK_SHARP: {
+ pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
+ if(f==sc->NIL) {
+ Error_0(sc,"undefined sharp expression");
+ } else {
+ sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
+ s_goto(sc,OP_EVAL);
+ }
+ }
+ case TOK_SHARP_CONST:
+ if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
+ Error_0(sc,"undefined sharp expression");
+ } else {
+ s_return(sc,x);
+ }
+ default:
+ Error_1(sc, "syntax error: illegal token", mk_integer (sc, sc->tok));
+ }
+ break;
+
+ case OP_RDLIST: {
+ sc->args = cons(sc, sc->value, sc->args);
+ sc->tok = token(sc);
+/* We now skip comments in the scanner
+ while (sc->tok == TOK_COMMENT) {
+ gunichar c;
+ while ((c=inchar(sc)) != '\n' && c!=EOF)
+ ;
+ sc->tok = token(sc);
+ }
+*/
+ if (sc->tok == TOK_EOF)
+ { s_return(sc,sc->EOF_OBJ); }
+ else if (sc->tok == TOK_RPAREN) {
+ gunichar c = inchar(sc);
+ if (c != '\n')
+ backchar(sc,c);
+#if SHOW_ERROR_LINE
+ else if (sc->load_stack[sc->file_i].kind & port_file)
+ sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+#endif
+ sc->nesting_stack[sc->file_i]--;
+ s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
+ } else if (sc->tok == TOK_DOT) {
+ s_save(sc,OP_RDDOT, sc->args, sc->NIL);
+ sc->tok = token(sc);
+ s_goto(sc,OP_RDSEXPR);
+ } else {
+ s_save(sc,OP_RDLIST, sc->args, sc->NIL);
+ s_goto(sc,OP_RDSEXPR);
+ }
+ }
+
+ case OP_RDDOT:
+ if (token(sc) != TOK_RPAREN) {
+ Error_0(sc,"syntax error: illegal dot expression");
+ } else {
+ sc->nesting_stack[sc->file_i]--;
+ s_return(sc,reverse_in_place(sc, sc->value, sc->args));
+ }
+
+ case OP_RDQUOTE:
+ s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
+
+ case OP_RDQQUOTE:
+ s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
+
+ case OP_RDQQUOTEVEC:
+ s_return(sc,cons(sc, mk_symbol(sc,"apply"),
+ cons(sc, mk_symbol(sc,"vector"),
+ cons(sc,cons(sc, sc->QQUOTE,
+ cons(sc,sc->value,sc->NIL)),
+ sc->NIL))));
+
+ case OP_RDUNQUOTE:
+ s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
+
+ case OP_RDUQTSP:
+ s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
+
+ case OP_RDVEC:
+ /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
+ s_goto(sc,OP_EVAL); Cannot be quoted*/
+ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
+ s_return(sc,x); Cannot be part of pairs*/
+ /*sc->code=mk_proc(sc,OP_VECTOR);
+ sc->args=sc->value;
+ s_goto(sc,OP_APPLY);*/
+ sc->args=sc->value;
+ s_goto(sc,OP_VECTOR);
+
+ /* ========== printing part ========== */
+ case OP_P0LIST:
+ if(is_vector(sc->args)) {
+ putstr(sc,"#(");
+ sc->args=cons(sc,sc->args,mk_integer(sc,0));
+ s_goto(sc,OP_PVECFROM);
+ } else if(is_environment(sc->args)) {
+ putstr(sc,"#<ENVIRONMENT>");
+ s_return(sc,sc->T);
+ } else if (!is_pair(sc->args)) {
+ printatom(sc, sc->args, sc->print_flag);
+ s_return(sc,sc->T);
+ } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, "'");
+ sc->args = cadr(sc->args);
+ s_goto(sc,OP_P0LIST);
+ } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, "`");
+ sc->args = cadr(sc->args);
+ s_goto(sc,OP_P0LIST);
+ } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, ",");
+ sc->args = cadr(sc->args);
+ s_goto(sc,OP_P0LIST);
+ } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, ",@");
+ sc->args = cadr(sc->args);
+ s_goto(sc,OP_P0LIST);
+ } else {
+ putstr(sc, "(");
+ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
+ sc->args = car(sc->args);
+ s_goto(sc,OP_P0LIST);
+ }
+
+ case OP_P1LIST:
+ if (is_pair(sc->args)) {
+ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
+ putstr(sc, " ");
+ sc->args = car(sc->args);
+ s_goto(sc,OP_P0LIST);
+ } else if(is_vector(sc->args)) {
+ s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
+ putstr(sc, " . ");
+ s_goto(sc,OP_P0LIST);
+ } else {
+ if (sc->args != sc->NIL) {
+ putstr(sc, " . ");
+ printatom(sc, sc->args, sc->print_flag);
+ }
+ putstr(sc, ")");
+ s_return(sc,sc->T);
+ }
+ case OP_PVECFROM: {
+ int i=ivalue_unchecked(cdr(sc->args));
+ pointer vec=car(sc->args);
+ int len=ivalue_unchecked(vec);
+ if(i==len) {
+ putstr(sc,")");
+ s_return(sc,sc->T);
+ } else {
+ pointer elem=vector_elem(vec,i);
+ ivalue_unchecked(cdr(sc->args))=i+1;
+ s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
+ sc->args=elem;
+ if (i > 0)
+ putstr(sc," ");
+ s_goto(sc,OP_P0LIST);
+ }
+ }
+
+ default:
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
+ Error_0(sc,sc->strbuff);
+
+ }
+ return sc->T;
+}
+
+static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
+ pointer x, y;
+ long v;
+
+ switch (op) {
+ case OP_LIST_LENGTH: /* length */ /* a.k */
+ v=list_length(sc,car(sc->args));
+ if(v<0) {
+ Error_1(sc,"length: not a list:",car(sc->args));
+ }
+ s_return(sc,mk_integer(sc, v));
+
+ case OP_ASSQ: /* assq */ /* a.k */
+ x = car(sc->args);
+ for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
+ if (!is_pair(car(y))) {
+ Error_0(sc,"unable to handle non pair element");
+ }
+ if (x == caar(y))
+ break;
+ }
+ if (is_pair(y)) {
+ s_return(sc,car(y));
+ } else {
+ s_return(sc,sc->F);
+ }
+
+
+ case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */
+ sc->args = car(sc->args);
+ if (sc->args == sc->NIL) {
+ s_return(sc,sc->F);
+ } else if (is_closure(sc->args)) {
+ s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
+ } else if (is_macro(sc->args)) {
+ s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
+ } else {
+ s_return(sc,sc->F);
+ }
+ case OP_CLOSUREP: /* closure? */
+ /*
+ * Note, macro object is also a closure.
+ * Therefore, (closure? <#MACRO>) ==> #t
+ */
+ s_retbool(is_closure(car(sc->args)));
+ case OP_MACROP: /* macro? */
+ s_retbool(is_macro(car(sc->args)));
+ default:
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
+ Error_0(sc,sc->strbuff);
+ }
+ return sc->T; /* NOTREACHED */
+}
+
+typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
+
+typedef int (*test_predicate)(pointer);
+static int is_any(pointer p) { return 1;}
+
+static int is_nonneg(pointer p) {
+ return ivalue(p)>=0 && is_integer(p);
+}
+
+/* Correspond carefully with following defines! */
+static struct {
+ test_predicate fct;
+ const char *kind;
+} tests[]={
+ {0,0}, /* unused */
+ {is_any, 0},
+ {is_string, "string"},
+ {is_symbol, "symbol"},
+ {is_port, "port"},
+ {is_inport,"input port"},
+ {is_outport,"output port"},
+ {is_environment, "environment"},
+ {is_pair, "pair"},
+ {0, "pair or '()"},
+ {is_character, "character"},
+ {is_vector, "vector"},
+ {is_number, "number"},
+ {is_integer, "integer"},
+ {is_nonneg, "non-negative integer"}
+};
+
+#define TST_NONE 0
+#define TST_ANY "\001"
+#define TST_STRING "\002"
+#define TST_SYMBOL "\003"
+#define TST_PORT "\004"
+#define TST_INPORT "\005"
+#define TST_OUTPORT "\006"
+#define TST_ENVIRONMENT "\007"
+#define TST_PAIR "\010"
+#define TST_LIST "\011"
+#define TST_CHAR "\012"
+#define TST_VECTOR "\013"
+#define TST_NUMBER "\014"
+#define TST_INTEGER "\015"
+#define TST_NATURAL "\016"
+
+typedef struct {
+ dispatch_func func;
+ char *name;
+ int min_arity;
+ int max_arity;
+ char *arg_tests_encoding;
+} op_code_info;
+
+#define INF_ARG 0xffff
+
+static op_code_info dispatch_table[]= {
+#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
+#include "opdefines.h"
+ { 0 }
+};
+
+static const char *procname(pointer x) {
+ int n=procnum(x);
+ const char *name=dispatch_table[n].name;
+ if(name==0) {
+ name="ILLEGAL!";
+ }
+ return name;
+}
+
+/* kernel of this interpreter */
+static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
+ sc->op = op;
+ for (;;) {
+ op_code_info *pcd=dispatch_table+sc->op;
+ if (pcd->name!=0) { /* if built-in function, check arguments */
+ char msg[STRBUFFSIZE];
+ int ok=1;
+ int n=list_length(sc,sc->args);
+
+ /* Check number of arguments */
+ if(n<pcd->min_arity) {
+ ok=0;
+ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity==pcd->max_arity?"":" at least",
+ pcd->min_arity);
+ }
+ if(ok && n>pcd->max_arity) {
+ ok=0;
+ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity==pcd->max_arity?"":" at most",
+ pcd->max_arity);
+ }
+ if(ok) {
+ if(pcd->arg_tests_encoding!=0) {
+ int i=0;
+ int j;
+ const char *t=pcd->arg_tests_encoding;
+ pointer arglist=sc->args;
+ do {
+ pointer arg=car(arglist);
+ j=(int)t[0];
+ if(j==TST_LIST[0]) {
+ if(arg!=sc->NIL && !is_pair(arg)) break;
+ } else {
+ if(!tests[j].fct(arg)) break;
+ }
+
+ if(t[1]!=0) {/* last test is replicated as necessary */
+ t++;
+ }
+ arglist=cdr(arglist);
+ i++;
+ } while(i<n);
+ if(i<n) {
+ ok=0;
+ snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
+ pcd->name,
+ i+1,
+ tests[j].kind);
+ }
+ }
+ }
+ if(!ok) {
+ if(_Error_1(sc,msg,0)==sc->NIL) {
+ return;
+ }
+ pcd=dispatch_table+sc->op;
+ }
+ }
+ ok_to_freely_gc(sc);
+ if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
+ return;
+ }
+ if(sc->no_memory) {
+ fprintf(stderr,"No memory!\n");
+ return;
+ }
+ }
+}
+
+/* ========== Initialization of internal keywords ========== */
+
+static void assign_syntax(scheme *sc, char *name) {
+ pointer x;
+
+ x = oblist_add_by_name(sc, name);
+ typeflag(x) |= T_SYNTAX;
+}
+
+static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
+ pointer x, y;
+
+ x = mk_symbol(sc, name);
+ y = mk_proc(sc,op);
+ new_slot_in_env(sc, x, y);
+}
+
+static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
+ pointer y;
+
+ y = get_cell(sc, sc->NIL, sc->NIL);
+ typeflag(y) = (T_PROC | T_ATOM);
+ ivalue_unchecked(y) = (long) op;
+ set_num_integer(y);
+ return y;
+}
+
+/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
+static int syntaxnum(pointer p) {
+ const char *s=strvalue(car(p));
+ switch(strlength(car(p))) {
+ case 2:
+ if(s[0]=='i') return OP_IF0; /* if */
+ else return OP_OR0; /* or */
+ case 3:
+ if(s[0]=='a') return OP_AND0; /* and */
+ else return OP_LET0; /* let */
+ case 4:
+ switch(s[3]) {
+ case 'e': return OP_CASE0; /* case */
+ case 'd': return OP_COND0; /* cond */
+ case '*': return OP_LET0AST; /* let* */
+ default: return OP_SET0; /* set! */
+ }
+ case 5:
+ switch(s[2]) {
+ case 'g': return OP_BEGIN; /* begin */
+ case 'l': return OP_DELAY; /* delay */
+ case 'c': return OP_MACRO0; /* macro */
+ default: return OP_QUOTE; /* quote */
+ }
+ case 6:
+ switch(s[2]) {
+ case 'm': return OP_LAMBDA; /* lambda */
+ case 'f': return OP_DEF0; /* define */
+ default: return OP_LET0REC; /* letrec */
+ }
+ default:
+ return OP_C0STREAM; /* cons-stream */
+ }
+}
+
+/* initialization of TinyScheme */
+#if USE_INTERFACE
+INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
+ return cons(sc,a,b);
+}
+INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
+ return immutable_cons(sc,a,b);
+}
+
+static struct scheme_interface vtbl ={
+ scheme_define,
+ s_cons,
+ s_immutable_cons,
+ reserve_cells,
+ mk_integer,
+ mk_real,
+ mk_symbol,
+ gensym,
+ mk_string,
+ mk_counted_string,
+ mk_character,
+ mk_vector,
+ mk_foreign_func,
+ mk_closure,
+ putstr,
+ putcharacter,
+
+ is_string,
+ string_length,
+ string_value,
+ is_number,
+ nvalue,
+ ivalue,
+ rvalue,
+ is_integer,
+ is_real,
+ is_character,
+ charvalue,
+ is_list,
+ is_vector,
+ list_length,
+ ivalue,
+ fill_vector,
+ vector_elem,
+ set_vector_elem,
+ is_port,
+ is_pair,
+ pair_car,
+ pair_cdr,
+ set_car,
+ set_cdr,
+
+ is_symbol,
+ symname,
+
+ is_syntax,
+ is_proc,
+ is_foreign,
+ syntaxname,
+ is_closure,
+ is_macro,
+ closure_code,
+ closure_env,
+
+ is_continuation,
+ is_promise,
+ is_environment,
+ is_immutable,
+ setimmutable,
+
+ scheme_load_file,
+ scheme_load_string
+};
+#endif
+
+scheme *scheme_init_new(void) {
+ scheme *sc=(scheme*)malloc(sizeof(scheme));
+ if(!scheme_init(sc)) {
+ free(sc);
+ return 0;
+ } else {
+ return sc;
+ }
+}
+
+scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
+ scheme *sc=(scheme*)malloc(sizeof(scheme));
+ if(!scheme_init_custom_alloc(sc,malloc,free)) {
+ free(sc);
+ return 0;
+ } else {
+ return sc;
+ }
+}
+
+
+int scheme_init(scheme *sc) {
+ return scheme_init_custom_alloc(sc,malloc,free);
+}
+
+int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
+ int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
+ pointer x;
+
+ num_zero.is_fixnum=1;
+ num_zero.value.ivalue=0;
+ num_one.is_fixnum=1;
+ num_one.value.ivalue=1;
+
+#if USE_INTERFACE
+ sc->vptr=&vtbl;
+#endif
+ sc->gensym_cnt=0;
+ sc->malloc=malloc;
+ sc->free=free;
+ sc->last_cell_seg = -1;
+ sc->sink = &sc->_sink;
+ sc->NIL = &sc->_NIL;
+ sc->T = &sc->_HASHT;
+ sc->F = &sc->_HASHF;
+ sc->EOF_OBJ=&sc->_EOF_OBJ;
+ sc->free_cell = &sc->_NIL;
+ sc->fcells = 0;
+ sc->no_memory=0;
+ sc->inport=sc->NIL;
+ sc->outport=sc->NIL;
+ sc->save_inport=sc->NIL;
+ sc->loadport=sc->NIL;
+ sc->nesting=0;
+ sc->interactive_repl=0;
+ sc->print_output=0;
+
+ if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
+ sc->no_memory=1;
+ return 0;
+ }
+ sc->gc_verbose = 0;
+ dump_stack_initialize(sc);
+ sc->code = sc->NIL;
+ sc->tracing=0;
+ sc->bc_flag = 0;
+
+ /* init sc->NIL */
+ typeflag(sc->NIL) = (T_ATOM | MARK);
+ car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
+ /* init T */
+ typeflag(sc->T) = (T_ATOM | MARK);
+ car(sc->T) = cdr(sc->T) = sc->T;
+ /* init F */
+ typeflag(sc->F) = (T_ATOM | MARK);
+ car(sc->F) = cdr(sc->F) = sc->F;
+ /* init sink */
+ typeflag(sc->sink) = (T_PAIR | MARK);
+ car(sc->sink) = sc->NIL;
+ /* init c_nest */
+ sc->c_nest = sc->NIL;
+
+ sc->oblist = oblist_initial_value(sc);
+ /* init global_env */
+ new_frame_in_env(sc, sc->NIL);
+ sc->global_env = sc->envir;
+ /* init else */
+ x = mk_symbol(sc,"else");
+ new_slot_in_env(sc, x, sc->T);
+
+ assign_syntax(sc, "lambda");
+ assign_syntax(sc, "quote");
+ assign_syntax(sc, "define");
+ assign_syntax(sc, "if");
+ assign_syntax(sc, "begin");
+ assign_syntax(sc, "set!");
+ assign_syntax(sc, "let");
+ assign_syntax(sc, "let*");
+ assign_syntax(sc, "letrec");
+ assign_syntax(sc, "cond");
+ assign_syntax(sc, "delay");
+ assign_syntax(sc, "and");
+ assign_syntax(sc, "or");
+ assign_syntax(sc, "cons-stream");
+ assign_syntax(sc, "macro");
+ assign_syntax(sc, "case");
+
+ for(i=0; i<n; i++) {
+ if(dispatch_table[i].name!=0) {
+ assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
+ }
+ }
+
+ /* initialization of global pointers to special symbols */
+ sc->LAMBDA = mk_symbol(sc, "lambda");
+ sc->QUOTE = mk_symbol(sc, "quote");
+ sc->QQUOTE = mk_symbol(sc, "quasiquote");
+ sc->UNQUOTE = mk_symbol(sc, "unquote");
+ sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
+ sc->FEED_TO = mk_symbol(sc, "=>");
+ sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
+ sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
+ sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
+ sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
+
+ return !sc->no_memory;
+}
+
+SCHEME_EXPORT void scheme_set_input_port_file(scheme *sc, FILE *fin) {
+ sc->inport=port_from_file(sc,fin,port_input);
+}
+
+void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
+ sc->inport=port_from_string(sc,start,past_the_end,port_input);
+}
+
+SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fout) {
+ sc->outport=port_from_file(sc,fout,port_output);
+}
+
+void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
+ sc->outport=port_from_string(sc,start,past_the_end,port_output);
+}
+
+void scheme_set_external_data(scheme *sc, void *p) {
+ sc->ext_data=p;
+}
+
+void scheme_deinit(scheme *sc) {
+ int i;
+
+#if SHOW_ERROR_LINE
+ char *fname;
+#endif
+
+ sc->oblist=sc->NIL;
+ sc->global_env=sc->NIL;
+ dump_stack_free(sc);
+ sc->envir=sc->NIL;
+ sc->code=sc->NIL;
+ sc->args=sc->NIL;
+ sc->value=sc->NIL;
+ if(is_port(sc->inport)) {
+ typeflag(sc->inport) = T_ATOM;
+ }
+ sc->inport=sc->NIL;
+ sc->outport=sc->NIL;
+ if(is_port(sc->save_inport)) {
+ typeflag(sc->save_inport) = T_ATOM;
+ }
+ sc->save_inport=sc->NIL;
+ if(is_port(sc->loadport)) {
+ typeflag(sc->loadport) = T_ATOM;
+ }
+ sc->loadport=sc->NIL;
+ sc->gc_verbose=0;
+ gc(sc,sc->NIL,sc->NIL);
+
+ for(i=0; i<=sc->last_cell_seg; i++) {
+ sc->free(sc->alloc_seg[i]);
+ }
+
+#if SHOW_ERROR_LINE
+ for(i=0; i<sc->file_i; i++) {
+ if (sc->load_stack[sc->file_i].kind & port_file) {
+ fname = sc->load_stack[i].rep.stdio.filename;
+ if(fname)
+ sc->free(fname);
+ }
+ }
+#endif
+}
+
+void scheme_load_file(scheme *sc, FILE *fin)
+{ scheme_load_named_file(sc,fin,0); }
+
+void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
+ dump_stack_reset(sc);
+ sc->envir = sc->global_env;
+ sc->file_i=0;
+ sc->load_stack[0].kind=port_input|port_file;
+ sc->load_stack[0].rep.stdio.file=fin;
+ sc->loadport=mk_port(sc,sc->load_stack);
+ sc->retcode=0;
+ if(fin==stdin) {
+ sc->interactive_repl=1;
+ }
+
+#if SHOW_ERROR_LINE
+ sc->load_stack[0].rep.stdio.curr_line = 0;
+ if(fin!=stdin && filename)
+ sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
+ else
+ sc->load_stack[0].rep.stdio.filename = NULL;
+#endif
+
+ sc->inport=sc->loadport;
+ sc->args = mk_integer(sc,sc->file_i);
+ Eval_Cycle(sc, OP_T0LVL);
+ typeflag(sc->loadport)=T_ATOM;
+ if(sc->retcode==0) {
+ sc->retcode=sc->nesting!=0;
+ }
+}
+
+void scheme_load_string(scheme *sc, const char *cmd) {
+ dump_stack_reset(sc);
+ sc->envir = sc->global_env;
+ sc->file_i=0;
+ sc->load_stack[0].kind=port_input|port_string;
+ sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
+ sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
+ sc->load_stack[0].rep.string.curr=(char*)cmd;
+ sc->loadport=mk_port(sc,sc->load_stack);
+ sc->retcode=0;
+ sc->interactive_repl=0;
+ sc->inport=sc->loadport;
+ sc->args = mk_integer(sc,sc->file_i);
+ Eval_Cycle(sc, OP_T0LVL);
+ typeflag(sc->loadport)=T_ATOM;
+ if(sc->retcode==0) {
+ sc->retcode=sc->nesting!=0;
+ }
+}
+
+void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
+ pointer x;
+
+ x=find_slot_in_env(sc,envir,symbol,0);
+ if (x != sc->NIL) {
+ set_slot_in_env(sc, x, value);
+ } else {
+ new_slot_spec_in_env(sc, envir, symbol, value);
+ }
+}
+
+#if !STANDALONE
+void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
+{
+ scheme_define(sc,
+ sc->global_env,
+ mk_symbol(sc,sr->name),
+ mk_foreign_func(sc, sr->f));
+}
+
+void scheme_register_foreign_func_list(scheme * sc,
+ scheme_registerable * list,
+ int count)
+{
+ int i;
+ for(i = 0; i < count; i++)
+ {
+ scheme_register_foreign_func(sc, list + i);
+ }
+}
+
+pointer scheme_apply0(scheme *sc, const char *procname)
+{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
+
+static void save_from_C_call(scheme *sc)
+{
+ pointer saved_data =
+ cons(sc,
+ car(sc->sink),
+ cons(sc,
+ sc->envir,
+ sc->dump));
+ /* Push */
+ sc->c_nest = cons(sc, saved_data, sc->c_nest);
+ /* Truncate the dump stack so TS will return here when done, not
+ directly resume pre-C-call operations. */
+ dump_stack_reset(sc);
+}
+
+static void restore_from_C_call(scheme *sc)
+{
+ car(sc->sink) = caar(sc->c_nest);
+ sc->envir = cadar(sc->c_nest);
+ sc->dump = cdr(cdar(sc->c_nest));
+ /* Pop */
+ sc->c_nest = cdr(sc->c_nest);
+}
+
+/* "func" and "args" are assumed to be already eval'ed. */
+pointer scheme_call(scheme *sc, pointer func, pointer args)
+{
+ int old_repl = sc->interactive_repl;
+ sc->interactive_repl = 0;
+ save_from_C_call(sc);
+ sc->envir = sc->global_env;
+ sc->args = args;
+ sc->code = func;
+ sc->retcode = 0;
+ Eval_Cycle(sc, OP_APPLY);
+ sc->interactive_repl = old_repl;
+ restore_from_C_call(sc);
+ return sc->value;
+}
+
+pointer scheme_eval(scheme *sc, pointer obj)
+{
+ int old_repl = sc->interactive_repl;
+ sc->interactive_repl = 0;
+ save_from_C_call(sc);
+ sc->args = sc->NIL;
+ sc->code = obj;
+ sc->retcode = 0;
+ Eval_Cycle(sc, OP_EVAL);
+ sc->interactive_repl = old_repl;
+ restore_from_C_call(sc);
+ return sc->value;
+}
+
+
+#endif
+
+/* ========== Main ========== */
+
+#if STANDALONE
+
+#if defined(__APPLE__) && !defined (OSX)
+int main(int argc, char **argv)
+{
+ extern MacTS_main(int argc, char **argv);
+ char** argv;
+ int argc = ccommand(&argv);
+ MacTS_main(argc,argv);
+ return 0;
+}
+int MacTS_main(int argc, char **argv) {
+#else
+int main(int argc, char **argv) {
+#endif
+ scheme sc;
+ FILE *fin;
+ char *file_name=InitFile;
+ int retcode;
+ int isfile=1;
+
+ if(argc==1) {
+ printf(banner);
+ }
+ if(argc==2 && strcmp(argv[1],"-?")==0) {
+ printf("Usage: tinyscheme -?\n");
+ printf("or: tinyscheme [<file1> <file2> ...]\n");
+ printf("followed by\n");
+ printf(" -1 <file> [<arg1> <arg2> ...]\n");
+ printf(" -c <Scheme commands> [<arg1> <arg2> ...]\n");
+ printf("assuming that the executable is named tinyscheme.\n");
+ printf("Use - as filename for stdin.\n");
+ return 1;
+ }
+ if(!scheme_init(&sc)) {
+ fprintf(stderr,"Could not initialize!\n");
+ return 2;
+ }
+ scheme_set_input_port_file(&sc, stdin);
+ scheme_set_output_port_file(&sc, stdout);
+#if USE_DL
+ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
+#endif
+ argv++;
+ if(g_access(file_name,0)!=0) {
+ char *p=getenv("TINYSCHEMEINIT");
+ if(p!=0) {
+ file_name=p;
+ }
+ }
+ do {
+ if(strcmp(file_name,"-")==0) {
+ fin=stdin;
+ } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
+ pointer args=sc.NIL;
+ isfile=file_name[1]=='1';
+ file_name=*argv++;
+ if(strcmp(file_name,"-")==0) {
+ fin=stdin;
+ } else if(isfile) {
+ fin=g_fopen(file_name,"r");
+ }
+ for(;*argv;argv++) {
+ pointer value=mk_string(&sc,*argv);
+ args=cons(&sc,value,args);
+ }
+ args=reverse_in_place(&sc,sc.NIL,args);
+ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
+
+ } else {
+ fin=g_fopen(file_name,"r");
+ }
+ if(isfile && fin==0) {
+ fprintf(stderr,"Could not open file %s\n",file_name);
+ } else {
+ if(isfile) {
+ scheme_load_named_file(&sc,fin,file_name);
+ } else {
+ scheme_load_string(&sc,file_name);
+ }
+ if(!isfile || fin!=stdin) {
+ if(sc.retcode!=0) {
+ fprintf(stderr,"Errors encountered reading %s\n",file_name);
+ }
+ if(isfile) {
+ fclose(fin);
+ }
+ }
+ }
+ file_name=*argv++;
+ } while(file_name!=0);
+ if(argc==1) {
+ scheme_load_named_file(&sc,stdin,0);
+ }
+ retcode=sc.retcode;
+ scheme_deinit(&sc);
+
+ return retcode;
+}
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
diff --git a/plug-ins/script-fu/tinyscheme/scheme.h b/plug-ins/script-fu/tinyscheme/scheme.h
new file mode 100644
index 0000000..198182c
--- /dev/null
+++ b/plug-ins/script-fu/tinyscheme/scheme.h
@@ -0,0 +1,273 @@
+/* SCHEME.H */
+
+#ifndef _SCHEME_H
+#define _SCHEME_H
+
+#include <stdio.h>
+#include <glib.h>
+#include <glib/gstdio.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*
+ * Default values for #define'd symbols
+ */
+#ifndef STANDALONE /* If used as standalone interpreter */
+# define STANDALONE 1
+#endif
+
+#ifndef _MSC_VER
+# ifndef USE_STRLWR
+# define USE_STRLWR 1
+# endif
+# define SCHEME_EXPORT extern
+#else
+# define USE_STRLWR 0
+# ifdef _SCHEME_SOURCE
+# define SCHEME_EXPORT __declspec(dllexport)
+# else
+# define SCHEME_EXPORT __declspec(dllimport)
+# endif
+#endif
+
+#if USE_NO_FEATURES
+# define USE_MATH 0
+# define USE_CHAR_CLASSIFIERS 0
+# define USE_ASCII_NAMES 0
+# define USE_STRING_PORTS 0
+# define USE_ERROR_HOOK 0
+# define USE_TRACING 0
+# define USE_COLON_HOOK 0
+# define USE_DL 0
+# define USE_PLIST 0
+#endif
+
+/*
+ * Leave it defined if you want continuations, and also for the Sharp Zaurus.
+ * Undefine it if you only care about faster speed and not strict Scheme compatibility.
+ */
+#define USE_SCHEME_STACK
+
+#if USE_DL
+# define USE_INTERFACE 1
+#endif
+
+
+#ifndef USE_MATH /* If math support is needed */
+# define USE_MATH 1
+#endif
+
+#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */
+# define USE_CHAR_CLASSIFIERS 1
+#endif
+
+#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */
+# define USE_ASCII_NAMES 1
+#endif
+
+#ifndef USE_STRING_PORTS /* Enable string ports */
+# define USE_STRING_PORTS 1
+#endif
+
+#ifndef USE_TRACING
+# define USE_TRACING 1
+#endif
+
+#ifndef USE_PLIST
+# define USE_PLIST 0
+#endif
+
+/* To force system errors through user-defined error handling (see *error-hook*) */
+#ifndef USE_ERROR_HOOK
+# define USE_ERROR_HOOK 1
+#endif
+
+#ifndef USE_COLON_HOOK /* Enable qualified qualifier */
+# define USE_COLON_HOOK 1
+#endif
+
+#ifndef USE_STRLWR
+# define USE_STRLWR 1
+#endif
+
+#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */
+# define STDIO_ADDS_CR 0
+#endif
+
+#ifndef INLINE
+# define INLINE
+#endif
+
+#ifndef USE_INTERFACE
+# define USE_INTERFACE 0
+#endif
+
+#ifndef SHOW_ERROR_LINE /* Show error line in file */
+# define SHOW_ERROR_LINE 1
+#endif
+
+typedef struct scheme scheme;
+typedef struct cell *pointer;
+
+typedef void * (*func_alloc)(size_t);
+typedef void (*func_dealloc)(void *);
+
+/* num, for generic arithmetic */
+typedef struct num {
+ char is_fixnum;
+ union {
+ long ivalue;
+ double rvalue;
+ } value;
+} num;
+
+#if !STANDALONE
+
+typedef enum { TS_OUTPUT_NORMAL, TS_OUTPUT_ERROR } TsOutputType;
+
+typedef void (* ts_output_func) (TsOutputType type,
+ const char *string,
+ int len,
+ gpointer data);
+
+SCHEME_EXPORT void ts_register_output_func (ts_output_func func,
+ gpointer user_data);
+SCHEME_EXPORT void ts_output_string (TsOutputType type,
+ const char *string,
+ int len);
+#endif
+
+SCHEME_EXPORT scheme *scheme_init_new(void);
+SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free);
+SCHEME_EXPORT int scheme_init(scheme *sc);
+SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc);
+SCHEME_EXPORT void scheme_deinit(scheme *sc);
+SCHEME_EXPORT void scheme_set_input_port_file(scheme *sc, FILE *fin);
+void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end);
+SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin);
+void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end);
+SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin);
+SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename);
+SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd);
+SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname);
+SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args);
+SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj);
+void scheme_set_external_data(scheme *sc, void *p);
+SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value);
+
+typedef pointer (*foreign_func)(scheme *, pointer);
+
+pointer _cons(scheme *sc, pointer a, pointer b, int immutable);
+pointer mk_integer(scheme *sc, long num);
+pointer mk_real(scheme *sc, double num);
+pointer mk_symbol(scheme *sc, const char *name);
+pointer gensym(scheme *sc);
+pointer mk_string(scheme *sc, const char *str);
+pointer mk_counted_string(scheme *sc, const char *str, int len);
+pointer mk_empty_string(scheme *sc, int len, gunichar fill);
+pointer mk_character(scheme *sc, gunichar c);
+pointer mk_foreign_func(scheme *sc, foreign_func f);
+void putcharacter(scheme *sc, gunichar c);
+void putstr(scheme *sc, const char *s);
+int list_length(scheme *sc, pointer a);
+int eqv(pointer a, pointer b);
+
+SCHEME_EXPORT pointer foreign_error (scheme *sc, const char *s, pointer a);
+
+#if USE_INTERFACE
+struct scheme_interface {
+ void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value);
+ pointer (*cons)(scheme *sc, pointer a, pointer b);
+ pointer (*immutable_cons)(scheme *sc, pointer a, pointer b);
+ pointer (*reserve_cells)(scheme *sc, int n);
+ pointer (*mk_integer)(scheme *sc, long num);
+ pointer (*mk_real)(scheme *sc, double num);
+ pointer (*mk_symbol)(scheme *sc, const char *name);
+ pointer (*gensym)(scheme *sc);
+ pointer (*mk_string)(scheme *sc, const char *str);
+ pointer (*mk_counted_string)(scheme *sc, const char *str, int len);
+ pointer (*mk_character)(scheme *sc, gunichar c);
+ pointer (*mk_vector)(scheme *sc, int len);
+ pointer (*mk_foreign_func)(scheme *sc, foreign_func f);
+ pointer (*mk_closure)(scheme *sc, pointer c, pointer e);
+ void (*putstr)(scheme *sc, const char *s);
+ void (*putcharacter)(scheme *sc, gunichar c);
+
+ int (*is_string)(pointer p);
+ int (*string_length)(pointer p);
+ char *(*string_value)(pointer p);
+ int (*is_number)(pointer p);
+ num (*nvalue)(pointer p);
+ long (*ivalue)(pointer p);
+ double (*rvalue)(pointer p);
+ int (*is_integer)(pointer p);
+ int (*is_real)(pointer p);
+ int (*is_character)(pointer p);
+ gunichar (*charvalue)(pointer p);
+ int (*is_list)(scheme *sc, pointer p);
+ int (*is_vector)(pointer p);
+ int (*list_length)(scheme *sc, pointer p);
+ long (*vector_length)(pointer vec);
+ void (*fill_vector)(pointer vec, pointer elem);
+ pointer (*vector_elem)(pointer vec, int ielem);
+ pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel);
+
+ int (*is_port)(pointer p);
+
+ int (*is_pair)(pointer p);
+ pointer (*pair_car)(pointer p);
+ pointer (*pair_cdr)(pointer p);
+ pointer (*set_car)(pointer p, pointer q);
+ pointer (*set_cdr)(pointer p, pointer q);
+
+ int (*is_symbol)(pointer p);
+ char *(*symname)(pointer p);
+
+ int (*is_syntax)(pointer p);
+ int (*is_proc)(pointer p);
+ int (*is_foreign)(pointer p);
+ char *(*syntaxname)(pointer p);
+ int (*is_closure)(pointer p);
+ int (*is_macro)(pointer p);
+ pointer (*closure_code)(pointer p);
+ pointer (*closure_env)(pointer p);
+
+ int (*is_continuation)(pointer p);
+ int (*is_promise)(pointer p);
+ int (*is_environment)(pointer p);
+ int (*is_immutable)(pointer p);
+ void (*setimmutable)(pointer p);
+
+ void (*load_file)(scheme *sc, FILE *fin);
+ void (*load_string)(scheme *sc, const char *input);
+};
+#endif
+
+#if !STANDALONE
+typedef struct scheme_registerable
+{
+ foreign_func f;
+ const char * name;
+}
+scheme_registerable;
+
+void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr);
+void scheme_register_foreign_func_list(scheme * sc,
+ scheme_registerable * list,
+ int n);
+
+#endif /* !STANDALONE */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/