security-and-privacy/gnupg
security-and-privacy/gnupg
1
0
Fork 0
mirror of git://git.gnupg.org/gnupg.git synced 2024-06-01 22:28:02 +02:00
Code Activity

tests/gpgscm: Verbatim import of latest TinySCHEME.

Browse Source 
* tests/gpgscm/COPYING: New file.
* tests/gpgscm/init.scm: Likewise.
* tests/gpgscm/opdefines.h: Likewise.
* tests/gpgscm/scheme-private.h: Likewise.
* tests/gpgscm/scheme.c: Likewise.
* tests/gpgscm/scheme.h: Likewise.

Signed-off-by: Justus Winter <justus@g10code.com>
This commit is contained in:
Justus Winter 2016-01-06 11:54:03 +01:00
parent b8cb0973bc
commit fabb066f90
7 changed files with 6913 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
tests/gpgscm/COPYING Normal file
View File

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

444
tests/gpgscm/Manual.txt Normal file
View File

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

716
tests/gpgscm/init.scm Normal file
View File

@ -0,0 +1,716 @@
; Initialization file for TinySCHEME 1.41
; Per R5RS, up to four deep compositions should be defined
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
;;;; Utility to ease macro creation
(define (macro-expand form)
((eval (get-closure-code (eval (car form)))) form))
(define (macro-expand-all form)
(if (macro? form)
(macro-expand-all (macro-expand form))
form))
(define *compile-hook* macro-expand-all)
(macro (unless form)
`(if (not ,(cadr form)) (begin ,@(cddr form))))
(macro (when form)
`(if ,(cadr form) (begin ,@(cddr form))))
; DEFINE-MACRO Contributed by Andy Gaynor
(macro (define-macro dform)
(if (symbol? (cadr dform))
`(macro ,@(cdr dform))
(let ((form (gensym)))
`(macro (,(caadr dform) ,form)
(apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
; Utilities for math. Notice that inexact->exact is primitive,
; but exact->inexact is not.
(define exact? integer?)
(define (inexact? x) (and (real? x) (not (integer? x))))
(define (even? n) (= (remainder n 2) 0))
(define (odd? n) (not (= (remainder n 2) 0)))
(define (zero? n) (= n 0))
(define (positive? n) (> n 0))
(define (negative? n) (< n 0))
(define complex? number?)
(define rational? real?)
(define (abs n) (if (>= n 0) n (- n)))
(define (exact->inexact n) (* n 1.0))
(define (<> n1 n2) (not (= n1 n2)))
; min and max must return inexact if any arg is inexact; use (+ n 0.0)
(define (max . lst)
(foldr (lambda (a b)
(if (> a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (min . lst)
(foldr (lambda (a b)
(if (< a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (succ x) (+ x 1))
(define (pred x) (- x 1))
(define gcd
(lambda a
(if (null? a)
0
(let ((aa (abs (car a)))
(bb (abs (cadr a))))
(if (= bb 0)
aa
(gcd bb (remainder aa bb)))))))
(define lcm
(lambda a
(if (null? a)
1
(let ((aa (abs (car a)))
(bb (abs (cadr a))))
(if (or (= aa 0) (= bb 0))
0
(abs (* (quotient aa (gcd aa bb)) bb)))))))
(define (string . charlist)
(list->string charlist))
(define (list->string charlist)
(let* ((len (length charlist))
(newstr (make-string len))
(fill-string!
(lambda (str i len charlist)
(if (= i len)
str
(begin (string-set! str i (car charlist))
(fill-string! str (+ i 1) len (cdr charlist)))))))
(fill-string! newstr 0 len charlist)))
(define (string-fill! s e)
(let ((n (string-length s)))
(let loop ((i 0))
(if (= i n)
s
(begin (string-set! s i e) (loop (succ i)))))))
(define (string->list s)
(let loop ((n (pred (string-length s))) (l '()))
(if (= n -1)
l
(loop (pred n) (cons (string-ref s n) l)))))
(define (string-copy str)
(string-append str))
(define (string->anyatom str pred)
(let* ((a (string->atom str)))
(if (pred a) a
(error "string->xxx: not a xxx" a))))
(define (string->number str . base)
(let ((n (string->atom str (if (null? base) 10 (car base)))))
(if (number? n) n #f)))
(define (anyatom->string n pred)
(if (pred n)
(atom->string n)
(error "xxx->string: not a xxx" n)))
(define (number->string n . base)
(atom->string n (if (null? base) 10 (car base))))
(define (char-cmp? cmp a b)
(cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b)
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char=? a b) (char-cmp? = a b))
(define (char<? a b) (char-cmp? < a b))
(define (char>? a b) (char-cmp? > a b))
(define (char<=? a b) (char-cmp? <= a b))
(define (char>=? a b) (char-cmp? >= a b))
(define (char-ci=? a b) (char-ci-cmp? = a b))
(define (char-ci<? a b) (char-ci-cmp? < a b))
(define (char-ci>? a b) (char-ci-cmp? > a b))
(define (char-ci<=? a b) (char-ci-cmp? <= a b))
(define (char-ci>=? a b) (char-ci-cmp? >= a b))
; Note the trick of returning (cmp x y)
(define (string-cmp? chcmp cmp a b)
(let ((na (string-length a)) (nb (string-length b)))
(let loop ((i 0))
(cond
((= i na)
(if (= i nb) (cmp 0 0) (cmp 0 1)))
((= i nb)
(cmp 1 0))
((chcmp = (string-ref a i) (string-ref b i))
(loop (succ i)))
(else
(chcmp cmp (string-ref a i) (string-ref b i)))))))
(define (string=? a b) (string-cmp? char-cmp? = a b))
(define (string<? a b) (string-cmp? char-cmp? < a b))
(define (string>? a b) (string-cmp? char-cmp? > a b))
(define (string<=? a b) (string-cmp? char-cmp? <= a b))
(define (string>=? a b) (string-cmp? char-cmp? >= a b))
(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
(define (list . x) x)
(define (foldr f x lst)
(if (null? lst)
x
(foldr f (f x (car lst)) (cdr lst))))
(define (unzip1-with-cdr . lists)
(unzip1-with-cdr-iterative lists '() '()))
(define (unzip1-with-cdr-iterative lists cars cdrs)
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
(unzip1-with-cdr-iterative
(cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
(define (map proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
'()
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(cons (apply proc cars) (apply map (cons proc cdrs)))))))
(define (for-each proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
#t
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(apply proc cars) (apply map (cons proc cdrs))))))
(define (list-tail x k)
(if (zero? k)
x
(list-tail (cdr x) (- k 1))))
(define (list-ref x k)
(car (list-tail x k)))
(define (last-pair x)
(if (pair? (cdr x))
(last-pair (cdr x))
x))
(define (head stream) (car stream))
(define (tail stream) (force (cdr stream)))
(define (vector-equal? x y)
(and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
(let ((n (vector-length x)))
(let loop ((i 0))
(if (= i n)
#t
(and (equal? (vector-ref x i) (vector-ref y i))
(loop (succ i))))))))
(define (list->vector x)
(apply vector x))
(define (vector-fill! v e)
(let ((n (vector-length v)))
(let loop ((i 0))
(if (= i n)
v
(begin (vector-set! v i e) (loop (succ i)))))))
(define (vector->list v)
(let loop ((n (pred (vector-length v))) (l '()))
(if (= n -1)
l
(loop (pred n) (cons (vector-ref v n) l)))))
;; The following quasiquote macro is due to Eric S. Tiedemann.
;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
;;
;; Subsequently modified to handle vectors: D. Souflis
(macro
quasiquote
(lambda (l)
(define (mcons f l r)
(if (and (pair? r)
(eq? (car r) 'quote)
(eq? (car (cdr r)) (cdr f))
(pair? l)
(eq? (car l) 'quote)
(eq? (car (cdr l)) (car f)))
(if (or (procedure? f) (number? f) (string? f))
f
(list 'quote f))
(if (eqv? l vector)
(apply l (eval r))
(list 'cons l r)
)))
(define (mappend f l r)
(if (or (null? (cdr f))
(and (pair? r)
(eq? (car r) 'quote)
(eq? (car (cdr r)) '())))
l
(list 'append l r)))
(define (foo level form)
(cond ((not (pair? form))
(if (or (procedure? form) (number? form) (string? form))
form
(list 'quote form))
)
((eq? 'quasiquote (car form))
(mcons form ''quasiquote (foo (+ level 1) (cdr form))))
(#t (if (zero? level)
(cond ((eq? (car form) 'unquote) (car (cdr form)))
((eq? (car form) 'unquote-splicing)
(error "Unquote-splicing wasn't in a list:"
form))
((and (pair? (car form))
(eq? (car (car form)) 'unquote-splicing))
(mappend form (car (cdr (car form)))
(foo level (cdr form))))
(#t (mcons form (foo level (car form))
(foo level (cdr form)))))
(cond ((eq? (car form) 'unquote)
(mcons form ''unquote (foo (- level 1)
(cdr form))))
((eq? (car form) 'unquote-splicing)
(mcons form ''unquote-splicing
(foo (- level 1) (cdr form))))
(#t (mcons form (foo level (car form))
(foo level (cdr form)))))))))
(foo 0 (car (cdr l)))))
;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
(define (shared-tail x y)
(let ((len-x (length x))
(len-y (length y)))
(define (shared-tail-helper x y)
(if
(eq? x y)
x
(shared-tail-helper (cdr x) (cdr y))))
(cond
((> len-x len-y)
(shared-tail-helper
(list-tail x (- len-x len-y))
y))
((< len-x len-y)
(shared-tail-helper
x
(list-tail y (- len-y len-x))))
(#t (shared-tail-helper x y)))))
;;;;;Dynamic-wind by Tom Breton (Tehom)
;;Guarded because we must only eval this once, because doing so
;;redefines call/cc in terms of old call/cc
(unless (defined? 'dynamic-wind)
(let
;;These functions are defined in the context of a private list of
;;pairs of before/after procs.
( (*active-windings* '())
;;We'll define some functions into the larger environment, so
;;we need to know it.
(outer-env (current-environment)))
;;Poor-man's structure operations
(define before-func car)
(define after-func cdr)
(define make-winding cons)
;;Manage active windings
(define (activate-winding! new)
((before-func new))
(set! *active-windings* (cons new *active-windings*)))
(define (deactivate-top-winding!)
(let ((old-top (car *active-windings*)))
;;Remove it from the list first so it's not active during its
;;own exit.
(set! *active-windings* (cdr *active-windings*))
((after-func old-top))))
(define (set-active-windings! new-ws)
(unless (eq? new-ws *active-windings*)
(let ((shared (shared-tail new-ws *active-windings*)))
;;Define the looping functions.
;;Exit the old list. Do deeper ones last. Don't do
;;any shared ones.
(define (pop-many)
(unless (eq? *active-windings* shared)
(deactivate-top-winding!)
(pop-many)))
;;Enter the new list. Do deeper ones first so that the
;;deeper windings will already be active. Don't do any
;;shared ones.
(define (push-many new-ws)
(unless (eq? new-ws shared)
(push-many (cdr new-ws))
(activate-winding! (car new-ws))))
;;Do it.
(pop-many)
(push-many new-ws))))
;;The definitions themselves.
(eval
`(define call-with-current-continuation
;;It internally uses the built-in call/cc, so capture it.
,(let ((old-c/cc call-with-current-continuation))
(lambda (func)
;;Use old call/cc to get the continuation.
(old-c/cc
(lambda (continuation)
;;Call func with not the continuation itself
;;but a procedure that adjusts the active
;;windings to what they were when we made
;;this, and only then calls the
;;continuation.
(func
(let ((current-ws *active-windings*))
(lambda (x)
(set-active-windings! current-ws)
(continuation x)))))))))
outer-env)
;;We can't just say "define (dynamic-wind before thunk after)"
;;because the lambda it's defined to lives in this environment,
;;not in the global environment.
(eval
`(define dynamic-wind
,(lambda (before thunk after)
;;Make a new winding
(activate-winding! (make-winding before after))
(let ((result (thunk)))
;;Get rid of the new winding.
(deactivate-top-winding!)
;;The return value is that of thunk.
result)))
outer-env)))
(define call/cc call-with-current-continuation)
;;;;; atom? and equal? written by a.k
;;;; atom?
(define (atom? x)
(not (pair? x)))
;;;; equal?
(define (equal? x y)
(cond
((pair? x)
(and (pair? y)
(equal? (car x) (car y))
(equal? (cdr x) (cdr y))))
((vector? x)
(and (vector? y) (vector-equal? x y)))
((string? x)
(and (string? y) (string=? x y)))
(else (eqv? x y))))
;;;; (do ((var init inc) ...) (endtest result ...) body ...)
;;
(macro do
(lambda (do-macro)
(apply (lambda (do vars endtest . body)
(let ((do-loop (gensym)))
`(letrec ((,do-loop
(lambda ,(map (lambda (x)
(if (pair? x) (car x) x))
`,vars)
(if ,(car endtest)
(begin ,@(cdr endtest))
(begin
,@body
(,do-loop
,@(map (lambda (x)
(cond
((not (pair? x)) x)
((< (length x) 3) (car x))
(else (car (cdr (cdr x))))))
`,vars)))))))
(,do-loop
,@(map (lambda (x)
(if (and (pair? x) (cdr x))
(car (cdr x))
'()))
`,vars)))))
do-macro)))
;;;; generic-member
(define (generic-member cmp obj lst)
(cond
((null? lst) #f)
((cmp obj (car lst)) lst)
(else (generic-member cmp obj (cdr lst)))))
(define (memq obj lst)
(generic-member eq? obj lst))
(define (memv obj lst)
(generic-member eqv? obj lst))
(define (member obj lst)
(generic-member equal? obj lst))
;;;; generic-assoc
(define (generic-assoc cmp obj alst)
(cond
((null? alst) #f)
((cmp obj (caar alst)) (car alst))
(else (generic-assoc cmp obj (cdr alst)))))
(define (assq obj alst)
(generic-assoc eq? obj alst))
(define (assv obj alst)
(generic-assoc eqv? obj alst))
(define (assoc obj alst)
(generic-assoc equal? obj alst))
(define (acons x y z) (cons (cons x y) z))
;;;; Handy for imperative programs
;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
(macro (define-with-return form)
`(define ,(cadr form)
(call/cc (lambda (return) ,@(cddr form)))))
;;;; Simple exception handling
;
; Exceptions are caught as follows:
;
; (catch (do-something to-recover and-return meaningful-value)
; (if-something goes-wrong)
; (with-these calls))
;
; "Catch" establishes a scope spanning multiple call-frames
; until another "catch" is encountered.
;
; Exceptions are thrown with:
;
; (throw "message")
;
; If used outside a (catch ...), reverts to (error "message)
(define *handlers* (list))
(define (push-handler proc)
(set! *handlers* (cons proc *handlers*)))
(define (pop-handler)
(let ((h (car *handlers*)))
(set! *handlers* (cdr *handlers*))
h))
(define (more-handlers?)
(pair? *handlers*))
(define (throw . x)
(if (more-handlers?)
(apply (pop-handler))
(apply error x)))
(macro (catch form)
(let ((label (gensym)))
`(call/cc (lambda (exit)
(push-handler (lambda () (exit ,(cadr form))))
(let ((,label (begin ,@(cddr form))))
(pop-handler)
,label)))))
(define *error-hook* throw)
;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
(macro (make-environment form)
`(apply (lambda ()
,@(cdr form)
(current-environment))))
(define-macro (eval-polymorphic x . envl)
(display envl)
(let* ((env (if (null? envl) (current-environment) (eval (car envl))))
(xval (eval x env)))
(if (closure? xval)
(make-closure (get-closure-code xval) env)
xval)))
; Redefine this if you install another package infrastructure
; Also redefine 'package'
(define *colon-hook* eval)
;;;;; I/O
(define (input-output-port? p)
(and (input-port? p) (output-port? p)))
(define (close-port p)
(cond
((input-output-port? p) (close-input-port p) (close-output-port p))
((input-port? p) (close-input-port p))
((output-port? p) (close-output-port p))
(else (throw "Not a port" p))))
(define (call-with-input-file s p)
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((res (p inport)))
(close-input-port inport)
res))))
(define (call-with-output-file s p)
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((res (p outport)))
(close-output-port outport)
res))))
(define (with-input-from-file s p)
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((prev-inport (current-input-port)))
(set-input-port inport)
(let ((res (p)))
(close-input-port inport)
(set-input-port prev-inport)
res)))))
(define (with-output-to-file s p)
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((prev-outport (current-output-port)))
(set-output-port outport)
(let ((res (p)))
(close-output-port outport)
(set-output-port prev-outport)
res)))))
(define (with-input-output-from-to-files si so p)
(let ((inport (open-input-file si))
(outport (open-input-file so)))
(if (not (and inport outport))
(begin
(close-input-port inport)
(close-output-port outport)
#f)
(let ((prev-inport (current-input-port))
(prev-outport (current-output-port)))
(set-input-port inport)
(set-output-port outport)
(let ((res (p)))
(close-input-port inport)
(close-output-port outport)
(set-input-port prev-inport)
(set-output-port prev-outport)
res)))))
; Random number generator (maximum cycle)
(define *seed* 1)
(define (random-next)
(let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
(set! *seed*
(- (* a (- *seed*
(* (quotient *seed* q) q)))
(* (quotient *seed* q) r)))
(if (< *seed* 0) (set! *seed* (+ *seed* m)))
*seed*))
;; SRFI-0
;; COND-EXPAND
;; Implemented as a macro
(define *features* '(srfi-0 tinyscheme))
(define-macro (cond-expand . cond-action-list)
(cond-expand-runtime cond-action-list))
(define (cond-expand-runtime cond-action-list)
(if (null? cond-action-list)
#t
(if (cond-eval (caar cond-action-list))
`(begin ,@(cdar cond-action-list))
(cond-expand-runtime (cdr cond-action-list)))))
(define (cond-eval-and cond-list)
(foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
(define (cond-eval-or cond-list)
(foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
(define (cond-eval condition)
(cond
((symbol? condition)
(if (member condition *features*) #t #f))
((eq? condition #t) #t)
((eq? condition #f) #f)
(else (case (car condition)
((and) (cond-eval-and (cdr condition)))
((or) (cond-eval-or (cdr condition)))
((not) (if (not (null? (cddr condition)))
(error "cond-expand : 'not' takes 1 argument")
(not (cond-eval (cadr condition)))))
(else (error "cond-expand : unknown operator" (car condition)))))))
(gc-verbose #f)

195
tests/gpgscm/opdefines.h Normal file
View File

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

220
tests/gpgscm/scheme-private.h Normal file
View File

@ -0,0 +1,220 @@
/* 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;
#ifndef CELL_SEGSIZE
#define CELL_SEGSIZE 5000 /* # of cells in one segment */
#endif
#ifndef CELL_NSEGMENT
#define CELL_NSEGMENT 10 /* # of segments for cells */
#endif
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;
#ifndef MAXFIL
#define MAXFIL 64
#endif
port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */
int nesting_stack[MAXFIL];
int file_i;
int nesting;
char gc_verbose; /* if gc_verbose is not zero, print gc status */
char no_memory; /* Whether mem. alloc. has failed */
#ifndef LINESIZE
#define LINESIZE 1024
#endif
char linebuff[LINESIZE];
#ifndef STRBUFFSIZE
#define STRBUFFSIZE 256
#endif
char strbuff[STRBUFFSIZE];
FILE *tmpfp;
int tok;
int print_flag;
pointer value;
int op;
void *ext_data; /* For the benefit of foreign functions */
long gensym_cnt;
struct scheme_interface *vptr;
void *dump_base; /* pointer to base of allocated dump stack */
int dump_size; /* number of frames allocated for dump stack */
};
/* operator code */
enum scheme_opcodes {
#define _OP_DEF(A,B,C,D,E,OP) OP,
#include "opdefines.h"
OP_MAXDEFINED
};
#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:
*/

5052
tests/gpgscm/scheme.c Normal file
View File

File diff suppressed because it is too large Load Diff

255
tests/gpgscm/scheme.h Normal file
View File

@ -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(void);
SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free);
SCHEME_EXPORT int scheme_init(scheme *sc);
SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc);
SCHEME_EXPORT void scheme_deinit(scheme *sc);
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:
*/