graphics/gimp
graphics/gimp
1
0
Fork 0
mirror of https://gitlab.gnome.org/GNOME/gimp synced 2024-10-21 12:02:32 +00:00
Code Issues Packages Projects Releases Wiki Activity

Added extra files temporarily lost during the autoconf process.

Browse source
This commit is contained in:
Kevin Cozens 2004-10-07 05:45:51 +00:00
parent 4117fa4474
commit fcf69f02d6
11 changed files with 1971 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
plug-ins/script-fu/ftx/LICENSE Normal file
View file

@ -0,0 +1,31 @@
LICENSE TERMS
(c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com)
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 Manuel Heras-Gilsanz 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.

108
plug-ins/script-fu/ftx/ftx-functions.txt Normal file
View file

@ -0,0 +1,108 @@
File and Time Extensions for TinyScheme (FTX) 1.0 [August, 2004]
Based on the TinyScheme Extensions (TSX) 1.1 [September, 2002]
(c) 2002 Manuel Heras-Gilsanz (manuel@heras-gilsanz.com)
This software is subject to the license terms contained in the
LICENSE file.
TSX FUNCTIONS
TSX incorporates the following functions:
*File system (included if HAVE_FILESYSTEM is defined in tsx.h)
Scheme already defines functions to read and write files. These
functions allow access to the filesystem to check if a certain
file exists, to get its size, etc.
In addition to these functions, a string constant DIR-SEPARATOR
has been defined. It should be used in scripts which build file
names that include one or more directories to keep the scripts
portable to different operating systems.
(file-exists? filename)
filename: string
This function returns #t if the indicated file exists, and
#f if it does not exist or if it is not accessible to the
requesting user. Accessibility is based on the real user
and group ID rather than the effective user ID and group ID.
(file-type filename)
filename: string
This function returns a value based on the file type. It
returns FILE_TYPE_FILE (1) for regular files, FILE_TYPE_DIR
(2) for directories, and FILE_TYPE_LINK (3) for symbolic
links. The value FILE_TYPE_OTHER (0) is returned if the file
is of some other type, does not exist, or if the user does
not have sufficient priveleges to allow the file type to be
determined.
(file-size filename)
filename: string
This function returns the size (in bytes) of the
indicated file, or #f if the file does not exists or
is not accessible to the requesting user.
(file-delete filename)
filename: string
Removes the specified file. It returns #t if the operation
succeeds, or #f otherwise (e.g., because the file is
read-only, or because the file does not exist).
(dir-open-stream path)
path: string
Opens a "directory stream" on the provided directory path.
This stream will provide all the files within the directory,
using the function read-dir-entry. The stream should be closed
at the end with dir-close-stream.
(dir-read-entry dirstream)
dirstream: directory stream, obtained with dir-open-stream.
It returns the name of the following directory entry, or eof
if all the entries were provided. Check the return value with
with eof-object?.
(dir-rewind dirstream)
dirstream: directory stream, obtained with dir-open-stream.
Resets the given directory stream. The next call to dir-read-entry
will return the first entry again. It returns #t if the operation
succeeds, or #f otherwise (ie. dirstream not valid)..
(dir-close-stream dirstream)
dirstream: directory stream, obtained with dir-open-stream.
Close directory stream. No further calls to read-dir-entry should
be performed.
*Time (available if HAVE_TIME is defined in tsx.h)
(time)
Returns the current local time, as a list of integer
containing:
(year month day-of-month hour min sec millisec)
The year is expressed as an offsett from 1900.
(gettimeofday)
Returns a list containing the number of seconds from
the beginning of the day, and microseconds within the
current second.
(usleep microsec)
microsec: integer
Suspends execution of the calling thread during the
specified number of microseconds.
END

58
plug-ins/script-fu/ftx/listhome.scm Normal file
View file

@ -0,0 +1,58 @@
; listhome.scm
; Sample usage of TinyScheme Extension
; This simple program lists the directory entries on the
; user's home directory.
; It uses the following TinyScheme Extension functions:
; getenv
; Used to get HOME environment variable.
; open-dir-stream
; Used to open directory stream.
; read-dir-entry
; Used to read directory entries.
; close-dir-entry
; Used at the end, to close directory stream when done.
; check that extensions are enabled
(if (not (defined? 'load-extension))
(begin
(display "TinyScheme has extensions disabled. Enable them!!")
(newline)
(quit)))
; load TinyScheme extension
(load-extension "tsx-1.1/tsx")
; check that the necessary functions are available (the user
; might have removed some functionality...)
(if (or
(not (defined? 'getenv))
(not (defined? 'dir-open-stream))
(not (defined? 'dir-read-entry))
(not (defined? 'dir-close-stream)))
(begin
(display "Some necessary functions are not available. Exiting!")
(newline)
(quit)))
; get user's home dir from HOME environment var
(define homedir (getenv "HOME"))
(display "Listing contents of ") (display homedir) (newline)
; create directory stream to read dir entries
(define dirstream (dir-open-stream homedir))
(if (not dirstream)
(begin
(display "Unable to open home directory!! Check value of HOME environment var.")
(quit)))
(let listentry ((entry (dir-read-entry dirstream)))
(if (eof-object? entry)
#t
(begin
(display entry)
(newline)
(listentry (dir-read-entry dirstream)))))
(dir-close-stream dirstream)

64
plug-ins/script-fu/tinyscheme/BUILDING Normal file
View file

@ -0,0 +1,64 @@
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.

194
plug-ins/script-fu/tinyscheme/CHANGES Normal file
View file

@ -0,0 +1,194 @@
Change Log
----------
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 dissappeared from the interface. They
should be considered as deprecated.
Version 1.30
After many months, I followed Preston Bannister's advice of
using macros and a single source text to keep the enums and the
dispatch table in sync, and I used his contributed "opdefines.h".
Timothy Downs contributed a helpful function, "scheme_call".
Stephen Gildea contributed new versions of the makefile and
practically all other sources. He created a built-in STRING-APPEND,
and fixed a lot of other bugs.
Ruhi Bloodworth reported fixes necessary for OS X and a small
bug in dynload.c.
Version 1.29
The previous version contained a lot of corrections, but there
were a lot more that still wait on a sheet of paper lost in a
carton someplace after my house move... Manuel Heras-Gilsanz
noticed this and resent his own contribution, which relies on
another bugfix that v.1.28 was missing: a problem with string
output, that this version fixes. I hope other people will take
the time to resend their contributions, if they didn't make it
to v.1.28.
Version 1.28
Many people have contacted me with bugfixes or remarks in
the three months I was inactive. A lot of them spotted that
scheme_deinit crashed while reporting gc results. They suggested
that sc->outport be set to NIL in scheme_deinit, which I did.
Dennis Taylor remarked that OP_VALUEPRINT reset sc->value instead
of preserving it. He submitted a modification which I adopted
partially. David Hovemeyer sent me many little changes, that you
will find in version 1.28, and Partice Stoessel modified the
float reader to conform to R5RS.
Version 1.27
Version 1.27 is the successor of 1.25. Bug fixes only, but I had to
release them so that everybody can profit. 'Backchar' tried to write
back to the string, which obviously didn't work for const strings.
'Substring' didn't check for crossed start and end indices. Defines
changed to restore the ability to compile under MSVC.
Version 1.26
Version 1.26 was never released. I changed a lot of things, in fact
too much, even the garbage collector, and hell broke loose. I'll
try a more gradual approach next time.
Version 1.25
Types have been homogenized to be able to accomodate 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.

452
plug-ins/script-fu/tinyscheme/Manual.txt Normal file
View file

@ -0,0 +1,452 @@
TinySCHEME Version 1.34
"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
----------
SCM tests had revealed a memory allocation error in the past, but not
anymore. It probably had to do with vectors, and version 1.21 probably
got rid of it.
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...
I will add a debugger... The user will be able to specify breakpoints,
and a new toplevel will be entered when the breakpoint is reached. Most
of the actual debugger will be in Scheme, with minimal additions to
scheme.c.
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 immediatelly.
(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 and \xDD (hex 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
refered 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,
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.
Esoteric procedures
(oblist)
Returns the oblist, an immutable list of all the symbols.
(macro-expand <form>)
Returns the expanded form of the macro call denoted by the argument
(define-with-return (<procname> <args>...) <body>)
Like plain 'define', but makes the continuation available as 'return'
inside the procedure. Handy for imperative programs.
(new-segment <num>)
Allocates more memory segments.
defined?
See "Environments"
(get-closure-code <closure>)
Gets the code as scheme data.
(make-closure <code> <environment>)
Makes a new closure in the given environment.
Obsolete procedures
(print-width <object>)
Programmer's Reference
----------------------
The interpreter state is initialized with "scheme_init".
Custom memory allocation routines can be installed with an alternate
initialization function: "scheme_init_custom_alloc".
Files can be loaded with "scheme_load_file". Strings containing Scheme
code can be loaded with "scheme_load_string". It is a good idea to
"scheme_load" init.scm before anything else.
External data for keeping external state (of use to foreign functions)
can be installed with "scheme_set_external_data".
Foreign functions are installed with "assign_foreign". Additional
definitions can be added to the interpreter state, with "scheme_define"
(this is the way HTTP header data and HTML form data are passed to the
Scheme script in the Altera SQL Server). If you wish to define the
foreign function in a specific environment (to enhance modularity),
use "assign_foreign_env".
The procedure "scheme_apply0" has been added with persistent scripts in
mind. Persistent scripts are loaded once, and every time they are needed
to produce HTTP output, appropriate data are passed through global
definitions and function "main" is called to do the job. One could
add easily "scheme_apply1" etc.
The interpreter state should be deinitialized with "scheme_deinit".
DLLs containing foreign functions should define a function named
init_<base-name>. E.g. foo.dll should define init_foo, and bar.so
should define init_bar. This function should assign_foreign any foreign
function contained in the DLL.
The first dynamically loaded extension available for TinyScheme is
a regular expression library. Although it's by no means an
established standard, this library is supposed to be installed in
a directory mirroring its name under the TinyScheme location.
Foreign Functions
-----------------
The user can add foreign functions in C. For example, a function
that squares its argument:
pointer square(scheme *sc, pointer args) {
if(args!=sc->NIL) {
if(sc->isnumber(sc->pair_car(args))) {
double v=sc->rvalue(sc->pair_car(args));
return sc->mk_real(sc,v*v);
}
}
return sc->NIL;
}
Foreign functions are now defined as closures:
sc->interface->scheme_define(
sc,
sc->global_env,
sc->interface->mk_symbol(sc,"square"),
sc->interface->mk_foreign_func(sc, square));
Foreign functions can use the external data in the "scheme" struct
to implement any kind of external state.
External data are set with the following function:
void scheme_set_external_data(scheme *sc, void *p);
As of v.1.17, the canonical way for a foreign function in a DLL to
manipulate Scheme data is using the function pointers in sc->interface.
Standalone
----------
Usage: tinyscheme -?
or: tinyscheme [<file1> <file2> ...]
followed by
-1 <file> [<arg1> <arg2> ...]
-c <Scheme commands> [<arg1> <arg2> ...]
assuming that the executable is named tinyscheme.
Use - in the place of a filename to denote stdin.
The -1 flag is meant for #! usage in shell scripts. If you specify
#! /somewhere/tinyscheme -1
then tinyscheme will be called to process the file. For example, the
following script echoes the Scheme list of its arguments.
#! /somewhere/tinyscheme -1
(display *args*)
The -c flag permits execution of arbitrary Scheme code.
Error Handling
--------------
Errors are recovered from without damage. The user can install his
own handler for system errors, by defining *error-hook*. Defining
to '() gives the default behavior, which is equivalent to "error".
USE_ERROR_HOOK must be defined.
A simple exception handling mechanism can be found in "init.scm".
A new syntactic form is introduced:
(catch <expr returned exceptionally>
<expr1> <expr2> ... <exprN>)
"Catch" establishes a scope spanning multiple call-frames
until another "catch" is encountered.
Exceptions are thrown with:
(throw "message")
If used outside a (catch ...), reverts to (error "message").
Example of use:
(define (foo x) (write x) (newline) (/ x 0))
(catch (begin (display "Error!\n") 0)
(write "Before foo ... ")
(foo 5)
(write "After foo"))
The exception mechanism can be used even by system errors, by
(define *error-hook* throw)
which makes use of the error hook described above.
If necessary, the user can devise his own exception mechanism with
tagged exceptions etc.
Reader extensions
-----------------
When encountering an unknown character after '#', the user-specified
procedure *sharp-hook* (if any), is called to read the expression.
This can be used to extend the reader to handle user-defined constants
or whatever. It should be a procedure without arguments, reading from
the current input port (which will be the load-port).
Colon Qualifiers - Packages
---------------------------
When USE_COLON_HOOK=1:
The lexer now recognizes the construction <qualifier>::<symbol> and
transforms it in the following manner (T is the transformation function):
T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>)
where <qualifier> is a symbol not containing any double-colons.
As the definition is recursive, qualifiers can be nested.
The user can define his own *colon-hook*, to handle qualified names.
By default, "init.scm" defines *colon-hook* as EVAL. Consequently,
the qualifier must denote a Scheme environment, such as one returned
by (interaction-environment). "Init.scm" defines a new syntantic form,
PACKAGE, as a simple example. It is used like this:
(define toto
(package
(define foo 1)
(define bar +)))
foo ==> Error, "foo" undefined
(eval 'foo) ==> Error, "foo" undefined
(eval 'foo toto) ==> 1
toto::foo ==> 1
((eval 'bar toto) 2 (eval 'foo toto)) ==> 3
(toto::bar 2 toto::foo) ==> 3
(eval (bar 2 foo) toto) ==> 3
If the user installs another package infrastructure, he must define
a new 'package' procedure or macro to retain compatibility with supplied
code.
Note: Older versions used ':' as a qualifier. Unfortunately, the use
of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially
precludes its use as a real qualifier.

88
plug-ins/script-fu/tinyscheme/MiniSCHEMETribute.txt Normal file
View file

@ -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 trully 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")

143
plug-ins/script-fu/tinyscheme/dynload.c Normal file
View file

@ -0,0 +1,143 @@
/* 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>
#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)();
#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) {
HMODULE dll = LoadLibrary(module);
if (!dll) display_w32_error_msg(module);
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/tinyscheme/dynload.h Normal file
View 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

236
plug-ins/script-fu/tinyscheme/hack.txt Normal file
View file

@ -0,0 +1,236 @@
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.
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; it begins with T_STRING. Add a new one at the end, say
T_MEMBLOCK. There can be at most 31 types, but you don't have to
worry about that limit yet.
| ...
| T_PORT,
| T_VECTOR, /* remember to add a comma to the preceding item! */
| T_MEMBLOCK
} };
Then, some helper macros would be useful. Go to where isstring() and
the rest are defined and define:
> int ismemblock(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 ismemblock(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 couln't reuse existing fields, we could always add other
alternatives in union _object.
We then procede 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(isstring(a)) {
| sc->free(strvalue(a));
| }
> else if(ismemblock(a)) {
> sc->free(strvalue(x));
> }
| }
There are no MEMBLOCK literals, so we don't concern ourselfs with
the READER part (yet!). We must cater to the PRINTER, though. We
add one case more in printatom().
| } else if (iscontinuation(l)) {
| p = "#<CONTINUATION>";
> } else if (ismemblock(l)) {
> p = "#<MEMORY BLOCK>";
| }
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. There is a huge enum with OP_XXX values.
That's where the op-codes are declared. For reasons of cohesion, we add
the new op-codes right after those for vectors:
| OP_VECSET,
> OP_MKBLOCK,
> OP_MEMBLOCKP,
> OP_BLOCKLEN,
> OP_BLOCKREF,
> OP_BLOCKSET,
| OP_NOT,
We add the predicate along the other predicates:
| OP_VECTORP,
> OP_BLOCKP,
| OP_EQ,
Op-codes are really just tags for a huge C switch, only this switch
is broke up in a number of different opexe_X functions. The
correspondence is made in table "dispatch_table". There, we assign
the new op-codes to opexe_2, where the equivalent ones for vectors
are situated. We also assign a name for them, and specify the minimum
and maximum arity. INF_ARG as a maximum arity means "unlimited".
| {opexe_2, "vector-set!", 3, 3}, /* OP_VECSET */
> {opexe_2, "make-block", 1, 2}, /* OP_MKBLOCK */
> {opexe_2, "block-length", 1, 1}, /* OP_BLOCKLEN */
> {opexe_2, "block-ref", 2, 2}, /* OP_BLOCKREF */
> {opexe_2, "block-set!",3 ,3}, /* OP_BLOCKSET */
The predicate goes with the other predicates, in opexe_3.
| {opexe_3, "vector?", 1, 1}, /* OP_VECTORP, */
> {opexe_3, "block?", 1, 1}, /* OP_BLOCKP, */
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)));

585
plug-ins/script-fu/tinyscheme/init.scm Normal file
View file

@ -0,0 +1,585 @@
; Initialization file for TinySCHEME 1.34
; 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)))))
(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)))
(define (max . lst)
(foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst)))
(define (min . lst)
(foldr (lambda (a b) (if (< a b) a b)) (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 call/cc call-with-current-continuation)
(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) (string->anyatom str number?))
(define (anyatom->string n pred)
(if (pred n)
(atom->string n)
(error "xxx->string: not a xxx" n)))
(define (number->string n) (anyatom->string n number?))
(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)))))
;;;;; 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))
;;;; Utility to ease macro creation
(define (macro-expand form)
((eval (get-closure-code (eval (car form)))) form))
;;;; 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 (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))
(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)