diff options
Diffstat (limited to 'plug-ins/script-fu/tinyscheme')
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/BUILDING | 139 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/CHANGES | 326 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/COPYING | 31 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/Makefile.am | 26 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/Makefile.in | 923 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/Manual.txt | 452 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/MiniSCHEMETribute.txt | 88 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/README | 14 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/hack.txt | 233 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/opdefines.h | 195 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/scheme-private.h | 227 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/scheme.c | 5357 | ||||
| -rw-r--r-- | plug-ins/script-fu/tinyscheme/scheme.h | 273 |
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: +*/ |