Initial checkin of Pika from heckimp
This commit is contained in:
139
plug-ins/script-fu/libscriptfu/tinyscheme/BUILDING
Normal file
139
plug-ins/script-fu/libscriptfu/tinyscheme/BUILDING
Normal file
@ -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
|
||||
341
plug-ins/script-fu/libscriptfu/tinyscheme/CHANGES
Normal file
341
plug-ins/script-fu/libscriptfu/tinyscheme/CHANGES
Normal file
@ -0,0 +1,341 @@
|
||||
Change Log
|
||||
----------
|
||||
|
||||
Version 1.42
|
||||
Other changes:
|
||||
- Fixed segfault crash caused by invalid syntax to cond (PG)
|
||||
- Fixed a bug in the close-port routine in init.scm
|
||||
- Fixed possible crash loading file due to uninitialized variable (MP)
|
||||
- Don't use snprintf() in atom2str to return some fixed strings (KC/MP)
|
||||
- Added "tinyscheme" to the features list (JaW)
|
||||
- Added Sconstruct to allow building using scons (AG)
|
||||
- Fixed function prototype for scheme_init_new (JuW)
|
||||
- Make various limits configurable (JuW)
|
||||
|
||||
Contributors:
|
||||
Kevin Cozens, Mauro Persano, Pedro Gimeno, James Woodcock, Atanu Ghosh,
|
||||
and Justus Winter.
|
||||
|
||||
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,
|
||||
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 Patrice 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.
|
||||
31
plug-ins/script-fu/libscriptfu/tinyscheme/COPYING
Normal file
31
plug-ins/script-fu/libscriptfu/tinyscheme/COPYING
Normal file
@ -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.
|
||||
452
plug-ins/script-fu/libscriptfu/tinyscheme/Manual.txt
Normal file
452
plug-ins/script-fu/libscriptfu/tinyscheme/Manual.txt
Normal file
@ -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 their
|
||||
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 their 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 their 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.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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")
|
||||
14
plug-ins/script-fu/libscriptfu/tinyscheme/README
Normal file
14
plug-ins/script-fu/libscriptfu/tinyscheme/README
Normal file
@ -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.
|
||||
|
||||
152
plug-ins/script-fu/libscriptfu/tinyscheme/dynload.c
Normal file
152
plug-ins/script-fu/libscriptfu/tinyscheme/dynload.c
Normal file
@ -0,0 +1,152 @@
|
||||
/* dynload.c Dynamic Loader for TinyScheme */
|
||||
/* Original Copyright (c) 1999 Alexander Shendi */
|
||||
/* Modifications for NT and dl_* interface, scm_load_ext: D. Souflis */
|
||||
/* Refurbished by Stephen Gildea */
|
||||
|
||||
#define _SCHEME_SOURCE
|
||||
#include "dynload.h"
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#include <glib/glib.h>
|
||||
|
||||
#ifndef MAXPATHLEN
|
||||
# define MAXPATHLEN 1024
|
||||
#endif
|
||||
|
||||
static void make_filename(const char *name, char *filename);
|
||||
static void make_init_fn(const char *name, char *init_fn);
|
||||
|
||||
#ifdef _WIN32
|
||||
# include <windows.h>
|
||||
#else
|
||||
typedef void *HMODULE;
|
||||
typedef void (*FARPROC)();
|
||||
#ifndef SUN_DL
|
||||
#define SUN_DL
|
||||
#endif
|
||||
#include <dlfcn.h>
|
||||
#endif
|
||||
|
||||
#ifdef _WIN32
|
||||
|
||||
#define PREFIX ""
|
||||
#define SUFFIX ".dll"
|
||||
|
||||
static void display_w32_error_msg(const char *additional_message)
|
||||
{
|
||||
LPVOID msg_buf;
|
||||
|
||||
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
|
||||
NULL, GetLastError(), 0,
|
||||
(LPTSTR)&msg_buf, 0, NULL);
|
||||
fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf);
|
||||
LocalFree(msg_buf);
|
||||
}
|
||||
|
||||
static HMODULE dl_attach(const char *module) {
|
||||
wchar_t *module_utf16 = g_utf8_to_utf16 (module, -1, NULL, NULL, NULL);
|
||||
HMODULE dll = NULL;
|
||||
|
||||
if (!module_utf16)
|
||||
return NULL;
|
||||
|
||||
dll = LoadLibraryW (module_utf16);
|
||||
if (!dll)
|
||||
display_w32_error_msg (module);
|
||||
|
||||
free (module_utf16);
|
||||
return dll;
|
||||
}
|
||||
|
||||
static FARPROC dl_proc(HMODULE mo, const char *proc) {
|
||||
FARPROC procedure = GetProcAddress(mo,proc);
|
||||
if (!procedure) display_w32_error_msg(proc);
|
||||
return procedure;
|
||||
}
|
||||
|
||||
static void dl_detach(HMODULE mo) {
|
||||
(void)FreeLibrary(mo);
|
||||
}
|
||||
|
||||
#elif defined(SUN_DL)
|
||||
|
||||
#include <dlfcn.h>
|
||||
|
||||
#define PREFIX "lib"
|
||||
#define SUFFIX ".so"
|
||||
|
||||
static HMODULE dl_attach(const char *module) {
|
||||
HMODULE so=dlopen(module,RTLD_LAZY);
|
||||
if(!so) {
|
||||
fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror());
|
||||
}
|
||||
return so;
|
||||
}
|
||||
|
||||
static FARPROC dl_proc(HMODULE mo, const char *proc) {
|
||||
const char *errmsg;
|
||||
FARPROC fp=(FARPROC)dlsym(mo,proc);
|
||||
if ((errmsg = dlerror()) == 0) {
|
||||
return fp;
|
||||
}
|
||||
fprintf(stderr, "Error initializing scheme module \"%s\": %s\n", proc, errmsg);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static void dl_detach(HMODULE mo) {
|
||||
(void)dlclose(mo);
|
||||
}
|
||||
#endif
|
||||
|
||||
pointer scm_load_ext(scheme *sc, pointer args)
|
||||
{
|
||||
pointer first_arg;
|
||||
pointer retval;
|
||||
char filename[MAXPATHLEN], init_fn[MAXPATHLEN+6];
|
||||
char *name;
|
||||
HMODULE dll_handle;
|
||||
void (*module_init)(scheme *sc);
|
||||
|
||||
if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) {
|
||||
name = string_value(first_arg);
|
||||
make_filename(name,filename);
|
||||
make_init_fn(name,init_fn);
|
||||
dll_handle = dl_attach(filename);
|
||||
if (dll_handle == 0) {
|
||||
retval = sc -> F;
|
||||
}
|
||||
else {
|
||||
module_init = (void(*)(scheme *))dl_proc(dll_handle, init_fn);
|
||||
if (module_init != 0) {
|
||||
(*module_init)(sc);
|
||||
retval = sc -> T;
|
||||
}
|
||||
else {
|
||||
retval = sc->F;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
retval = sc -> F;
|
||||
}
|
||||
|
||||
return(retval);
|
||||
}
|
||||
|
||||
static void make_filename(const char *name, char *filename) {
|
||||
strcpy(filename,name);
|
||||
strcat(filename,SUFFIX);
|
||||
}
|
||||
|
||||
static void make_init_fn(const char *name, char *init_fn) {
|
||||
const char *p=strrchr(name,'/');
|
||||
if(p==0) {
|
||||
p=name;
|
||||
} else {
|
||||
p++;
|
||||
}
|
||||
strcpy(init_fn,"init_");
|
||||
strcat(init_fn,p);
|
||||
}
|
||||
12
plug-ins/script-fu/libscriptfu/tinyscheme/dynload.h
Normal file
12
plug-ins/script-fu/libscriptfu/tinyscheme/dynload.h
Normal file
@ -0,0 +1,12 @@
|
||||
/* dynload.h */
|
||||
/* Original Copyright (c) 1999 Alexander Shendi */
|
||||
/* Modifications for NT and dl_* interface: D. Souflis */
|
||||
|
||||
#ifndef DYNLOAD_H
|
||||
#define DYNLOAD_H
|
||||
|
||||
#include "scheme-private.h"
|
||||
|
||||
SCHEME_EXPORT pointer scm_load_ext(scheme *sc, pointer arglist);
|
||||
|
||||
#endif
|
||||
233
plug-ins/script-fu/libscriptfu/tinyscheme/hack.txt
Normal file
233
plug-ins/script-fu/libscriptfu/tinyscheme/hack.txt
Normal file
@ -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)));
|
||||
716
plug-ins/script-fu/libscriptfu/tinyscheme/init.scm
Normal file
716
plug-ins/script-fu/libscriptfu/tinyscheme/init.scm
Normal file
@ -0,0 +1,716 @@
|
||||
; Initialization file for TinySCHEME 1.41
|
||||
|
||||
; Per R5RS, up to four deep compositions should be defined
|
||||
(define (caar x) (car (car x)))
|
||||
(define (cadr x) (car (cdr x)))
|
||||
(define (cdar x) (cdr (car x)))
|
||||
(define (cddr x) (cdr (cdr x)))
|
||||
(define (caaar x) (car (car (car x))))
|
||||
(define (caadr x) (car (car (cdr x))))
|
||||
(define (cadar x) (car (cdr (car x))))
|
||||
(define (caddr x) (car (cdr (cdr x))))
|
||||
(define (cdaar x) (cdr (car (car x))))
|
||||
(define (cdadr x) (cdr (car (cdr x))))
|
||||
(define (cddar x) (cdr (cdr (car x))))
|
||||
(define (cdddr x) (cdr (cdr (cdr x))))
|
||||
(define (caaaar x) (car (car (car (car x)))))
|
||||
(define (caaadr x) (car (car (car (cdr x)))))
|
||||
(define (caadar x) (car (car (cdr (car x)))))
|
||||
(define (caaddr x) (car (car (cdr (cdr x)))))
|
||||
(define (cadaar x) (car (cdr (car (car x)))))
|
||||
(define (cadadr x) (car (cdr (car (cdr x)))))
|
||||
(define (caddar x) (car (cdr (cdr (car x)))))
|
||||
(define (cadddr x) (car (cdr (cdr (cdr x)))))
|
||||
(define (cdaaar x) (cdr (car (car (car x)))))
|
||||
(define (cdaadr x) (cdr (car (car (cdr x)))))
|
||||
(define (cdadar x) (cdr (car (cdr (car x)))))
|
||||
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
|
||||
(define (cddaar x) (cdr (cdr (car (car x)))))
|
||||
(define (cddadr x) (cdr (cdr (car (cdr x)))))
|
||||
(define (cdddar x) (cdr (cdr (cdr (car x)))))
|
||||
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
|
||||
|
||||
;;;; Utility to ease macro creation
|
||||
(define (macro-expand form)
|
||||
((eval (get-closure-code (eval (car form)))) form))
|
||||
|
||||
(define (macro-expand-all form)
|
||||
(if (macro? form)
|
||||
(macro-expand-all (macro-expand form))
|
||||
form))
|
||||
|
||||
(define *compile-hook* macro-expand-all)
|
||||
|
||||
|
||||
(macro (unless form)
|
||||
`(if (not ,(cadr form)) (begin ,@(cddr form))))
|
||||
|
||||
(macro (when form)
|
||||
`(if ,(cadr form) (begin ,@(cddr form))))
|
||||
|
||||
; DEFINE-MACRO Contributed by Andy Gaynor
|
||||
(macro (define-macro dform)
|
||||
(if (symbol? (cadr dform))
|
||||
`(macro ,@(cdr dform))
|
||||
(let ((form (gensym)))
|
||||
`(macro (,(caadr dform) ,form)
|
||||
(apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
|
||||
|
||||
; Utilities for math. Notice that inexact->exact is primitive,
|
||||
; but exact->inexact is not.
|
||||
(define exact? integer?)
|
||||
(define (inexact? x) (and (real? x) (not (integer? x))))
|
||||
(define (even? n) (= (remainder n 2) 0))
|
||||
(define (odd? n) (not (= (remainder n 2) 0)))
|
||||
(define (zero? n) (= n 0))
|
||||
(define (positive? n) (> n 0))
|
||||
(define (negative? n) (< n 0))
|
||||
(define complex? number?)
|
||||
(define rational? real?)
|
||||
(define (abs n) (if (>= n 0) n (- n)))
|
||||
(define (exact->inexact n) (* n 1.0))
|
||||
(define (<> n1 n2) (not (= n1 n2)))
|
||||
|
||||
; min and max must return inexact if any arg is inexact; use (+ n 0.0)
|
||||
(define (max . lst)
|
||||
(foldr (lambda (a b)
|
||||
(if (> a b)
|
||||
(if (exact? b) a (+ a 0.0))
|
||||
(if (exact? a) b (+ b 0.0))))
|
||||
(car lst) (cdr lst)))
|
||||
(define (min . lst)
|
||||
(foldr (lambda (a b)
|
||||
(if (< a b)
|
||||
(if (exact? b) a (+ a 0.0))
|
||||
(if (exact? a) b (+ b 0.0))))
|
||||
(car lst) (cdr lst)))
|
||||
|
||||
(define (succ x) (+ x 1))
|
||||
(define (pred x) (- x 1))
|
||||
(define gcd
|
||||
(lambda a
|
||||
(if (null? a)
|
||||
0
|
||||
(let ((aa (abs (car a)))
|
||||
(bb (abs (cadr a))))
|
||||
(if (= bb 0)
|
||||
aa
|
||||
(gcd bb (remainder aa bb)))))))
|
||||
(define lcm
|
||||
(lambda a
|
||||
(if (null? a)
|
||||
1
|
||||
(let ((aa (abs (car a)))
|
||||
(bb (abs (cadr a))))
|
||||
(if (or (= aa 0) (= bb 0))
|
||||
0
|
||||
(abs (* (quotient aa (gcd aa bb)) bb)))))))
|
||||
|
||||
|
||||
(define (string . charlist)
|
||||
(list->string charlist))
|
||||
|
||||
(define (list->string charlist)
|
||||
(let* ((len (length charlist))
|
||||
(newstr (make-string len))
|
||||
(fill-string!
|
||||
(lambda (str i len charlist)
|
||||
(if (= i len)
|
||||
str
|
||||
(begin (string-set! str i (car charlist))
|
||||
(fill-string! str (+ i 1) len (cdr charlist)))))))
|
||||
(fill-string! newstr 0 len charlist)))
|
||||
|
||||
(define (string-fill! s e)
|
||||
(let ((n (string-length s)))
|
||||
(let loop ((i 0))
|
||||
(if (= i n)
|
||||
s
|
||||
(begin (string-set! s i e) (loop (succ i)))))))
|
||||
|
||||
(define (string->list s)
|
||||
(let loop ((n (pred (string-length s))) (l '()))
|
||||
(if (= n -1)
|
||||
l
|
||||
(loop (pred n) (cons (string-ref s n) l)))))
|
||||
|
||||
(define (string-copy str)
|
||||
(string-append str))
|
||||
|
||||
(define (string->anyatom str pred)
|
||||
(let* ((a (string->atom str)))
|
||||
(if (pred a) a
|
||||
(error "string->xxx: not a xxx" a))))
|
||||
|
||||
(define (string->number str . base)
|
||||
(let ((n (string->atom str (if (null? base) 10 (car base)))))
|
||||
(if (number? n) n #f)))
|
||||
|
||||
(define (anyatom->string n pred)
|
||||
(if (pred n)
|
||||
(atom->string n)
|
||||
(error "xxx->string: not a xxx" n)))
|
||||
|
||||
(define (number->string n . base)
|
||||
(atom->string n (if (null? base) 10 (car base))))
|
||||
|
||||
|
||||
(define (char-cmp? cmp a b)
|
||||
(cmp (char->integer a) (char->integer b)))
|
||||
(define (char-ci-cmp? cmp a b)
|
||||
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
|
||||
|
||||
(define (char=? a b) (char-cmp? = a b))
|
||||
(define (char<? a b) (char-cmp? < a b))
|
||||
(define (char>? a b) (char-cmp? > a b))
|
||||
(define (char<=? a b) (char-cmp? <= a b))
|
||||
(define (char>=? a b) (char-cmp? >= a b))
|
||||
|
||||
(define (char-ci=? a b) (char-ci-cmp? = a b))
|
||||
(define (char-ci<? a b) (char-ci-cmp? < a b))
|
||||
(define (char-ci>? a b) (char-ci-cmp? > a b))
|
||||
(define (char-ci<=? a b) (char-ci-cmp? <= a b))
|
||||
(define (char-ci>=? a b) (char-ci-cmp? >= a b))
|
||||
|
||||
; Note the trick of returning (cmp x y)
|
||||
(define (string-cmp? chcmp cmp a b)
|
||||
(let ((na (string-length a)) (nb (string-length b)))
|
||||
(let loop ((i 0))
|
||||
(cond
|
||||
((= i na)
|
||||
(if (= i nb) (cmp 0 0) (cmp 0 1)))
|
||||
((= i nb)
|
||||
(cmp 1 0))
|
||||
((chcmp = (string-ref a i) (string-ref b i))
|
||||
(loop (succ i)))
|
||||
(else
|
||||
(chcmp cmp (string-ref a i) (string-ref b i)))))))
|
||||
|
||||
|
||||
(define (string=? a b) (string-cmp? char-cmp? = a b))
|
||||
(define (string<? a b) (string-cmp? char-cmp? < a b))
|
||||
(define (string>? a b) (string-cmp? char-cmp? > a b))
|
||||
(define (string<=? a b) (string-cmp? char-cmp? <= a b))
|
||||
(define (string>=? a b) (string-cmp? char-cmp? >= a b))
|
||||
|
||||
(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
|
||||
(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
|
||||
(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
|
||||
(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
|
||||
(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
|
||||
|
||||
(define (list . x) x)
|
||||
|
||||
(define (foldr f x lst)
|
||||
(if (null? lst)
|
||||
x
|
||||
(foldr f (f x (car lst)) (cdr lst))))
|
||||
|
||||
(define (unzip1-with-cdr . lists)
|
||||
(unzip1-with-cdr-iterative lists '() '()))
|
||||
|
||||
(define (unzip1-with-cdr-iterative lists cars cdrs)
|
||||
(if (null? lists)
|
||||
(cons cars cdrs)
|
||||
(let ((car1 (caar lists))
|
||||
(cdr1 (cdar lists)))
|
||||
(unzip1-with-cdr-iterative
|
||||
(cdr lists)
|
||||
(append cars (list car1))
|
||||
(append cdrs (list cdr1))))))
|
||||
|
||||
(define (map proc . lists)
|
||||
(if (null? lists)
|
||||
(apply proc)
|
||||
(if (null? (car lists))
|
||||
'()
|
||||
(let* ((unz (apply unzip1-with-cdr lists))
|
||||
(cars (car unz))
|
||||
(cdrs (cdr unz)))
|
||||
(cons (apply proc cars) (apply map (cons proc cdrs)))))))
|
||||
|
||||
(define (for-each proc . lists)
|
||||
(if (null? lists)
|
||||
(apply proc)
|
||||
(if (null? (car lists))
|
||||
#t
|
||||
(let* ((unz (apply unzip1-with-cdr lists))
|
||||
(cars (car unz))
|
||||
(cdrs (cdr unz)))
|
||||
(apply proc cars) (apply map (cons proc cdrs))))))
|
||||
|
||||
(define (list-tail x k)
|
||||
(if (zero? k)
|
||||
x
|
||||
(list-tail (cdr x) (- k 1))))
|
||||
|
||||
(define (list-ref x k)
|
||||
(car (list-tail x k)))
|
||||
|
||||
(define (last-pair x)
|
||||
(if (pair? (cdr x))
|
||||
(last-pair (cdr x))
|
||||
x))
|
||||
|
||||
(define (head stream) (car stream))
|
||||
|
||||
(define (tail stream) (force (cdr stream)))
|
||||
|
||||
(define (vector-equal? x y)
|
||||
(and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
|
||||
(let ((n (vector-length x)))
|
||||
(let loop ((i 0))
|
||||
(if (= i n)
|
||||
#t
|
||||
(and (equal? (vector-ref x i) (vector-ref y i))
|
||||
(loop (succ i))))))))
|
||||
|
||||
(define (list->vector x)
|
||||
(apply vector x))
|
||||
|
||||
(define (vector-fill! v e)
|
||||
(let ((n (vector-length v)))
|
||||
(let loop ((i 0))
|
||||
(if (= i n)
|
||||
v
|
||||
(begin (vector-set! v i e) (loop (succ i)))))))
|
||||
|
||||
(define (vector->list v)
|
||||
(let loop ((n (pred (vector-length v))) (l '()))
|
||||
(if (= n -1)
|
||||
l
|
||||
(loop (pred n) (cons (vector-ref v n) l)))))
|
||||
|
||||
;; The following quasiquote macro is due to Eric S. Tiedemann.
|
||||
;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
|
||||
;;
|
||||
;; Subsequently modified to handle vectors: D. Souflis
|
||||
|
||||
(macro
|
||||
quasiquote
|
||||
(lambda (l)
|
||||
(define (mcons f l r)
|
||||
(if (and (pair? r)
|
||||
(eq? (car r) 'quote)
|
||||
(eq? (car (cdr r)) (cdr f))
|
||||
(pair? l)
|
||||
(eq? (car l) 'quote)
|
||||
(eq? (car (cdr l)) (car f)))
|
||||
(if (or (procedure? f) (number? f) (string? f))
|
||||
f
|
||||
(list 'quote f))
|
||||
(if (eqv? l vector)
|
||||
(apply l (eval r))
|
||||
(list 'cons l r)
|
||||
)))
|
||||
(define (mappend f l r)
|
||||
(if (or (null? (cdr f))
|
||||
(and (pair? r)
|
||||
(eq? (car r) 'quote)
|
||||
(eq? (car (cdr r)) '())))
|
||||
l
|
||||
(list 'append l r)))
|
||||
(define (foo level form)
|
||||
(cond ((not (pair? form))
|
||||
(if (or (procedure? form) (number? form) (string? form))
|
||||
form
|
||||
(list 'quote form))
|
||||
)
|
||||
((eq? 'quasiquote (car form))
|
||||
(mcons form ''quasiquote (foo (+ level 1) (cdr form))))
|
||||
(#t (if (zero? level)
|
||||
(cond ((eq? (car form) 'unquote) (car (cdr form)))
|
||||
((eq? (car form) 'unquote-splicing)
|
||||
(error "Unquote-splicing wasn't in a list:"
|
||||
form))
|
||||
((and (pair? (car form))
|
||||
(eq? (car (car form)) 'unquote-splicing))
|
||||
(mappend form (car (cdr (car form)))
|
||||
(foo level (cdr form))))
|
||||
(#t (mcons form (foo level (car form))
|
||||
(foo level (cdr form)))))
|
||||
(cond ((eq? (car form) 'unquote)
|
||||
(mcons form ''unquote (foo (- level 1)
|
||||
(cdr form))))
|
||||
((eq? (car form) 'unquote-splicing)
|
||||
(mcons form ''unquote-splicing
|
||||
(foo (- level 1) (cdr form))))
|
||||
(#t (mcons form (foo level (car form))
|
||||
(foo level (cdr form)))))))))
|
||||
(foo 0 (car (cdr l)))))
|
||||
|
||||
;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
|
||||
(define (shared-tail x y)
|
||||
(let ((len-x (length x))
|
||||
(len-y (length y)))
|
||||
(define (shared-tail-helper x y)
|
||||
(if
|
||||
(eq? x y)
|
||||
x
|
||||
(shared-tail-helper (cdr x) (cdr y))))
|
||||
|
||||
(cond
|
||||
((> len-x len-y)
|
||||
(shared-tail-helper
|
||||
(list-tail x (- len-x len-y))
|
||||
y))
|
||||
((< len-x len-y)
|
||||
(shared-tail-helper
|
||||
x
|
||||
(list-tail y (- len-y len-x))))
|
||||
(#t (shared-tail-helper x y)))))
|
||||
|
||||
;;;;;Dynamic-wind by Tom Breton (Tehom)
|
||||
|
||||
;;Guarded because we must only eval this once, because doing so
|
||||
;;redefines call/cc in terms of old call/cc
|
||||
(unless (defined? 'dynamic-wind)
|
||||
(let
|
||||
;;These functions are defined in the context of a private list of
|
||||
;;pairs of before/after procs.
|
||||
( (*active-windings* '())
|
||||
;;We'll define some functions into the larger environment, so
|
||||
;;we need to know it.
|
||||
(outer-env (current-environment)))
|
||||
|
||||
;;Poor-man's structure operations
|
||||
(define before-func car)
|
||||
(define after-func cdr)
|
||||
(define make-winding cons)
|
||||
|
||||
;;Manage active windings
|
||||
(define (activate-winding! new)
|
||||
((before-func new))
|
||||
(set! *active-windings* (cons new *active-windings*)))
|
||||
(define (deactivate-top-winding!)
|
||||
(let ((old-top (car *active-windings*)))
|
||||
;;Remove it from the list first so it's not active during its
|
||||
;;own exit.
|
||||
(set! *active-windings* (cdr *active-windings*))
|
||||
((after-func old-top))))
|
||||
|
||||
(define (set-active-windings! new-ws)
|
||||
(unless (eq? new-ws *active-windings*)
|
||||
(let ((shared (shared-tail new-ws *active-windings*)))
|
||||
|
||||
;;Define the looping functions.
|
||||
;;Exit the old list. Do deeper ones last. Don't do
|
||||
;;any shared ones.
|
||||
(define (pop-many)
|
||||
(unless (eq? *active-windings* shared)
|
||||
(deactivate-top-winding!)
|
||||
(pop-many)))
|
||||
;;Enter the new list. Do deeper ones first so that the
|
||||
;;deeper windings will already be active. Don't do any
|
||||
;;shared ones.
|
||||
(define (push-many new-ws)
|
||||
(unless (eq? new-ws shared)
|
||||
(push-many (cdr new-ws))
|
||||
(activate-winding! (car new-ws))))
|
||||
|
||||
;;Do it.
|
||||
(pop-many)
|
||||
(push-many new-ws))))
|
||||
|
||||
;;The definitions themselves.
|
||||
(eval
|
||||
`(define call-with-current-continuation
|
||||
;;It internally uses the built-in call/cc, so capture it.
|
||||
,(let ((old-c/cc call-with-current-continuation))
|
||||
(lambda (func)
|
||||
;;Use old call/cc to get the continuation.
|
||||
(old-c/cc
|
||||
(lambda (continuation)
|
||||
;;Call func with not the continuation itself
|
||||
;;but a procedure that adjusts the active
|
||||
;;windings to what they were when we made
|
||||
;;this, and only then calls the
|
||||
;;continuation.
|
||||
(func
|
||||
(let ((current-ws *active-windings*))
|
||||
(lambda (x)
|
||||
(set-active-windings! current-ws)
|
||||
(continuation x)))))))))
|
||||
outer-env)
|
||||
;;We can't just say "define (dynamic-wind before thunk after)"
|
||||
;;because the lambda it's defined to lives in this environment,
|
||||
;;not in the global environment.
|
||||
(eval
|
||||
`(define dynamic-wind
|
||||
,(lambda (before thunk after)
|
||||
;;Make a new winding
|
||||
(activate-winding! (make-winding before after))
|
||||
(let ((result (thunk)))
|
||||
;;Get rid of the new winding.
|
||||
(deactivate-top-winding!)
|
||||
;;The return value is that of thunk.
|
||||
result)))
|
||||
outer-env)))
|
||||
|
||||
(define call/cc call-with-current-continuation)
|
||||
|
||||
|
||||
;;;;; atom? and equal? written by a.k
|
||||
|
||||
;;;; atom?
|
||||
(define (atom? x)
|
||||
(not (pair? x)))
|
||||
|
||||
;;;; equal?
|
||||
(define (equal? x y)
|
||||
(cond
|
||||
((pair? x)
|
||||
(and (pair? y)
|
||||
(equal? (car x) (car y))
|
||||
(equal? (cdr x) (cdr y))))
|
||||
((vector? x)
|
||||
(and (vector? y) (vector-equal? x y)))
|
||||
((string? x)
|
||||
(and (string? y) (string=? x y)))
|
||||
(else (eqv? x y))))
|
||||
|
||||
;;;; (do ((var init inc) ...) (endtest result ...) body ...)
|
||||
;;
|
||||
(macro do
|
||||
(lambda (do-macro)
|
||||
(apply (lambda (do vars endtest . body)
|
||||
(let ((do-loop (gensym)))
|
||||
`(letrec ((,do-loop
|
||||
(lambda ,(map (lambda (x)
|
||||
(if (pair? x) (car x) x))
|
||||
`,vars)
|
||||
(if ,(car endtest)
|
||||
(begin ,@(cdr endtest))
|
||||
(begin
|
||||
,@body
|
||||
(,do-loop
|
||||
,@(map (lambda (x)
|
||||
(cond
|
||||
((not (pair? x)) x)
|
||||
((< (length x) 3) (car x))
|
||||
(else (car (cdr (cdr x))))))
|
||||
`,vars)))))))
|
||||
(,do-loop
|
||||
,@(map (lambda (x)
|
||||
(if (and (pair? x) (cdr x))
|
||||
(car (cdr x))
|
||||
'()))
|
||||
`,vars)))))
|
||||
do-macro)))
|
||||
|
||||
;;;; generic-member
|
||||
(define (generic-member cmp obj lst)
|
||||
(cond
|
||||
((null? lst) #f)
|
||||
((cmp obj (car lst)) lst)
|
||||
(else (generic-member cmp obj (cdr lst)))))
|
||||
|
||||
(define (memq obj lst)
|
||||
(generic-member eq? obj lst))
|
||||
(define (memv obj lst)
|
||||
(generic-member eqv? obj lst))
|
||||
(define (member obj lst)
|
||||
(generic-member equal? obj lst))
|
||||
|
||||
;;;; generic-assoc
|
||||
(define (generic-assoc cmp obj alst)
|
||||
(cond
|
||||
((null? alst) #f)
|
||||
((cmp obj (caar alst)) (car alst))
|
||||
(else (generic-assoc cmp obj (cdr alst)))))
|
||||
|
||||
(define (assq obj alst)
|
||||
(generic-assoc eq? obj alst))
|
||||
(define (assv obj alst)
|
||||
(generic-assoc eqv? obj alst))
|
||||
(define (assoc obj alst)
|
||||
(generic-assoc equal? obj alst))
|
||||
|
||||
(define (acons x y z) (cons (cons x y) z))
|
||||
|
||||
;;;; Handy for imperative programs
|
||||
;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
|
||||
(macro (define-with-return form)
|
||||
`(define ,(cadr form)
|
||||
(call/cc (lambda (return) ,@(cddr form)))))
|
||||
|
||||
;;;; Simple exception handling
|
||||
;
|
||||
; Exceptions are caught as follows:
|
||||
;
|
||||
; (catch (do-something to-recover and-return meaningful-value)
|
||||
; (if-something goes-wrong)
|
||||
; (with-these calls))
|
||||
;
|
||||
; "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)
|
||||
|
||||
(define *handlers* (list))
|
||||
|
||||
(define (push-handler proc)
|
||||
(set! *handlers* (cons proc *handlers*)))
|
||||
|
||||
(define (pop-handler)
|
||||
(let ((h (car *handlers*)))
|
||||
(set! *handlers* (cdr *handlers*))
|
||||
h))
|
||||
|
||||
(define (more-handlers?)
|
||||
(pair? *handlers*))
|
||||
|
||||
(define (throw . x)
|
||||
(if (more-handlers?)
|
||||
(apply (pop-handler))
|
||||
(apply error x)))
|
||||
|
||||
(macro (catch form)
|
||||
(let ((label (gensym)))
|
||||
`(call/cc (lambda (exit)
|
||||
(push-handler (lambda () (exit ,(cadr form))))
|
||||
(let ((,label (begin ,@(cddr form))))
|
||||
(pop-handler)
|
||||
,label)))))
|
||||
|
||||
(define *error-hook* throw)
|
||||
|
||||
|
||||
;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
|
||||
|
||||
(macro (make-environment form)
|
||||
`(apply (lambda ()
|
||||
,@(cdr form)
|
||||
(current-environment))))
|
||||
|
||||
(define-macro (eval-polymorphic x . envl)
|
||||
(display envl)
|
||||
(let* ((env (if (null? envl) (current-environment) (eval (car envl))))
|
||||
(xval (eval x env)))
|
||||
(if (closure? xval)
|
||||
(make-closure (get-closure-code xval) env)
|
||||
xval)))
|
||||
|
||||
; Redefine this if you install another package infrastructure
|
||||
; Also redefine 'package'
|
||||
(define *colon-hook* eval)
|
||||
|
||||
;;;;; I/O
|
||||
|
||||
(define (input-output-port? p)
|
||||
(and (input-port? p) (output-port? p)))
|
||||
|
||||
(define (close-port p)
|
||||
(cond
|
||||
((input-output-port? p) (close-input-port p) (close-output-port p))
|
||||
((input-port? p) (close-input-port p))
|
||||
((output-port? p) (close-output-port p))
|
||||
(else (throw "Not a port" p))))
|
||||
|
||||
(define (call-with-input-file s p)
|
||||
(let ((inport (open-input-file s)))
|
||||
(if (eq? inport #f)
|
||||
#f
|
||||
(let ((res (p inport)))
|
||||
(close-input-port inport)
|
||||
res))))
|
||||
|
||||
(define (call-with-output-file s p)
|
||||
(let ((outport (open-output-file s)))
|
||||
(if (eq? outport #f)
|
||||
#f
|
||||
(let ((res (p outport)))
|
||||
(close-output-port outport)
|
||||
res))))
|
||||
|
||||
(define (with-input-from-file s p)
|
||||
(let ((inport (open-input-file s)))
|
||||
(if (eq? inport #f)
|
||||
#f
|
||||
(let ((prev-inport (current-input-port)))
|
||||
(set-input-port inport)
|
||||
(let ((res (p)))
|
||||
(close-input-port inport)
|
||||
(set-input-port prev-inport)
|
||||
res)))))
|
||||
|
||||
(define (with-output-to-file s p)
|
||||
(let ((outport (open-output-file s)))
|
||||
(if (eq? outport #f)
|
||||
#f
|
||||
(let ((prev-outport (current-output-port)))
|
||||
(set-output-port outport)
|
||||
(let ((res (p)))
|
||||
(close-output-port outport)
|
||||
(set-output-port prev-outport)
|
||||
res)))))
|
||||
|
||||
(define (with-input-output-from-to-files si so p)
|
||||
(let ((inport (open-input-file si))
|
||||
(outport (open-input-file so)))
|
||||
(if (not (and inport outport))
|
||||
(begin
|
||||
(close-input-port inport)
|
||||
(close-output-port outport)
|
||||
#f)
|
||||
(let ((prev-inport (current-input-port))
|
||||
(prev-outport (current-output-port)))
|
||||
(set-input-port inport)
|
||||
(set-output-port outport)
|
||||
(let ((res (p)))
|
||||
(close-input-port inport)
|
||||
(close-output-port outport)
|
||||
(set-input-port prev-inport)
|
||||
(set-output-port prev-outport)
|
||||
res)))))
|
||||
|
||||
; Random number generator (maximum cycle)
|
||||
(define *seed* 1)
|
||||
(define (random-next)
|
||||
(let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
|
||||
(set! *seed*
|
||||
(- (* a (- *seed*
|
||||
(* (quotient *seed* q) q)))
|
||||
(* (quotient *seed* q) r)))
|
||||
(if (< *seed* 0) (set! *seed* (+ *seed* m)))
|
||||
*seed*))
|
||||
;; SRFI-0
|
||||
;; COND-EXPAND
|
||||
;; Implemented as a macro
|
||||
(define *features* '(srfi-0 tinyscheme))
|
||||
|
||||
(define-macro (cond-expand . cond-action-list)
|
||||
(cond-expand-runtime cond-action-list))
|
||||
|
||||
(define (cond-expand-runtime cond-action-list)
|
||||
(if (null? cond-action-list)
|
||||
#t
|
||||
(if (cond-eval (caar cond-action-list))
|
||||
`(begin ,@(cdar cond-action-list))
|
||||
(cond-expand-runtime (cdr cond-action-list)))))
|
||||
|
||||
(define (cond-eval-and cond-list)
|
||||
(foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
|
||||
|
||||
(define (cond-eval-or cond-list)
|
||||
(foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
|
||||
|
||||
(define (cond-eval condition)
|
||||
(cond
|
||||
((symbol? condition)
|
||||
(if (member condition *features*) #t #f))
|
||||
((eq? condition #t) #t)
|
||||
((eq? condition #f) #f)
|
||||
(else (case (car condition)
|
||||
((and) (cond-eval-and (cdr condition)))
|
||||
((or) (cond-eval-or (cdr condition)))
|
||||
((not) (if (not (null? (cddr condition)))
|
||||
(error "cond-expand : 'not' takes 1 argument")
|
||||
(not (cond-eval (cadr condition)))))
|
||||
(else (error "cond-expand : unknown operator" (car condition)))))))
|
||||
|
||||
(gc-verbose #f)
|
||||
18
plug-ins/script-fu/libscriptfu/tinyscheme/meson.build
Normal file
18
plug-ins/script-fu/libscriptfu/tinyscheme/meson.build
Normal file
@ -0,0 +1,18 @@
|
||||
|
||||
# No include_directories('.') here; use libscriptfuInclude
|
||||
|
||||
scriptfu_tinyscheme = static_library('scriptfu-tinyscheme',
|
||||
'scheme.c',
|
||||
include_directories: [ rootInclude, ],
|
||||
dependencies: [
|
||||
glib,
|
||||
],
|
||||
c_args: [
|
||||
'-DSTANDALONE=0',
|
||||
'-DUSE_ASCII_NAMES=0',
|
||||
'-DUSE_INTERFACE=1',
|
||||
'-DUSE_MATH=1',
|
||||
'-DUSE_STRLWR=0',
|
||||
],
|
||||
install: false,
|
||||
)
|
||||
202
plug-ins/script-fu/libscriptfu/tinyscheme/opdefines.h
Normal file
202
plug-ins/script-fu/libscriptfu/tinyscheme/opdefines.h
Normal file
@ -0,0 +1,202 @@
|
||||
_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", 2, 2, 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, "byte->integer", 1, 1, TST_BYTE, OP_BYTE2INT )
|
||||
_OP_DEF(opexe_2, "integer->byte", 1, 1, TST_NATURAL, OP_INT2BYTE )
|
||||
_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, "byte?", 1, 1, TST_ANY, OP_BYTEP )
|
||||
_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-byte", 1, 2, TST_BYTE TST_OUTPORT, OP_WRITE_BYTE )
|
||||
_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, "read-byte", 0, 1, TST_INPORT, OP_READ_BYTE )
|
||||
_OP_DEF(opexe_5, "peek-byte", 0, 1, TST_INPORT, OP_PEEK_BYTE )
|
||||
_OP_DEF(opexe_5, "byte-ready?", 0, 1, TST_INPORT, OP_BYTE_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
|
||||
226
plug-ins/script-fu/libscriptfu/tinyscheme/scheme-private.h
Normal file
226
plug-ins/script-fu/libscriptfu/tinyscheme/scheme-private.h
Normal file
@ -0,0 +1,226 @@
|
||||
/* 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 */
|
||||
};
|
||||
|
||||
/* 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_byte (pointer p);
|
||||
int is_character(pointer p);
|
||||
int string_length(pointer p);
|
||||
guint8 bytevalue (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:
|
||||
*/
|
||||
5593
plug-ins/script-fu/libscriptfu/tinyscheme/scheme.c
Normal file
5593
plug-ins/script-fu/libscriptfu/tinyscheme/scheme.c
Normal file
File diff suppressed because it is too large
Load Diff
277
plug-ins/script-fu/libscriptfu/tinyscheme/scheme.h
Normal file
277
plug-ins/script-fu/libscriptfu/tinyscheme/scheme.h
Normal file
@ -0,0 +1,277 @@
|
||||
/* 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_byte (scheme *sc, guint8 b);
|
||||
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_byte)(scheme *sc, guint8 b);
|
||||
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_byte)(pointer p);
|
||||
int (*is_character)(pointer p);
|
||||
guint8 (*bytevalue)(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:
|
||||
*/
|
||||
Reference in New Issue
Block a user
