adding scheme, updating gitignore

* gitingore now allows directories. Before I was trying to exclude
  the binaries from checkin but matched whole subdirectorys, so
  added a negative pattern to exclude directories specifically
* added tinyscheme that's not used

.gitignore

@@ -10,11 +10,17 @@ piu_minder
 showmessage
 
 billdb
+!*billdb/
 debug_client
+!*debug_client/
 ipc_server
+!*ipc_server/
 paddlemgr
+!*paddlemgr/
 passdb
+!*passdb/
 diuhttpd
+!*diuhttpd/
 
 passdb_slim
 fpeek

busunit/passdb/tinyscheme-1.41/BUILDING

@@ -0,0 +1,139 @@
+        Building TinyScheme
+        -------------------
+
+The included makefile includes logic for Linux, Solaris and Win32, and can
+readily serve as an example for other OSes, especially Unixes. There are
+a lot of compile-time flags in TinyScheme (preprocessor defines) that can trim
+unwanted features. See next section. 'make all' and 'make clean' function as
+expected.
+
+Autoconfing TinyScheme was once proposed, but the distribution would not be
+so small anymore. There are few platform dependencies in TinyScheme, and in
+general compiles out of the box.
+
+     Customizing
+     -----------
+
+     The following symbols are defined to default values in scheme.h.
+     Use the -D flag of cc to set to either 1 or 0.
+
+     STANDALONE
+     Define this to produce a standalone interpreter.
+
+     USE_MATH
+     Includes math routines.
+
+     USE_CHAR_CLASSIFIERS
+     Includes character classifier procedures.
+
+     USE_ASCII_NAMES
+     Enable extended character notation based on ASCII names.
+
+     USE_STRING_PORTS
+     Enables string ports.
+
+     USE_ERROR_HOOK
+     To force system errors through user-defined error handling.
+     (see "Error handling")
+
+     USE_TRACING
+     To enable use of TRACING.
+
+     USE_COLON_HOOK
+     Enable use of qualified identifiers. (see "Colon Qualifiers - Packages")
+     Defining this as 0 has the rather drastic consequence that any code using
+     packages will stop working, and will have to be modified. It should only
+     be used if you *absolutely* need to use '::' in identifiers.
+
+     USE_STRCASECMP
+     Defines stricmp as strcasecmp, for Unix.
+
+     STDIO_ADDS_CR
+     Informs TinyScheme that stdio translates "\n" to "\r\n". For DOS/Windows.
+
+     USE_DL
+     Enables dynamically loaded routines. If you define this symbol, you
+     should also include dynload.c in your compile.
+
+     USE_PLIST
+     Enables property lists (not Standard Scheme stuff). Off by default.
+     
+     USE_NO_FEATURES
+     Shortcut to disable USE_MATH, USE_CHAR_CLASSIFIERS, USE_ASCII_NAMES,
+     USE_STRING_PORTS, USE_ERROR_HOOK, USE_TRACING, USE_COLON_HOOK,
+     USE_DL.
+
+     USE_SCHEME_STACK
+     Enables 'cons' stack (the alternative is a faster calling scheme, which 
+     breaks continuations). Undefine it if you don't care about strict compatibility
+     but you do care about faster execution.
+
+
+     OS-X tip
+     --------
+     I don't have access to OS-X, but Brian Maher submitted the following tip:
+
+[1] Download and install fink (I installed fink in
+/usr/local/fink)
+[2] Install the 'dlcompat' package using fink as such:
+> fink install dlcompat
+[3] Make the following changes to the
+tinyscheme-1.32.tar.gz
+
+diff -r tinyscheme-1.32/dynload.c
+tinyscheme-1.32-new/dynload.c
+24c24
+< #define SUN_DL
+---
+> 
+Only in tinyscheme-1.32-new/: dynload.o
+Only in tinyscheme-1.32-new/: libtinyscheme.a Only in tinyscheme-1.32-new/: libtinyscheme.so diff -r tinyscheme-1.32/makefile tinyscheme-1.32-new/makefile
+33,34c33,43
+< LD = gcc
+< LDFLAGS = -shared
+---
+> #LD = gcc
+> #LDFLAGS = -shared
+> #DEBUG=-g -Wno-char-subscripts -O
+> #SYS_LIBS= -ldl
+> #PLATFORM_FEATURES= -DSUN_DL=1
+> 
+> # Mac OS X
+> CC = gcc
+> CFLAGS = -I/usr/local/fink/include
+> LD = gcc
+> LDFLAGS = -L/usr/local/fink/lib
+37c46
+< PLATFORM_FEATURES= -DSUN_DL=1
+---
+> PLATFORM_FEATURES= -DSUN_DL=1 -DOSX
+60c69
+<       $(CC) -I. -c $(DEBUG) $(FEATURES)
+$(DL_FLAGS) $<
+---
+>       $(CC) $(CFLAGS) -I. -c $(DEBUG)
+$(FEATURES) $(DL_FLAGS) $<
+66c75
+<       $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 
+---
+>       $(CC) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS)
+$(SYS_LIBS)
+Only in tinyscheme-1.32-new/: scheme
+diff -r tinyscheme-1.32/scheme.c
+tinyscheme-1.32-new/scheme.c
+60,61c60,61
+< #ifndef macintosh
+< # include <malloc.h>
+---
+> #ifdef OSX
+> /* Do nothing */
+62a63,65
+> # ifndef macintosh
+> #  include <malloc.h>
+> # else
+77c80,81
+< #endif /* macintosh */
+---
+> # endif /* macintosh */
+> #endif /* !OSX */
+Only in tinyscheme-1.32-new/: scheme.o

busunit/passdb/tinyscheme-1.41/CHANGES

@@ -0,0 +1,326 @@
+Change Log
+----------
+
+Version 1.41
+    Bugs fixed:
+        #3020389 - Added makefile section for Mac OS X  (SL)
+        #3286135 - Fixed num_mod routine which caused errors in use of modulo
+        #3290232 - Corrected version number shown on startup  (GM)
+        #3394882 - Added missing #if in opdefines.h around get and put  (DC)
+        #3395547 - Fix for the modulo procedure  (DC)
+        #3400290 - Optimized append to make it an O(n) operation  (DC)
+        #3493926 - Corrected flag used when building shared files on OSX (J)
+
+    R5RS related changes:
+        #2866196 - Parser does not handle delimiters correctly
+        #3395548 - Add a decimal point to inexact numbers in atom2str  (DC)
+        #3399331 - Make min/max return inexact when any argument is inexact
+        #3399332 - Compatability 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 - Compatability 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 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 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.

busunit/passdb/tinyscheme-1.41/COPYING

@@ -0,0 +1,31 @@
+                         LICENSE TERMS
+
+Copyright (c) 2000, Dimitrios Souflis
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+Neither the name of Dimitrios Souflis nor the names of the
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

busunit/passdb/tinyscheme-1.41/Manual.txt

@@ -0,0 +1,452 @@
+
+
+                       TinySCHEME Version 1.41
+
+                    "Safe if used as prescribed"
+                    -- Philip K. Dick, "Ubik"
+
+This software is open source, covered by a BSD-style license.
+Please read accompanying file COPYING.
+-------------------------------------------------------------------------------
+
+     This Scheme interpreter is based on MiniSCHEME version 0.85k4
+     (see miniscm.tar.gz in the Scheme Repository)
+     Original credits in file MiniSCHEMETribute.txt.
+
+     D. Souflis (dsouflis@acm.org)
+
+-------------------------------------------------------------------------------
+     What is TinyScheme?
+     -------------------
+
+     TinyScheme is a lightweight Scheme interpreter that implements as large
+     a subset of R5RS as was possible without getting very large and
+     complicated. It is meant to be used as an embedded scripting interpreter
+     for other programs. As such, it does not offer IDEs or extensive toolkits
+     although it does sport a small top-level loop, included conditionally.
+     A lot of functionality in TinyScheme is included conditionally, to allow
+     developers freedom in balancing features and footprint.
+
+     As an embedded interpreter, it allows multiple interpreter states to
+     coexist in the same program, without any interference between them.
+     Programmatically, foreign functions in C can be added and values
+     can be defined in the Scheme environment. Being a quite small program,
+     it is easy to comprehend, get to grips with, and use.
+
+     Known bugs
+     ----------
+
+     TinyScheme is known to misbehave when memory is exhausted.
+
+
+     Things that keep missing, or that need fixing
+     ---------------------------------------------
+
+     There are no hygienic macros. No rational or
+     complex numbers. No unwind-protect and call-with-values.
+
+     Maybe (a subset of) SLIB will work with TinySCHEME...
+
+     Decent debugging facilities are missing. Only tracing is supported
+     natively.
+
+
+     Scheme Reference
+     ----------------
+
+     If something seems to be missing, please refer to the code and
+     "init.scm", since some are library functions.  Refer to the MiniSCHEME
+     readme as a last resort.
+
+          Environments
+     (interaction-environment)
+     See R5RS. In TinySCHEME, immutable list of association lists.
+
+     (current-environment)
+     The environment in effect at the time of the call. An example of its
+     use and its utility can be found in the sample code that implements
+     packages in "init.scm":
+
+          (macro (package form)
+               `(apply (lambda ()
+                         ,@(cdr form)
+                         (current-environment))))
+
+     The environment containing the (local) definitions inside the closure
+     is returned as an immutable value.
+
+     (defined? <symbol>) (defined? <symbol> <environment>)
+     Checks whether the given symbol is defined in the current (or given)
+     environment.
+
+          Symbols
+     (gensym)
+     Returns a new interned symbol each time. Will probably move to the
+     library when string->symbol is implemented.
+
+          Directives
+     (gc)
+     Performs garbage collection 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, \xDD (hex representations) and \DDD (octal representations).
+     Note also that it is possible to include literal newlines in string
+     literals, e.g.
+
+          (define s "String with newline here
+          and here
+          that can function like a HERE-string")
+
+     Character literals contain #\space and #\newline and are supplemented
+     with #\return and #\tab, with obvious meanings. Hex character
+     representations are allowed (e.g. #\x20 is #\space).
+     When USE_ASCII_NAMES is defined, various control characters can be
+     referred to by their ASCII name.
+     0	     #\nul	       17       #\dc1
+     1	     #\soh             18       #\dc2
+     2	     #\stx             19       #\dc3
+     3	     #\etx             20       #\dc4
+     4	     #\eot             21       #\nak
+     5	     #\enq             22       #\syn
+     6	     #\ack             23       #\etv
+     7	     #\bel             24       #\can
+     8	     #\bs              25       #\em
+     9	     #\ht              26       #\sub
+     10	     #\lf              27       #\esc
+     11	     #\vt              28       #\fs
+     12	     #\ff              29       #\gs
+     13	     #\cr              30       #\rs
+     14	     #\so              31       #\us
+     15	     #\si
+     16	     #\dle             127      #\del 		
+
+     Numeric literals support #x #o #b and #d. Flonums are currently read only
+     in decimal notation. Full grammar will be supported soon.
+
+          Quote, quasiquote etc.
+     As usual.
+
+          Immutable values
+     Immutable pairs cannot be modified by set-car! and set-cdr!.
+     Immutable strings cannot be modified via string-set!
+
+          I/O
+     As per R5RS, plus String Ports (see below).
+     current-input-port, current-output-port,
+     close-input-port, close-output-port, input-port?, output-port?,
+     open-input-file, open-output-file.
+     read, write, display, newline, write-char, read-char, peek-char.
+     char-ready? returns #t only for string ports, because there is no
+     portable way in stdio to determine if a character is available.
+     Also open-input-output-file, set-input-port, set-output-port (not R5RS)
+     Library: call-with-input-file, call-with-output-file,
+     with-input-from-file, with-output-from-file and
+     with-input-output-from-to-files, close-port and input-output-port?
+     (not R5RS).
+     String Ports: open-input-string, open-output-string, get-output-string,
+     open-input-output-string. Strings can be used with I/O routines.
+
+          Vectors
+     make-vector, vector, vector-length, vector-ref, vector-set!, list->vector,
+     vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS)
+
+          Strings
+     string, make-string, list->string, string-length, string-ref, string-set!,
+     substring, string->list, string-fill!, string-append, string-copy.
+     string=?, string<?, string>?, string>?, string<=?, string>=?.
+     (No string-ci*? yet). string->number, number->string. Also atom->string,
+     string->atom (not R5RS).
+
+          Symbols
+     symbol->string, string->symbol
+
+          Characters
+     integer->char, char->integer.
+     char=?, char<?, char>?, char<=?, char>=?.
+     (No char-ci*?)
+
+          Pairs & Lists
+     cons, car, cdr, list, length, map, for-each, foldr, list-tail,
+     list-ref, last-pair, reverse, append.
+     Also member, memq, memv, based on generic-member, assoc, assq, assv
+     based on generic-assoc.
+
+          Streams
+     head, tail, cons-stream
+
+          Control features
+     Apart from procedure?, also macro? and closure?
+     map, for-each, force, delay, call-with-current-continuation (or call/cc),
+     eval, apply. 'Forcing' a value that is not a promise produces the value.
+     There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in
+     the presence of continuations would require support from the abstract
+     machine itself.
+
+          Property lists
+     TinyScheme inherited from MiniScheme property lists for symbols.
+     put, get.
+
+          Dynamically-loaded extensions
+     (load-extension <filename without extension>)
+     Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use
+     of the ld.so.conf file or the LD_RUN_PATH system variable in order to place
+     the library in a directory other than the current one. Please refer to the
+     appropriate 'man' page.
+
+          Esoteric procedures
+     (oblist)
+     Returns the oblist, an immutable list of all the symbols.
+
+     (macro-expand <form>)
+     Returns the expanded form of the macro call denoted by the argument
+
+     (define-with-return (<procname> <args>...) <body>)
+     Like plain 'define', but makes the continuation available as 'return'
+     inside the procedure. Handy for imperative programs.
+
+     (new-segment <num>)
+     Allocates more memory segments.
+
+     defined?
+     See "Environments"
+
+     (get-closure-code <closure>)
+     Gets the code as scheme data.
+
+     (make-closure <code> <environment>)
+     Makes a new closure in the given environment.
+
+          Obsolete procedures
+     (print-width <object>)
+
+     Programmer's Reference
+     ----------------------
+
+     The interpreter state is initialized with "scheme_init".
+     Custom memory allocation routines can be installed with an alternate
+     initialization function: "scheme_init_custom_alloc".
+     Files can be loaded with "scheme_load_file". Strings containing Scheme
+     code can be loaded with "scheme_load_string". It is a good idea to
+     "scheme_load" init.scm before anything else.
+
+     External data for keeping external state (of use to foreign functions)
+     can be installed with "scheme_set_external_data".
+     Foreign functions are installed with "assign_foreign". Additional
+     definitions can be added to the interpreter state, with "scheme_define"
+     (this is the way HTTP header data and HTML form data are passed to the
+     Scheme script in the Altera SQL Server). If you wish to define the
+     foreign function in a specific environment (to enhance modularity),
+     use "assign_foreign_env".
+
+     The procedure "scheme_apply0" has been added with persistent scripts in
+     mind. Persistent scripts are loaded once, and every time they are needed
+     to produce HTTP output, appropriate data are passed through global
+     definitions and function "main" is called to do the job. One could
+     add easily "scheme_apply1" etc.
+
+     The interpreter state should be deinitialized with "scheme_deinit".
+
+     DLLs containing foreign functions should define a function named
+     init_<base-name>. E.g. foo.dll should define init_foo, and bar.so
+     should define init_bar. This function should assign_foreign any foreign
+     function contained in the DLL.
+
+     The first dynamically loaded extension available for TinyScheme is
+     a regular expression library. Although it's by no means an
+     established standard, this library is supposed to be installed in
+     a directory mirroring its name under the TinyScheme location.
+
+
+     Foreign Functions
+     -----------------
+
+     The user can add foreign functions in C. For example, a function
+     that squares its argument:
+
+          pointer square(scheme *sc, pointer args) {
+           if(args!=sc->NIL) {
+               if(sc->isnumber(sc->pair_car(args))) {
+                    double v=sc->rvalue(sc->pair_car(args));
+                    return sc->mk_real(sc,v*v);
+               }
+           }
+           return sc->NIL;
+          }
+
+   Foreign functions are now defined as closures:
+
+   sc->interface->scheme_define(
+        sc,
+        sc->global_env,
+        sc->interface->mk_symbol(sc,"square"),
+        sc->interface->mk_foreign_func(sc, square));
+
+
+     Foreign functions can use the external data in the "scheme" struct
+     to implement any kind of external state.
+
+     External data are set with the following function:
+          void scheme_set_external_data(scheme *sc, void *p);
+
+     As of v.1.17, the canonical way for a foreign function in a DLL to
+     manipulate Scheme data is using the function pointers in sc->interface.
+
+     Standalone
+     ----------
+
+     Usage: tinyscheme -?
+     or:    tinyscheme [<file1> <file2> ...]
+     followed by
+	       -1 <file> [<arg1> <arg2> ...]
+	       -c <Scheme commands> [<arg1> <arg2> ...]
+     assuming that the executable is named tinyscheme.
+
+     Use - in the place of a filename to denote stdin.
+     The -1 flag is meant for #! usage in shell scripts. If you specify
+          #! /somewhere/tinyscheme -1
+     then tinyscheme will be called to process the file. For example, the
+     following script echoes the Scheme list of its arguments.
+
+	       #! /somewhere/tinyscheme -1
+	       (display *args*)
+
+     The -c flag permits execution of arbitrary Scheme code.
+
+
+     Error Handling
+     --------------
+
+     Errors are recovered from without damage. The user can install his
+     own handler for system errors, by defining *error-hook*. Defining
+     to '() gives the default behavior, which is equivalent to "error".
+     USE_ERROR_HOOK must be defined.
+
+     A simple exception handling mechanism can be found in "init.scm".
+     A new syntactic form is introduced:
+
+          (catch <expr returned exceptionally>
+               <expr1> <expr2> ... <exprN>)
+
+     "Catch" establishes a scope spanning multiple call-frames
+     until another "catch" is encountered.
+
+     Exceptions are thrown with:
+
+          (throw "message")
+
+     If used outside a (catch ...), reverts to (error "message").
+
+     Example of use:
+
+          (define (foo x) (write x) (newline) (/ x 0))
+
+          (catch (begin (display "Error!\n") 0)
+               (write "Before foo ... ")
+               (foo 5)
+               (write "After foo"))
+
+     The exception mechanism can be used even by system errors, by
+
+          (define *error-hook* throw)
+
+     which makes use of the error hook described above.
+
+     If necessary, the user can devise his own exception mechanism with
+     tagged exceptions etc.
+
+
+     Reader extensions
+     -----------------
+
+     When encountering an unknown character after '#', the user-specified
+     procedure *sharp-hook* (if any), is called to read the expression.
+     This can be used to extend the reader to handle user-defined constants
+     or whatever. It should be a procedure without arguments, reading from
+     the current input port (which will be the load-port).
+
+
+     Colon Qualifiers - Packages
+     ---------------------------
+
+     When USE_COLON_HOOK=1:
+     The lexer now recognizes the construction <qualifier>::<symbol> and
+     transforms it in the following manner (T is the transformation function):
+
+          T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>)
+
+     where <qualifier> is a symbol not containing any double-colons.
+
+     As the definition is recursive, qualifiers can be nested.
+     The user can define his own *colon-hook*, to handle qualified names.
+     By default, "init.scm" defines *colon-hook* as EVAL. Consequently,
+     the qualifier must denote a Scheme environment, such as one returned
+     by (interaction-environment). "Init.scm" defines a new syntantic form,
+     PACKAGE, as a simple example. It is used like this:
+
+          (define toto
+               (package
+                    (define foo 1)
+                    (define bar +)))
+
+          foo                                     ==>  Error, "foo" undefined
+          (eval 'foo)                             ==>  Error, "foo" undefined
+          (eval 'foo toto)                        ==>  1
+          toto::foo                               ==>  1
+          ((eval 'bar toto) 2 (eval 'foo toto))   ==>  3
+          (toto::bar 2 toto::foo)                 ==>  3
+          (eval (bar 2 foo) toto)                 ==>  3
+
+     If the user installs another package infrastructure, he must define
+     a new 'package' procedure or macro to retain compatibility with supplied
+     code.
+
+     Note: Older versions used ':' as a qualifier. Unfortunately, the use
+     of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially
+     precludes its use as a real qualifier.
+
+
+
+
+
+
+
+

busunit/passdb/tinyscheme-1.41/MiniSCHEMETribute.txt

@@ -0,0 +1,88 @@
+     TinyScheme would not exist if it wasn't for MiniScheme. I had just
+     written the HTTP server for Ovrimos SQL Server, and I was lamenting the
+     lack of a scripting language. Server-side Javascript would have been the
+     preferred solution, had there been a Javascript interpreter I could
+     lay my hands on. But there weren't. Perl would have been another solution,
+     but it was probably ten times bigger that the program it was supposed to
+     be embedded in. There would also be thorny licencing issues. 
+     
+     So, the obvious thing to do was find a 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")

busunit/passdb/tinyscheme-1.41/dynload.c

@@ -0,0 +1,146 @@
+/* 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)();
+#define SUN_DL
+#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) {
+  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);
+}
+
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/

busunit/passdb/tinyscheme-1.41/dynload.h

@@ -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

busunit/passdb/tinyscheme-1.41/hack.txt

@@ -0,0 +1,244 @@
+
+                              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 denote lines to be removed from the code.
+
+     First of all, we need to assign a typeid to our new type. Typeids
+     in TinyScheme are small integers declared in the scheme_types enum
+     located near the top of the scheme.c file; it begins with T_STRING.
+     Add a new entry at the end, say T_MEMBLOCK. Remember to adjust the
+     value of T_LAST_SYTEM_TYPE when adding new entries. There can be at
+     most 31 types, but you don't have to worry about that limit yet.
+
+|       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 add:
+
+>     INTERFACE INLINE 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 couln'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 (iscontinuation(l)) {
+|          p = "#<CONTINUATION>";
+>     } else if (is_memblock(l)) {
+>          p = "#<MEMORY BLOCK>";
+|     } 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. The op-codes are defined in the opdefines.h file with one line
+     for each op-code. The lines in the file have six columns between the
+     starting _OPDEF( and ending ): A, B, C, D, E, and OP.
+     Note that this file uses unusually long lines to accomodate all the
+     information; adjust your editor to handle this.
+
+     The purpose of the columns is:
+       - Column A is the name of the subroutine that handles the op-code.
+       - Column B is the name of the op-code function.
+       - Columns C and D are the minimum and maximum number of arguments
+         that are accepted by the op-code.
+       - Column E is a set of flags that tells the interpreter the type of
+         each of the arguments expected by the op-code.
+       - Column OP is used in the scheme_opcodes enum located in the
+         scheme-private.h file.
+
+     Op-codes are really just tags for a huge C switch, only this switch
+     is broken up in to 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 (number of expected arguments). INF_ARG as a maximum
+     arity means "unlimited".
+
+     For reasons of consistency, 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 with the other predicates in opexe_3:
+
+|     _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 code to do the processing and
+     add it to the switch statement in opexe_2, after the OP_VECSET case.
+
+>     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));
+>     }
+
+     Finally, do the same for the predicate in opexe_3.
+
+|     case OP_VECTORP:     /* vector? */
+|          s_retbool(is_vector(car(sc->args)));
+>     case OP_BLOCKP:     /* block? */
+>          s_retbool(is_memblock(car(sc->args)));
+|     case OP_EQ:         /* eq? */

busunit/passdb/tinyscheme-1.41/init.scm

@@ -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 (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)

busunit/passdb/tinyscheme-1.41/makefile

@@ -0,0 +1,98 @@
+# Makefile for TinyScheme
+# Time-stamp: <2002-06-24 14:13:27 gildea>
+
+# Windows/2000
+#CC = cl -nologo
+#DEBUG= -W3 -Z7 -MD
+#DL_FLAGS=
+#SYS_LIBS=
+#Osuf=obj
+#SOsuf=dll
+#LIBsuf=.lib
+#EXE_EXT=.exe
+#LD = link -nologo
+#LDFLAGS = -debug -map -dll -incremental:no
+#LIBPREFIX =
+#OUT = -out:$@
+#RM= -del
+#AR= echo
+
+# Unix, generally
+CC = gcc -fpic -pedantic
+DEBUG=-g -Wall -Wno-char-subscripts -O
+Osuf=o
+SOsuf=so
+LIBsuf=a
+EXE_EXT=
+LIBPREFIX=lib
+OUT = -o $@
+RM= -rm -f
+AR= ar crs
+
+# Linux
+LD = gcc
+LDFLAGS = -shared
+DEBUG=-g -Wno-char-subscripts -O
+SYS_LIBS= -ldl -lm
+PLATFORM_FEATURES= -DSUN_DL=1
+
+# Cygwin
+#PLATFORM_FEATURES = -DUSE_STRLWR=0
+
+# MinGW/MSYS
+#SOsuf=dll
+#PLATFORM_FEATURES = -DUSE_STRLWR=0
+
+# Mac OS X
+#LD = gcc
+#LDFLAGS = --dynamiclib
+#DEBUG=-g -Wno-char-subscripts -O
+#SYS_LIBS= -ldl
+#PLATFORM_FEATURES= -DUSE_STRLWR=1 -D__APPLE__=1 -DOSX=1
+
+
+# Solaris
+#SYS_LIBS= -ldl -lc
+#Osuf=o
+#SOsuf=so
+#EXE_EXT=
+#LD = ld
+#LDFLAGS = -G -Bsymbolic -z text
+#LIBPREFIX = lib
+#OUT = -o $@
+
+FEATURES = $(PLATFORM_FEATURES) -DUSE_DL=1 -DUSE_MATH=1 -DUSE_ASCII_NAMES=0
+
+OBJS = scheme.$(Osuf) dynload.$(Osuf)
+
+LIBTARGET = $(LIBPREFIX)tinyscheme.$(SOsuf)
+STATICLIBTARGET = $(LIBPREFIX)tinyscheme.$(LIBsuf)
+
+all: $(LIBTARGET) $(STATICLIBTARGET) scheme$(EXE_EXT)
+
+%.$(Osuf): %.c
+	$(CC) -I. -c $(DEBUG) $(FEATURES) $(DL_FLAGS) $<
+
+$(LIBTARGET): $(OBJS)
+	$(LD) $(LDFLAGS) $(OUT) $(OBJS) $(SYS_LIBS)
+
+scheme$(EXE_EXT): $(OBJS)
+	$(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS)
+
+$(STATICLIBTARGET): $(OBJS)
+	$(AR) $@ $(OBJS)
+
+$(OBJS): scheme.h scheme-private.h opdefines.h
+dynload.$(Osuf): dynload.h
+
+clean:
+	$(RM) $(OBJS) $(LIBTARGET) $(STATICLIBTARGET) scheme$(EXE_EXT)
+	$(RM) tinyscheme.ilk tinyscheme.map tinyscheme.pdb tinyscheme.exp
+	$(RM) scheme.ilk scheme.map scheme.pdb scheme.lib scheme.exp
+	$(RM) *~
+
+TAGS_SRCS = scheme.h scheme.c dynload.h dynload.c
+
+tags: TAGS
+TAGS: $(TAGS_SRCS)
+	etags $(TAGS_SRCS)

busunit/passdb/tinyscheme-1.41/opdefines.h

@@ -0,0 +1,195 @@
+    _OP_DEF(opexe_0, "load",                           1,  1,       TST_STRING,                      OP_LOAD             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_T0LVL            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_T1LVL            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_READ_INTERNAL    )
+    _OP_DEF(opexe_0, "gensym",                         0,  0,       0,                               OP_GENSYM           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_VALUEPRINT       )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_EVAL             )
+#if USE_TRACING
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_REAL_EVAL        )
+#endif
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_E0ARGS           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_E1ARGS           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_APPLY            )
+#if USE_TRACING
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_REAL_APPLY       )
+    _OP_DEF(opexe_0, "tracing",                        1,  1,       TST_NATURAL,                     OP_TRACING          )
+#endif
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DOMACRO          )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA1          )
+    _OP_DEF(opexe_0, "make-closure",                   1,  2,       TST_PAIR TST_ENVIRONMENT,        OP_MKCLOSURE        )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_QUOTE            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DEF0             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DEF1             )
+    _OP_DEF(opexe_0, "defined?",                       1,  2,       TST_SYMBOL TST_ENVIRONMENT,      OP_DEFP             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_BEGIN            )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_IF0              )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_IF1              )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_SET0             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_SET1             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET0             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET1             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET2             )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET0AST          )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET1AST          )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET2AST          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET0REC          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET1REC          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET2REC          )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_COND0            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_COND1            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_DELAY            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_AND0             )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_AND1             )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_OR0              )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_OR1              )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_C0STREAM         )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_C1STREAM         )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_MACRO0           )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_MACRO1           )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE0            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE1            )
+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE2            )
+    _OP_DEF(opexe_1, "eval",                           1,  2,       TST_ANY TST_ENVIRONMENT,         OP_PEVAL            )
+    _OP_DEF(opexe_1, "apply",                          1,  INF_ARG, TST_NONE,                        OP_PAPPLY           )
+    _OP_DEF(opexe_1, "call-with-current-continuation", 1,  1,       TST_NONE,                        OP_CONTINUATION     )
+#if USE_MATH
+    _OP_DEF(opexe_2, "inexact->exact",                 1,  1,       TST_NUMBER,                      OP_INEX2EX          )
+    _OP_DEF(opexe_2, "exp",                            1,  1,       TST_NUMBER,                      OP_EXP              )
+    _OP_DEF(opexe_2, "log",                            1,  1,       TST_NUMBER,                      OP_LOG              )
+    _OP_DEF(opexe_2, "sin",                            1,  1,       TST_NUMBER,                      OP_SIN              )
+    _OP_DEF(opexe_2, "cos",                            1,  1,       TST_NUMBER,                      OP_COS              )
+    _OP_DEF(opexe_2, "tan",                            1,  1,       TST_NUMBER,                      OP_TAN              )
+    _OP_DEF(opexe_2, "asin",                           1,  1,       TST_NUMBER,                      OP_ASIN             )
+    _OP_DEF(opexe_2, "acos",                           1,  1,       TST_NUMBER,                      OP_ACOS             )
+    _OP_DEF(opexe_2, "atan",                           1,  2,       TST_NUMBER,                      OP_ATAN             )
+    _OP_DEF(opexe_2, "sqrt",                           1,  1,       TST_NUMBER,                      OP_SQRT             )
+    _OP_DEF(opexe_2, "expt",                           2,  2,       TST_NUMBER,                      OP_EXPT             )
+    _OP_DEF(opexe_2, "floor",                          1,  1,       TST_NUMBER,                      OP_FLOOR            )
+    _OP_DEF(opexe_2, "ceiling",                        1,  1,       TST_NUMBER,                      OP_CEILING          )
+    _OP_DEF(opexe_2, "truncate",                       1,  1,       TST_NUMBER,                      OP_TRUNCATE         )
+    _OP_DEF(opexe_2, "round",                          1,  1,       TST_NUMBER,                      OP_ROUND            )
+#endif
+    _OP_DEF(opexe_2, "+",                              0,  INF_ARG, TST_NUMBER,                      OP_ADD              )
+    _OP_DEF(opexe_2, "-",                              1,  INF_ARG, TST_NUMBER,                      OP_SUB              )
+    _OP_DEF(opexe_2, "*",                              0,  INF_ARG, TST_NUMBER,                      OP_MUL              )
+    _OP_DEF(opexe_2, "/",                              1,  INF_ARG, TST_NUMBER,                      OP_DIV              )
+    _OP_DEF(opexe_2, "quotient",                       1,  INF_ARG, TST_INTEGER,                     OP_INTDIV           )
+    _OP_DEF(opexe_2, "remainder",                      2,  2,       TST_INTEGER,                     OP_REM              )
+    _OP_DEF(opexe_2, "modulo",                         2,  2,       TST_INTEGER,                     OP_MOD              )
+    _OP_DEF(opexe_2, "car",                            1,  1,       TST_PAIR,                        OP_CAR              )
+    _OP_DEF(opexe_2, "cdr",                            1,  1,       TST_PAIR,                        OP_CDR              )
+    _OP_DEF(opexe_2, "cons",                           2,  2,       TST_NONE,                        OP_CONS             )
+    _OP_DEF(opexe_2, "set-car!",                       2,  2,       TST_PAIR TST_ANY,                OP_SETCAR           )
+    _OP_DEF(opexe_2, "set-cdr!",                       2,  2,       TST_PAIR TST_ANY,                OP_SETCDR           )
+    _OP_DEF(opexe_2, "char->integer",                  1,  1,       TST_CHAR,                        OP_CHAR2INT         )
+    _OP_DEF(opexe_2, "integer->char",                  1,  1,       TST_NATURAL,                     OP_INT2CHAR         )
+    _OP_DEF(opexe_2, "char-upcase",                    1,  1,       TST_CHAR,                        OP_CHARUPCASE       )
+    _OP_DEF(opexe_2, "char-downcase",                  1,  1,       TST_CHAR,                        OP_CHARDNCASE       )
+    _OP_DEF(opexe_2, "symbol->string",                 1,  1,       TST_SYMBOL,                      OP_SYM2STR          )
+    _OP_DEF(opexe_2, "atom->string",                   1,  2,       TST_ANY TST_NATURAL,             OP_ATOM2STR         )
+    _OP_DEF(opexe_2, "string->symbol",                 1,  1,       TST_STRING,                      OP_STR2SYM          )
+    _OP_DEF(opexe_2, "string->atom",                   1,  2,       TST_STRING TST_NATURAL,          OP_STR2ATOM         )
+    _OP_DEF(opexe_2, "make-string",                    1,  2,       TST_NATURAL TST_CHAR,            OP_MKSTRING         )
+    _OP_DEF(opexe_2, "string-length",                  1,  1,       TST_STRING,                      OP_STRLEN           )
+    _OP_DEF(opexe_2, "string-ref",                     2,  2,       TST_STRING TST_NATURAL,          OP_STRREF           )
+    _OP_DEF(opexe_2, "string-set!",                    3,  3,       TST_STRING TST_NATURAL TST_CHAR, OP_STRSET           )
+    _OP_DEF(opexe_2, "string-append",                  0,  INF_ARG, TST_STRING,                      OP_STRAPPEND        )
+    _OP_DEF(opexe_2, "substring",                      2,  3,       TST_STRING TST_NATURAL,          OP_SUBSTR           )
+    _OP_DEF(opexe_2, "vector",                         0,  INF_ARG, TST_NONE,                        OP_VECTOR           )
+    _OP_DEF(opexe_2, "make-vector",                    1,  2,       TST_NATURAL TST_ANY,             OP_MKVECTOR         )
+    _OP_DEF(opexe_2, "vector-length",                  1,  1,       TST_VECTOR,                      OP_VECLEN           )
+    _OP_DEF(opexe_2, "vector-ref",                     2,  2,       TST_VECTOR TST_NATURAL,          OP_VECREF           )
+    _OP_DEF(opexe_2, "vector-set!",                    3,  3,       TST_VECTOR TST_NATURAL TST_ANY,  OP_VECSET           )
+    _OP_DEF(opexe_3, "not",                            1,  1,       TST_NONE,                        OP_NOT              )
+    _OP_DEF(opexe_3, "boolean?",                       1,  1,       TST_NONE,                        OP_BOOLP            )
+    _OP_DEF(opexe_3, "eof-object?",                    1,  1,       TST_NONE,                        OP_EOFOBJP          )
+    _OP_DEF(opexe_3, "null?",                          1,  1,       TST_NONE,                        OP_NULLP            )
+    _OP_DEF(opexe_3, "=",                              2,  INF_ARG, TST_NUMBER,                      OP_NUMEQ            )
+    _OP_DEF(opexe_3, "<",                              2,  INF_ARG, TST_NUMBER,                      OP_LESS             )
+    _OP_DEF(opexe_3, ">",                              2,  INF_ARG, TST_NUMBER,                      OP_GRE              )
+    _OP_DEF(opexe_3, "<=",                             2,  INF_ARG, TST_NUMBER,                      OP_LEQ              )
+    _OP_DEF(opexe_3, ">=",                             2,  INF_ARG, TST_NUMBER,                      OP_GEQ              )
+    _OP_DEF(opexe_3, "symbol?",                        1,  1,       TST_ANY,                         OP_SYMBOLP          )
+    _OP_DEF(opexe_3, "number?",                        1,  1,       TST_ANY,                         OP_NUMBERP          )
+    _OP_DEF(opexe_3, "string?",                        1,  1,       TST_ANY,                         OP_STRINGP          )
+    _OP_DEF(opexe_3, "integer?",                       1,  1,       TST_ANY,                         OP_INTEGERP         )
+    _OP_DEF(opexe_3, "real?",                          1,  1,       TST_ANY,                         OP_REALP            )
+    _OP_DEF(opexe_3, "char?",                          1,  1,       TST_ANY,                         OP_CHARP            )
+#if USE_CHAR_CLASSIFIERS
+    _OP_DEF(opexe_3, "char-alphabetic?",               1,  1,       TST_CHAR,                        OP_CHARAP           )
+    _OP_DEF(opexe_3, "char-numeric?",                  1,  1,       TST_CHAR,                        OP_CHARNP           )
+    _OP_DEF(opexe_3, "char-whitespace?",               1,  1,       TST_CHAR,                        OP_CHARWP           )
+    _OP_DEF(opexe_3, "char-upper-case?",               1,  1,       TST_CHAR,                        OP_CHARUP           )
+    _OP_DEF(opexe_3, "char-lower-case?",               1,  1,       TST_CHAR,                        OP_CHARLP           )
+#endif
+    _OP_DEF(opexe_3, "port?",                          1,  1,       TST_ANY,                         OP_PORTP            )
+    _OP_DEF(opexe_3, "input-port?",                    1,  1,       TST_ANY,                         OP_INPORTP          )
+    _OP_DEF(opexe_3, "output-port?",                   1,  1,       TST_ANY,                         OP_OUTPORTP         )
+    _OP_DEF(opexe_3, "procedure?",                     1,  1,       TST_ANY,                         OP_PROCP            )
+    _OP_DEF(opexe_3, "pair?",                          1,  1,       TST_ANY,                         OP_PAIRP            )
+    _OP_DEF(opexe_3, "list?",                          1,  1,       TST_ANY,                         OP_LISTP            )
+    _OP_DEF(opexe_3, "environment?",                   1,  1,       TST_ANY,                         OP_ENVP             )
+    _OP_DEF(opexe_3, "vector?",                        1,  1,       TST_ANY,                         OP_VECTORP          )
+    _OP_DEF(opexe_3, "eq?",                            2,  2,       TST_ANY,                         OP_EQ               )
+    _OP_DEF(opexe_3, "eqv?",                           2,  2,       TST_ANY,                         OP_EQV              )
+    _OP_DEF(opexe_4, "force",                          1,  1,       TST_ANY,                         OP_FORCE            )
+    _OP_DEF(opexe_4, 0,                                0,  0,       0,                               OP_SAVE_FORCED      )
+    _OP_DEF(opexe_4, "write",                          1,  2,       TST_ANY TST_OUTPORT,             OP_WRITE            )
+    _OP_DEF(opexe_4, "write-char",                     1,  2,       TST_CHAR TST_OUTPORT,            OP_WRITE_CHAR       )
+    _OP_DEF(opexe_4, "display",                        1,  2,       TST_ANY TST_OUTPORT,             OP_DISPLAY          )
+    _OP_DEF(opexe_4, "newline",                        0,  1,       TST_OUTPORT,                     OP_NEWLINE          )
+    _OP_DEF(opexe_4, "error",                          1,  INF_ARG, TST_NONE,                        OP_ERR0             )
+    _OP_DEF(opexe_4, 0,                                0,  0,       0,                               OP_ERR1             )
+    _OP_DEF(opexe_4, "reverse",                        1,  1,       TST_LIST,                        OP_REVERSE          )
+    _OP_DEF(opexe_4, "list*",                          1,  INF_ARG, TST_NONE,                        OP_LIST_STAR        )
+    _OP_DEF(opexe_4, "append",                         0,  INF_ARG, TST_NONE,                        OP_APPEND           )
+#if USE_PLIST
+    _OP_DEF(opexe_4, "put",                            3,  3,       TST_NONE,                        OP_PUT              )
+    _OP_DEF(opexe_4, "get",                            2,  2,       TST_NONE,                        OP_GET              )
+#endif
+    _OP_DEF(opexe_4, "quit",                           0,  1,       TST_NUMBER,                      OP_QUIT             )
+    _OP_DEF(opexe_4, "gc",                             0,  0,       0,                               OP_GC               )
+    _OP_DEF(opexe_4, "gc-verbose",                     0,  1,       TST_NONE,                        OP_GCVERB           )
+    _OP_DEF(opexe_4, "new-segment",                    0,  1,       TST_NUMBER,                      OP_NEWSEGMENT       )
+    _OP_DEF(opexe_4, "oblist",                         0,  0,       0,                               OP_OBLIST           )
+    _OP_DEF(opexe_4, "current-input-port",             0,  0,       0,                               OP_CURR_INPORT      )
+    _OP_DEF(opexe_4, "current-output-port",            0,  0,       0,                               OP_CURR_OUTPORT     )
+    _OP_DEF(opexe_4, "open-input-file",                1,  1,       TST_STRING,                      OP_OPEN_INFILE      )
+    _OP_DEF(opexe_4, "open-output-file",               1,  1,       TST_STRING,                      OP_OPEN_OUTFILE     )
+    _OP_DEF(opexe_4, "open-input-output-file",         1,  1,       TST_STRING,                      OP_OPEN_INOUTFILE   )
+#if USE_STRING_PORTS
+    _OP_DEF(opexe_4, "open-input-string",              1,  1,       TST_STRING,                      OP_OPEN_INSTRING    )
+    _OP_DEF(opexe_4, "open-input-output-string",       1,  1,       TST_STRING,                      OP_OPEN_INOUTSTRING )
+    _OP_DEF(opexe_4, "open-output-string",             0,  1,       TST_STRING,                      OP_OPEN_OUTSTRING   )
+    _OP_DEF(opexe_4, "get-output-string",              1,  1,       TST_OUTPORT,                     OP_GET_OUTSTRING    )
+#endif
+    _OP_DEF(opexe_4, "close-input-port",               1,  1,       TST_INPORT,                      OP_CLOSE_INPORT     )
+    _OP_DEF(opexe_4, "close-output-port",              1,  1,       TST_OUTPORT,                     OP_CLOSE_OUTPORT    )
+    _OP_DEF(opexe_4, "interaction-environment",        0,  0,       0,                               OP_INT_ENV          )
+    _OP_DEF(opexe_4, "current-environment",            0,  0,       0,                               OP_CURR_ENV         )
+    _OP_DEF(opexe_5, "read",                           0,  1,       TST_INPORT,                      OP_READ             )
+    _OP_DEF(opexe_5, "read-char",                      0,  1,       TST_INPORT,                      OP_READ_CHAR        )
+    _OP_DEF(opexe_5, "peek-char",                      0,  1,       TST_INPORT,                      OP_PEEK_CHAR        )
+    _OP_DEF(opexe_5, "char-ready?",                    0,  1,       TST_INPORT,                      OP_CHAR_READY       )
+    _OP_DEF(opexe_5, "set-input-port",                 1,  1,       TST_INPORT,                      OP_SET_INPORT       )
+    _OP_DEF(opexe_5, "set-output-port",                1,  1,       TST_OUTPORT,                     OP_SET_OUTPORT      )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDSEXPR          )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDLIST           )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDDOT            )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQUOTE          )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQQUOTE         )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQQUOTEVEC      )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDUNQUOTE        )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDUQTSP          )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDVEC            )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_P0LIST           )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_P1LIST           )
+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_PVECFROM         )
+    _OP_DEF(opexe_6, "length",                         1,  1,       TST_LIST,                        OP_LIST_LENGTH      )
+    _OP_DEF(opexe_6, "assq",                           2,  2,       TST_NONE,                        OP_ASSQ             )
+    _OP_DEF(opexe_6, "get-closure-code",               1,  1,       TST_NONE,                        OP_GET_CLOSURE      )
+    _OP_DEF(opexe_6, "closure?",                       1,  1,       TST_NONE,                        OP_CLOSUREP         )
+    _OP_DEF(opexe_6, "macro?",                         1,  1,       TST_NONE,                        OP_MACROP           )
+#undef _OP_DEF

busunit/passdb/tinyscheme-1.41/scheme-private.h

@@ -0,0 +1,210 @@
+/* scheme-private.h */
+
+#ifndef _SCHEME_PRIVATE_H
+#define _SCHEME_PRIVATE_H
+
+#include "scheme.h"
+/*------------------ Ugly internals -----------------------------------*/
+/*------------------ Of interest only to FFI users --------------------*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+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;
+
+
+#define CELL_SEGSIZE    5000  /* # of cells in one segment */
+#define CELL_NSEGMENT   10    /* # of segments for cells */
+char *alloc_seg[CELL_NSEGMENT];
+pointer cell_seg[CELL_NSEGMENT];
+int     last_cell_seg;
+
+/* We use 4 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 */
+
+int interactive_repl;    /* are we in an interactive REPL? */
+
+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;
+
+#define MAXFIL 64
+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 */
+
+#define LINESIZE 1024
+char    linebuff[LINESIZE];
+#define STRBUFFSIZE 256
+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
+};
+
+
+#define cons(sc,a,b) _cons(sc,a,b,0)
+#define immutable_cons(sc,a,b) _cons(sc,a,b,1)
+
+int is_string(pointer p);
+char *string_value(pointer p);
+int is_number(pointer p);
+num nvalue(pointer p);
+long ivalue(pointer p);
+double rvalue(pointer p);
+int is_integer(pointer p);
+int is_real(pointer p);
+int is_character(pointer p);
+long charvalue(pointer p);
+int is_vector(pointer p);
+
+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 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);
+#ifdef USE_MACRO
+int is_macro(pointer p);
+#endif
+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:
+*/

busunit/passdb/tinyscheme-1.41/scheme.h

@@ -0,0 +1,255 @@
+/* SCHEME.H */
+
+#ifndef _SCHEME_H
+#define _SCHEME_H
+
+#include <stdio.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
+# define USE_STRCASECMP 1
+# ifndef USE_STRLWR
+#   define USE_STRLWR 1
+# endif
+# define SCHEME_EXPORT
+#else
+# define USE_STRCASECMP 0
+# 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_STRCASECMP   /* stricmp for Unix */
+# define USE_STRCASECMP 0
+#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;
+
+SCHEME_EXPORT scheme *scheme_init_new();
+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);
+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, char fill);
+pointer mk_character(scheme *sc, int c);
+pointer mk_foreign_func(scheme *sc, foreign_func f);
+void putstr(scheme *sc, const char *s);
+int list_length(scheme *sc, pointer a);
+int eqv(pointer a, pointer b);
+
+
+#if USE_INTERFACE
+struct scheme_interface {
+  void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value);
+  pointer (*cons)(scheme *sc, pointer a, pointer b);
+  pointer (*immutable_cons)(scheme *sc, pointer a, pointer b);
+  pointer (*reserve_cells)(scheme *sc, int n);
+  pointer (*mk_integer)(scheme *sc, long num);
+  pointer (*mk_real)(scheme *sc, double num);
+  pointer (*mk_symbol)(scheme *sc, const char *name);
+  pointer (*gensym)(scheme *sc);
+  pointer (*mk_string)(scheme *sc, const char *str);
+  pointer (*mk_counted_string)(scheme *sc, const char *str, int len);
+  pointer (*mk_character)(scheme *sc, int c);
+  pointer (*mk_vector)(scheme *sc, int len);
+  pointer (*mk_foreign_func)(scheme *sc, foreign_func f);
+  void (*putstr)(scheme *sc, const char *s);
+  void (*putcharacter)(scheme *sc, int c);
+
+  int (*is_string)(pointer p);
+  char *(*string_value)(pointer p);
+  int (*is_number)(pointer p);
+  num (*nvalue)(pointer p);
+  long (*ivalue)(pointer p);
+  double (*rvalue)(pointer p);
+  int (*is_integer)(pointer p);
+  int (*is_real)(pointer p);
+  int (*is_character)(pointer p);
+  long (*charvalue)(pointer p);
+  int (*is_list)(scheme *sc, pointer p);
+  int (*is_vector)(pointer p);
+  int (*list_length)(scheme *sc, pointer vec);
+  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_list(scheme * sc,
+                                       scheme_registerable * list,
+                                       int n);
+
+#endif /* !STANDALONE */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/