From 864992fdf695996dbac9bb344b1fdd879f735473 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 6 Jan 2016 11:54:03 +0100 Subject: tests/gpgscm: Verbatim import of latest TinySCHEME. Revision 110 from svn://svn.code.sf.net/p/tinyscheme/code/trunk * tests/gpgscm/COPYING: New file. * tests/gpgscm/Manual.txt: Likewise. * 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 --- COPYING | 31 + Manual.txt | 444 +++++ init.scm | 716 ++++++++ opdefines.h | 195 +++ scheme-private.h | 220 +++ scheme.c | 5056 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ scheme.h | 255 +++ 7 files changed, 6917 insertions(+) create mode 100644 COPYING create mode 100644 Manual.txt create mode 100644 init.scm create mode 100644 opdefines.h create mode 100644 scheme-private.h create mode 100644 scheme.c create mode 100644 scheme.h diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..23a7e85 --- /dev/null +++ b/COPYING @@ -0,0 +1,31 @@ + LICENSE TERMS + +Copyright (c) 2000, Dimitrios Souflis +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of Dimitrios Souflis nor the names of the +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Manual.txt b/Manual.txt new file mode 100644 index 0000000..ffda956 --- /dev/null +++ b/Manual.txt @@ -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? ) (defined? ) + 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 ) + The argument (defaulting to #t) controls whether GC produces + visible outcome. + + (quit) (quit ) + Stops the interpreter and sets the 'retcode' internal field (defaults + to 0). When standalone, 'retcode' is returned as exit code to the OS. + + (tracing ) + 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>=?. + (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>=?. + (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 ) + 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
) + Returns the expanded form of the macro call denoted by the argument + + (define-with-return ( ...) ) + Like plain 'define', but makes the continuation available as 'return' + inside the procedure. Handy for imperative programs. + + (new-segment ) + Allocates more memory segments. + + defined? + See "Environments" + + (get-closure-code ) + Gets the code as scheme data. + + (make-closure ) + Makes a new closure in the given environment. + + Obsolete procedures + (print-width ) + + 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_. 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 [ ...] + followed by + -1 [ ...] + -c [ ...] + 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 + ... ) + + "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 :: and + transforms it in the following manner (T is the transformation function): + + T(::) = (*colon-hook* 'T() ) + + where is a symbol not containing any double-colons. + + As the definition is recursive, qualifiers can be nested. + The user can define his own *colon-hook*, to handle qualified names. + By default, "init.scm" defines *colon-hook* as EVAL. Consequently, + the qualifier must denote a Scheme environment, such as one returned + by (interaction-environment). "Init.scm" defines a new syntantic form, + PACKAGE, as a simple example. It is used like this: + + (define toto + (package + (define foo 1) + (define bar +))) + + foo ==> Error, "foo" undefined + (eval 'foo) ==> Error, "foo" undefined + (eval 'foo toto) ==> 1 + toto::foo ==> 1 + ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 + (toto::bar 2 toto::foo) ==> 3 + (eval (bar 2 foo) toto) ==> 3 + + If the user installs another package infrastructure, he must define + a new 'package' procedure or macro to retain compatibility with supplied + code. + + Note: Older versions used ':' as a qualifier. Unfortunately, the use + of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially + precludes its use as a real qualifier. diff --git a/init.scm b/init.scm new file mode 100644 index 0000000..57ae079 --- /dev/null +++ b/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-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-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) diff --git a/opdefines.h b/opdefines.h new file mode 100644 index 0000000..ceb4d0e --- /dev/null +++ b/opdefines.h @@ -0,0 +1,195 @@ + _OP_DEF(opexe_0, "load", 1, 1, TST_STRING, OP_LOAD ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T0LVL ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T1LVL ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_READ_INTERNAL ) + _OP_DEF(opexe_0, "gensym", 0, 0, 0, OP_GENSYM ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_VALUEPRINT ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_EVAL ) +#if USE_TRACING + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL ) +#endif + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) +#if USE_TRACING + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY ) + _OP_DEF(opexe_0, "tracing", 1, 1, TST_NATURAL, OP_TRACING ) +#endif + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DOMACRO ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA1 ) + _OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_QUOTE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF1 ) + _OP_DEF(opexe_0, "defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_BEGIN ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0AST ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1AST ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2AST ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET0REC ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET1REC ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET2REC ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_DELAY ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C0STREAM ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C1STREAM ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE2 ) + _OP_DEF(opexe_1, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) + _OP_DEF(opexe_1, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) + _OP_DEF(opexe_1, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) +#if USE_MATH + _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) + _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP ) + _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG ) + _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN ) + _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS ) + _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN ) + _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN ) + _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS ) + _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN ) + _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) + _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT ) + _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) + _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) + _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) + _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND ) +#endif + _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) + _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) + _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) + _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) + _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) + _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM ) + _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD ) + _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR ) + _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR ) + _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS ) + _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) + _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) + _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) + _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) + _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) + _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) + _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) + _OP_DEF(opexe_2, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) + _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) + _OP_DEF(opexe_2, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) + _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) + _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN ) + _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) + _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) + _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) + _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) + _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) + _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) + _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) + _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) + _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) + _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) + _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) + _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) + _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP ) + _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) + _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) + _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) + _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) + _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) + _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) + _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP ) + _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP ) + _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) + _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP ) + _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP ) +#if USE_CHAR_CLASSIFIERS + _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) + _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) + _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) + _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) + _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) +#endif + _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP ) + _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) + _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) + _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP ) + _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP ) + _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP ) + _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP ) + _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) + _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) + _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV ) + _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE ) + _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED ) + _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) + _OP_DEF(opexe_4, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) + _OP_DEF(opexe_4, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) + _OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) + _OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) + _OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1 ) + _OP_DEF(opexe_4, "reverse", 1, 1, TST_LIST, OP_REVERSE ) + _OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) + _OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) +#if USE_PLIST + _OP_DEF(opexe_4, "put", 3, 3, TST_NONE, OP_PUT ) + _OP_DEF(opexe_4, "get", 2, 2, TST_NONE, OP_GET ) +#endif + _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) + _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) + _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) + _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) + _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST ) + _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) + _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) + _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) + _OP_DEF(opexe_4, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) + _OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) +#if USE_STRING_PORTS + _OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) + _OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) + _OP_DEF(opexe_4, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) + _OP_DEF(opexe_4, "get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) +#endif + _OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) + _OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) + _OP_DEF(opexe_4, "interaction-environment", 0, 0, 0, OP_INT_ENV ) + _OP_DEF(opexe_4, "current-environment", 0, 0, 0, OP_CURR_ENV ) + _OP_DEF(opexe_5, "read", 0, 1, TST_INPORT, OP_READ ) + _OP_DEF(opexe_5, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) + _OP_DEF(opexe_5, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) + _OP_DEF(opexe_5, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) + _OP_DEF(opexe_5, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) + _OP_DEF(opexe_5, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDSEXPR ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDLIST ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDDOT ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQUOTE ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTE ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTEVEC ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUNQUOTE ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUQTSP ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDVEC ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P0LIST ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P1LIST ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_PVECFROM ) + _OP_DEF(opexe_6, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) + _OP_DEF(opexe_6, "assq", 2, 2, TST_NONE, OP_ASSQ ) + _OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) + _OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) + _OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP ) +#undef _OP_DEF diff --git a/scheme-private.h b/scheme-private.h new file mode 100644 index 0000000..404243e --- /dev/null +++ b/scheme-private.h @@ -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: +*/ diff --git a/scheme.c b/scheme.c new file mode 100644 index 0000000..3d4330d --- /dev/null +++ b/scheme.c @@ -0,0 +1,5056 @@ +/* T I N Y S C H E M E 1 . 4 1 + * Dimitrios Souflis (dsouflis@acm.org) + * Based on MiniScheme (original credits follow) + * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) + * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp + * (MINISCM) This version has been modified by R.C. Secrist. + * (MINISCM) + * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. + * (MINISCM) + * (MINISCM) This is a revised and modified version by Akira KIDA. + * (MINISCM) current version is 0.85k4 (15 May 1994) + * + */ + +#define _SCHEME_SOURCE +#include "scheme-private.h" +#ifndef WIN32 +# include +#endif +#ifdef WIN32 +#define snprintf _snprintf +#endif +#if USE_DL +# include "dynload.h" +#endif +#if USE_MATH +# include +#endif + +#include +#include +#include + +#if USE_STRCASECMP +#include +# ifndef __APPLE__ +# define stricmp strcasecmp +# endif +#endif + +/* Used for documentation purposes, to signal functions in 'interface' */ +#define INTERFACE + +#define TOK_EOF (-1) +#define TOK_LPAREN 0 +#define TOK_RPAREN 1 +#define TOK_DOT 2 +#define TOK_ATOM 3 +#define TOK_QUOTE 4 +#define TOK_COMMENT 5 +#define TOK_DQUOTE 6 +#define TOK_BQUOTE 7 +#define TOK_COMMA 8 +#define TOK_ATMARK 9 +#define TOK_SHARP 10 +#define TOK_SHARP_CONST 11 +#define TOK_VEC 12 + +#define BACKQUOTE '`' +#define DELIMITERS "()\";\f\t\v\n\r " + +/* + * Basic memory allocation units + */ + +#define banner "TinyScheme 1.41" + +#include +#include + +#ifdef __APPLE__ +static int stricmp(const char *s1, const char *s2) +{ + unsigned char c1, c2; + do { + c1 = tolower(*s1); + c2 = tolower(*s2); + if (c1 < c2) + return -1; + else if (c1 > c2) + return 1; + s1++, s2++; + } while (c1 != 0); + return 0; +} +#endif /* __APPLE__ */ + +#if USE_STRLWR +static const char *strlwr(char *s) { + const char *p=s; + while(*s) { + *s=tolower(*s); + s++; + } + return p; +} +#endif + +#ifndef prompt +# define prompt "ts> " +#endif + +#ifndef InitFile +# define InitFile "init.scm" +#endif + +#ifndef FIRST_CELLSEGS +# define FIRST_CELLSEGS 3 +#endif + +enum scheme_types { + T_STRING=1, + T_NUMBER=2, + T_SYMBOL=3, + T_PROC=4, + T_PAIR=5, + T_CLOSURE=6, + T_CONTINUATION=7, + T_FOREIGN=8, + T_CHARACTER=9, + T_PORT=10, + T_VECTOR=11, + T_MACRO=12, + T_PROMISE=13, + T_ENVIRONMENT=14, + T_LAST_SYSTEM_TYPE=14 +}; + +/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ +#define ADJ 32 +#define TYPE_BITS 5 +#define T_MASKTYPE 31 /* 0000000000011111 */ +#define T_SYNTAX 4096 /* 0001000000000000 */ +#define T_IMMUTABLE 8192 /* 0010000000000000 */ +#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ +#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ +#define MARK 32768 /* 1000000000000000 */ +#define UNMARK 32767 /* 0111111111111111 */ + + +static num num_add(num a, num b); +static num num_mul(num a, num b); +static num num_div(num a, num b); +static num num_intdiv(num a, num b); +static num num_sub(num a, num b); +static num num_rem(num a, num b); +static num num_mod(num a, num b); +static int num_eq(num a, num b); +static int num_gt(num a, num b); +static int num_ge(num a, num b); +static int num_lt(num a, num b); +static int num_le(num a, num b); + +#if USE_MATH +static double round_per_R5RS(double x); +#endif +static int is_zero_double(double x); +static INLINE int num_is_integer(pointer p) { + return ((p)->_object._number.is_fixnum); +} + +static num num_zero; +static num num_one; + +/* macros for cell operations */ +#define typeflag(p) ((p)->_flag) +#define type(p) (typeflag(p)&T_MASKTYPE) + +INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } +#define strvalue(p) ((p)->_object._string._svalue) +#define strlength(p) ((p)->_object._string._length) + +INTERFACE static int is_list(scheme *sc, pointer p); +INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } +INTERFACE static void fill_vector(pointer vec, pointer obj); +INTERFACE static pointer vector_elem(pointer vec, int ielem); +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); +INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } +INTERFACE INLINE int is_integer(pointer p) { + if (!is_number(p)) + return 0; + if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) + return 1; + return 0; +} + +INTERFACE INLINE int is_real(pointer p) { + return is_number(p) && (!(p)->_object._number.is_fixnum); +} + +INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } +INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } +INLINE num nvalue(pointer p) { return ((p)->_object._number); } +INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } +INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } +#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) +#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) +#define set_num_integer(p) (p)->_object._number.is_fixnum=1; +#define set_num_real(p) (p)->_object._number.is_fixnum=0; +INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } + +INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } +INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } +INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } + +INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } +#define car(p) ((p)->_object._cons._car) +#define cdr(p) ((p)->_object._cons._cdr) +INTERFACE pointer pair_car(pointer p) { return car(p); } +INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } +INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } +INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } + +INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } +INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } +#if USE_PLIST +SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } +#define symprop(p) cdr(p) +#endif + +INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } +INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } +INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } +INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } +#define procnum(p) ivalue(p) +static const char *procname(pointer x); + +INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } +INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } +INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } +INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } + +INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } +#define cont_dump(p) cdr(p) + +/* To do: promise should be forced ONCE only */ +INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } + +INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } +#define setenvironment(p) typeflag(p) = T_ENVIRONMENT + +#define is_atom(p) (typeflag(p)&T_ATOM) +#define setatom(p) typeflag(p) |= T_ATOM +#define clratom(p) typeflag(p) &= CLRATOM + +#define is_mark(p) (typeflag(p)&MARK) +#define setmark(p) typeflag(p) |= MARK +#define clrmark(p) typeflag(p) &= UNMARK + +INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } +/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ +INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } + +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define cdar(p) cdr(car(p)) +#define cddr(p) cdr(cdr(p)) +#define cadar(p) car(cdr(car(p))) +#define caddr(p) car(cdr(cdr(p))) +#define cdaar(p) cdr(car(car(p))) +#define cadaar(p) car(cdr(car(car(p)))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define cddddr(p) cdr(cdr(cdr(cdr(p)))) + +#if USE_CHAR_CLASSIFIERS +static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } +static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } +static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } +static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } +static INLINE int Cislower(int c) { return isascii(c) && islower(c); } +#endif + +#if USE_ASCII_NAMES +static const char *charnames[32]={ + "nul", + "soh", + "stx", + "etx", + "eot", + "enq", + "ack", + "bel", + "bs", + "ht", + "lf", + "vt", + "ff", + "cr", + "so", + "si", + "dle", + "dc1", + "dc2", + "dc3", + "dc4", + "nak", + "syn", + "etb", + "can", + "em", + "sub", + "esc", + "fs", + "gs", + "rs", + "us" +}; + +static int is_ascii_name(const char *name, int *pc) { + int i; + for(i=0; i<32; i++) { + if(stricmp(name,charnames[i])==0) { + *pc=i; + return 1; + } + } + if(stricmp(name,"del")==0) { + *pc=127; + return 1; + } + return 0; +} + +#endif + +static int file_push(scheme *sc, const char *fname); +static void file_pop(scheme *sc); +static int file_interactive(scheme *sc); +static INLINE int is_one_of(char *s, int c); +static int alloc_cellseg(scheme *sc, int n); +static long binary_decode(const char *s); +static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); +static pointer _get_cell(scheme *sc, pointer a, pointer b); +static pointer reserve_cells(scheme *sc, int n); +static pointer get_consecutive_cells(scheme *sc, int n); +static pointer find_consecutive_cells(scheme *sc, int n); +static void finalize_cell(scheme *sc, pointer a); +static int count_consecutive_cells(pointer x, int needed); +static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); +static pointer mk_number(scheme *sc, num n); +static char *store_string(scheme *sc, int len, const char *str, char fill); +static pointer mk_vector(scheme *sc, int len); +static pointer mk_atom(scheme *sc, char *q); +static pointer mk_sharp_const(scheme *sc, char *name); +static pointer mk_port(scheme *sc, port *p); +static pointer port_from_filename(scheme *sc, const char *fn, int prop); +static pointer port_from_file(scheme *sc, FILE *, int prop); +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); +static port *port_rep_from_file(scheme *sc, FILE *, int prop); +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static void port_close(scheme *sc, pointer p, int flag); +static void mark(pointer a); +static void gc(scheme *sc, pointer a, pointer b); +static int basic_inchar(port *pt); +static int inchar(scheme *sc); +static void backchar(scheme *sc, int c); +static char *readstr_upto(scheme *sc, char *delim); +static pointer readstrexp(scheme *sc); +static INLINE int skipspace(scheme *sc); +static int token(scheme *sc); +static void printslashstring(scheme *sc, char *s, int len); +static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); +static void printatom(scheme *sc, pointer l, int f); +static pointer mk_proc(scheme *sc, enum scheme_opcodes op); +static pointer mk_closure(scheme *sc, pointer c, pointer e); +static pointer mk_continuation(scheme *sc, pointer d); +static pointer reverse(scheme *sc, pointer a); +static pointer reverse_in_place(scheme *sc, pointer term, pointer list); +static pointer revappend(scheme *sc, pointer a, pointer b); +static void dump_stack_mark(scheme *); +static pointer opexe_0(scheme *sc, enum scheme_opcodes op); +static pointer opexe_1(scheme *sc, enum scheme_opcodes op); +static pointer opexe_2(scheme *sc, enum scheme_opcodes op); +static pointer opexe_3(scheme *sc, enum scheme_opcodes op); +static pointer opexe_4(scheme *sc, enum scheme_opcodes op); +static pointer opexe_5(scheme *sc, enum scheme_opcodes op); +static pointer opexe_6(scheme *sc, enum scheme_opcodes op); +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); +static void assign_syntax(scheme *sc, char *name); +static int syntaxnum(pointer p); +static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); + +#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) +#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) + +static num num_add(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue+b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)+num_rvalue(b); + } + return ret; +} + +static num num_mul(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue*b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)*num_rvalue(b); + } + return ret; +} + +static num num_div(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_intdiv(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_sub(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue-b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)-num_rvalue(b); + } + return ret; +} + +static num num_rem(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* remainder should have same sign as second operand */ + if (res > 0) { + if (e1 < 0) { + res -= labs(e2); + } + } else if (res < 0) { + if (e1 > 0) { + res += labs(e2); + } + } + ret.value.ivalue=res; + return ret; +} + +static num num_mod(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* modulo should have same sign as second operand */ + if (res * e2 < 0) { + res += e2; + } + ret.value.ivalue=res; + return ret; +} + +static int num_eq(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue==b.value.ivalue; + } else { + ret=num_rvalue(a)==num_rvalue(b); + } + return ret; +} + + +static int num_gt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue>b.value.ivalue; + } else { + ret=num_rvalue(a)>num_rvalue(b); + } + return ret; +} + +static int num_ge(num a, num b) { + return !num_lt(a,b); +} + +static int num_lt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivaluedce) { + return ce; + } else if(dfl-DBL_MIN; +} + +static long binary_decode(const char *s) { + long x=0; + + while(*s!=0 && (*s=='1' || *s=='0')) { + x<<=1; + x+=*s-'0'; + s++; + } + + return x; +} + +/* allocate new cell segment */ +static int alloc_cellseg(scheme *sc, int n) { + pointer newp; + pointer last; + pointer p; + char *cp; + long i; + int k; + int adj=ADJ; + + if(adjlast_cell_seg >= CELL_NSEGMENT - 1) + return k; + cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); + if (cp == 0) + return k; + i = ++sc->last_cell_seg ; + sc->alloc_seg[i] = cp; + /* adjust in TYPE_BITS-bit boundary */ + if(((unsigned long)cp)%adj!=0) { + cp=(char*)(adj*((unsigned long)cp/adj+1)); + } + /* insert new segment in address order */ + newp=(pointer)cp; + sc->cell_seg[i] = newp; + while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { + p = sc->cell_seg[i]; + sc->cell_seg[i] = sc->cell_seg[i - 1]; + sc->cell_seg[--i] = p; + } + sc->fcells += CELL_SEGSIZE; + last = newp + CELL_SEGSIZE - 1; + for (p = newp; p <= last; p++) { + typeflag(p) = 0; + cdr(p) = p + 1; + car(p) = sc->NIL; + } + /* insert new cells in address order on free list */ + if (sc->free_cell == sc->NIL || p < sc->free_cell) { + cdr(last) = sc->free_cell; + sc->free_cell = newp; + } else { + p = sc->free_cell; + while (cdr(p) != sc->NIL && newp > cdr(p)) + p = cdr(p); + cdr(last) = cdr(p); + cdr(p) = newp; + } + } + return n; +} + +static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { + if (sc->free_cell != sc->NIL) { + pointer x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); + } + return _get_cell (sc, a, b); +} + + +/* get new cell. parameter a, b is marked by gc. */ +static pointer _get_cell(scheme *sc, pointer a, pointer b) { + pointer x; + + if(sc->no_memory) { + return sc->sink; + } + + if (sc->free_cell == sc->NIL) { + const int min_to_be_recovered = sc->last_cell_seg*8; + gc(sc,a, b); + if (sc->fcells < min_to_be_recovered + || sc->free_cell == sc->NIL) { + /* if only a few recovered, get more to avoid fruitless gc's */ + if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { + sc->no_memory=1; + return sc->sink; + } + } + } + x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); +} + +/* make sure that there is a given number of cells free */ +static pointer reserve_cells(scheme *sc, int n) { + if(sc->no_memory) { + return sc->NIL; + } + + /* Are there enough cells available? */ + if (sc->fcells < n) { + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + if (sc->fcells < n) { + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) { + sc->no_memory=1; + return sc->NIL; + } + } + if (sc->fcells < n) { + /* If all fail, report failure */ + sc->no_memory=1; + return sc->NIL; + } + } + return (sc->T); +} + +static pointer get_consecutive_cells(scheme *sc, int n) { + pointer x; + + if(sc->no_memory) { return sc->sink; } + + /* Are there any cells available? */ + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) + { + sc->no_memory=1; + return sc->sink; + } + + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If all fail, report failure */ + sc->no_memory=1; + return sc->sink; +} + +static int count_consecutive_cells(pointer x, int needed) { + int n=1; + while(cdr(x)==x+1) { + x=cdr(x); + n++; + if(n>needed) return n; + } + return n; +} + +static pointer find_consecutive_cells(scheme *sc, int n) { + pointer *pp; + int cnt; + + pp=&sc->free_cell; + while(*pp!=sc->NIL) { + cnt=count_consecutive_cells(*pp,n); + if(cnt>=n) { + pointer x=*pp; + *pp=cdr(*pp+n-1); + sc->fcells -= n; + return x; + } + pp=&cdr(*pp+cnt-1); + } + return sc->NIL; +} + +/* To retain recent allocs before interpreter knows about them - + Tehom */ + +static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) +{ + pointer holder = get_cell_x(sc, recent, extra); + typeflag(holder) = T_PAIR | T_IMMUTABLE; + car(holder) = recent; + cdr(holder) = car(sc->sink); + car(sc->sink) = holder; +} + + +static pointer get_cell(scheme *sc, pointer a, pointer b) +{ + pointer cell = get_cell_x(sc, a, b); + /* For right now, include "a" and "b" in "cell" so that gc doesn't + think they are garbage. */ + /* Tentatively record it as a pair so gc understands it. */ + typeflag(cell) = T_PAIR; + car(cell) = a; + cdr(cell) = b; + push_recent_alloc(sc, cell, sc->NIL); + return cell; +} + +static pointer get_vector_object(scheme *sc, int len, pointer init) +{ + pointer cells = get_consecutive_cells(sc,len/2+len%2+1); + if(sc->no_memory) { return sc->sink; } + /* Record it as a vector so that gc understands it. */ + typeflag(cells) = (T_VECTOR | T_ATOM); + ivalue_unchecked(cells)=len; + set_num_integer(cells); + fill_vector(cells,init); + push_recent_alloc(sc, cells, sc->NIL); + return cells; +} + +static INLINE void ok_to_freely_gc(scheme *sc) +{ + car(sc->sink) = sc->NIL; +} + + +#if defined TSGRIND +static void check_cell_alloced(pointer p, int expect_alloced) +{ + /* Can't use putstr(sc,str) because callers have no access to + sc. */ + if(typeflag(p) & !expect_alloced) + { + fprintf(stderr,"Cell is already allocated!\n"); + } + if(!(typeflag(p)) & expect_alloced) + { + fprintf(stderr,"Cell is not allocated!\n"); + } + +} +static void check_range_alloced(pointer p, int n, int expect_alloced) +{ + int i; + for(i = 0;iNIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + + location = hash_fn(name, ivalue_unchecked(sc->oblist)); + set_vector_elem(sc->oblist, location, + immutable_cons(sc, x, vector_elem(sc->oblist, location))); + return x; +} + +static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +{ + int location; + pointer x; + char *s; + + location = hash_fn(name, ivalue_unchecked(sc->oblist)); + for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + if(stricmp(name, s) == 0) { + return car(x); + } + } + return sc->NIL; +} + +static pointer oblist_all_symbols(scheme *sc) +{ + int i; + pointer x; + pointer ob_list = sc->NIL; + + for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { + for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { + ob_list = cons(sc, x, ob_list); + } + } + return ob_list; +} + +#else + +static pointer oblist_initial_value(scheme *sc) +{ + return sc->NIL; +} + +static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +{ + pointer x; + char *s; + + for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + if(stricmp(name, s) == 0) { + return car(x); + } + } + return sc->NIL; +} + +/* returns the new symbol */ +static pointer oblist_add_by_name(scheme *sc, const char *name) +{ + pointer x; + + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + sc->oblist = immutable_cons(sc, x, sc->oblist); + return x; +} +static pointer oblist_all_symbols(scheme *sc) +{ + return sc->oblist; +} + +#endif + +static pointer mk_port(scheme *sc, port *p) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = T_PORT|T_ATOM; + x->_object._port=p; + return (x); +} + +pointer mk_foreign_func(scheme *sc, foreign_func f) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN | T_ATOM); + x->_object._ff=f; + return (x); +} + +INTERFACE pointer mk_character(scheme *sc, int c) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_CHARACTER | T_ATOM); + ivalue_unchecked(x)= c; + set_num_integer(x); + return (x); +} + +/* get number atom (integer) */ +INTERFACE pointer mk_integer(scheme *sc, long num) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + ivalue_unchecked(x)= num; + set_num_integer(x); + return (x); +} + +INTERFACE pointer mk_real(scheme *sc, double n) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + rvalue_unchecked(x)= n; + set_num_real(x); + return (x); +} + +static pointer mk_number(scheme *sc, num n) { + if(n.is_fixnum) { + return mk_integer(sc,n.value.ivalue); + } else { + return mk_real(sc,n.value.rvalue); + } +} + +/* allocate name to string area */ +static char *store_string(scheme *sc, int len_str, const char *str, char fill) { + char *q; + + q=(char*)sc->malloc(len_str+1); + if(q==0) { + sc->no_memory=1; + return sc->strbuff; + } + if(str!=0) { + snprintf(q, len_str+1, "%s", str); + } else { + memset(q, fill, len_str); + q[len_str]=0; + } + return (q); +} + +/* get new string */ +INTERFACE pointer mk_string(scheme *sc, const char *str) { + return mk_counted_string(sc,str,strlen(str)); +} + +INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM); + strvalue(x) = store_string(sc,len,str,0); + strlength(x) = len; + return (x); +} + +INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM); + strvalue(x) = store_string(sc,len,0,fill); + strlength(x) = len; + return (x); +} + +INTERFACE static pointer mk_vector(scheme *sc, int len) +{ return get_vector_object(sc,len,sc->NIL); } + +INTERFACE static void fill_vector(pointer vec, pointer obj) { + int i; + int num=ivalue(vec)/2+ivalue(vec)%2; + for(i=0; iNIL) { + return (x); + } else { + x = oblist_add_by_name(sc, name); + return (x); + } +} + +INTERFACE pointer gensym(scheme *sc) { + pointer x; + char name[40]; + + for(; sc->gensym_cntgensym_cnt++) { + snprintf(name,40,"gensym-%ld",sc->gensym_cnt); + + /* first check oblist */ + x = oblist_find_by_name(sc, name); + + if (x != sc->NIL) { + continue; + } else { + x = oblist_add_by_name(sc, name); + return (x); + } + } + + return sc->NIL; +} + +/* make symbol or number atom from string */ +static pointer mk_atom(scheme *sc, char *q) { + char c, *p; + int has_dec_point=0; + int has_fp_exp = 0; + +#if USE_COLON_HOOK + if((p=strstr(q,"::"))!=0) { + *p=0; + return cons(sc, sc->COLON_HOOK, + cons(sc, + cons(sc, + sc->QUOTE, + cons(sc, mk_atom(sc,p+2), sc->NIL)), + cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); + } +#endif + + p = q; + c = *p++; + if ((c == '+') || (c == '-')) { + c = *p++; + if (c == '.') { + has_dec_point=1; + c = *p++; + } + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (c == '.') { + has_dec_point=1; + c = *p++; + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + + for ( ; (c = *p) != 0; ++p) { + if (!isdigit(c)) { + if(c=='.') { + if(!has_dec_point) { + has_dec_point=1; + continue; + } + } + else if ((c == 'e') || (c == 'E')) { + if(!has_fp_exp) { + has_dec_point = 1; /* decimal point illegal + from now on */ + p++; + if ((*p == '-') || (*p == '+') || isdigit(*p)) { + continue; + } + } + } + return (mk_symbol(sc, strlwr(q))); + } + } + if(has_dec_point) { + return mk_real(sc,atof(q)); + } + return (mk_integer(sc, atol(q))); +} + +/* make constant */ +static pointer mk_sharp_const(scheme *sc, char *name) { + long x; + char tmp[STRBUFFSIZE]; + + if (!strcmp(name, "t")) + return (sc->T); + else if (!strcmp(name, "f")) + return (sc->F); + else if (*name == 'o') {/* #o (octal) */ + snprintf(tmp, STRBUFFSIZE, "0%s", name+1); + sscanf(tmp, "%lo", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'd') { /* #d (decimal) */ + sscanf(name+1, "%ld", (long int *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'x') { /* #x (hex) */ + snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); + sscanf(tmp, "%lx", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'b') { /* #b (binary) */ + x = binary_decode(name+1); + return (mk_integer(sc, x)); + } else if (*name == '\\') { /* #\w (character) */ + int c=0; + if(stricmp(name+1,"space")==0) { + c=' '; + } else if(stricmp(name+1,"newline")==0) { + c='\n'; + } else if(stricmp(name+1,"return")==0) { + c='\r'; + } else if(stricmp(name+1,"tab")==0) { + c='\t'; + } else if(name[1]=='x' && name[2]!=0) { + int c1=0; + if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { + c=c1; + } else { + return sc->NIL; + } +#if USE_ASCII_NAMES + } else if(is_ascii_name(name+1,&c)) { + /* nothing */ +#endif + } else if(name[2]==0) { + c=name[1]; + } else { + return sc->NIL; + } + return mk_character(sc,c); + } else + return (sc->NIL); +} + +/* ========== garbage collector ========== */ + +/*-- + * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, + * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, + * for marking. + */ +static void mark(pointer a) { + pointer t, q, p; + + t = (pointer) 0; + p = a; +E2: setmark(p); + if(is_vector(p)) { + int i; + int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; + for(i=0; igc_verbose) { + putstr(sc, "gc..."); + } + + /* mark system globals */ + mark(sc->oblist); + mark(sc->global_env); + + /* mark current registers */ + mark(sc->args); + mark(sc->envir); + mark(sc->code); + dump_stack_mark(sc); + mark(sc->value); + mark(sc->inport); + mark(sc->save_inport); + mark(sc->outport); + mark(sc->loadport); + + /* Mark recent objects the interpreter doesn't know about yet. */ + mark(car(sc->sink)); + /* Mark any older stuff above nested C calls */ + mark(sc->c_nest); + + /* mark variables a, b */ + mark(a); + mark(b); + + /* garbage collect */ + clrmark(sc->NIL); + sc->fcells = 0; + sc->free_cell = sc->NIL; + /* free-list is kept sorted by address so as to maintain consecutive + ranges, if possible, for use with vectors. Here we scan the cells + (which are also kept sorted by address) downwards to build the + free-list in sorted order. + */ + for (i = sc->last_cell_seg; i >= 0; i--) { + p = sc->cell_seg[i] + CELL_SEGSIZE; + while (--p >= sc->cell_seg[i]) { + if (is_mark(p)) { + clrmark(p); + } else { + /* reclaim cell */ + if (typeflag(p) != 0) { + finalize_cell(sc, p); + typeflag(p) = 0; + car(p) = sc->NIL; + } + ++sc->fcells; + cdr(p) = sc->free_cell; + sc->free_cell = p; + } + } + } + + if (sc->gc_verbose) { + char msg[80]; + snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); + putstr(sc,msg); + } +} + +static void finalize_cell(scheme *sc, pointer a) { + if(is_string(a)) { + sc->free(strvalue(a)); + } else if(is_port(a)) { + if(a->_object._port->kind&port_file + && a->_object._port->rep.stdio.closeit) { + port_close(sc,a,port_input|port_output); + } + sc->free(a->_object._port); + } +} + +/* ========== Routines for Reading ========== */ + +static int file_push(scheme *sc, const char *fname) { + FILE *fin = NULL; + + if (sc->file_i == MAXFIL-1) + return 0; + fin=fopen(fname,"r"); + if(fin!=0) { + sc->file_i++; + sc->load_stack[sc->file_i].kind=port_file|port_input; + sc->load_stack[sc->file_i].rep.stdio.file=fin; + sc->load_stack[sc->file_i].rep.stdio.closeit=1; + sc->nesting_stack[sc->file_i]=0; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + +#if SHOW_ERROR_LINE + sc->load_stack[sc->file_i].rep.stdio.curr_line = 0; + if(fname) + sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0); +#endif + } + return fin!=0; +} + +static void file_pop(scheme *sc) { + if(sc->file_i != 0) { + sc->nesting=sc->nesting_stack[sc->file_i]; + port_close(sc,sc->loadport,port_input); + sc->file_i--; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + } +} + +static int file_interactive(scheme *sc) { + return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin + && sc->inport->_object._port->kind&port_file; +} + +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { + FILE *f; + char *rw; + port *pt; + if(prop==(port_input|port_output)) { + rw="a+"; + } else if(prop==port_output) { + rw="w"; + } else { + rw="r"; + } + f=fopen(fn,rw); + if(f==0) { + return 0; + } + pt=port_rep_from_file(sc,f,prop); + pt->rep.stdio.closeit=1; + +#if SHOW_ERROR_LINE + if(fn) + pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0); + + pt->rep.stdio.curr_line = 0; +#endif + return pt; +} + +static pointer port_from_filename(scheme *sc, const char *fn, int prop) { + port *pt; + pt=port_rep_from_filename(sc,fn,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_file(scheme *sc, FILE *f, int prop) +{ + port *pt; + + pt = (port *)sc->malloc(sizeof *pt); + if (pt == NULL) { + return NULL; + } + pt->kind = port_file | prop; + pt->rep.stdio.file = f; + pt->rep.stdio.closeit = 0; + return pt; +} + +static pointer port_from_file(scheme *sc, FILE *f, int prop) { + port *pt; + pt=port_rep_from_file(sc,f,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + pt->kind=port_string|prop; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=past_the_end; + return pt; +} + +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=port_rep_from_string(sc,start,past_the_end,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +#define BLOCK_SIZE 256 + +static port *port_rep_from_scratch(scheme *sc) { + port *pt; + char *start; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + start=sc->malloc(BLOCK_SIZE); + if(start==0) { + return 0; + } + memset(start,' ',BLOCK_SIZE-1); + start[BLOCK_SIZE-1]='\0'; + pt->kind=port_string|port_output|port_srfi6; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=start+BLOCK_SIZE-1; + return pt; +} + +static pointer port_from_scratch(scheme *sc) { + port *pt; + pt=port_rep_from_scratch(sc); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static void port_close(scheme *sc, pointer p, int flag) { + port *pt=p->_object._port; + pt->kind&=~flag; + if((pt->kind & (port_input|port_output))==0) { + if(pt->kind&port_file) { + +#if SHOW_ERROR_LINE + /* Cleanup is here so (close-*-port) functions could work too */ + pt->rep.stdio.curr_line = 0; + + if(pt->rep.stdio.filename) + sc->free(pt->rep.stdio.filename); +#endif + + fclose(pt->rep.stdio.file); + } + pt->kind=port_free; + } +} + +/* get new character from input file */ +static int inchar(scheme *sc) { + int c; + port *pt; + + pt = sc->inport->_object._port; + if(pt->kind & port_saw_EOF) + { return EOF; } + c = basic_inchar(pt); + if(c == EOF && sc->inport == sc->loadport) { + /* Instead, set port_saw_EOF */ + pt->kind |= port_saw_EOF; + + /* file_pop(sc); */ + return EOF; + /* NOTREACHED */ + } + return c; +} + +static int basic_inchar(port *pt) { + if(pt->kind & port_file) { + return fgetc(pt->rep.stdio.file); + } else { + if(*pt->rep.string.curr == 0 || + pt->rep.string.curr == pt->rep.string.past_the_end) { + return EOF; + } else { + return *pt->rep.string.curr++; + } + } +} + +/* back character to input buffer */ +static void backchar(scheme *sc, int c) { + port *pt; + if(c==EOF) return; + pt=sc->inport->_object._port; + if(pt->kind&port_file) { + ungetc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.start) { + --pt->rep.string.curr; + } + } +} + +static int realloc_port_string(scheme *sc, port *p) +{ + char *start=p->rep.string.start; + size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; + char *str=sc->malloc(new_size); + if(str) { + memset(str,' ',new_size-1); + str[new_size-1]='\0'; + strcpy(str,start); + p->rep.string.start=str; + p->rep.string.past_the_end=str+new_size-1; + p->rep.string.curr-=start-str; + sc->free(start); + return 1; + } else { + return 0; + } +} + +INTERFACE void putstr(scheme *sc, const char *s) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputs(s,pt->rep.stdio.file); + } else { + for(;*s;s++) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s; + } + } + } +} + +static void putchars(scheme *sc, const char *s, int len) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fwrite(s,1,len,pt->rep.stdio.file); + } else { + for(;len;len--) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s++; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s++; + } + } + } +} + +INTERFACE void putcharacter(scheme *sc, int c) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=c; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=c; + } + } +} + +/* read characters up to delimiter, but cater to character constants */ +static char *readstr_upto(scheme *sc, char *delim) { + char *p = sc->strbuff; + + while ((p - sc->strbuff < sizeof(sc->strbuff)) && + !is_one_of(delim, (*p++ = inchar(sc)))); + + if(p == sc->strbuff+2 && p[-2] == '\\') { + *p=0; + } else { + backchar(sc,p[-1]); + *--p = '\0'; + } + return sc->strbuff; +} + +/* read string expression "xxx...xxx" */ +static pointer readstrexp(scheme *sc) { + char *p = sc->strbuff; + int c; + int c1=0; + enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; + + for (;;) { + c=inchar(sc); + if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) { + return sc->F; + } + switch(state) { + case st_ok: + switch(c) { + case '\\': + state=st_bsl; + break; + case '"': + *p=0; + return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); + default: + *p++=c; + break; + } + break; + case st_bsl: + switch(c) { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + state=st_oct1; + c1=c-'0'; + break; + case 'x': + case 'X': + state=st_x1; + c1=0; + break; + case 'n': + *p++='\n'; + state=st_ok; + break; + case 't': + *p++='\t'; + state=st_ok; + break; + case 'r': + *p++='\r'; + state=st_ok; + break; + case '"': + *p++='"'; + state=st_ok; + break; + default: + *p++=c; + state=st_ok; + break; + } + break; + case st_x1: + case st_x2: + c=toupper(c); + if(c>='0' && c<='F') { + if(c<='9') { + c1=(c1<<4)+c-'0'; + } else { + c1=(c1<<4)+c-'A'+10; + } + if(state==st_x1) { + state=st_x2; + } else { + *p++=c1; + state=st_ok; + } + } else { + return sc->F; + } + break; + case st_oct1: + case st_oct2: + if (c < '0' || c > '7') + { + *p++=c1; + backchar(sc, c); + state=st_ok; + } + else + { + if (state==st_oct2 && c1 >= 32) + return sc->F; + + c1=(c1<<3)+(c-'0'); + + if (state == st_oct1) + state=st_oct2; + else + { + *p++=c1; + state=st_ok; + } + } + break; + + } + } +} + +/* check c is in chars */ +static INLINE int is_one_of(char *s, int c) { + if(c==EOF) return 1; + while (*s) + if (*s++ == c) + return (1); + return (0); +} + +/* skip white characters */ +static INLINE int skipspace(scheme *sc) { + int c = 0, curr_line = 0; + + do { + c=inchar(sc); +#if SHOW_ERROR_LINE + if(c=='\n') + curr_line++; +#endif + } while (isspace(c)); + +/* record it */ +#if SHOW_ERROR_LINE + if (sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line; +#endif + + if(c!=EOF) { + backchar(sc,c); + return 1; + } + else + { return EOF; } +} + +/* get token */ +static int token(scheme *sc) { + int c; + c = skipspace(sc); + if(c == EOF) { return (TOK_EOF); } + switch (c=inchar(sc)) { + case EOF: + return (TOK_EOF); + case '(': + return (TOK_LPAREN); + case ')': + return (TOK_RPAREN); + case '.': + c=inchar(sc); + if(is_one_of(" \n\t",c)) { + return (TOK_DOT); + } else { + backchar(sc,c); + backchar(sc,'.'); + return TOK_ATOM; + } + case '\'': + return (TOK_QUOTE); + case ';': + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + +#if SHOW_ERROR_LINE + if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line++; +#endif + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + case '"': + return (TOK_DQUOTE); + case BACKQUOTE: + return (TOK_BQUOTE); + case ',': + if ((c=inchar(sc)) == '@') { + return (TOK_ATMARK); + } else { + backchar(sc,c); + return (TOK_COMMA); + } + case '#': + c=inchar(sc); + if (c == '(') { + return (TOK_VEC); + } else if(c == '!') { + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + +#if SHOW_ERROR_LINE + if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line++; +#endif + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + } else { + backchar(sc,c); + if(is_one_of(" tfodxb\\",c)) { + return TOK_SHARP_CONST; + } else { + return (TOK_SHARP); + } + } + default: + backchar(sc,c); + return (TOK_ATOM); + } +} + +/* ========== Routines for Printing ========== */ +#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) + +static void printslashstring(scheme *sc, char *p, int len) { + int i; + unsigned char *s=(unsigned char*)p; + putcharacter(sc,'"'); + for ( i=0; iNIL) { + p = "()"; + } else if (l == sc->T) { + p = "#t"; + } else if (l == sc->F) { + p = "#f"; + } else if (l == sc->EOF_OBJ) { + p = "#"; + } else if (is_port(l)) { + p = "#"; + } else if (is_number(l)) { + p = sc->strbuff; + if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { + if(num_is_integer(l)) { + snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); + } else { + snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); + /* r5rs says there must be a '.' (unless 'e'?) */ + f = strcspn(p, ".e"); + if (p[f] == 0) { + p[f] = '.'; /* not found, so add '.0' at the end */ + p[f+1] = '0'; + p[f+2] = 0; + } + } + } else { + long v = ivalue(l); + if (f == 16) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lx", v); + else + snprintf(p, STRBUFFSIZE, "-%lx", -v); + } else if (f == 8) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lo", v); + else + snprintf(p, STRBUFFSIZE, "-%lo", -v); + } else if (f == 2) { + unsigned long b = (v < 0) ? -v : v; + p = &p[STRBUFFSIZE-1]; + *p = 0; + do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); + if (v < 0) *--p = '-'; + } + } + } else if (is_string(l)) { + if (!f) { + p = strvalue(l); + } else { /* Hack, uses the fact that printing is needed */ + *pp=sc->strbuff; + *plen=0; + printslashstring(sc, strvalue(l), strlength(l)); + return; + } + } else if (is_character(l)) { + int c=charvalue(l); + p = sc->strbuff; + if (!f) { + p[0]=c; + p[1]=0; + } else { + switch(c) { + case ' ': + p = "#\\space"; + break; + case '\n': + p = "#\\newline"; + break; + case '\r': + p = "#\\return"; + break; + case '\t': + p = "#\\tab"; + break; + default: +#if USE_ASCII_NAMES + if(c==127) { + p = "#\\del"; + break; + } else if(c<32) { + snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]); + break; + } +#else + if(c<32) { + snprintf(p,STRBUFFSIZE,"#\\x%x",c); + break; + } +#endif + snprintf(p,STRBUFFSIZE,"#\\%c",c); + break; + } + } + } else if (is_symbol(l)) { + p = symname(l); + } else if (is_proc(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); + } else if (is_macro(l)) { + p = "#"; + } else if (is_closure(l)) { + p = "#"; + } else if (is_promise(l)) { + p = "#"; + } else if (is_foreign(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#", procnum(l)); + } else if (is_continuation(l)) { + p = "#"; + } else { + p = "#"; + } + *pp=p; + *plen=strlen(p); +} +/* ========== Routines for Evaluation Cycle ========== */ + +/* make closure. c is code. e is environment */ +static pointer mk_closure(scheme *sc, pointer c, pointer e) { + pointer x = get_cell(sc, c, e); + + typeflag(x) = T_CLOSURE; + car(x) = c; + cdr(x) = e; + return (x); +} + +/* make continuation. */ +static pointer mk_continuation(scheme *sc, pointer d) { + pointer x = get_cell(sc, sc->NIL, d); + + typeflag(x) = T_CONTINUATION; + cont_dump(x) = d; + return (x); +} + +static pointer list_star(scheme *sc, pointer d) { + pointer p, q; + if(cdr(d)==sc->NIL) { + return car(d); + } + p=cons(sc,car(d),cdr(d)); + q=p; + while(cdr(cdr(p))!=sc->NIL) { + d=cons(sc,car(p),cdr(p)); + if(cdr(cdr(p))!=sc->NIL) { + p=cdr(d); + } + } + cdr(p)=car(cdr(p)); + return q; +} + +/* reverse list -- produce new list */ +static pointer reverse(scheme *sc, pointer a) { +/* a must be checked by gc */ + pointer p = sc->NIL; + + for ( ; is_pair(a); a = cdr(a)) { + p = cons(sc, car(a), p); + } + return (p); +} + +/* reverse list --- in-place */ +static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { + pointer p = list, result = term, q; + + while (p != sc->NIL) { + q = cdr(p); + cdr(p) = result; + result = p; + p = q; + } + return (result); +} + +/* append list -- produce new list (in reverse order) */ +static pointer revappend(scheme *sc, pointer a, pointer b) { + pointer result = a; + pointer p = b; + + while (is_pair(p)) { + result = cons(sc, car(p), result); + p = cdr(p); + } + + if (p == sc->NIL) { + return result; + } + + return sc->F; /* signal an error */ +} + +/* equivalence of atoms */ +int eqv(pointer a, pointer b) { + if (is_string(a)) { + if (is_string(b)) + return (strvalue(a) == strvalue(b)); + else + return (0); + } else if (is_number(a)) { + if (is_number(b)) { + if (num_is_integer(a) == num_is_integer(b)) + return num_eq(nvalue(a),nvalue(b)); + } + return (0); + } else if (is_character(a)) { + if (is_character(b)) + return charvalue(a)==charvalue(b); + else + return (0); + } else if (is_port(a)) { + if (is_port(b)) + return a==b; + else + return (0); + } else if (is_proc(a)) { + if (is_proc(b)) + return procnum(a)==procnum(b); + else + return (0); + } else { + return (a == b); + } +} + +/* true or false value macro */ +/* () is #t in R5RS */ +#define is_true(p) ((p) != sc->F) +#define is_false(p) ((p) == sc->F) + +/* ========== Environment implementation ========== */ + +#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) + +static int hash_fn(const char *key, int table_size) +{ + unsigned int hashed = 0; + const char *c; + int bits_per_int = sizeof(unsigned int)*8; + + for (c = key; *c; c++) { + /* letters have about 5 bits in them */ + hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); + hashed ^= *c; + } + return hashed % table_size; +} +#endif + +#ifndef USE_ALIST_ENV + +/* + * In this implementation, each frame of the environment may be + * a hash table: a vector of alists hashed by variable name. + * In practice, we use a vector only for the initial frame; + * subsequent frames are too small and transient for the lookup + * speed to out-weigh the cost of making a new vector. + */ + +static void new_frame_in_env(scheme *sc, pointer old_env) +{ + pointer new_frame; + + /* The interaction-environment has about 300 variables in it. */ + if (old_env == sc->NIL) { + new_frame = mk_vector(sc, 461); + } else { + new_frame = sc->NIL; + } + + sc->envir = immutable_cons(sc, new_frame, old_env); + setenvironment(sc->envir); +} + +static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, + pointer variable, pointer value) +{ + pointer slot = immutable_cons(sc, variable, value); + + if (is_vector(car(env))) { + int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); + + set_vector_elem(car(env), location, + immutable_cons(sc, slot, vector_elem(car(env), location))); + } else { + car(env) = immutable_cons(sc, slot, car(env)); + } +} + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + pointer x,y; + int location; + + for (x = env; x != sc->NIL; x = cdr(x)) { + if (is_vector(car(x))) { + location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); + y = vector_elem(car(x), location); + } else { + y = car(x); + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (caar(y) == hdl) { + break; + } + } + if (y != sc->NIL) { + break; + } + if(!all) { + return sc->NIL; + } + } + if (x != sc->NIL) { + return car(y); + } + return sc->NIL; +} + +#else /* USE_ALIST_ENV */ + +static INLINE void new_frame_in_env(scheme *sc, pointer old_env) +{ + sc->envir = immutable_cons(sc, sc->NIL, old_env); + setenvironment(sc->envir); +} + +static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, + pointer variable, pointer value) +{ + car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); +} + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + pointer x,y; + for (x = env; x != sc->NIL; x = cdr(x)) { + for (y = car(x); y != sc->NIL; y = cdr(y)) { + if (caar(y) == hdl) { + break; + } + } + if (y != sc->NIL) { + break; + } + if(!all) { + return sc->NIL; + } + } + if (x != sc->NIL) { + return car(y); + } + return sc->NIL; +} + +#endif /* USE_ALIST_ENV else */ + +static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) +{ + new_slot_spec_in_env(sc, sc->envir, variable, value); +} + +static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) +{ + cdr(slot) = value; +} + +static INLINE pointer slot_value_in_env(pointer slot) +{ + return cdr(slot); +} + +/* ========== Evaluation Cycle ========== */ + + +static pointer _Error_1(scheme *sc, const char *s, pointer a) { + const char *str = s; +#if USE_ERROR_HOOK + pointer x; + pointer hdl=sc->ERROR_HOOK; +#endif + +#if SHOW_ERROR_LINE + char sbuf[STRBUFFSIZE]; + + /* make sure error is not in REPL */ + if (sc->load_stack[sc->file_i].kind & port_file && + sc->load_stack[sc->file_i].rep.stdio.file != stdin) { + int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line; + const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename; + + /* should never happen */ + if(!fname) fname = ""; + + /* we started from 0 */ + ln++; + snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s); + + str = (const char*)sbuf; + } +#endif + +#if USE_ERROR_HOOK + x=find_slot_in_env(sc,sc->envir,hdl,1); + if (x != sc->NIL) { + if(a!=0) { + sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); + } else { + sc->code = sc->NIL; + } + sc->code = cons(sc, mk_string(sc, str), sc->code); + setimmutable(car(sc->code)); + sc->code = cons(sc, slot_value_in_env(x), sc->code); + sc->op = (int)OP_EVAL; + return sc->T; + } +#endif + + if(a!=0) { + sc->args = cons(sc, (a), sc->NIL); + } else { + sc->args = sc->NIL; + } + sc->args = cons(sc, mk_string(sc, str), sc->args); + setimmutable(car(sc->args)); + sc->op = (int)OP_ERR0; + return sc->T; +} +#define Error_1(sc,s, a) return _Error_1(sc,s,a) +#define Error_0(sc,s) return _Error_1(sc,s,0) + +/* Too small to turn into function */ +# define BEGIN do { +# define END } while (0) +#define s_goto(sc,a) BEGIN \ + sc->op = (int)(a); \ + return sc->T; END + +#define s_return(sc,a) return _s_return(sc,a) + +#ifndef USE_SCHEME_STACK + +/* this structure holds all the interpreter's registers */ +struct dump_stack_frame { + enum scheme_opcodes op; + pointer args; + pointer envir; + pointer code; +}; + +#define STACK_GROWTH 3 + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) +{ + int nframes = (int)sc->dump; + struct dump_stack_frame *next_frame; + + /* enough room for the next frame? */ + if (nframes >= sc->dump_size) { + sc->dump_size += STACK_GROWTH; + /* alas there is no sc->realloc */ + sc->dump_base = realloc(sc->dump_base, + sizeof(struct dump_stack_frame) * sc->dump_size); + } + next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; + next_frame->op = op; + next_frame->args = args; + next_frame->envir = sc->envir; + next_frame->code = code; + sc->dump = (pointer)(nframes+1); +} + +static pointer _s_return(scheme *sc, pointer a) +{ + int nframes = (int)sc->dump; + struct dump_stack_frame *frame; + + sc->value = (a); + if (nframes <= 0) { + return sc->NIL; + } + nframes--; + frame = (struct dump_stack_frame *)sc->dump_base + nframes; + sc->op = frame->op; + sc->args = frame->args; + sc->envir = frame->envir; + sc->code = frame->code; + sc->dump = (pointer)nframes; + return sc->T; +} + +static INLINE void dump_stack_reset(scheme *sc) +{ + /* in this implementation, sc->dump is the number of frames on the stack */ + sc->dump = (pointer)0; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + sc->dump_size = 0; + sc->dump_base = NULL; + dump_stack_reset(sc); +} + +static void dump_stack_free(scheme *sc) +{ + free(sc->dump_base); + sc->dump_base = NULL; + sc->dump = (pointer)0; + sc->dump_size = 0; +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + int nframes = (int)sc->dump; + int i; + for(i=0; idump_base + i; + mark(frame->args); + mark(frame->envir); + mark(frame->code); + } +} + +#else + +static INLINE void dump_stack_reset(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + dump_stack_reset(sc); +} + +static void dump_stack_free(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static pointer _s_return(scheme *sc, pointer a) { + sc->value = (a); + if(sc->dump==sc->NIL) return sc->NIL; + sc->op = ivalue(car(sc->dump)); + sc->args = cadr(sc->dump); + sc->envir = caddr(sc->dump); + sc->code = cadddr(sc->dump); + sc->dump = cddddr(sc->dump); + return sc->T; +} + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { + sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); + sc->dump = cons(sc, (args), sc->dump); + sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + mark(sc->dump); +} +#endif + +#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) + +static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_LOAD: /* load */ + if(file_interactive(sc)) { + fprintf(sc->outport->_object._port->rep.stdio.file, + "Loading %s\n", strvalue(car(sc->args))); + } + if (!file_push(sc,strvalue(car(sc->args)))) { + Error_1(sc,"unable to open", car(sc->args)); + } + else + { + sc->args = mk_integer(sc,sc->file_i); + s_goto(sc,OP_T0LVL); + } + + case OP_T0LVL: /* top level */ + /* If we reached the end of file, this loop is done. */ + if(sc->loadport->_object._port->kind & port_saw_EOF) + { + if(sc->file_i == 0) + { + sc->args=sc->NIL; + s_goto(sc,OP_QUIT); + } + else + { + file_pop(sc); + s_return(sc,sc->value); + } + /* NOTREACHED */ + } + + /* If interactive, be nice to user. */ + if(file_interactive(sc)) + { + sc->envir = sc->global_env; + dump_stack_reset(sc); + putstr(sc,"\n"); + putstr(sc,prompt); + } + + /* Set up another iteration of REPL */ + sc->nesting=0; + sc->save_inport=sc->inport; + sc->inport = sc->loadport; + s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); + s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); + s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); + s_goto(sc,OP_READ_INTERNAL); + + case OP_T1LVL: /* top level */ + sc->code = sc->value; + sc->inport=sc->save_inport; + s_goto(sc,OP_EVAL); + + case OP_READ_INTERNAL: /* internal read */ + sc->tok = token(sc); + if(sc->tok==TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + s_goto(sc,OP_RDSEXPR); + + case OP_GENSYM: + s_return(sc, gensym(sc)); + + case OP_VALUEPRINT: /* print evaluation result */ + /* OP_VALUEPRINT is always pushed, because when changing from + non-interactive to interactive mode, it needs to be + already on the stack */ + if(sc->tracing) { + putstr(sc,"\nGives: "); + } + if(file_interactive(sc)) { + sc->print_flag = 1; + sc->args = sc->value; + s_goto(sc,OP_P0LIST); + } else { + s_return(sc,sc->value); + } + + case OP_EVAL: /* main part of evaluation */ +#if USE_TRACING + if(sc->tracing) { + /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ + s_save(sc,OP_REAL_EVAL,sc->args,sc->code); + sc->args=sc->code; + putstr(sc,"\nEval: "); + s_goto(sc,OP_P0LIST); + } + /* fall through */ + case OP_REAL_EVAL: +#endif + if (is_symbol(sc->code)) { /* symbol */ + x=find_slot_in_env(sc,sc->envir,sc->code,1); + if (x != sc->NIL) { + s_return(sc,slot_value_in_env(x)); + } else { + Error_1(sc,"eval: unbound variable:", sc->code); + } + } else if (is_pair(sc->code)) { + if (is_syntax(x = car(sc->code))) { /* SYNTAX */ + sc->code = cdr(sc->code); + s_goto(sc,syntaxnum(x)); + } else {/* first, eval top element and eval arguments */ + s_save(sc,OP_E0ARGS, sc->NIL, sc->code); + /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + } else { + s_return(sc,sc->code); + } + + case OP_E0ARGS: /* eval arguments */ + if (is_macro(sc->value)) { /* macro expansion */ + s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); + sc->args = cons(sc,sc->code, sc->NIL); + sc->code = sc->value; + s_goto(sc,OP_APPLY); + } else { + sc->code = cdr(sc->code); + s_goto(sc,OP_E1ARGS); + } + + case OP_E1ARGS: /* eval arguments */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); + sc->code = car(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_APPLY); + } + +#if USE_TRACING + case OP_TRACING: { + int tr=sc->tracing; + sc->tracing=ivalue(car(sc->args)); + s_return(sc,mk_integer(sc,tr)); + } +#endif + + case OP_APPLY: /* apply 'code' to 'args' */ +#if USE_TRACING + if(sc->tracing) { + s_save(sc,OP_REAL_APPLY,sc->args,sc->code); + sc->print_flag = 1; + /* sc->args=cons(sc,sc->code,sc->args);*/ + putstr(sc,"\nApply to: "); + s_goto(sc,OP_P0LIST); + } + /* fall through */ + case OP_REAL_APPLY: +#endif + if (is_proc(sc->code)) { + s_goto(sc,procnum(sc->code)); /* PROCEDURE */ + } else if (is_foreign(sc->code)) + { + /* Keep nested calls from GC'ing the arglist */ + push_recent_alloc(sc,sc->args,sc->NIL); + x=sc->code->_object._ff(sc,sc->args); + s_return(sc,x); + } else if (is_closure(sc->code) || is_macro(sc->code) + || is_promise(sc->code)) { /* CLOSURE */ + /* Should not accept promise */ + /* make environment */ + new_frame_in_env(sc, closure_env(sc->code)); + for (x = car(closure_code(sc->code)), y = sc->args; + is_pair(x); x = cdr(x), y = cdr(y)) { + if (y == sc->NIL) { + Error_0(sc,"not enough arguments"); + } else { + new_slot_in_env(sc, car(x), car(y)); + } + } + if (x == sc->NIL) { + /*-- + * if (y != sc->NIL) { + * Error_0(sc,"too many arguments"); + * } + */ + } else if (is_symbol(x)) + new_slot_in_env(sc, x, y); + else { + Error_1(sc,"syntax error in closure: not a symbol:", x); + } + sc->code = cdr(closure_code(sc->code)); + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + } else if (is_continuation(sc->code)) { /* CONTINUATION */ + sc->dump = cont_dump(sc->code); + s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); + } else { + Error_0(sc,"illegal function"); + } + + case OP_DOMACRO: /* do macro */ + sc->code = sc->value; + s_goto(sc,OP_EVAL); + +#if 1 + case OP_LAMBDA: /* lambda */ + /* If the hook is defined, apply it to sc->code, otherwise + set sc->value fall thru */ + { + pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); + if(f==sc->NIL) { + sc->value = sc->code; + /* Fallthru */ + } else { + s_save(sc,OP_LAMBDA1,sc->args,sc->code); + sc->args=cons(sc,sc->code,sc->NIL); + sc->code=slot_value_in_env(f); + s_goto(sc,OP_APPLY); + } + } + + case OP_LAMBDA1: + s_return(sc,mk_closure(sc, sc->value, sc->envir)); + +#else + case OP_LAMBDA: /* lambda */ + s_return(sc,mk_closure(sc, sc->code, sc->envir)); + +#endif + + case OP_MKCLOSURE: /* make-closure */ + x=car(sc->args); + if(car(x)==sc->LAMBDA) { + x=cdr(x); + } + if(cdr(sc->args)==sc->NIL) { + y=sc->envir; + } else { + y=cadr(sc->args); + } + s_return(sc,mk_closure(sc, x, y)); + + case OP_QUOTE: /* quote */ + s_return(sc,car(sc->code)); + + case OP_DEF0: /* define */ + if(is_immutable(car(sc->code))) + Error_1(sc,"define: unable to alter immutable", car(sc->code)); + + if (is_pair(car(sc->code))) { + x = caar(sc->code); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_DEF1, sc->NIL, x); + s_goto(sc,OP_EVAL); + + case OP_DEF1: /* define */ + x=find_slot_in_env(sc,sc->envir,sc->code,0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_in_env(sc, sc->code, sc->value); + } + s_return(sc,sc->code); + + + case OP_DEFP: /* defined? */ + x=sc->envir; + if(cdr(sc->args)!=sc->NIL) { + x=cadr(sc->args); + } + s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); + + case OP_SET0: /* set! */ + if(is_immutable(car(sc->code))) + Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); + s_save(sc,OP_SET1, sc->NIL, car(sc->code)); + sc->code = cadr(sc->code); + s_goto(sc,OP_EVAL); + + case OP_SET1: /* set! */ + y=find_slot_in_env(sc,sc->envir,sc->code,1); + if (y != sc->NIL) { + set_slot_in_env(sc, y, sc->value); + s_return(sc,sc->value); + } else { + Error_1(sc,"set!: unbound variable:", sc->code); + } + + + case OP_BEGIN: /* begin */ + if (!is_pair(sc->code)) { + s_return(sc,sc->code); + } + if (cdr(sc->code) != sc->NIL) { + s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); + } + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_IF0: /* if */ + s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_IF1: /* if */ + if (is_true(sc->value)) + sc->code = car(sc->code); + else + sc->code = cadr(sc->code); /* (if #f 1) ==> () because + * car(sc->NIL) = sc->NIL */ + s_goto(sc,OP_EVAL); + + case OP_LET0: /* let */ + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); + s_goto(sc,OP_LET1); + + case OP_LET1: /* let (calculate parameters) */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in let :", + car(sc->code)); + } + s_save(sc,OP_LET1, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_LET2); + } + + case OP_LET2: /* let */ + new_frame_in_env(sc, sc->envir); + for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; + y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + if (is_symbol(car(sc->code))) { /* named let */ + for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { + if (!is_pair(x)) + Error_1(sc, "Bad syntax of binding in let :", x); + if (!is_list(sc, car(x))) + Error_1(sc, "Bad syntax of binding in let :", car(x)); + sc->args = cons(sc, caar(x), sc->args); + } + x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); + new_slot_in_env(sc, car(sc->code), x); + sc->code = cddr(sc->code); + sc->args = sc->NIL; + } else { + sc->code = cdr(sc->code); + sc->args = sc->NIL; + } + s_goto(sc,OP_BEGIN); + + case OP_LET0AST: /* let* */ + if (car(sc->code) == sc->NIL) { + new_frame_in_env(sc, sc->envir); + sc->code = cdr(sc->code); + s_goto(sc,OP_BEGIN); + } + if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { + Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code)); + } + s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); + sc->code = cadaar(sc->code); + s_goto(sc,OP_EVAL); + + case OP_LET1AST: /* let* (make new frame) */ + new_frame_in_env(sc, sc->envir); + s_goto(sc,OP_LET2AST); + + case OP_LET2AST: /* let* (calculate parameters) */ + new_slot_in_env(sc, caar(sc->code), sc->value); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_LET2AST, sc->args, sc->code); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->code = sc->args; + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + } + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_LET0REC: /* letrec */ + new_frame_in_env(sc, sc->envir); + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = car(sc->code); + s_goto(sc,OP_LET1REC); + + case OP_LET1REC: /* letrec (calculate parameters) */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in letrec :", + car(sc->code)); + } + s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_LET2REC); + } + + case OP_LET2REC: /* letrec */ + for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + sc->code = cdr(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + + case OP_COND0: /* cond */ + if (!is_pair(sc->code)) { + Error_0(sc,"syntax error in cond"); + } + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_goto(sc,OP_EVAL); + + case OP_COND1: /* cond */ + if (is_true(sc->value)) { + if ((sc->code = cdar(sc->code)) == sc->NIL) { + s_return(sc,sc->value); + } + if(!sc->code || car(sc->code)==sc->FEED_TO) { + if(!is_pair(cdr(sc->code))) { + Error_0(sc,"syntax error in cond"); + } + x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); + sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); + s_goto(sc,OP_EVAL); + } + s_goto(sc,OP_BEGIN); + } else { + if ((sc->code = cdr(sc->code)) == sc->NIL) { + s_return(sc,sc->NIL); + } else { + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_goto(sc,OP_EVAL); + } + } + + case OP_DELAY: /* delay */ + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return(sc,x); + + case OP_AND0: /* and */ + if (sc->code == sc->NIL) { + s_return(sc,sc->T); + } + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_AND1: /* and */ + if (is_false(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + + case OP_OR0: /* or */ + if (sc->code == sc->NIL) { + s_return(sc,sc->F); + } + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_OR1: /* or */ + if (is_true(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + + case OP_C0STREAM: /* cons-stream */ + s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_C1STREAM: /* cons-stream */ + sc->args = sc->value; /* save sc->value to register sc->args for gc */ + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return(sc,cons(sc, sc->args, x)); + + case OP_MACRO0: /* macro */ + if (is_pair(car(sc->code))) { + x = caar(sc->code); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_MACRO1, sc->NIL, x); + s_goto(sc,OP_EVAL); + + case OP_MACRO1: /* macro */ + typeflag(sc->value) = T_MACRO; + x = find_slot_in_env(sc, sc->envir, sc->code, 0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_in_env(sc, sc->code, sc->value); + } + s_return(sc,sc->code); + + case OP_CASE0: /* case */ + s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_CASE1: /* case */ + for (x = sc->code; x != sc->NIL; x = cdr(x)) { + if (!is_pair(y = caar(x))) { + break; + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (eqv(car(y), sc->value)) { + break; + } + } + if (y != sc->NIL) { + break; + } + } + if (x != sc->NIL) { + if (is_pair(caar(x))) { + sc->code = cdar(x); + s_goto(sc,OP_BEGIN); + } else {/* else */ + s_save(sc,OP_CASE2, sc->NIL, cdar(x)); + sc->code = caar(x); + s_goto(sc,OP_EVAL); + } + } else { + s_return(sc,sc->NIL); + } + + case OP_CASE2: /* case */ + if (is_true(sc->value)) { + s_goto(sc,OP_BEGIN); + } else { + s_return(sc,sc->NIL); + } + + case OP_PAPPLY: /* apply */ + sc->code = car(sc->args); + sc->args = list_star(sc,cdr(sc->args)); + /*sc->args = cadr(sc->args);*/ + s_goto(sc,OP_APPLY); + + case OP_PEVAL: /* eval */ + if(cdr(sc->args)!=sc->NIL) { + sc->envir=cadr(sc->args); + } + sc->code = car(sc->args); + s_goto(sc,OP_EVAL); + + case OP_CONTINUATION: /* call-with-current-continuation */ + sc->code = car(sc->args); + sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); + s_goto(sc,OP_APPLY); + + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { + pointer x; + num v; +#if USE_MATH + double dd; +#endif + + switch (op) { +#if USE_MATH + case OP_INEX2EX: /* inexact->exact */ + x=car(sc->args); + if(num_is_integer(x)) { + s_return(sc,x); + } else if(modf(rvalue_unchecked(x),&dd)==0.0) { + s_return(sc,mk_integer(sc,ivalue(x))); + } else { + Error_1(sc,"inexact->exact: not integral:",x); + } + + case OP_EXP: + x=car(sc->args); + s_return(sc, mk_real(sc, exp(rvalue(x)))); + + case OP_LOG: + x=car(sc->args); + s_return(sc, mk_real(sc, log(rvalue(x)))); + + case OP_SIN: + x=car(sc->args); + s_return(sc, mk_real(sc, sin(rvalue(x)))); + + case OP_COS: + x=car(sc->args); + s_return(sc, mk_real(sc, cos(rvalue(x)))); + + case OP_TAN: + x=car(sc->args); + s_return(sc, mk_real(sc, tan(rvalue(x)))); + + case OP_ASIN: + x=car(sc->args); + s_return(sc, mk_real(sc, asin(rvalue(x)))); + + case OP_ACOS: + x=car(sc->args); + s_return(sc, mk_real(sc, acos(rvalue(x)))); + + case OP_ATAN: + x=car(sc->args); + if(cdr(sc->args)==sc->NIL) { + s_return(sc, mk_real(sc, atan(rvalue(x)))); + } else { + pointer y=cadr(sc->args); + s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); + } + + case OP_SQRT: + x=car(sc->args); + s_return(sc, mk_real(sc, sqrt(rvalue(x)))); + + case OP_EXPT: { + double result; + int real_result=1; + pointer y=cadr(sc->args); + x=car(sc->args); + if (num_is_integer(x) && num_is_integer(y)) + real_result=0; + /* This 'if' is an R5RS compatibility fix. */ + /* NOTE: Remove this 'if' fix for R6RS. */ + if (rvalue(x) == 0 && rvalue(y) < 0) { + result = 0.0; + } else { + result = pow(rvalue(x),rvalue(y)); + } + /* Before returning integer result make sure we can. */ + /* If the test fails, result is too big for integer. */ + if (!real_result) + { + long result_as_long = (long)result; + if (result != (double)result_as_long) + real_result = 1; + } + if (real_result) { + s_return(sc, mk_real(sc, result)); + } else { + s_return(sc, mk_integer(sc, result)); + } + } + + case OP_FLOOR: + x=car(sc->args); + s_return(sc, mk_real(sc, floor(rvalue(x)))); + + case OP_CEILING: + x=car(sc->args); + s_return(sc, mk_real(sc, ceil(rvalue(x)))); + + case OP_TRUNCATE : { + double rvalue_of_x ; + x=car(sc->args); + rvalue_of_x = rvalue(x) ; + if (rvalue_of_x > 0) { + s_return(sc, mk_real(sc, floor(rvalue_of_x))); + } else { + s_return(sc, mk_real(sc, ceil(rvalue_of_x))); + } + } + + case OP_ROUND: + x=car(sc->args); + if (num_is_integer(x)) + s_return(sc, x); + s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); +#endif + + case OP_ADD: /* + */ + v=num_zero; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_add(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_MUL: /* * */ + v=num_one; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_mul(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_SUB: /* - */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_zero; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + v=num_sub(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_DIV: /* / */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (!is_zero_double(rvalue(car(x)))) + v=num_div(v,nvalue(car(x))); + else { + Error_0(sc,"/: division by zero"); + } + } + s_return(sc,mk_number(sc, v)); + + case OP_INTDIV: /* quotient */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (ivalue(car(x)) != 0) + v=num_intdiv(v,nvalue(car(x))); + else { + Error_0(sc,"quotient: division by zero"); + } + } + s_return(sc,mk_number(sc, v)); + + case OP_REM: /* remainder */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_rem(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"remainder: division by zero"); + } + s_return(sc,mk_number(sc, v)); + + case OP_MOD: /* modulo */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_mod(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"modulo: division by zero"); + } + s_return(sc,mk_number(sc, v)); + + case OP_CAR: /* car */ + s_return(sc,caar(sc->args)); + + case OP_CDR: /* cdr */ + s_return(sc,cdar(sc->args)); + + case OP_CONS: /* cons */ + cdr(sc->args) = cadr(sc->args); + s_return(sc,sc->args); + + case OP_SETCAR: /* set-car! */ + if(!is_immutable(car(sc->args))) { + caar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-car!: unable to alter immutable pair"); + } + + case OP_SETCDR: /* set-cdr! */ + if(!is_immutable(car(sc->args))) { + cdar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-cdr!: unable to alter immutable pair"); + } + + case OP_CHAR2INT: { /* char->integer */ + char c; + c=(char)ivalue(car(sc->args)); + s_return(sc,mk_integer(sc,(unsigned char)c)); + } + + case OP_INT2CHAR: { /* integer->char */ + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_CHARUPCASE: { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=toupper(c); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_CHARDNCASE: { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=tolower(c); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_STR2SYM: /* string->symbol */ + s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); + + case OP_STR2ATOM: /* string->atom */ { + char *s=strvalue(car(sc->args)); + long pf = 0; + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "string->atom: bad base:", cadr(sc->args)); + } else if(*s=='#') /* no use of base! */ { + s_return(sc, mk_sharp_const(sc, s+1)); + } else { + if (pf == 0 || pf == 10) { + s_return(sc, mk_atom(sc, s)); + } + else { + char *ep; + long iv = strtol(s,&ep,(int )pf); + if (*ep == 0) { + s_return(sc, mk_integer(sc, iv)); + } + else { + s_return(sc, sc->F); + } + } + } + } + + case OP_SYM2STR: /* symbol->string */ + x=mk_string(sc,symname(car(sc->args))); + setimmutable(x); + s_return(sc,x); + + case OP_ATOM2STR: /* atom->string */ { + long pf = 0; + x=car(sc->args); + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "atom->string: bad base:", cadr(sc->args)); + } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { + char *p; + int len; + atom2str(sc,x,(int )pf,&p,&len); + s_return(sc,mk_counted_string(sc,p,len)); + } else { + Error_1(sc, "atom->string: not an atom:", x); + } + } + + case OP_MKSTRING: { /* make-string */ + int fill=' '; + int len; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=charvalue(cadr(sc->args)); + } + s_return(sc,mk_empty_string(sc,len,(char)fill)); + } + + case OP_STRLEN: /* string-length */ + s_return(sc,mk_integer(sc,strlength(car(sc->args)))); + + case OP_STRREF: { /* string-ref */ + char *str; + int index; + + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + + if(index>=strlength(car(sc->args))) { + Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); + } + + s_return(sc,mk_character(sc,((unsigned char*)str)[index])); + } + + case OP_STRSET: { /* string-set! */ + char *str; + int index; + int c; + + if(is_immutable(car(sc->args))) { + Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); + } + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + if(index>=strlength(car(sc->args))) { + Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); + } + + c=charvalue(caddr(sc->args)); + + str[index]=(char)c; + s_return(sc,car(sc->args)); + } + + case OP_STRAPPEND: { /* string-append */ + /* in 1.29 string-append was in Scheme in init.scm but was too slow */ + int len = 0; + pointer newstr; + char *pos; + + /* compute needed length for new string */ + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + len += strlength(car(x)); + } + newstr = mk_empty_string(sc, len, ' '); + /* store the contents of the argument strings into the new string */ + for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; + pos += strlength(car(x)), x = cdr(x)) { + memcpy(pos, strvalue(car(x)), strlength(car(x))); + } + s_return(sc, newstr); + } + + case OP_SUBSTR: { /* substring */ + char *str; + int index0; + int index1; + int len; + + str=strvalue(car(sc->args)); + + index0=ivalue(cadr(sc->args)); + + if(index0>strlength(car(sc->args))) { + Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); + } + + if(cddr(sc->args)!=sc->NIL) { + index1=ivalue(caddr(sc->args)); + if(index1>strlength(car(sc->args)) || index1args)); + } + } else { + index1=strlength(car(sc->args)); + } + + len=index1-index0; + x=mk_empty_string(sc,len,' '); + memcpy(strvalue(x),str+index0,len); + strvalue(x)[len]=0; + + s_return(sc,x); + } + + case OP_VECTOR: { /* vector */ + int i; + pointer vec; + int len=list_length(sc,sc->args); + if(len<0) { + Error_1(sc,"vector: not a proper list:",sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { + set_vector_elem(vec,i,car(x)); + } + s_return(sc,vec); + } + + case OP_MKVECTOR: { /* make-vector */ + pointer fill=sc->NIL; + int len; + pointer vec; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=cadr(sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + if(fill!=sc->NIL) { + fill_vector(vec,fill); + } + s_return(sc,vec); + } + + case OP_VECLEN: /* vector-length */ + s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); + + case OP_VECREF: { /* vector-ref */ + int index; + + index=ivalue(cadr(sc->args)); + + if(index>=ivalue(car(sc->args))) { + Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); + } + + s_return(sc,vector_elem(car(sc->args),index)); + } + + case OP_VECSET: { /* vector-set! */ + int index; + + if(is_immutable(car(sc->args))) { + Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); + } + + index=ivalue(cadr(sc->args)); + if(index>=ivalue(car(sc->args))) { + Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); + } + + set_vector_elem(car(sc->args),index,caddr(sc->args)); + s_return(sc,car(sc->args)); + } + + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static int is_list(scheme *sc, pointer a) +{ return list_length(sc,a) >= 0; } + +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +int list_length(scheme *sc, pointer a) { + int i=0; + pointer slow, fast; + + slow = fast = a; + while (1) + { + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + fast = cdr(fast); + ++i; + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + ++i; + fast = cdr(fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr(slow); + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + +static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { + pointer x; + num v; + int (*comp_func)(num,num)=0; + + switch (op) { + case OP_NOT: /* not */ + s_retbool(is_false(car(sc->args))); + case OP_BOOLP: /* boolean? */ + s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); + case OP_EOFOBJP: /* boolean? */ + s_retbool(car(sc->args) == sc->EOF_OBJ); + case OP_NULLP: /* null? */ + s_retbool(car(sc->args) == sc->NIL); + case OP_NUMEQ: /* = */ + case OP_LESS: /* < */ + case OP_GRE: /* > */ + case OP_LEQ: /* <= */ + case OP_GEQ: /* >= */ + switch(op) { + case OP_NUMEQ: comp_func=num_eq; break; + case OP_LESS: comp_func=num_lt; break; + case OP_GRE: comp_func=num_gt; break; + case OP_LEQ: comp_func=num_le; break; + case OP_GEQ: comp_func=num_ge; break; + } + x=sc->args; + v=nvalue(car(x)); + x=cdr(x); + + for (; x != sc->NIL; x = cdr(x)) { + if(!comp_func(v,nvalue(car(x)))) { + s_retbool(0); + } + v=nvalue(car(x)); + } + s_retbool(1); + case OP_SYMBOLP: /* symbol? */ + s_retbool(is_symbol(car(sc->args))); + case OP_NUMBERP: /* number? */ + s_retbool(is_number(car(sc->args))); + case OP_STRINGP: /* string? */ + s_retbool(is_string(car(sc->args))); + case OP_INTEGERP: /* integer? */ + s_retbool(is_integer(car(sc->args))); + case OP_REALP: /* real? */ + s_retbool(is_number(car(sc->args))); /* All numbers are real */ + case OP_CHARP: /* char? */ + s_retbool(is_character(car(sc->args))); +#if USE_CHAR_CLASSIFIERS + case OP_CHARAP: /* char-alphabetic? */ + s_retbool(Cisalpha(ivalue(car(sc->args)))); + case OP_CHARNP: /* char-numeric? */ + s_retbool(Cisdigit(ivalue(car(sc->args)))); + case OP_CHARWP: /* char-whitespace? */ + s_retbool(Cisspace(ivalue(car(sc->args)))); + case OP_CHARUP: /* char-upper-case? */ + s_retbool(Cisupper(ivalue(car(sc->args)))); + case OP_CHARLP: /* char-lower-case? */ + s_retbool(Cislower(ivalue(car(sc->args)))); +#endif + case OP_PORTP: /* port? */ + s_retbool(is_port(car(sc->args))); + case OP_INPORTP: /* input-port? */ + s_retbool(is_inport(car(sc->args))); + case OP_OUTPORTP: /* output-port? */ + s_retbool(is_outport(car(sc->args))); + case OP_PROCP: /* procedure? */ + /*-- + * continuation should be procedure by the example + * (call-with-current-continuation procedure?) ==> #t + * in R^3 report sec. 6.9 + */ + s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) + || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); + case OP_PAIRP: /* pair? */ + s_retbool(is_pair(car(sc->args))); + case OP_LISTP: /* list? */ + s_retbool(list_length(sc,car(sc->args)) >= 0); + + case OP_ENVP: /* environment? */ + s_retbool(is_environment(car(sc->args))); + case OP_VECTORP: /* vector? */ + s_retbool(is_vector(car(sc->args))); + case OP_EQ: /* eq? */ + s_retbool(car(sc->args) == cadr(sc->args)); + case OP_EQV: /* eqv? */ + s_retbool(eqv(car(sc->args), cadr(sc->args))); + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_FORCE: /* force */ + sc->code = car(sc->args); + if (is_promise(sc->code)) { + /* Should change type to closure here */ + s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_APPLY); + } else { + s_return(sc,sc->code); + } + + case OP_SAVE_FORCED: /* Save forced value replacing promise */ + memcpy(sc->code,sc->value,sizeof(struct cell)); + s_return(sc,sc->value); + + case OP_WRITE: /* write */ + case OP_DISPLAY: /* display */ + case OP_WRITE_CHAR: /* write-char */ + if(is_pair(cdr(sc->args))) { + if(cadr(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=cadr(sc->args); + } + } + sc->args = car(sc->args); + if(op==OP_WRITE) { + sc->print_flag = 1; + } else { + sc->print_flag = 0; + } + s_goto(sc,OP_P0LIST); + + case OP_NEWLINE: /* newline */ + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=car(sc->args); + } + } + putstr(sc, "\n"); + s_return(sc,sc->T); + + case OP_ERR0: /* error */ + sc->retcode=-1; + if (!is_string(car(sc->args))) { + sc->args=cons(sc,mk_string(sc," -- "),sc->args); + setimmutable(car(sc->args)); + } + putstr(sc, "Error: "); + putstr(sc, strvalue(car(sc->args))); + sc->args = cdr(sc->args); + s_goto(sc,OP_ERR1); + + case OP_ERR1: /* error */ + putstr(sc, " "); + if (sc->args != sc->NIL) { + s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + sc->print_flag = 1; + s_goto(sc,OP_P0LIST); + } else { + putstr(sc, "\n"); + if(sc->interactive_repl) { + s_goto(sc,OP_T0LVL); + } else { + return sc->NIL; + } + } + + case OP_REVERSE: /* reverse */ + s_return(sc,reverse(sc, car(sc->args))); + + case OP_LIST_STAR: /* list* */ + s_return(sc,list_star(sc,sc->args)); + + case OP_APPEND: /* append */ + x = sc->NIL; + y = sc->args; + if (y == x) { + s_return(sc, x); + } + + /* cdr() in the while condition is not a typo. If car() */ + /* is used (append '() 'a) will return the wrong result.*/ + while (cdr(y) != sc->NIL) { + x = revappend(sc, x, car(y)); + y = cdr(y); + if (x == sc->F) { + Error_0(sc, "non-list argument to append"); + } + } + + s_return(sc, reverse_in_place(sc, car(y), x)); + +#if USE_PLIST + case OP_PUT: /* put */ + if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { + Error_0(sc,"illegal use of put"); + } + for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { + if (caar(x) == y) { + break; + } + } + if (x != sc->NIL) + cdar(x) = caddr(sc->args); + else + symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), + symprop(car(sc->args))); + s_return(sc,sc->T); + + case OP_GET: /* get */ + if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { + Error_0(sc,"illegal use of get"); + } + for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { + if (caar(x) == y) { + break; + } + } + if (x != sc->NIL) { + s_return(sc,cdar(x)); + } else { + s_return(sc,sc->NIL); + } +#endif /* USE_PLIST */ + case OP_QUIT: /* quit */ + if(is_pair(sc->args)) { + sc->retcode=ivalue(car(sc->args)); + } + return (sc->NIL); + + case OP_GC: /* gc */ + gc(sc, sc->NIL, sc->NIL); + s_return(sc,sc->T); + + case OP_GCVERB: /* gc-verbose */ + { int was = sc->gc_verbose; + + sc->gc_verbose = (car(sc->args) != sc->F); + s_retbool(was); + } + + case OP_NEWSEGMENT: /* new-segment */ + if (!is_pair(sc->args) || !is_number(car(sc->args))) { + Error_0(sc,"new-segment: argument must be a number"); + } + alloc_cellseg(sc, (int) ivalue(car(sc->args))); + s_return(sc,sc->T); + + case OP_OBLIST: /* oblist */ + s_return(sc, oblist_all_symbols(sc)); + + case OP_CURR_INPORT: /* current-input-port */ + s_return(sc,sc->inport); + + case OP_CURR_OUTPORT: /* current-output-port */ + s_return(sc,sc->outport); + + case OP_OPEN_INFILE: /* open-input-file */ + case OP_OPEN_OUTFILE: /* open-output-file */ + case OP_OPEN_INOUTFILE: /* open-input-output-file */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INFILE: prop=port_input; break; + case OP_OPEN_OUTFILE: prop=port_output; break; + case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; + } + p=port_from_filename(sc,strvalue(car(sc->args)),prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + } + +#if USE_STRING_PORTS + case OP_OPEN_INSTRING: /* open-input-string */ + case OP_OPEN_INOUTSTRING: /* open-input-output-string */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INSTRING: prop=port_input; break; + case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; + } + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + } + case OP_OPEN_OUTSTRING: /* open-output-string */ { + pointer p; + if(car(sc->args)==sc->NIL) { + p=port_from_scratch(sc); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } else { + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), + port_output); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } + s_return(sc,p); + } + case OP_GET_OUTSTRING: /* get-output-string */ { + port *p; + + if ((p=car(sc->args)->_object._port)->kind&port_string) { + off_t size; + char *str; + + size=p->rep.string.curr-p->rep.string.start+1; + str=sc->malloc(size); + if(str != NULL) { + pointer s; + + memcpy(str,p->rep.string.start,size-1); + str[size-1]='\0'; + s=mk_string(sc,str); + sc->free(str); + s_return(sc,s); + } + } + s_return(sc,sc->F); + } +#endif + + case OP_CLOSE_INPORT: /* close-input-port */ + port_close(sc,car(sc->args),port_input); + s_return(sc,sc->T); + + case OP_CLOSE_OUTPORT: /* close-output-port */ + port_close(sc,car(sc->args),port_output); + s_return(sc,sc->T); + + case OP_INT_ENV: /* interaction-environment */ + s_return(sc,sc->global_env); + + case OP_CURR_ENV: /* current-environment */ + s_return(sc,sc->envir); + + } + return sc->T; +} + +static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { + pointer x; + + if(sc->nesting!=0) { + int n=sc->nesting; + sc->nesting=0; + sc->retcode=-1; + Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); + } + + switch (op) { + /* ========== reading part ========== */ + case OP_READ: + if(!is_pair(sc->args)) { + s_goto(sc,OP_READ_INTERNAL); + } + if(!is_inport(car(sc->args))) { + Error_1(sc,"read: not an input port:",car(sc->args)); + } + if(car(sc->args)==sc->inport) { + s_goto(sc,OP_READ_INTERNAL); + } + x=sc->inport; + sc->inport=car(sc->args); + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + s_goto(sc,OP_READ_INTERNAL); + + case OP_READ_CHAR: /* read-char */ + case OP_PEEK_CHAR: /* peek-char */ { + int c; + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->inport) { + x=sc->inport; + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + sc->inport=car(sc->args); + } + } + c=inchar(sc); + if(c==EOF) { + s_return(sc,sc->EOF_OBJ); + } + if(sc->op==OP_PEEK_CHAR) { + backchar(sc,c); + } + s_return(sc,mk_character(sc,c)); + } + + case OP_CHAR_READY: /* char-ready? */ { + pointer p=sc->inport; + int res; + if(is_pair(sc->args)) { + p=car(sc->args); + } + res=p->_object._port->kind&port_string; + s_retbool(res); + } + + case OP_SET_INPORT: /* set-input-port */ + sc->inport=car(sc->args); + s_return(sc,sc->value); + + case OP_SET_OUTPORT: /* set-output-port */ + sc->outport=car(sc->args); + s_return(sc,sc->value); + + case OP_RDSEXPR: + switch (sc->tok) { + case TOK_EOF: + s_return(sc,sc->EOF_OBJ); + /* NOTREACHED */ +/* + * Commented out because we now skip comments in the scanner + * + case TOK_COMMENT: { + int c; + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + } +*/ + case TOK_VEC: + s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); + /* fall through */ + case TOK_LPAREN: + sc->tok = token(sc); + if (sc->tok == TOK_RPAREN) { + s_return(sc,sc->NIL); + } else if (sc->tok == TOK_DOT) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]++; + s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); + s_goto(sc,OP_RDSEXPR); + } + case TOK_QUOTE: + s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_BQUOTE: + sc->tok = token(sc); + if(sc->tok==TOK_VEC) { + s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); + sc->tok=TOK_LPAREN; + s_goto(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); + } + s_goto(sc,OP_RDSEXPR); + case TOK_COMMA: + s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_ATMARK: + s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_ATOM: + s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); + case TOK_DQUOTE: + x=readstrexp(sc); + if(x==sc->F) { + Error_0(sc,"Error reading string"); + } + setimmutable(x); + s_return(sc,x); + case TOK_SHARP: { + pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); + if(f==sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + sc->code=cons(sc,slot_value_in_env(f),sc->NIL); + s_goto(sc,OP_EVAL); + } + } + case TOK_SHARP_CONST: + if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + s_return(sc,x); + } + default: + Error_0(sc,"syntax error: illegal token"); + } + break; + + case OP_RDLIST: { + sc->args = cons(sc, sc->value, sc->args); + sc->tok = token(sc); +/* We now skip comments in the scanner + while (sc->tok == TOK_COMMENT) { + int c; + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + sc->tok = token(sc); + } +*/ + if (sc->tok == TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + else if (sc->tok == TOK_RPAREN) { + int c = inchar(sc); + if (c != '\n') + backchar(sc,c); +#if SHOW_ERROR_LINE + else if (sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line++; +#endif + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); + } else if (sc->tok == TOK_DOT) { + s_save(sc,OP_RDDOT, sc->args, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDLIST, sc->args, sc->NIL);; + s_goto(sc,OP_RDSEXPR); + } + } + + case OP_RDDOT: + if (token(sc) != TOK_RPAREN) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->value, sc->args)); + } + + case OP_RDQUOTE: + s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDQQUOTE: + s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDQQUOTEVEC: + s_return(sc,cons(sc, mk_symbol(sc,"apply"), + cons(sc, mk_symbol(sc,"vector"), + cons(sc,cons(sc, sc->QQUOTE, + cons(sc,sc->value,sc->NIL)), + sc->NIL)))); + + case OP_RDUNQUOTE: + s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDUQTSP: + s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); + + case OP_RDVEC: + /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_goto(sc,OP_EVAL); Cannot be quoted*/ + /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_return(sc,x); Cannot be part of pairs*/ + /*sc->code=mk_proc(sc,OP_VECTOR); + sc->args=sc->value; + s_goto(sc,OP_APPLY);*/ + sc->args=sc->value; + s_goto(sc,OP_VECTOR); + + /* ========== printing part ========== */ + case OP_P0LIST: + if(is_vector(sc->args)) { + putstr(sc,"#("); + sc->args=cons(sc,sc->args,mk_integer(sc,0)); + s_goto(sc,OP_PVECFROM); + } else if(is_environment(sc->args)) { + putstr(sc,"#"); + s_return(sc,sc->T); + } else if (!is_pair(sc->args)) { + printatom(sc, sc->args, sc->print_flag); + s_return(sc,sc->T); + } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "'"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "`"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, ","); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { + putstr(sc, ",@"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else { + putstr(sc, "("); + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + s_goto(sc,OP_P0LIST); + } + + case OP_P1LIST: + if (is_pair(sc->args)) { + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + putstr(sc, " "); + sc->args = car(sc->args); + s_goto(sc,OP_P0LIST); + } else if(is_vector(sc->args)) { + s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); + putstr(sc, " . "); + s_goto(sc,OP_P0LIST); + } else { + if (sc->args != sc->NIL) { + putstr(sc, " . "); + printatom(sc, sc->args, sc->print_flag); + } + putstr(sc, ")"); + s_return(sc,sc->T); + } + case OP_PVECFROM: { + int i=ivalue_unchecked(cdr(sc->args)); + pointer vec=car(sc->args); + int len=ivalue_unchecked(vec); + if(i==len) { + putstr(sc,")"); + s_return(sc,sc->T); + } else { + pointer elem=vector_elem(vec,i); + ivalue_unchecked(cdr(sc->args))=i+1; + s_save(sc,OP_PVECFROM, sc->args, sc->NIL); + sc->args=elem; + if (i > 0) + putstr(sc," "); + s_goto(sc,OP_P0LIST); + } + } + + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + + } + return sc->T; +} + +static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + long v; + + switch (op) { + case OP_LIST_LENGTH: /* length */ /* a.k */ + v=list_length(sc,car(sc->args)); + if(v<0) { + Error_1(sc,"length: not a list:",car(sc->args)); + } + s_return(sc,mk_integer(sc, v)); + + case OP_ASSQ: /* assq */ /* a.k */ + x = car(sc->args); + for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { + if (!is_pair(car(y))) { + Error_0(sc,"unable to handle non pair element"); + } + if (x == caar(y)) + break; + } + if (is_pair(y)) { + s_return(sc,car(y)); + } else { + s_return(sc,sc->F); + } + + + case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ + sc->args = car(sc->args); + if (sc->args == sc->NIL) { + s_return(sc,sc->F); + } else if (is_closure(sc->args)) { + s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + } else if (is_macro(sc->args)) { + s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + } else { + s_return(sc,sc->F); + } + case OP_CLOSUREP: /* closure? */ + /* + * Note, macro object is also a closure. + * Therefore, (closure? <#MACRO>) ==> #t + */ + s_retbool(is_closure(car(sc->args))); + case OP_MACROP: /* macro? */ + s_retbool(is_macro(car(sc->args))); + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; /* NOTREACHED */ +} + +typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); + +typedef int (*test_predicate)(pointer); +static int is_any(pointer p) { return 1;} + +static int is_nonneg(pointer p) { + return ivalue(p)>=0 && is_integer(p); +} + +/* Correspond carefully with following defines! */ +static struct { + test_predicate fct; + const char *kind; +} tests[]={ + {0,0}, /* unused */ + {is_any, 0}, + {is_string, "string"}, + {is_symbol, "symbol"}, + {is_port, "port"}, + {is_inport,"input port"}, + {is_outport,"output port"}, + {is_environment, "environment"}, + {is_pair, "pair"}, + {0, "pair or '()"}, + {is_character, "character"}, + {is_vector, "vector"}, + {is_number, "number"}, + {is_integer, "integer"}, + {is_nonneg, "non-negative integer"} +}; + +#define TST_NONE 0 +#define TST_ANY "\001" +#define TST_STRING "\002" +#define TST_SYMBOL "\003" +#define TST_PORT "\004" +#define TST_INPORT "\005" +#define TST_OUTPORT "\006" +#define TST_ENVIRONMENT "\007" +#define TST_PAIR "\010" +#define TST_LIST "\011" +#define TST_CHAR "\012" +#define TST_VECTOR "\013" +#define TST_NUMBER "\014" +#define TST_INTEGER "\015" +#define TST_NATURAL "\016" + +typedef struct { + dispatch_func func; + char *name; + int min_arity; + int max_arity; + char *arg_tests_encoding; +} op_code_info; + +#define INF_ARG 0xffff + +static op_code_info dispatch_table[]= { +#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, +#include "opdefines.h" + { 0 } +}; + +static const char *procname(pointer x) { + int n=procnum(x); + const char *name=dispatch_table[n].name; + if(name==0) { + name="ILLEGAL!"; + } + return name; +} + +/* kernel of this interpreter */ +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { + sc->op = op; + for (;;) { + op_code_info *pcd=dispatch_table+sc->op; + if (pcd->name!=0) { /* if built-in function, check arguments */ + char msg[STRBUFFSIZE]; + int ok=1; + int n=list_length(sc,sc->args); + + /* Check number of arguments */ + if(nmin_arity) { + ok=0; + snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity==pcd->max_arity?"":" at least", + pcd->min_arity); + } + if(ok && n>pcd->max_arity) { + ok=0; + snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity==pcd->max_arity?"":" at most", + pcd->max_arity); + } + if(ok) { + if(pcd->arg_tests_encoding!=0) { + int i=0; + int j; + const char *t=pcd->arg_tests_encoding; + pointer arglist=sc->args; + do { + pointer arg=car(arglist); + j=(int)t[0]; + if(j==TST_LIST[0]) { + if(arg!=sc->NIL && !is_pair(arg)) break; + } else { + if(!tests[j].fct(arg)) break; + } + + if(t[1]!=0) {/* last test is replicated as necessary */ + t++; + } + arglist=cdr(arglist); + i++; + } while(iname, + i+1, + tests[j].kind); + } + } + } + if(!ok) { + if(_Error_1(sc,msg,0)==sc->NIL) { + return; + } + pcd=dispatch_table+sc->op; + } + } + ok_to_freely_gc(sc); + if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { + return; + } + if(sc->no_memory) { + fprintf(stderr,"No memory!\n"); + return; + } + } +} + +/* ========== Initialization of internal keywords ========== */ + +static void assign_syntax(scheme *sc, char *name) { + pointer x; + + x = oblist_add_by_name(sc, name); + typeflag(x) |= T_SYNTAX; +} + +static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { + pointer x, y; + + x = mk_symbol(sc, name); + y = mk_proc(sc,op); + new_slot_in_env(sc, x, y); +} + +static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { + pointer y; + + y = get_cell(sc, sc->NIL, sc->NIL); + typeflag(y) = (T_PROC | T_ATOM); + ivalue_unchecked(y) = (long) op; + set_num_integer(y); + return y; +} + +/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ +static int syntaxnum(pointer p) { + const char *s=strvalue(car(p)); + switch(strlength(car(p))) { + case 2: + if(s[0]=='i') return OP_IF0; /* if */ + else return OP_OR0; /* or */ + case 3: + if(s[0]=='a') return OP_AND0; /* and */ + else return OP_LET0; /* let */ + case 4: + switch(s[3]) { + case 'e': return OP_CASE0; /* case */ + case 'd': return OP_COND0; /* cond */ + case '*': return OP_LET0AST; /* let* */ + default: return OP_SET0; /* set! */ + } + case 5: + switch(s[2]) { + case 'g': return OP_BEGIN; /* begin */ + case 'l': return OP_DELAY; /* delay */ + case 'c': return OP_MACRO0; /* macro */ + default: return OP_QUOTE; /* quote */ + } + case 6: + switch(s[2]) { + case 'm': return OP_LAMBDA; /* lambda */ + case 'f': return OP_DEF0; /* define */ + default: return OP_LET0REC; /* letrec */ + } + default: + return OP_C0STREAM; /* cons-stream */ + } +} + +/* initialization of TinyScheme */ +#if USE_INTERFACE +INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { + return cons(sc,a,b); +} +INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { + return immutable_cons(sc,a,b); +} + +static struct scheme_interface vtbl ={ + scheme_define, + s_cons, + s_immutable_cons, + reserve_cells, + mk_integer, + mk_real, + mk_symbol, + gensym, + mk_string, + mk_counted_string, + mk_character, + mk_vector, + mk_foreign_func, + putstr, + putcharacter, + + is_string, + string_value, + is_number, + nvalue, + ivalue, + rvalue, + is_integer, + is_real, + is_character, + charvalue, + is_list, + is_vector, + list_length, + ivalue, + fill_vector, + vector_elem, + set_vector_elem, + is_port, + is_pair, + pair_car, + pair_cdr, + set_car, + set_cdr, + + is_symbol, + symname, + + is_syntax, + is_proc, + is_foreign, + syntaxname, + is_closure, + is_macro, + closure_code, + closure_env, + + is_continuation, + is_promise, + is_environment, + is_immutable, + setimmutable, + + scheme_load_file, + scheme_load_string +}; +#endif + +scheme *scheme_init_new() { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init(sc)) { + free(sc); + return 0; + } else { + return sc; + } +} + +scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init_custom_alloc(sc,malloc,free)) { + free(sc); + return 0; + } else { + return sc; + } +} + + +int scheme_init(scheme *sc) { + return scheme_init_custom_alloc(sc,malloc,free); +} + +int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { + int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); + pointer x; + + num_zero.is_fixnum=1; + num_zero.value.ivalue=0; + num_one.is_fixnum=1; + num_one.value.ivalue=1; + +#if USE_INTERFACE + sc->vptr=&vtbl; +#endif + sc->gensym_cnt=0; + sc->malloc=malloc; + sc->free=free; + sc->last_cell_seg = -1; + sc->sink = &sc->_sink; + sc->NIL = &sc->_NIL; + sc->T = &sc->_HASHT; + sc->F = &sc->_HASHF; + sc->EOF_OBJ=&sc->_EOF_OBJ; + sc->free_cell = &sc->_NIL; + sc->fcells = 0; + sc->no_memory=0; + sc->inport=sc->NIL; + sc->outport=sc->NIL; + sc->save_inport=sc->NIL; + sc->loadport=sc->NIL; + sc->nesting=0; + sc->interactive_repl=0; + + if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { + sc->no_memory=1; + return 0; + } + sc->gc_verbose = 0; + dump_stack_initialize(sc); + sc->code = sc->NIL; + sc->tracing=0; + + /* init sc->NIL */ + typeflag(sc->NIL) = (T_ATOM | MARK); + car(sc->NIL) = cdr(sc->NIL) = sc->NIL; + /* init T */ + typeflag(sc->T) = (T_ATOM | MARK); + car(sc->T) = cdr(sc->T) = sc->T; + /* init F */ + typeflag(sc->F) = (T_ATOM | MARK); + car(sc->F) = cdr(sc->F) = sc->F; + /* init sink */ + typeflag(sc->sink) = (T_PAIR | MARK); + car(sc->sink) = sc->NIL; + /* init c_nest */ + sc->c_nest = sc->NIL; + + sc->oblist = oblist_initial_value(sc); + /* init global_env */ + new_frame_in_env(sc, sc->NIL); + sc->global_env = sc->envir; + /* init else */ + x = mk_symbol(sc,"else"); + new_slot_in_env(sc, x, sc->T); + + assign_syntax(sc, "lambda"); + assign_syntax(sc, "quote"); + assign_syntax(sc, "define"); + assign_syntax(sc, "if"); + assign_syntax(sc, "begin"); + assign_syntax(sc, "set!"); + assign_syntax(sc, "let"); + assign_syntax(sc, "let*"); + assign_syntax(sc, "letrec"); + assign_syntax(sc, "cond"); + assign_syntax(sc, "delay"); + assign_syntax(sc, "and"); + assign_syntax(sc, "or"); + assign_syntax(sc, "cons-stream"); + assign_syntax(sc, "macro"); + assign_syntax(sc, "case"); + + for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); + sc->QUOTE = mk_symbol(sc, "quote"); + sc->QQUOTE = mk_symbol(sc, "quasiquote"); + sc->UNQUOTE = mk_symbol(sc, "unquote"); + sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); + sc->FEED_TO = mk_symbol(sc, "=>"); + sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); + sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); + sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); + sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); + + return !sc->no_memory; +} + +void scheme_set_input_port_file(scheme *sc, FILE *fin) { + sc->inport=port_from_file(sc,fin,port_input); +} + +void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { + sc->inport=port_from_string(sc,start,past_the_end,port_input); +} + +void scheme_set_output_port_file(scheme *sc, FILE *fout) { + sc->outport=port_from_file(sc,fout,port_output); +} + +void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { + sc->outport=port_from_string(sc,start,past_the_end,port_output); +} + +void scheme_set_external_data(scheme *sc, void *p) { + sc->ext_data=p; +} + +void scheme_deinit(scheme *sc) { + int i; + +#if SHOW_ERROR_LINE + char *fname; +#endif + + sc->oblist=sc->NIL; + sc->global_env=sc->NIL; + dump_stack_free(sc); + sc->envir=sc->NIL; + sc->code=sc->NIL; + sc->args=sc->NIL; + sc->value=sc->NIL; + if(is_port(sc->inport)) { + typeflag(sc->inport) = T_ATOM; + } + sc->inport=sc->NIL; + sc->outport=sc->NIL; + if(is_port(sc->save_inport)) { + typeflag(sc->save_inport) = T_ATOM; + } + sc->save_inport=sc->NIL; + if(is_port(sc->loadport)) { + typeflag(sc->loadport) = T_ATOM; + } + sc->loadport=sc->NIL; + sc->gc_verbose=0; + gc(sc,sc->NIL,sc->NIL); + + for(i=0; i<=sc->last_cell_seg; i++) { + sc->free(sc->alloc_seg[i]); + } + +#if SHOW_ERROR_LINE + for(i=0; i<=sc->file_i; i++) { + if (sc->load_stack[i].kind & port_file) { + fname = sc->load_stack[i].rep.stdio.filename; + if(fname) + sc->free(fname); + } + } +#endif +} + +void scheme_load_file(scheme *sc, FILE *fin) +{ scheme_load_named_file(sc,fin,0); } + +void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_file; + sc->load_stack[0].rep.stdio.file=fin; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + if(fin==stdin) { + sc->interactive_repl=1; + } + +#if SHOW_ERROR_LINE + sc->load_stack[0].rep.stdio.curr_line = 0; + if(fin!=stdin && filename) + sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0); + else + sc->load_stack[0].rep.stdio.filename = NULL; +#endif + + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } +} + +void scheme_load_string(scheme *sc, const char *cmd) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_string; + sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ + sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); + sc->load_stack[0].rep.string.curr=(char*)cmd; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + sc->interactive_repl=0; + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } +} + +void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { + pointer x; + + x=find_slot_in_env(sc,envir,symbol,0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, value); + } else { + new_slot_spec_in_env(sc, envir, symbol, value); + } +} + +#if !STANDALONE +void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) +{ + scheme_define(sc, + sc->global_env, + mk_symbol(sc,sr->name), + mk_foreign_func(sc, sr->f)); +} + +void scheme_register_foreign_func_list(scheme * sc, + scheme_registerable * list, + int count) +{ + int i; + for(i = 0; i < count; i++) + { + scheme_register_foreign_func(sc, list + i); + } +} + +pointer scheme_apply0(scheme *sc, const char *procname) +{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } + +void save_from_C_call(scheme *sc) +{ + pointer saved_data = + cons(sc, + car(sc->sink), + cons(sc, + sc->envir, + sc->dump)); + /* Push */ + sc->c_nest = cons(sc, saved_data, sc->c_nest); + /* Truncate the dump stack so TS will return here when done, not + directly resume pre-C-call operations. */ + dump_stack_reset(sc); +} +void restore_from_C_call(scheme *sc) +{ + car(sc->sink) = caar(sc->c_nest); + sc->envir = cadar(sc->c_nest); + sc->dump = cdr(cdar(sc->c_nest)); + /* Pop */ + sc->c_nest = cdr(sc->c_nest); +} + +/* "func" and "args" are assumed to be already eval'ed. */ +pointer scheme_call(scheme *sc, pointer func, pointer args) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->envir = sc->global_env; + sc->args = args; + sc->code = func; + sc->retcode = 0; + Eval_Cycle(sc, OP_APPLY); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + +pointer scheme_eval(scheme *sc, pointer obj) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->args = sc->NIL; + sc->code = obj; + sc->retcode = 0; + Eval_Cycle(sc, OP_EVAL); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + + +#endif + +/* ========== Main ========== */ + +#if STANDALONE + +#if defined(__APPLE__) && !defined (OSX) +int main() +{ + extern MacTS_main(int argc, char **argv); + char** argv; + int argc = ccommand(&argv); + MacTS_main(argc,argv); + return 0; +} +int MacTS_main(int argc, char **argv) { +#else +int main(int argc, char **argv) { +#endif + scheme sc; + FILE *fin; + char *file_name=InitFile; + int retcode; + int isfile=1; + + if(argc==1) { + printf(banner); + } + if(argc==2 && strcmp(argv[1],"-?")==0) { + printf("Usage: tinyscheme -?\n"); + printf("or: tinyscheme [ ...]\n"); + printf("followed by\n"); + printf(" -1 [ ...]\n"); + printf(" -c [ ...]\n"); + printf("assuming that the executable is named tinyscheme.\n"); + printf("Use - as filename for stdin.\n"); + return 1; + } + if(!scheme_init(&sc)) { + fprintf(stderr,"Could not initialize!\n"); + return 2; + } + scheme_set_input_port_file(&sc, stdin); + scheme_set_output_port_file(&sc, stdout); +#if USE_DL + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); +#endif + argv++; + if(access(file_name,0)!=0) { + char *p=getenv("TINYSCHEMEINIT"); + if(p!=0) { + file_name=p; + } + } + do { + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { + pointer args=sc.NIL; + isfile=file_name[1]=='1'; + file_name=*argv++; + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(isfile) { + fin=fopen(file_name,"r"); + } + for(;*argv;argv++) { + pointer value=mk_string(&sc,*argv); + args=cons(&sc,value,args); + } + args=reverse_in_place(&sc,sc.NIL,args); + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); + + } else { + fin=fopen(file_name,"r"); + } + if(isfile && fin==0) { + fprintf(stderr,"Could not open file %s\n",file_name); + } else { + if(isfile) { + scheme_load_named_file(&sc,fin,file_name); + } else { + scheme_load_string(&sc,file_name); + } + if(!isfile || fin!=stdin) { + if(sc.retcode!=0) { + fprintf(stderr,"Errors encountered reading %s\n",file_name); + } + if(isfile) { + fclose(fin); + } + } + } + file_name=*argv++; + } while(file_name!=0); + if(argc==1) { + scheme_load_named_file(&sc,stdin,0); + } + retcode=sc.retcode; + scheme_deinit(&sc); + + return retcode; +} + +#endif + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/scheme.h b/scheme.h new file mode 100644 index 0000000..05ae7fe --- /dev/null +++ b/scheme.h @@ -0,0 +1,255 @@ +/* SCHEME.H */ + +#ifndef _SCHEME_H +#define _SCHEME_H + +#include + +#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: +*/ -- cgit v1.2.3 From fe1c0866bc1b2c685136ea19521ffab2deb25ec3 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 7 Jan 2016 14:07:20 +0100 Subject: tests/gpgscm: Handle unhandled enumeration values. * tests/gpgscm/scheme.c (opexe_{3,4}): Handle unhandled enumeration values in the opcode dispatching code. Signed-off-by: Justus Winter --- scheme.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/scheme.c b/scheme.c index 3d4330d..220eed3 100644 --- a/scheme.c +++ b/scheme.c @@ -27,6 +27,7 @@ # include #endif +#include #include #include #include @@ -3654,6 +3655,7 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { case OP_GRE: comp_func=num_gt; break; case OP_LEQ: comp_func=num_le; break; case OP_GEQ: comp_func=num_ge; break; + default: assert (! "reached"); } x=sc->args; v=nvalue(car(x)); @@ -3898,12 +3900,15 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { case OP_OPEN_INFILE: prop=port_input; break; case OP_OPEN_OUTFILE: prop=port_output; break; case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; + default: assert (! "reached"); } p=port_from_filename(sc,strvalue(car(sc->args)),prop); if(p==sc->NIL) { s_return(sc,sc->F); } s_return(sc,p); + break; + default: assert (! "reached"); } #if USE_STRING_PORTS @@ -3914,6 +3919,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { switch(op) { case OP_OPEN_INSTRING: prop=port_input; break; case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; + default: assert (! "reached"); } p=port_from_string(sc, strvalue(car(sc->args)), strvalue(car(sc->args))+strlength(car(sc->args)), prop); -- cgit v1.2.3 From 16e4898a735e8f85c4ca6b44adf5a92b1a42d1af Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 7 Jan 2016 16:53:06 +0100 Subject: tests/gpgscm: Fix error hook. * tests/gpgscm/init.scm (*error-hook*): Fix error hook so that the whole error message is displayed. Signed-off-by: Justus Winter --- init.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/init.scm b/init.scm index 57ae079..3c0ee7d 100644 --- a/init.scm +++ b/init.scm @@ -577,7 +577,8 @@ (pop-handler) ,label))))) -(define *error-hook* throw) +(define (*error-hook* . args) + (throw args)) ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL -- cgit v1.2.3 From 0c601ae085e95745a950a9d75ffdc8be42b3e1b2 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 22 Jan 2016 11:13:14 +0100 Subject: tests/gpgscm: Nicer error message. * tests/gpgscm/scheme.c (opexe_0): Include the value that we tried to evaluate as function-like in the error message. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 220eed3..fba1071 100644 --- a/scheme.c +++ b/scheme.c @@ -2683,7 +2683,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->dump = cont_dump(sc->code); s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); } else { - Error_0(sc,"illegal function"); + Error_1(sc,"illegal function",sc->code); } case OP_DOMACRO: /* do macro */ -- cgit v1.2.3 From 2717b9c172f0a25094ad2e654459dbe9d7180e38 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 22 Jan 2016 11:15:20 +0100 Subject: tests/gpgscm: Expose function to open streams as Scheme ports. * tests/gpgscm/scheme.c (vtbl): Add 'port_from_file' to the vtable. * tests/gpgscm/scheme.h (struct scheme_interface): New field 'mk_port_from_file'. Signed-off-by: Justus Winter --- scheme.c | 3 ++- scheme.h | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index fba1071..fd8f294 100644 --- a/scheme.c +++ b/scheme.c @@ -4614,7 +4614,8 @@ static struct scheme_interface vtbl ={ setimmutable, scheme_load_file, - scheme_load_string + scheme_load_string, + port_from_file }; #endif diff --git a/scheme.h b/scheme.h index 05ae7fe..4ba2daa 100644 --- a/scheme.h +++ b/scheme.h @@ -224,6 +224,7 @@ struct scheme_interface { void (*setimmutable)(pointer p); void (*load_file)(scheme *sc, FILE *fin); void (*load_string)(scheme *sc, const char *input); + pointer (*mk_port_from_file)(scheme *sc, FILE *f, int kind); }; #endif -- cgit v1.2.3 From f6c0f9a420c4401d8d358049f8814799161185fa Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 28 Jan 2016 18:19:07 +0100 Subject: tests/gpgscm: Add package macro. * tests/gpgscm/init.scm: Add package macro from manual. Signed-off-by: Justus Winter --- init.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/init.scm b/init.scm index 3c0ee7d..630f27a 100644 --- a/init.scm +++ b/init.scm @@ -600,6 +600,11 @@ ; Also redefine 'package' (define *colon-hook* eval) +(macro (package form) + `(apply (lambda () + ,@(cdr form) + (current-environment)))) + ;;;;; I/O (define (input-output-port? p) -- cgit v1.2.3 From c0cf52627d8d68d23bcac60571455ffd1b052106 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 22 Feb 2016 16:36:12 +0100 Subject: tests/gpgscm: Make exception value available. * tests/gpgscm/init.scm (throw): Hand exception value to the handler. (catch): And bind it to *error*. --- init.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/init.scm b/init.scm index 630f27a..0889366 100644 --- a/init.scm +++ b/init.scm @@ -542,8 +542,9 @@ ; (if-something goes-wrong) ; (with-these calls)) ; -; "Catch" establishes a scope spanning multiple call-frames -; until another "catch" is encountered. +; "Catch" establishes a scope spanning multiple call-frames until +; another "catch" is encountered. Within the recovery expression +; the thrown exception is bound to *error*. ; ; Exceptions are thrown with: ; @@ -566,13 +567,13 @@ (define (throw . x) (if (more-handlers?) - (apply (pop-handler)) + (apply (pop-handler) x) (apply error x))) (macro (catch form) (let ((label (gensym))) `(call/cc (lambda (exit) - (push-handler (lambda () (exit ,(cadr form)))) + (push-handler (lambda (*error*) (exit ,(cadr form)))) (let ((,label (begin ,@(cddr form)))) (pop-handler) ,label))))) -- cgit v1.2.3 From ef65b7bb2232343f72d03a0e0521de4ada3dc63b Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 31 Mar 2016 13:33:03 +0200 Subject: tests/gpgscm: Dynamically allocate string buffer. * tests/gpgscm/scheme-config.h (strbuff{,_size}): Make buffer dynamic. * tests/gpgscm/scheme.c (expand_strbuff): New function. (putcharacter): Adapt length test. (readstrexp): Expand buffer if necessary. (scheme_init_custom_alloc): Initialize buffer. (scheme_deinit): Free buffer. Patch from Thomas Munro, https://sourceforge.net/p/tinyscheme/patches/11/ Signed-off-by: Justus Winter --- scheme-private.h | 4 ++-- scheme.c | 34 ++++++++++++++++++++++++++++++++-- 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 404243e..0ddfdbc 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -139,8 +139,8 @@ char linebuff[LINESIZE]; #ifndef STRBUFFSIZE #define STRBUFFSIZE 256 #endif -char strbuff[STRBUFFSIZE]; - +char *strbuff; +size_t strbuff_size; FILE *tmpfp; int tok; int print_flag; diff --git a/scheme.c b/scheme.c index fd8f294..1f40bb2 100644 --- a/scheme.c +++ b/scheme.c @@ -67,6 +67,7 @@ #define banner "TinyScheme 1.41" #include +#include #include #ifdef __APPLE__ @@ -1071,6 +1072,21 @@ INTERFACE pointer gensym(scheme *sc) { return sc->NIL; } +/* double the size of the string buffer */ +static int expand_strbuff(scheme *sc) { + size_t new_size = sc->strbuff_size * 2; + char *new_buffer = sc->malloc(new_size); + if (new_buffer == 0) { + sc->no_memory = 1; + return 1; + } + memcpy(new_buffer, sc->strbuff, sc->strbuff_size); + sc->free(sc->strbuff); + sc->strbuff = new_buffer; + sc->strbuff_size = new_size; + return 0; +} + /* make symbol or number atom from string */ static pointer mk_atom(scheme *sc, char *q) { char c, *p; @@ -1612,7 +1628,7 @@ INTERFACE void putcharacter(scheme *sc, int c) { static char *readstr_upto(scheme *sc, char *delim) { char *p = sc->strbuff; - while ((p - sc->strbuff < sizeof(sc->strbuff)) && + while ((p - sc->strbuff < sc->strbuff_size) && !is_one_of(delim, (*p++ = inchar(sc)))); if(p == sc->strbuff+2 && p[-2] == '\\') { @@ -1633,9 +1649,16 @@ static pointer readstrexp(scheme *sc) { for (;;) { c=inchar(sc); - if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) { + if(c == EOF) { return sc->F; } + if(p-sc->strbuff > (sc->strbuff_size)-1) { + ptrdiff_t offset = p - sc->strbuff; + if (expand_strbuff(sc) != 0) { + return sc->F; + } + p = sc->strbuff + offset; + } switch(state) { case st_ok: switch(c) { @@ -4674,6 +4697,12 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->loadport=sc->NIL; sc->nesting=0; sc->interactive_repl=0; + sc->strbuff = sc->malloc(STRBUFFSIZE); + if (sc->strbuff == 0) { + sc->no_memory=1; + return 0; + } + sc->strbuff_size = STRBUFFSIZE; if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { sc->no_memory=1; @@ -4798,6 +4827,7 @@ void scheme_deinit(scheme *sc) { for(i=0; i<=sc->last_cell_seg; i++) { sc->free(sc->alloc_seg[i]); } + sc->free(sc->strbuff); #if SHOW_ERROR_LINE for(i=0; i<=sc->file_i; i++) { -- cgit v1.2.3 From 9fecd60c32aca6b32008310237d0ed524eede3d5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 31 Mar 2016 13:49:56 +0200 Subject: tests/gpgscm: Foreign objects support for TinySCHEME. * tests/gpgscm/scheme-private.h (struct cell): Add 'foreign_object'. (is_foreign_object): New prototype. (get_foreign_object_{vtable,data}): Likewise. * tests/gpgscm/scheme.c (enum scheme_types): New type. (is_foreign_object): New function. (get_foreign_object_{vtable,data}): Likewise. (mk_foreign_object): Likewise. (finalize_cell): Free foreign objects. (atom2str): Pretty-print foreign objects. (vtbl): Add new functions. * tests/gpgscm/scheme.h (struct foreign_object_vtable): New type. (mk_foreign_object): New prototype. (struct scheme_interface): Add new functions. Patch from Thomas Munro, https://sourceforge.net/p/tinyscheme/patches/13/ Signed-off-by: Justus Winter --- scheme-private.h | 8 ++++++++ scheme.c | 28 +++++++++++++++++++++++++++- scheme.h | 10 ++++++++++ 3 files changed, 45 insertions(+), 1 deletion(-) diff --git a/scheme-private.h b/scheme-private.h index 0ddfdbc..9eafe76 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -55,6 +55,10 @@ struct cell { struct cell *_car; struct cell *_cdr; } _cons; + struct { + char *_data; + const foreign_object_vtable *_vtable; + } _foreign_object; } _object; }; @@ -207,6 +211,10 @@ int is_environment(pointer p); int is_immutable(pointer p); void setimmutable(pointer p); +int is_foreign_object(pointer p); +const foreign_object_vtable *get_foreign_object_vtable(pointer p); +void *get_foreign_object_data(pointer p); + #ifdef __cplusplus } #endif diff --git a/scheme.c b/scheme.c index 1f40bb2..748a022 100644 --- a/scheme.c +++ b/scheme.c @@ -125,7 +125,8 @@ enum scheme_types { T_MACRO=12, T_PROMISE=13, T_ENVIRONMENT=14, - T_LAST_SYSTEM_TYPE=14 + T_FOREIGN_OBJECT=15, + T_LAST_SYSTEM_TYPE=15 }; /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ @@ -235,6 +236,14 @@ INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } #define cont_dump(p) cdr(p) +INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); } +INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) { + return p->_object._foreign_object._vtable; +} +INTERFACE void *get_foreign_object_data(pointer p) { + return p->_object._foreign_object._data; +} + /* To do: promise should be forced ONCE only */ INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } @@ -930,6 +939,15 @@ pointer mk_foreign_func(scheme *sc, foreign_func f) { return (x); } +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM); + x->_object._foreign_object._vtable=vtable; + x->_object._foreign_object._data = data; + return (x); +} + INTERFACE pointer mk_character(scheme *sc, int c) { pointer x = get_cell(sc,sc->NIL, sc->NIL); @@ -1341,6 +1359,8 @@ static void finalize_cell(scheme *sc, pointer a) { port_close(sc,a,port_input|port_output); } sc->free(a->_object._port); + } else if(is_foreign_object(a)) { + a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); } } @@ -2047,6 +2067,9 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) { snprintf(p,STRBUFFSIZE,"#", procnum(l)); } else if (is_continuation(l)) { p = "#"; + } else if (is_foreign_object(l)) { + p = sc->strbuff; + l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data); } else { p = "#"; } @@ -4591,6 +4614,9 @@ static struct scheme_interface vtbl ={ mk_character, mk_vector, mk_foreign_func, + mk_foreign_object, + get_foreign_object_vtable, + get_foreign_object_data, putstr, putcharacter, diff --git a/scheme.h b/scheme.h index 4ba2daa..f4231c4 100644 --- a/scheme.h +++ b/scheme.h @@ -118,6 +118,12 @@ typedef struct cell *pointer; typedef void * (*func_alloc)(size_t); typedef void (*func_dealloc)(void *); +/* table of functions required for foreign objects */ +typedef struct foreign_object_vtable { + void (*finalize)(scheme *sc, void *data); + void (*to_string)(scheme *sc, char *out, size_t size, void *data); +} foreign_object_vtable; + /* num, for generic arithmetic */ typedef struct num { char is_fixnum; @@ -157,6 +163,7 @@ 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); +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data); void putstr(scheme *sc, const char *s); int list_length(scheme *sc, pointer a); int eqv(pointer a, pointer b); @@ -177,6 +184,9 @@ struct scheme_interface { pointer (*mk_character)(scheme *sc, int c); pointer (*mk_vector)(scheme *sc, int len); pointer (*mk_foreign_func)(scheme *sc, foreign_func f); + pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data); + const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p); + void *(*get_foreign_object_data)(pointer p); void (*putstr)(scheme *sc, const char *s); void (*putcharacter)(scheme *sc, int c); -- cgit v1.2.3 From 5b417d262de048ef221ed77b2f9d2c1a843096bb Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 6 Jan 2016 11:55:25 +0100 Subject: tests/gpgscm: Add a TinySCHEME-based test driver. * configure.ac: Add new component. * tests/Makefile.am: Likewise. * tests/gpgscm/Makefile.am: New file. * tests/gpgscm/ffi-private.h: Likewise. * tests/gpgscm/ffi.c: Likewise. * tests/gpgscm/ffi.h: Likewise. * tests/gpgscm/ffi.scm: Likewise. * tests/gpgscm/lib.scm: Likewise. * tests/gpgscm/main.c: Likewise. * tests/gpgscm/private.h: Likewise. * tests/gpgscm/repl.scm: Likewise. * tests/gpgscm/scheme-config.h: Likewise. * tests/gpgscm/t-child.c: Likewise. * tests/gpgscm/t-child.scm: Likewise. * tests/gpgscm/tests.scm: Likewise. Signed-off-by: Justus Winter --- Makefile.am | 57 +++ ffi-private.h | 132 +++++++ ffi.c | 1167 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ ffi.h | 30 ++ ffi.scm | 40 ++ lib.scm | 163 ++++++++ main.c | 286 ++++++++++++++ private.h | 26 ++ repl.scm | 50 +++ scheme-config.h | 36 ++ t-child.c | 66 ++++ t-child.scm | 93 +++++ tests.scm | 402 +++++++++++++++++++ 13 files changed, 2548 insertions(+) create mode 100644 Makefile.am create mode 100644 ffi-private.h create mode 100644 ffi.c create mode 100644 ffi.h create mode 100644 ffi.scm create mode 100644 lib.scm create mode 100644 main.c create mode 100644 private.h create mode 100644 repl.scm create mode 100644 scheme-config.h create mode 100644 t-child.c create mode 100644 t-child.scm create mode 100644 tests.scm diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..1fb9647 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,57 @@ +# TinyScheme-based test driver. +# +# Copyright (C) 2016 g10 Code GmbH +# +# This file is part of GnuPG. +# +# GnuPG is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# GnuPG is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . + +EXTRA_DIST = \ + COPYING \ + Manual.txt \ + ffi.scm \ + init.scm \ + lib.scm \ + t-child.scm \ + tests.scm + +AM_CPPFLAGS = -I$(top_srcdir)/common +include $(top_srcdir)/am/cmacros.am + +AM_CFLAGS = + +bin_PROGRAMS = gpgscm +noinst_PROGRAMS = t-child + +common_libs = ../$(libcommon) +commonpth_libs = ../$(libcommonpth) + +gpgscm_CFLAGS = -imacros scheme-config.h \ + $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) +gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ + scheme-config.h opdefines.h scheme.c scheme.h scheme-private.h +gpgscm_LDADD = $(LDADD) $(common_libs) \ + $(NETLIBS) $(LIBICONV) $(LIBREADLINE) \ + $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) + +t_child_SOURCES = t-child.c + +# Make sure that all libs are build before we use them. This is +# important for things like make -j2. +$(PROGRAMS): $(common_libs) + +.PHONY: check +check: gpgscm$(EXEEXT) t-child$(EXEEXT) + EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \ + ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm diff --git a/ffi-private.h b/ffi-private.h new file mode 100644 index 0000000..5467dac --- /dev/null +++ b/ffi-private.h @@ -0,0 +1,132 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef GPGSCM_FFI_PRIVATE_H +#define GPGSCM_FFI_PRIVATE_H + +#include +#include "scheme.h" +#include "scheme-private.h" + +#define FFI_PROLOG() \ + unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1; \ + int err GPGRT_ATTR_UNUSED = 0 \ + +int ffi_bool_value (scheme *sc, pointer p); + +#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X) +#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X) +#define CONVERSION_list(SC, X) (X) +#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X)) +#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \ + ? (SC)->vptr->string_value \ + : (SC)->vptr->symname) (X)) + +#define IS_A_number(SC, X) (SC)->vptr->is_number (X) +#define IS_A_string(SC, X) (SC)->vptr->is_string (X) +#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X) +#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T) +#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ + || (SC)->vptr->is_symbol (X)) + +#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS) \ + do { \ + if ((ARGS) == (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), \ + "too few arguments: want " \ + #TARGET "("#WANT"/"#CTYPE")\n"); \ + if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \ + char ffi_error_message[256]; \ + snprintf (ffi_error_message, sizeof ffi_error_message, \ + "argument %d must be: " #WANT "\n", ffi_arg_index); \ + return (SC)->vptr->mk_string ((SC), ffi_error_message); \ + } \ + TARGET = CONVERSION_##WANT (SC, pair_car (ARGS)); \ + ARGS = pair_cdr (ARGS); \ + ffi_arg_index += 1; \ + } while (0) + +#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS) \ + do { \ + if ((ARGS) != (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), "too many arguments"); \ + } while (0) + +#define FFI_RETURN_ERR(SC, ERR) \ + return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1) + +#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err) + +#define FFI_RETURN_POINTER(SC, X) \ + return _cons ((SC), mk_integer ((SC), err), \ + _cons ((SC), (X), (SC)->NIL, 1), 1) +#define FFI_RETURN_INT(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X))) +#define FFI_RETURN_STRING(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_string ((SC), (X))) + +const char *ffi_schemify_name (const char *s, int macro); + +void ffi_scheme_eval (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); +pointer ffi_sprintf (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); + +#define ffi_define_function_name(SC, NAME, F) \ + do { \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), ffi_schemify_name ("_" #F, 0)), \ + mk_foreign_func ((SC), (do_##F))); \ + ffi_scheme_eval ((SC), \ + "(define (%s . a) (ffi-apply \"%s\" %s a))", \ + (NAME), (NAME), ffi_schemify_name ("_" #F, 0)); \ + } while (0) + +#define ffi_define_function(SC, F) \ + ffi_define_function_name ((SC), ffi_schemify_name (#F, 0), F) + +#define ffi_define_constant(SC, C) \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), ffi_schemify_name (#C, 1)), \ + mk_integer ((SC), (C))) + +#define ffi_define(SC, SYM, EXP) \ + scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP) + +#define ffi_define_variable_pointer(SC, C, P) \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), ffi_schemify_name (#C, 0)), \ + (P)) + +#define ffi_define_variable_integer(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C)) + +#define ffi_define_variable_string(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: "")) + +gpg_error_t ffi_list2argv (scheme *sc, pointer list, + char ***argv, size_t *len); +gpg_error_t ffi_list2intv (scheme *sc, pointer list, + int **intv, size_t *len); + +#endif /* GPGSCM_FFI_PRIVATE_H */ diff --git a/ffi.c b/ffi.c new file mode 100644 index 0000000..babf1e1 --- /dev/null +++ b/ffi.c @@ -0,0 +1,1167 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#if HAVE_LIBREADLINE +#include +#include +#endif + +#include "../../common/util.h" +#include "../../common/exechelp.h" +#include "../../common/sysutils.h" + +#include "private.h" +#include "ffi.h" +#include "ffi-private.h" + + + +int +ffi_bool_value (scheme *sc, pointer p) +{ + return ! (p == sc->F); +} + + + +static pointer +do_logand (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = ~0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc &= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logior (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc |= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logxor (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc ^= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_lognot (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v; + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, ~v); +} + +/* User interface. */ + +static pointer +do_flush_stdio (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + fflush (stdout); + fflush (stderr); + FFI_RETURN (sc); +} + + +int use_libreadline; + +/* Read a string, and return a pointer to it. Returns NULL on EOF. */ +char * +rl_gets (const char *prompt) +{ + static char *line = NULL; + char *p; + xfree (line); + +#if HAVE_LIBREADLINE + { + line = readline (prompt); + if (line && *line) + add_history (line); + } +#else + { + size_t max_size = 0xff; + printf ("%s", prompt); + fflush (stdout); + line = xtrymalloc (max_size); + if (line != NULL) + fgets (line, max_size, stdin); + } +#endif + + /* Strip trailing whitespace. */ + if (line && strlen (line) > 0) + for (p = &line[strlen (line) - 1]; isspace (*p); p--) + *p = 0; + + return line; +} + +static pointer +do_prompt (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *prompt; + const char *line; + FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + line = rl_gets (prompt); + if (! line) + FFI_RETURN_POINTER (sc, sc->EOF_OBJ); + + FFI_RETURN_STRING (sc, line); +} + +static pointer +do_sleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int seconds; + FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + sleep (seconds); + FFI_RETURN (sc); +} + +static pointer +do_usleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + useconds_t microseconds; + FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + usleep (microseconds); + FFI_RETURN (sc); +} + +static pointer +do_chdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, path, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (chdir (name)) + FFI_RETURN_ERR (sc, errno); + FFI_RETURN (sc); +} + +static pointer +do_strerror (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int error; + FFI_ARG_OR_RETURN (sc, int, error, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_STRING (sc, gpg_strerror (error)); +} + +static pointer +do_getenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_STRING (sc, getenv (name) ?: ""); +} + +static pointer +do_setenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *value; + int overwrite; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, value, string, args); + FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, gnupg_setenv (name, value, overwrite)); +} + +static pointer +do_exit (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int retcode; + FFI_ARG_OR_RETURN (sc, int, retcode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + exit (retcode); +} + +/* XXX: use gnupgs variant b/c mode as string */ +static pointer +do_open (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + char *pathname; + int flags; + mode_t mode = 0; + FFI_ARG_OR_RETURN (sc, char *, pathname, path, args); + FFI_ARG_OR_RETURN (sc, int, flags, number, args); + if (args != sc->NIL) + FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + fd = open (pathname, flags, mode); + if (fd == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_INT (sc, fd); +} + +static pointer +do_fdopen (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FILE *stream; + int fd; + char *mode; + int kind; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + stream = fdopen (fd, mode); + if (stream == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + if (setvbuf (stream, NULL, _IONBF, 0) != 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + kind = 0; + if (strchr (mode, 'r')) + kind |= port_input; + if (strchr (mode, 'w')) + kind |= port_output; + + FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind)); +} + +static pointer +do_close (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); +} + +static pointer +do_mkdtemp (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *template; + char buffer[128]; + FFI_ARG_OR_RETURN (sc, char *, template, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (strlen (template) > sizeof buffer - 1) + FFI_RETURN_ERR (sc, EINVAL); + strncpy (buffer, template, sizeof buffer); + + FFI_RETURN_STRING (sc, gnupg_mkdtemp (buffer)); +} + +static pointer +do_unlink (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (unlink (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static gpg_error_t +unlink_recursively (const char *name) +{ + gpg_error_t err = 0; + struct stat st; + + if (stat (name, &st) == -1) + return gpg_error_from_syserror (); + + if (S_ISDIR (st.st_mode)) + { + DIR *dir; + struct dirent *dent; + + dir = opendir (name); + if (dir == NULL) + return gpg_error_from_syserror (); + + while ((dent = readdir (dir))) + { + char *child; + + if (strcmp (dent->d_name, ".") == 0 + || strcmp (dent->d_name, "..") == 0) + continue; + + child = xtryasprintf ("%s/%s", name, dent->d_name); + if (child == NULL) + { + err = gpg_error_from_syserror (); + goto leave; + } + + err = unlink_recursively (child); + xfree (child); + if (err == gpg_error_from_errno (ENOENT)) + err = 0; + if (err) + goto leave; + } + + leave: + closedir (dir); + if (! err) + rmdir (name); + return err; + } + else + if (unlink (name) == -1) + return gpg_error_from_syserror (); + return 0; +} + +static pointer +do_unlink_recursively (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = unlink_recursively (name); + FFI_RETURN (sc); +} + +static pointer +do_rename (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *old; + char *new; + FFI_ARG_OR_RETURN (sc, char *, old, string, args); + FFI_ARG_OR_RETURN (sc, char *, new, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rename (old, new) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_getcwd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result; + char *cwd; + FFI_ARGS_DONE_OR_RETURN (sc, args); + cwd = gnupg_getcwd (); + if (cwd == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + result = sc->vptr->mk_string (sc, cwd); + xfree (cwd); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_mkdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *mode; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (gnupg_mkdir (name, mode) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_rmdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rmdir (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + + + +/* estream functions. */ + +struct es_object_box +{ + estream_t stream; + int closed; +}; + +static void +es_object_finalize (scheme *sc, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + if (! box->closed) + es_fclose (box->stream); + xfree (box); +} + +static void +es_object_to_string (scheme *sc, char *out, size_t size, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + snprintf (out, size, "#estream %p", box->stream); +} + +static struct foreign_object_vtable es_object_vtable = + { + es_object_finalize, + es_object_to_string, + }; + +static pointer +es_wrap (scheme *sc, estream_t stream) +{ + struct es_object_box *box = xmalloc (sizeof *box); + if (box == NULL) + return sc->NIL; + + box->stream = stream; + box->closed = 0; + return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box); +} + +static struct es_object_box * +es_unwrap (scheme *sc, pointer object) +{ + (void) sc; + + if (! is_foreign_object (object)) + return NULL; + + if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable) + return NULL; + + return sc->vptr->get_foreign_object_data (object); +} + +#define CONVERSION_estream(SC, X) es_unwrap (SC, X) +#define IS_A_estream(SC, X) es_unwrap (SC, X) + +static pointer +do_es_fclose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = es_fclose (box->stream); + if (! err) + box->closed = 1; + FFI_RETURN (sc); +} + +static pointer +do_es_read (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + size_t bytes_to_read; + + pointer result; + void *buffer; + size_t bytes_read; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + buffer = xtrymalloc (bytes_to_read); + if (buffer == NULL) + FFI_RETURN_ERR (sc, ENOMEM); + + err = es_read (box->stream, buffer, bytes_to_read, &bytes_read); + if (err) + FFI_RETURN_ERR (sc, err); + + result = sc->vptr->mk_counted_string (sc, buffer, bytes_read); + xfree (buffer); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_es_feof (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F); +} + +static pointer +do_es_write (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + const char *buffer; + size_t bytes_to_write, bytes_written; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + /* XXX how to get the length of the string buffer? scheme strings + may contain \0. */ + FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + bytes_to_write = strlen (buffer); + while (bytes_to_write > 0) + { + err = es_write (box->stream, buffer, bytes_to_write, &bytes_written); + if (err) + break; + bytes_to_write -= bytes_written; + buffer += bytes_written; + } + + FFI_RETURN (sc); +} + + + +/* Process handling. */ + +static pointer +do_spawn_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + unsigned int flags; + + estream_t infp; + estream_t outfp; + estream_t errfp; + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process (argv[0], (const char **) &argv[1], + GPG_ERR_SOURCE_DEFAULT, + NULL, + flags, + &infp, &outfp, &errfp, &pid); + xfree (argv); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) +#define IMS(A, B) \ + _cons (sc, es_wrap (sc, (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMS (infp, + IMS (outfp, + IMS (errfp, + IMC (pid, sc->NIL))))); +#undef IMS +#undef IMC +} + +static pointer +do_spawn_process_fd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + int infd, outfd, errfd; + + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, int, infd, number, args); + FFI_ARG_OR_RETURN (sc, int, outfd, number, args); + FFI_ARG_OR_RETURN (sc, int, errfd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1], + infd, outfd, errfd, &pid); + xfree (argv); + FFI_RETURN_INT (sc, pid); +} + +static pointer +do_wait_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *name; + pid_t pid; + int hang; + + int retcode; + + FFI_ARG_OR_RETURN (sc, const char *, name, string, args); + FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_wait_process (name, pid, hang, &retcode); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return code speak for itself. */ + + FFI_RETURN_INT (sc, retcode); +} + + +static pointer +do_wait_processes (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer list_names; + char **names; + pointer list_pids; + size_t i, count; + pid_t *pids; + int hang; + int *retcodes; + pointer retcodes_list = sc->NIL; + + FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args); + FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (sc->vptr->list_length (sc, list_names) + != sc->vptr->list_length (sc, list_pids)) + return + sc->vptr->mk_string (sc, "length of first two arguments must match"); + + err = ffi_list2argv (sc, list_names, &names, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) count); + if (err) + FFI_RETURN_ERR (sc, err); + + err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of second argument is " + "neither string nor symbol", + (unsigned long) count); + if (err) + FFI_RETURN_ERR (sc, err); + + retcodes = xtrycalloc (sizeof *retcodes, count); + if (retcodes == NULL) + { + xfree (names); + xfree (pids); + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + } + + err = gnupg_wait_processes ((const char **) names, pids, count, hang, + retcodes); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return codes speak. */ + + for (i = 0; i < count; i++) + retcodes_list = + (sc->vptr->cons) (sc, + sc->vptr->mk_integer (sc, + (long) retcodes[count-1-i]), + retcodes_list); + + FFI_RETURN_POINTER (sc, retcodes_list); +} + + +static pointer +do_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_pipe (filedes); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_inbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_inbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_outbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_outbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + + + +/* Test helper functions. */ +static pointer +do_file_equal (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result = sc->F; + char *a_name, *b_name; + int binary; + const char *mode; + FILE *a_stream = NULL, *b_stream = NULL; + struct stat a_stat, b_stat; +#define BUFFER_SIZE 1024 + char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE]; +#undef BUFFER_SIZE + size_t chunk; + + FFI_ARG_OR_RETURN (sc, char *, a_name, string, args); + FFI_ARG_OR_RETURN (sc, char *, b_name, string, args); + FFI_ARG_OR_RETURN (sc, int, binary, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + mode = binary ? "rb" : "r"; + a_stream = fopen (a_name, mode); + if (a_stream == NULL) + goto errout; + + b_stream = fopen (b_name, mode); + if (b_stream == NULL) + goto errout; + + if (fstat (fileno (a_stream), &a_stat) < 0) + goto errout; + + if (fstat (fileno (b_stream), &b_stat) < 0) + goto errout; + + if (binary && a_stat.st_size != b_stat.st_size) + { + if (verbose) + fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n", + a_name, b_name, (unsigned long) a_stat.st_size, + (unsigned long) b_stat.st_size); + + goto out; + } + + while (! feof (a_stream)) + { + chunk = sizeof a_buf; + + chunk = fread (a_buf, 1, chunk, a_stream); + if (chunk == 0 && ferror (a_stream)) + goto errout; /* some error */ + + if (fread (b_buf, 1, chunk, b_stream) < chunk) + { + if (feof (b_stream)) + goto out; /* short read */ + goto errout; /* some error */ + } + + if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0) + goto out; + } + + fread (b_buf, 1, 1, b_stream); + if (! feof (b_stream)) + goto out; /* b is longer */ + + /* They match. */ + result = sc->T; + + out: + if (a_stream) + fclose (a_stream); + if (b_stream) + fclose (b_stream); + FFI_RETURN_POINTER (sc, result); + errout: + err = gpg_error_from_syserror (); + goto out; +} + +static pointer +do_splice (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int source; + int sink; + ssize_t len = -1; + char buffer[1024]; + ssize_t bytes_read; + FFI_ARG_OR_RETURN (sc, int, source, number, args); + FFI_ARG_OR_RETURN (sc, int, sink, number, args); + if (args != sc->NIL) + FFI_ARG_OR_RETURN (sc, ssize_t, len, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + while (len == -1 || len > 0) + { + size_t want = sizeof buffer; + if (len > 0 && (ssize_t) want > len) + want = (size_t) len; + + bytes_read = read (source, buffer, want); + if (bytes_read == 0) + break; + if (bytes_read < 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + if (write (sink, buffer, bytes_read) != bytes_read) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + if (len != -1) + len -= bytes_read; + } + FFI_RETURN (sc); +} + + +gpg_error_t +ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *argv = xtrycalloc (*len + 1, sizeof **argv); + if (*argv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_string (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list)); + else if (sc->vptr->is_symbol (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list)); + else + { + xfree (*argv); + *argv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + (*argv)[i] = NULL; + return 0; +} + +gpg_error_t +ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *intv = xtrycalloc (*len, sizeof **intv); + if (*intv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_number (sc->vptr->pair_car (list))) + (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list)); + else + { + xfree (*intv); + *intv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + + return 0; +} + + +const char * +ffi_schemify_name (const char *s, int macro) +{ + char *n = strdup (s), *p; + if (n == NULL) + return s; + for (p = n; *p; p++) + { + *p = (char) tolower (*p); + /* We convert _ to - in identifiers. We allow, however, for + function names to start with a leading _. The functions in + this namespace are not yet finalized and might change or + vanish without warning. Use them with care. */ + if (! macro + && p != n + && *p == '_') + *p = '-'; + } + return n; +} + +pointer +ffi_sprintf (scheme *sc, const char *format, ...) +{ + pointer result; + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return NULL; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + result = sc->vptr->mk_string (sc, expression); + xfree (expression); + return result; +} + +void +ffi_scheme_eval (scheme *sc, const char *format, ...) +{ + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + sc->vptr->load_string (sc, expression); + xfree (expression); +} + +gpg_error_t +ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) +{ + int i; + pointer args = sc->NIL; + + /* bitwise arithmetic */ + ffi_define_function (sc, logand); + ffi_define_function (sc, logior); + ffi_define_function (sc, logxor); + ffi_define_function (sc, lognot); + + /* libc. */ + ffi_define_constant (sc, O_RDONLY); + ffi_define_constant (sc, O_WRONLY); + ffi_define_constant (sc, O_RDWR); + ffi_define_constant (sc, O_CREAT); + ffi_define_constant (sc, O_APPEND); +#ifndef O_BINARY +# define O_BINARY 0 +#endif +#ifndef O_TEXT +# define O_TEXT 0 +#endif + ffi_define_constant (sc, O_BINARY); + ffi_define_constant (sc, O_TEXT); + ffi_define_constant (sc, STDIN_FILENO); + ffi_define_constant (sc, STDOUT_FILENO); + ffi_define_constant (sc, STDERR_FILENO); + + ffi_define_function (sc, sleep); + ffi_define_function (sc, usleep); + ffi_define_function (sc, chdir); + ffi_define_function (sc, strerror); + ffi_define_function (sc, getenv); + ffi_define_function (sc, setenv); + ffi_define_function (sc, exit); + ffi_define_function (sc, open); + ffi_define_function (sc, fdopen); + ffi_define_function (sc, close); + ffi_define_function (sc, mkdtemp); + ffi_define_function (sc, unlink); + ffi_define_function (sc, unlink_recursively); + ffi_define_function (sc, rename); + ffi_define_function (sc, getcwd); + ffi_define_function (sc, mkdir); + ffi_define_function (sc, rmdir); + + /* Process management. */ + ffi_define_function (sc, spawn_process); + ffi_define_function (sc, spawn_process_fd); + ffi_define_function (sc, wait_process); + ffi_define_function (sc, wait_processes); + ffi_define_function (sc, pipe); + ffi_define_function (sc, inbound_pipe); + ffi_define_function (sc, outbound_pipe); + + /* estream functions. */ + ffi_define_function_name (sc, "es-fclose", es_fclose); + ffi_define_function_name (sc, "es-read", es_read); + ffi_define_function_name (sc, "es-feof", es_feof); + ffi_define_function_name (sc, "es-write", es_write); + + /* Test helper functions. */ + ffi_define_function (sc, file_equal); + ffi_define_function (sc, splice); + + /* User interface. */ + ffi_define_function (sc, flush_stdio); + ffi_define_function (sc, prompt); + + /* Configuration. */ + ffi_define (sc, "*verbose*", sc->vptr->mk_integer (sc, verbose)); + + ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); + for (i = argc - 1; i >= 0; i--) + { + pointer value = sc->vptr->mk_string (sc, argv[i]); + args = (sc->vptr->cons) (sc, value, args); + } + ffi_define (sc, "*args*", args); + +#if _WIN32 + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';')); +#else + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); +#endif + + ffi_define (sc, "*stdin*", + sc->vptr->mk_port_from_file (sc, stdin, port_input)); + ffi_define (sc, "*stdout*", + sc->vptr->mk_port_from_file (sc, stdout, port_output)); + ffi_define (sc, "*stderr*", + sc->vptr->mk_port_from_file (sc, stderr, port_output)); + + return 0; +} diff --git a/ffi.h b/ffi.h new file mode 100644 index 0000000..02dd99d --- /dev/null +++ b/ffi.h @@ -0,0 +1,30 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef GPGSCM_FFI_H +#define GPGSCM_FFI_H + +#include +#include "scheme.h" + +gpg_error_t ffi_init (scheme *sc, const char *argv0, + int argc, const char **argv); + +#endif /* GPGSCM_FFI_H */ diff --git a/ffi.scm b/ffi.scm new file mode 100644 index 0000000..d0b8a99 --- /dev/null +++ b/ffi.scm @@ -0,0 +1,40 @@ +;; FFI interface for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Foreign function wrapper. Expects F to return a list with the +;; first element being the `error_t' value returned by the foreign +;; function. The error is thrown, or the cdr of the result is +;; returned. +(define (ffi-apply name f args) + (let ((result (apply f args))) + (cond + ((string? result) + (ffi-fail name args result)) + ((not (= (car result) 0)) + (ffi-fail name args (strerror (car result)))) + ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) + ((= (car result) 0) '()) + (else + (throw (list "Result violates FFI calling convention: " result)))))) + +(define (ffi-fail name args message) + (let ((args' (open-output-string))) + (write (cons (string->symbol name) args) args') + (throw (string-append + (get-output-string args') ": " message)))) diff --git a/lib.scm b/lib.scm new file mode 100644 index 0000000..871cc8f --- /dev/null +++ b/lib.scm @@ -0,0 +1,163 @@ +;; Additional library functions for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(macro (assert form) + `(if (not ,(cadr form)) + (begin + (display (list "Assertion failed:" (quote ,(cadr form)))) + (newline) + (exit 1)))) +(assert #t) + +(define (filter pred lst) + (cond ((null? lst) '()) + ((pred (car lst)) + (cons (car lst) (filter pred (cdr lst)))) + (else (filter pred (cdr lst))))) + +(define (any p l) + (cond ((null? l) #f) + ((p (car l)) #t) + (else (any p (cdr l))))) + +(define (all p l) + (cond ((null? l) #t) + ((not (p (car l))) #f) + (else (all p (cdr l))))) + +;; Is PREFIX a prefix of S? +(define (string-prefix? s prefix) + (and (>= (string-length s) (string-length prefix)) + (string=? prefix (substring s 0 (string-length prefix))))) +(assert (string-prefix? "Scheme" "Sch")) + +;; Is SUFFIX a suffix of S? +(define (string-suffix? s suffix) + (and (>= (string-length s) (string-length suffix)) + (string=? suffix (substring s (- (string-length s) + (string-length suffix)) + (string-length s))))) +(assert (string-suffix? "Scheme" "eme")) + +;; Locate the first occurrence of needle in haystack. +(define (string-index haystack needle) + (define (index i haystack needle) + (if (= (length haystack) 0) + #f + (if (char=? (car haystack) needle) + i + (index (+ i 1) (cdr haystack) needle)))) + (index 0 (string->list haystack) needle)) + +;; Locate the last occurrence of needle in haystack. +(define (string-rindex haystack needle) + (let ((rindex (string-index (list->string (reverse (string->list haystack))) + needle))) + (if rindex (- (string-length haystack) rindex 1) #f))) + +;; Split haystack at delimiter at most n times. +(define (string-splitn haystack delimiter n) + (define (split acc haystack delimiter n) + (if (= (string-length haystack) 0) + (reverse acc) + (let ((i (string-index haystack delimiter))) + (if (not (or (eq? i #f) (= 0 n))) + (split (cons (substring haystack 0 i) acc) + (substring haystack (+ i 1) (string-length haystack)) + delimiter (- n 1)) + (split (cons haystack acc) "" delimiter 0) + )))) + (split '() haystack delimiter n)) + +;; Split haystack at delimiter. +(define (string-split haystack delimiter) + (string-splitn haystack delimiter -1)) + +;; Trim the prefix of S containing only characters that make PREDICATE +;; true. For example (string-ltrim char-whitespace? " foo") => +;; "foo". +(define (string-ltrim predicate s) + (let loop ((s' (string->list s))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string s')))) + +;; Trim the suffix of S containing only characters that make PREDICATE +;; true. +(define (string-rtrim predicate s) + (let loop ((s' (reverse (string->list s)))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string (reverse s'))))) + +;; Trim both the prefix and suffix of S containing only characters +;; that make PREDICATE true. +(define (string-trim predicate s) + (string-ltrim predicate (string-rtrim predicate s))) + +(define (string-contains? s contained) + (let loop ((offset 0)) + (if (<= (+ offset (string-length contained)) (string-length s)) + (if (string=? (substring s offset (+ offset (string-length contained))) + contained) + #t + (loop (+ 1 offset))) + #f))) + +(define (echo . msg) + (for-each (lambda (x) (display x) (display " ")) msg) + (newline)) + +;; Read a word from port P. +(define (read-word . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char-alphabetic? c) + (apply read-char p) + (cons c (f))) + (else + (apply read-char p) + '())))))) + +;; Read a line from port P. +(define (read-line . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char=? c #\newline) + (apply read-char p) + '()) + (else + (apply read-char p) + (cons c (f)))))))) + +;; Read everything from port P. +(define (read-all . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + (else (apply read-char p) + (cons c (f)))))))) diff --git a/main.c b/main.c new file mode 100644 index 0000000..3414e3d --- /dev/null +++ b/main.c @@ -0,0 +1,286 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "private.h" +#include "scheme.h" +#include "ffi.h" +#include "i18n.h" +#include "../../common/argparse.h" +#include "../../common/init.h" +#include "../../common/logging.h" +#include "../../common/strlist.h" +#include "../../common/sysutils.h" + +/* The TinyScheme banner. Unfortunately, it isn't in the header + file. */ +#define ts_banner "TinyScheme 1.41" + +int verbose; + + + +/* Constants to identify the commands and options. */ +enum cmd_and_opt_values + { + aNull = 0, + oVerbose = 'v', + }; + +/* The list of commands and options. */ +static ARGPARSE_OPTS opts[] = + { + ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")), + ARGPARSE_end (), + }; + +char *scmpath = ""; +size_t scmpath_len = 0; + +/* Command line parsing. */ +static void +parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) +{ + int no_more_options = 0; + + while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts)) + { + switch (pargs->r_opt) + { + case oVerbose: + verbose++; + break; + + default: + pargs->err = 2; + break; + } + } +} + +/* Print usage information and and provide strings for help. */ +static const char * +my_strusage( int level ) +{ + const char *p; + + switch (level) + { + case 11: p = "gpgscm (@GNUPG@)"; + break; + case 13: p = VERSION; break; + case 17: p = PRINTABLE_OS_NAME; break; + case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break; + + case 1: + case 40: + p = _("Usage: gpgscm [options] [file] (-h for help)"); + break; + case 41: + p = _("Syntax: gpgscm [options] [file]\n" + "Execute the given Scheme program, or spawn interactive shell.\n"); + break; + + default: p = NULL; break; + } + return p; +} + + +/* Load the Scheme program from FILE_NAME. If FILE_NAME is not an + absolute path, and LOOKUP_IN_PATH is given, then it is qualified + with the values in scmpath until the file is found. */ +static gpg_error_t +load (scheme *sc, char *file_name, + int lookup_in_cwd, int lookup_in_path) +{ + gpg_error_t err = 0; + size_t n; + const char *directory; + char *qualified_name = file_name; + int use_path; + FILE *h = NULL; + + use_path = + lookup_in_path && ! (file_name[0] == '/' || scmpath_len == 0); + + if (file_name[0] == '/' || lookup_in_cwd || scmpath_len == 0) + { + h = fopen (file_name, "r"); + if (! h) + err = gpg_error_from_syserror (); + } + + if (h == NULL && use_path) + for (directory = scmpath, n = scmpath_len; n; + directory += strlen (directory) + 1, n--) + { + if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0) + return gpg_error_from_syserror (); + + h = fopen (qualified_name, "r"); + if (h) + break; + + if (n > 1) + { + free (qualified_name); + continue; /* Try again! */ + } + + err = gpg_error_from_syserror (); + } + + if (h == NULL) + { + /* Failed and no more elements in scmpath to try. */ + fprintf (stderr, "Could not read %s: %s.\n", + qualified_name, gpg_strerror (err)); + if (lookup_in_path) + fprintf (stderr, + "Consider using GPGSCM_PATH to specify the location " + "of the Scheme library.\n"); + return err; + } + if (verbose > 1) + fprintf (stderr, "Loading %s...\n", qualified_name); + scheme_load_named_file (sc, h, qualified_name); + fclose (h); + + if (file_name != qualified_name) + free (qualified_name); + return 0; +} + + + +int +main (int argc, char **argv) +{ + gpg_error_t err; + char *argv0; + ARGPARSE_ARGS pargs; + scheme *sc; + char *p; +#if _WIN32 + char pathsep = ';'; +#else + char pathsep = ':'; +#endif + char *script = NULL; + + /* Save argv[0] so that we can re-exec. */ + argv0 = argv[0]; + + /* Parse path. */ + if (getenv ("GPGSCM_PATH")) + scmpath = getenv ("GPGSCM_PATH"); + + p = scmpath = strdup (scmpath); + if (p == NULL) + return 2; + + if (*p) + scmpath_len++; + for (; *p; p++) + if (*p == pathsep) + *p = 0, scmpath_len++; + + set_strusage (my_strusage); + log_set_prefix ("gpgscm", 1); + + /* Make sure that our subsystems are ready. */ + i18n_init (); + init_common_subsystems (&argc, &argv); + + if (!gcry_check_version (GCRYPT_VERSION)) + { + fputs ("libgcrypt version mismatch\n", stderr); + exit (2); + } + + /* Parse the command line. */ + pargs.argc = &argc; + pargs.argv = &argv; + pargs.flags = 0; + parse_arguments (&pargs, opts); + + if (log_get_errorcount (0)) + exit (2); + + sc = scheme_init_new (); + if (! sc) { + fprintf (stderr, "Could not initialize TinyScheme!\n"); + return 2; + } + scheme_set_input_port_file (sc, stdin); + scheme_set_output_port_file (sc, stderr); + + if (argc) + { + script = argv[0]; + argc--, argv++; + } + + err = load (sc, "init.scm", 0, 1); + if (! err) + err = load (sc, "ffi.scm", 0, 1); + if (! err) + err = ffi_init (sc, argv0, argc, (const char **) argv); + if (! err) + err = load (sc, "lib.scm", 0, 1); + if (! err) + err = load (sc, "repl.scm", 0, 1); + if (! err) + err = load (sc, "tests.scm", 0, 1); + if (err) + { + fprintf (stderr, "Error initializing gpgscm: %s.\n", + gpg_strerror (err)); + exit (2); + } + + if (script == NULL) + { + /* Interactive shell. */ + fprintf (stderr, "gpgscm/"ts_banner".\n"); + scheme_load_string (sc, "(interactive-repl)"); + } + else + { + err = load (sc, script, 1, 1); + if (err) + log_fatal ("%s: %s", script, gpg_strerror (err)); + } + + scheme_deinit (sc); + return EXIT_SUCCESS; +} diff --git a/private.h b/private.h new file mode 100644 index 0000000..efa0cb0 --- /dev/null +++ b/private.h @@ -0,0 +1,26 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef __GPGSCM_PRIVATE_H__ +#define __GPGSCM_PRIVATE_H__ + +extern int verbose; + +#endif /* __GPGSCM_PRIVATE_H__ */ diff --git a/repl.scm b/repl.scm new file mode 100644 index 0000000..896554f --- /dev/null +++ b/repl.scm @@ -0,0 +1,50 @@ +;; A read-evaluate-print-loop for gpgscm. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Interactive repl using 'prompt' function. P must be a function +;; that given the current entered prefix returns the prompt to +;; display. +(define (repl p) + (let ((repl-environment (make-environment))) + (call/cc + (lambda (exit) + (let loop ((prefix "")) + (let ((line (prompt (p prefix)))) + (if (and (not (eof-object? line)) (= 0 (string-length line))) + (exit (loop prefix))) + (if (not (eof-object? line)) + (let* ((next (string-append prefix line)) + (c (catch (begin (echo "Parse error:" *error*) + (loop prefix)) + (read (open-input-string next))))) + (if (not (eof-object? c)) + (begin + (catch (echo "Error:" *error*) + (echo " ===>" (eval c repl-environment))) + (exit (loop "")))) + (exit (loop next)))))))))) + +(define (prompt-append-prefix prompt prefix) + (string-append prompt (if (> (string-length prefix) 0) + (string-append prefix "...") + "> "))) + +;; Default repl run by main.c. +(define (interactive-repl) + (repl (lambda (p) (prompt-append-prefix "gpgscm " p)))) diff --git a/scheme-config.h b/scheme-config.h new file mode 100644 index 0000000..fe3d746 --- /dev/null +++ b/scheme-config.h @@ -0,0 +1,36 @@ +/* TinyScheme configuration. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#define STANDALONE 0 +#define USE_MATH 0 +#define USE_CHAR_CLASSIFIERS 1 +#define USE_ASCII_NAMES 1 +#define USE_STRING_PORTS 1 +#define USE_ERROR_HOOK 1 +#define USE_TRACING 1 +#define USE_COLON_HOOK 1 +#define USE_DL 0 +#define USE_PLIST 0 +#define USE_INTERFACE 1 +#define SHOW_ERROR_LINE 1 + +#if __MINGW32__ +# define USE_STRLWR 0 +#endif /* __MINGW32__ */ diff --git a/t-child.c b/t-child.c new file mode 100644 index 0000000..fe2e7b4 --- /dev/null +++ b/t-child.c @@ -0,0 +1,66 @@ +/* Sanity check for the process and IPC primitives. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include +#include +#include + +#ifdef _WIN32 +# include +# include +#endif + +int +main (int argc, char **argv) +{ +#if _WIN32 + if (! setmode (stdin, O_BINARY)) + return 23; + if (! setmode (stdout, O_BINARY)) + return 23; +#endif + + if (argc == 1) + return 2; + else if (strcmp (argv[1], "return0") == 0) + return 0; + else if (strcmp (argv[1], "return1") == 0) + return 1; + else if (strcmp (argv[1], "return77") == 0) + return 77; + else if (strcmp (argv[1], "hello_stdout") == 0) + fprintf (stdout, "hello"); + else if (strcmp (argv[1], "hello_stderr") == 0) + fprintf (stderr, "hello"); + else if (strcmp (argv[1], "cat") == 0) + while (! feof (stdin)) + { + char buffer[4096]; + size_t bytes_read; + bytes_read = fread (buffer, 1, sizeof buffer, stdin); + fwrite (buffer, 1, bytes_read, stdout); + } + else + { + fprintf (stderr, "unknown command %s\n", argv[1]); + return 2; + } + return 0; +} diff --git a/t-child.scm b/t-child.scm new file mode 100644 index 0000000..27928f6 --- /dev/null +++ b/t-child.scm @@ -0,0 +1,93 @@ +;; Tests for the low-level process and IPC primitives. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(echo "Testing process and IPC primitives...") + +(define (qualify executable) + (string-append executable (getenv "EXEEXT"))) + +(assert (= 0 (call `(,(qualify "t-child") "return0")))) +(assert (= 1 (call `(,(qualify "t-child") "return1")))) +(assert (= 77 (call `(,(qualify "t-child") "return77")))) + +(let ((r (call-with-io `(,(qualify "t-child") "return0") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return1") ""))) + (assert (= 1 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return77") ""))) + (assert (= 77 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "hello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "hello" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello"))) + (assert (= 0 (:retcode r))) + (assert (string=? "hellohello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(define (spawn what) + (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO)) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return1"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(1 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return77"))) + (pid2 (spawn `(,(qualify "t-child") "return1")))) + (assert (equal? '(0 77 1) + (wait-processes '("child0" "child1" "child2") + (list pid0 pid1 pid2) #t)))) + +(let* ((p (pipe)) + (pid0 (spawn-process-fd + `(,(qualify "t-child") "hello_stdout") + CLOSED_FD (:write-end p) STDERR_FILENO)) + (_ (close (:write-end p))) + (pid1 (spawn-process-fd + `(,(qualify "t-child") "cat") + (:read-end p) STDOUT_FILENO STDERR_FILENO))) + (close (:read-end p)) + (assert + (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) +(echo " world.") + +(echo "All good.") diff --git a/tests.scm b/tests.scm new file mode 100644 index 0000000..7e20c34 --- /dev/null +++ b/tests.scm @@ -0,0 +1,402 @@ +;; Common definitions for writing tests. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Trace displays and returns the given value. A debugging aid. +(define (trace x) + (display x) + (newline) + x) + +;; Stringification. +(define (stringify expression) + (let ((p (open-output-string))) + (write expression p) + (get-output-string p))) + +;; Reporting. +(define (info msg) + (display msg) + (newline) + (flush-stdio)) + +(define (error msg) + (info msg) + (exit 1)) + +(define (skip msg) + (info msg) + (exit 77)) + +(define (make-counter) + (let ((c 0)) + (lambda () + (let ((r c)) + (set! c (+ 1 c)) + r)))) + +(define *progress-nesting* 0) + +(define (call-with-progress msg what) + (set! *progress-nesting* (+ 1 *progress-nesting*)) + (if (= 1 *progress-nesting*) + (begin + (info msg) + (display " > ") + (flush-stdio) + (what (lambda (item) + (display item) + (display " ") + (flush-stdio))) + (info "< ")) + (begin + (what (lambda (item) (display ".") (flush-stdio))) + (display " ") + (flush-stdio))) + (set! *progress-nesting* (- *progress-nesting* 1))) + +(define (for-each-p msg proc lst) + (for-each-p' msg proc (lambda (x) x) lst)) + +(define (for-each-p' msg proc fmt lst) + (call-with-progress + msg + (lambda (progress) + (for-each (lambda (a) + (progress (fmt a)) + (proc a)) + lst)))) + +;; Process management. +(define CLOSED_FD -1) +(define (call-with-fds what infd outfd errfd) + (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t)) +(define (call what) + (call-with-fds what + CLOSED_FD + (if (< *verbose* 0) STDOUT_FILENO CLOSED_FD) + (if (< *verbose* 0) STDERR_FILENO CLOSED_FD))) +(define (call-check what) + (if (not (= 0 (call what))) + (throw (list what "failed")))) + +;; Accessor functions for the results of 'spawn-process'. +(define :stdin car) +(define :stdout cadr) +(define :stderr caddr) +(define :pid cadddr) + +(define (call-with-io what in) + (let ((h (spawn-process what 0))) + (es-write (:stdin h) in) + (es-fclose (:stdin h)) + (let* ((out (es-read-all (:stdout h))) + (err (es-read-all (:stderr h))) + (result (wait-process (car what) (:pid h) #t))) + (es-fclose (:stdout h)) + (es-fclose (:stderr h)) + (list result out err)))) + +;; Accessor function for the results of 'call-with-io'. ':stdout' and +;; ':stderr' can also be used. +(define :retcode car) + +(define (call-popen command input-string) + (let ((result (call-with-io command input-string))) + (if (= 0 (:retcode result)) + (:stdout result) + (throw (:stderr result))))) + +;; +;; estream helpers. +;; + +(define (es-read-all stream) + (let loop + ((acc "")) + (if (es-feof stream) + acc + (loop (string-append acc (es-read stream 4096)))))) + +;; +;; File management. +;; +(define (file=? a b) + (file-equal a b #t)) + +(define (text-file=? a b) + (file-equal a b #f)) + +(define (file-copy from to) + (catch '() (unlink to)) + (letfd ((source (open from (logior O_RDONLY O_BINARY))) + (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (splice source sink))) + +(define (text-file-copy from to) + (catch '() (unlink to)) + (letfd ((source (open from O_RDONLY)) + (sink (open to (logior O_WRONLY O_CREAT) #o600))) + (splice source sink))) + +(define (canonical-path path) + (if (char=? #\/ (string-ref path 0)) + path + (string-append (getcwd) "/" path))) + +(define (in-srcdir what) + (canonical-path (string-append (getenv "srcdir") "/" what))) + +(define (with-path name) + (let loop ((path (string-split (getenv "GPGSCM_PATH") #\:))) + (if (null? path) + name + (let* ((qualified-name (string-append (car path) "/" name)) + (file-exists (call-with-input-file qualified-name + (lambda (x) #t)))) + (if file-exists + qualified-name + (loop (cdr path))))))) + +(define (basename path) + (let ((i (string-index path #\/))) + (if (equal? i #f) + path + (basename (substring path (+ 1 i) (string-length path)))))) + +;; Helper for (pipe). +(define :read-end car) +(define :write-end cadr) + +;; let-like macro that manages file descriptors. +;; +;; (letfd ) +;; +;; Bind all variables given in and initialize each of them +;; to the given initial value, and close them after evaluting . +(macro (letfd form) + (let ((result-sym (gensym))) + `((lambda (,(caaadr form)) + (let ((,result-sym + ,(if (= 1 (length (cadr form))) + `(begin ,@(cddr form)) + `(letfd ,(cdadr form) ,@(cddr form))))) + (close ,(caaadr form)) + ,result-sym)) ,@(cdaadr form)))) + +(macro (with-working-directory form) + (let ((result-sym (gensym)) (cwd-sym (gensym))) + `(let* ((,cwd-sym (getcwd)) + (_ (if ,(cadr form) (chdir ,(cadr form)))) + (,result-sym (begin ,@(cddr form)))) + (chdir ,cwd-sym) + ,result-sym))) + +(macro (with-temporary-working-directory form) + (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym))) + `(let* ((,cwd-sym (getcwd)) + (,tmp-sym (mkdtemp "gpgscm-XXXXXX")) + (_ (chdir ,tmp-sym)) + (,result-sym (begin ,@(cdr form)))) + (chdir ,cwd-sym) + (unlink-recursively ,tmp-sym) + ,result-sym))) + +(define (make-temporary-file . args) + (canonical-path (string-append (mkdtemp "gpgscm-XXXXXX") + "/" + (if (null? args) "a" (car args))))) + +(define (remove-temporary-file filename) + (catch '() + (unlink filename)) + (let ((dirname (substring filename 0 (string-rindex filename #\/)))) + (catch (echo "removing temporary directory" dirname "failed") + (rmdir dirname)))) + +;; let-like macro that manages temporary files. +;; +;; (lettmp ) +;; +;; Bind all variables given in , initialize each of them to +;; a string representing an unique path in the filesystem, and delete +;; them after evaluting . +(macro (lettmp form) + (let ((result-sym (gensym))) + `((lambda (,(caadr form)) + (let ((,result-sym + ,(if (= 1 (length (cadr form))) + `(begin ,@(cddr form)) + `(lettmp ,(cdadr form) ,@(cddr form))))) + (remove-temporary-file ,(caadr form)) + ,result-sym)) (make-temporary-file ,(symbol->string (caadr form)))))) + +(define (check-execution source transformer) + (lettmp (sink) + (transformer source sink))) + +(define (check-identity source transformer) + (lettmp (sink) + (transformer source sink) + (if (not (file=? source sink)) + (error "mismatch")))) + +;; +;; Monadic pipe support. +;; + +(define pipeM + (package + (define (new procs source sink producer) + (package + (define (dump) + (write (list procs source sink producer)) + (newline)) + (define (add-proc command pid) + (new (cons (list command pid) procs) source sink producer)) + (define (commands) + (map car procs)) + (define (pids) + (map cadr procs)) + (define (set-source source') + (new procs source' sink producer)) + (define (set-sink sink') + (new procs source sink' producer)) + (define (set-producer producer') + (if producer + (throw "producer already set")) + (new procs source sink producer')))))) + + +(define (pipe:do . commands) + (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands)) + (if (null? cmds) + (begin + (if M::producer (M::producer)) + (if (not (null? M::procs)) + (let* ((retcodes (wait-processes (map stringify (M::commands)) + (M::pids) #t)) + (results (map (lambda (p r) (append p (list r))) + M::procs retcodes)) + (failed (filter (lambda (x) (not (= 0 (caddr x)))) + results))) + (if (not (null? failed)) + (throw failed))))) ; xxx nicer reporting + (if (and (= 2 (length cmds)) (number? (cadr cmds))) + ;; hack: if it's an fd, use it as sink + (let ((M' ((car cmds) (M::set-sink (cadr cmds))))) + (if (> M::source 2) (close M::source)) + (if (> (cadr cmds) 2) (close (cadr cmds))) + (loop M' '())) + (let ((M' ((car cmds) M))) + (if (> M::source 2) (close M::source)) + (loop M' (cdr cmds))))))) + +(define (pipe:open pathname flags) + (lambda (M) + (M::set-source (open pathname flags)))) + +(define (pipe:defer producer) + (lambda (M) + (let* ((p (outbound-pipe)) + (M' (M::set-source (:read-end p)))) + (M'::set-producer (lambda () + (producer (:write-end p)) + (close (:write-end p))))))) +(define (pipe:echo data) + (pipe:defer (lambda (sink) (display data (fdopen sink "wb"))))) + +(define (pipe:spawn command) + (lambda (M) + (define (do-spawn M new-source) + (let ((pid (spawn-process-fd command M::source M::sink + (if (> *verbose* 0) + STDERR_FILENO CLOSED_FD))) + (M' (M::set-source new-source))) + (M'::add-proc command pid))) + (if (= CLOSED_FD M::sink) + (let* ((p (pipe)) + (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p)))) + (close (:write-end p)) + (M'::set-sink CLOSED_FD)) + (do-spawn M CLOSED_FD)))) + +(define (pipe:splice sink) + (lambda (M) + (splice M::source sink) + (M::set-source CLOSED_FD))) + +(define (pipe:write-to pathname flags mode) + (open pathname flags mode)) + +;; +;; Monadic transformer support. +;; + +(define (tr:do . commands) + (let loop ((tmpfiles '()) (source #f) (cmds commands)) + (if (null? cmds) + (for-each remove-temporary-file tmpfiles) + (let ((v ((car cmds) tmpfiles source))) + (loop (car v) (cadr v) (cdr cmds)))))) + +(define (tr:open pathname) + (lambda (tmpfiles source) + (list tmpfiles pathname))) + +(define (tr:spawn input command) + (lambda (tmpfiles source) + (let* ((t (make-temporary-file)) + (cmd (map (lambda (x) + (cond + ((equal? '**in** x) source) + ((equal? '**out** x) t) + (else x))) command))) + (call-popen cmd input) + (list (cons t tmpfiles) t)))) + +(define (tr:write-to pathname) + (lambda (tmpfiles source) + (rename source pathname) + (list tmpfiles pathname))) + +(define (tr:pipe-do . commands) + (lambda (tmpfiles source) + (let ((t (make-temporary-file))) + (apply pipe:do + `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) + ,@commands + ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) + (list (cons t tmpfiles) t)))) + +(define (tr:assert-identity reference) + (lambda (tmpfiles source) + (if (not (file=? source reference)) + (error "mismatch")) + (list tmpfiles source))) + +(define (tr:assert-weak-identity reference) + (lambda (tmpfiles source) + (if (not (text-file=? source reference)) + (error "mismatch")) + (list tmpfiles source))) + +(define (tr:call-with-content function) + (lambda (tmpfiles source) + (function (call-with-input-file source read-all)) + (list tmpfiles source))) -- cgit v1.2.3 From 8b1798f10c2641f79f4d770e88712be8b13dc22f Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Fri, 17 Jun 2016 18:53:14 +0200 Subject: Add license notices for TinySCHEME. * tests/gpgscm/COPYING: Rename to ... * tests/gpgscm/LICENSE.TinySCHEME: this. * AUTHORS: Add a note about TinySCHEME. * build-aux/speedo/w32/pkg-copyright.txt: Add TinySCHEME notice. -- I renamed the file with the license terms to avoid confusion with the standard name for the GPL. Signed-off-by: Werner Koch --- COPYING | 31 ------------------------------- LICENSE.TinySCHEME | 31 +++++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 31 deletions(-) delete mode 100644 COPYING create mode 100644 LICENSE.TinySCHEME diff --git a/COPYING b/COPYING deleted file mode 100644 index 23a7e85..0000000 --- a/COPYING +++ /dev/null @@ -1,31 +0,0 @@ - LICENSE TERMS - -Copyright (c) 2000, Dimitrios Souflis -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -Redistributions in binary form must reproduce the above copyright -notice, this list of conditions and the following disclaimer in the -documentation and/or other materials provided with the distribution. - -Neither the name of Dimitrios Souflis nor the names of the -contributors may be used to endorse or promote products derived from -this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR -CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LICENSE.TinySCHEME b/LICENSE.TinySCHEME new file mode 100644 index 0000000..23a7e85 --- /dev/null +++ b/LICENSE.TinySCHEME @@ -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. -- cgit v1.2.3 From d230bf3ee80cac2fe721afccab9e98b3a9be2e9a Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Fri, 17 Jun 2016 19:32:49 +0200 Subject: gpgscm: Silence compiler warnings. * tests/gpgscm/scheme.c (mk_integer): Rename arg NUM to N. (fill_vector): Ditto. (mark): Rename var NUM to N. (set_slot_in_env): Mark SC as unused. (is_any): Mark P as unused. -- Signed-off-by: Werner Koch --- scheme.c | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/scheme.c b/scheme.c index 748a022..ff595fa 100644 --- a/scheme.c +++ b/scheme.c @@ -958,11 +958,11 @@ INTERFACE pointer mk_character(scheme *sc, int c) { } /* get number atom (integer) */ -INTERFACE pointer mk_integer(scheme *sc, long num) { +INTERFACE pointer mk_integer(scheme *sc, long n) { pointer x = get_cell(sc,sc->NIL, sc->NIL); typeflag(x) = (T_NUMBER | T_ATOM); - ivalue_unchecked(x)= num; + ivalue_unchecked(x)= n; set_num_integer(x); return (x); } @@ -1028,8 +1028,8 @@ INTERFACE static pointer mk_vector(scheme *sc, int len) INTERFACE static void fill_vector(pointer vec, pointer obj) { int i; - int num=ivalue(vec)/2+ivalue(vec)%2; - for(i=0; i=0 && is_integer(p); -- cgit v1.2.3 From cdd09e054a6bc4716c7847fd0779a091cbca0e8f Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Fri, 17 Jun 2016 21:16:37 +0200 Subject: tests: Make make distcheck work again. * Makefile.am (tests): Remove test code which would led to doubling calls to for e.g. "make distclean". * tests/Makefile.am: Typo fixes. * tests/gpgscm/Makefile.am (EXTRA_DIST): Fix name of License file. Add repl.scm. (check): Replace by check-local because check is a standard automake target. * tests/openpgp/Makefile.am (TESTS_ENVIRONMENT): Replace gmake0sim by automake generated macro. (EXTRA_DIST): Add defs.scm Signed-off-by: Werner Koch --- Makefile.am | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/Makefile.am b/Makefile.am index 1fb9647..e57a4bb 100644 --- a/Makefile.am +++ b/Makefile.am @@ -18,11 +18,12 @@ # along with this program; if not, see . EXTRA_DIST = \ - COPYING \ + LICENSE.TinySCHEME \ Manual.txt \ ffi.scm \ init.scm \ lib.scm \ + repl.scm \ t-child.scm \ tests.scm @@ -31,6 +32,8 @@ include $(top_srcdir)/am/cmacros.am AM_CFLAGS = +CLEANFILES = + bin_PROGRAMS = gpgscm noinst_PROGRAMS = t-child @@ -51,7 +54,6 @@ t_child_SOURCES = t-child.c # important for things like make -j2. $(PROGRAMS): $(common_libs) -.PHONY: check -check: gpgscm$(EXEEXT) t-child$(EXEEXT) +check-local: gpgscm$(EXEEXT) t-child$(EXEEXT) EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \ ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm -- cgit v1.2.3 From 224c171c856c662d22ba236eaa2128323bde1d08 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 21 Jun 2016 12:19:07 +0200 Subject: gpgscm: Make memory allocation failures fatal. * tests/gpgscm/scheme.c (Eval_Cycle): Exit if we run out of memory. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index ff595fa..22b726f 100644 --- a/scheme.c +++ b/scheme.c @@ -4529,7 +4529,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { } if(sc->no_memory) { fprintf(stderr,"No memory!\n"); - return; + exit(1); } } } -- cgit v1.2.3 From 2bc2f95ac823f0a6449bd68dee4fc094db52f2e5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 21 Jun 2016 16:09:49 +0200 Subject: gpgscm: Improve error reporting. * tests/gpgscm/scheme.c (type_to_string): New function. (Eval_Cycle): Include actual type in error message. Signed-off-by: Justus Winter --- scheme.c | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index 22b726f..3c7910c 100644 --- a/scheme.c +++ b/scheme.c @@ -129,6 +129,30 @@ enum scheme_types { T_LAST_SYSTEM_TYPE=15 }; +static const char * +type_to_string (enum scheme_types typ) +{ + switch (typ) + { + case T_STRING: return "string"; + case T_NUMBER: return "number"; + case T_SYMBOL: return "symbol"; + case T_PROC: return "proc"; + case T_PAIR: return "pair"; + case T_CLOSURE: return "closure"; + case T_CONTINUATION: return "configuration"; + case T_FOREIGN: return "foreign"; + case T_CHARACTER: return "character"; + case T_PORT: return "port"; + case T_VECTOR: return "vector"; + case T_MACRO: return "macro"; + case T_PROMISE: return "promise"; + case T_ENVIRONMENT: return "environment"; + case T_FOREIGN_OBJECT: return "foreign object"; + } + assert (! "not reached"); +} + /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ #define ADJ 32 #define TYPE_BITS 5 @@ -4509,10 +4533,11 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { } while(iname, i+1, - tests[j].kind); + tests[j].kind, + type_to_string(type(car(arglist)))); } } } -- cgit v1.2.3 From f4a23bc0fae621ac4b0978de4ea8f976ec6b650f Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 21 Jun 2016 12:12:56 +0200 Subject: gpgscm: Use native string searching functions. * tests/gpgscm/ffi-private.h: Handle character arguments. * tests/gpgscm/ffi.c (do_string_index): New function. (do_string_rindex): Likewise. (do_string_contains): Likewise. (ffi_init): Define new functions. * tests/gpgscm/ffi.scm (ffi-define): New macro. * tests/gpgscm/lib.scm (string-index): Use native function, demonstrate behavior. (string-rindex): Likewise. (string-contains?): Likewise. Demonstrate behavior of various other functions. (read-all): Rework so that it can handle large files. Signed-off-by: Justus Winter --- ffi-private.h | 2 ++ ffi.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++ ffi.scm | 4 +++ lib.scm | 86 +++++++++++++++++++++++++++++------------------------------ 4 files changed, 118 insertions(+), 43 deletions(-) diff --git a/ffi-private.h b/ffi-private.h index 5467dac..849d1b7 100644 --- a/ffi-private.h +++ b/ffi-private.h @@ -33,6 +33,7 @@ int ffi_bool_value (scheme *sc, pointer p); #define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X) #define CONVERSION_string(SC, X) (SC)->vptr->string_value (X) +#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X) #define CONVERSION_list(SC, X) (X) #define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X)) #define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \ @@ -41,6 +42,7 @@ int ffi_bool_value (scheme *sc, pointer p); #define IS_A_number(SC, X) (SC)->vptr->is_number (X) #define IS_A_string(SC, X) (SC)->vptr->is_string (X) +#define IS_A_character(SC, X) (SC)->vptr->is_character (X) #define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X) #define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T) #define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ diff --git a/ffi.c b/ffi.c index babf1e1..fe418fc 100644 --- a/ffi.c +++ b/ffi.c @@ -939,6 +939,72 @@ do_splice (scheme *sc, pointer args) FFI_RETURN (sc); } +static pointer +do_string_index (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_rindex (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strrchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_contains (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char *needle; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char *, needle, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); +} + gpg_error_t ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) @@ -1134,6 +1200,9 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) /* Test helper functions. */ ffi_define_function (sc, file_equal); ffi_define_function (sc, splice); + ffi_define_function (sc, string_index); + ffi_define_function (sc, string_rindex); + ffi_define_function_name (sc, "string-contains?", string_contains); /* User interface. */ ffi_define_function (sc, flush_stdio); diff --git a/ffi.scm b/ffi.scm index d0b8a99..7c2f93a 100644 --- a/ffi.scm +++ b/ffi.scm @@ -38,3 +38,7 @@ (write (cons (string->symbol name) args) args') (throw (string-append (get-output-string args') ": " message)))) + +;; Pseudo-definitions for foreign functions. Evaluates to no code, +;; but serves as documentation. +(macro (ffi-define form)) diff --git a/lib.scm b/lib.scm index 871cc8f..48f53ea 100644 --- a/lib.scm +++ b/lib.scm @@ -55,48 +55,50 @@ (string-length s))))) (assert (string-suffix? "Scheme" "eme")) -;; Locate the first occurrence of needle in haystack. -(define (string-index haystack needle) - (define (index i haystack needle) - (if (= (length haystack) 0) - #f - (if (char=? (car haystack) needle) - i - (index (+ i 1) (cdr haystack) needle)))) - (index 0 (string->list haystack) needle)) - -;; Locate the last occurrence of needle in haystack. -(define (string-rindex haystack needle) - (let ((rindex (string-index (list->string (reverse (string->list haystack))) - needle))) - (if rindex (- (string-length haystack) rindex 1) #f))) +;; Locate the first occurrence of needle in haystack starting at offset. +(ffi-define (string-index haystack needle [offset])) +(assert (= 2 (string-index "Hallo" #\l))) +(assert (= 3 (string-index "Hallo" #\l 3))) +(assert (equal? #f (string-index "Hallo" #\.))) + +;; Locate the last occurrence of needle in haystack starting at offset. +(ffi-define (string-rindex haystack needle [offset])) +(assert (= 3 (string-rindex "Hallo" #\l))) +(assert (equal? #f (string-rindex "Hallo" #\a 2))) +(assert (equal? #f (string-rindex "Hallo" #\.))) ;; Split haystack at delimiter at most n times. (define (string-splitn haystack delimiter n) - (define (split acc haystack delimiter n) - (if (= (string-length haystack) 0) - (reverse acc) - (let ((i (string-index haystack delimiter))) - (if (not (or (eq? i #f) (= 0 n))) - (split (cons (substring haystack 0 i) acc) - (substring haystack (+ i 1) (string-length haystack)) - delimiter (- n 1)) - (split (cons haystack acc) "" delimiter 0) - )))) - (split '() haystack delimiter n)) + (let ((length (string-length haystack))) + (define (split acc delimiter offset n) + (if (>= offset length) + (reverse acc) + (let ((i (string-index haystack delimiter offset))) + (if (or (eq? i #f) (= 0 n)) + (reverse (cons (substring haystack offset length) acc)) + (split (cons (substring haystack offset i) acc) + delimiter (+ i 1) (- n 1)))))) + (split '() delimiter 0 n))) +(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1)))) ;; Split haystack at delimiter. (define (string-split haystack delimiter) (string-splitn haystack delimiter -1)) +(assert (= 3 (length (string-split "foo:bar:baz" #\:)))) +(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:)))) +(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:)))) +(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:)))) ;; Trim the prefix of S containing only characters that make PREDICATE -;; true. For example (string-ltrim char-whitespace? " foo") => -;; "foo". +;; true. (define (string-ltrim predicate s) (let loop ((s' (string->list s))) (if (predicate (car s')) (loop (cdr s')) (list->string s')))) +(assert (string=? "foo" (string-ltrim char-whitespace? " foo"))) ;; Trim the suffix of S containing only characters that make PREDICATE ;; true. @@ -105,20 +107,18 @@ (if (predicate (car s')) (loop (cdr s')) (list->string (reverse s'))))) +(assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) ;; Trim both the prefix and suffix of S containing only characters ;; that make PREDICATE true. (define (string-trim predicate s) (string-ltrim predicate (string-rtrim predicate s))) +(assert (string=? "foo" (string-trim char-whitespace? " foo "))) -(define (string-contains? s contained) - (let loop ((offset 0)) - (if (<= (+ offset (string-length contained)) (string-length s)) - (if (string=? (substring s offset (+ offset (string-length contained))) - contained) - #t - (loop (+ 1 offset))) - #f))) +;; Check if needle is contained in haystack. +(ffi-define (string-contains? haystack needle)) +(assert (string-contains? "Hallo" "llo")) +(assert (not (string-contains? "Hallo" "olla"))) (define (echo . msg) (for-each (lambda (x) (display x) (display " ")) msg) @@ -154,10 +154,10 @@ ;; Read everything from port P. (define (read-all . p) - (list->string - (let f () - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) '()) - (else (apply read-char p) - (cons c (f)))))))) + (let loop ((acc (open-output-string))) + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) (get-output-string acc)) + (else + (write-char (apply read-char p) acc) + (loop acc)))))) -- cgit v1.2.3 From d7df61081ec228db17e2bfe2e05820da8cc2d264 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 21 Jun 2016 12:21:10 +0200 Subject: gpgscm: Improve test framework. * tests/gpgscm/lib.scm (echo): Move... * tests/gpgscm/tests.scm (echo): ... here. (info, error, skip): And use echo here. (file-exists?): New function. (tr:spawn): Check that source exists and if the sink has been created. (tr:call-with-content): Hand in optional arguments. Signed-off-by: Justus Winter --- lib.scm | 4 ---- tests.scm | 28 +++++++++++++++++++--------- 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/lib.scm b/lib.scm index 48f53ea..e23977a 100644 --- a/lib.scm +++ b/lib.scm @@ -120,10 +120,6 @@ (assert (string-contains? "Hallo" "llo")) (assert (not (string-contains? "Hallo" "olla"))) -(define (echo . msg) - (for-each (lambda (x) (display x) (display " ")) msg) - (newline)) - ;; Read a word from port P. (define (read-word . p) (list->string diff --git a/tests.scm b/tests.scm index 7e20c34..6d70dca 100644 --- a/tests.scm +++ b/tests.scm @@ -30,17 +30,20 @@ (get-output-string p))) ;; Reporting. -(define (info msg) - (display msg) - (newline) +(define (echo . msg) + (for-each (lambda (x) (display x) (display " ")) msg) + (newline)) + +(define (info . msg) + (apply echo msg) (flush-stdio)) -(define (error msg) - (info msg) +(define (error . msg) + (apply info msg) (exit 1)) -(define (skip msg) - (info msg) +(define (skip . msg) + (apply info msg) (exit 77)) (define (make-counter) @@ -136,6 +139,9 @@ ;; ;; File management. ;; +(define (file-exists? name) + (call-with-input-file name (lambda (port) #t))) + (define (file=? a b) (file-equal a b #t)) @@ -361,6 +367,8 @@ (define (tr:spawn input command) (lambda (tmpfiles source) + (if (and (member '**in** command) (not source)) + (error (string-append (stringify cmd) " needs an input"))) (let* ((t (make-temporary-file)) (cmd (map (lambda (x) (cond @@ -368,6 +376,8 @@ ((equal? '**out** x) t) (else x))) command))) (call-popen cmd input) + (if (and (member '**out** command) (not (file-exists? t))) + (error (string-append (stringify cmd) " did not produce '" t "'."))) (list (cons t tmpfiles) t)))) (define (tr:write-to pathname) @@ -396,7 +406,7 @@ (error "mismatch")) (list tmpfiles source))) -(define (tr:call-with-content function) +(define (tr:call-with-content function . args) (lambda (tmpfiles source) - (function (call-with-input-file source read-all)) + (apply function `(,(call-with-input-file source read-all) ,@args)) (list tmpfiles source))) -- cgit v1.2.3 From 5fee932e0ad2b2f5e876a70bdeef77c38e248a2e Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 21 Jun 2016 18:12:03 +0200 Subject: gpgscm: Add more file handling functions. * tests/gpgscm/ffi.c (do_glob): New function. (ffi_init): Define new function. * tests/gpgscm/tests.scm (basename-suffix): New function.x Signed-off-by: Justus Winter --- ffi.c | 38 ++++++++++++++++++++++++++++++++++++++ tests.scm | 6 ++++++ 2 files changed, 44 insertions(+) diff --git a/ffi.c b/ffi.c index fe418fc..dcdadaa 100644 --- a/ffi.c +++ b/ffi.c @@ -25,6 +25,7 @@ #include #include #include +#include #include #include #include @@ -1005,6 +1006,42 @@ do_string_contains (scheme *sc, pointer args) FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); } +static pointer +do_glob (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result = sc->NIL; + size_t i; + char *pattern; + glob_t pglob; + FFI_ARG_OR_RETURN (sc, char *, pattern, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + switch (glob (pattern, 0, NULL, &pglob)) + { + case 0: + for (i = 0; i < pglob.gl_pathc; i++) + result = + (sc->vptr->cons) (sc, + sc->vptr->mk_string (sc, pglob.gl_pathv[i]), + result); + globfree (&pglob); + break; + + case GLOB_NOMATCH: + /* Return the empty list. */ + break; + + case GLOB_NOSPACE: + return ffi_sprintf (sc, "out of memory"); + case GLOB_ABORTED: + return ffi_sprintf (sc, "read error"); + default: + assert (! "not reached"); + } + FFI_RETURN_POINTER (sc, result); +} + gpg_error_t ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) @@ -1203,6 +1240,7 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) ffi_define_function (sc, string_index); ffi_define_function (sc, string_rindex); ffi_define_function_name (sc, "string-contains?", string_contains); + ffi_define_function (sc, glob); /* User interface. */ ffi_define_function (sc, flush_stdio); diff --git a/tests.scm b/tests.scm index 6d70dca..6c3eb79 100644 --- a/tests.scm +++ b/tests.scm @@ -185,6 +185,12 @@ path (basename (substring path (+ 1 i) (string-length path)))))) +(define (basename-suffix path suffix) + (basename + (if (string-suffix? path suffix) + (substring path 0 (- (string-length path) (string-length suffix))) + path))) + ;; Helper for (pipe). (define :read-end car) (define :write-end cadr) -- cgit v1.2.3 From 119d8f0e6172f786022de24633a2969fab356303 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 23 Jun 2016 13:18:25 +0200 Subject: gpgscm: Fix manual. -- Signed-off-by: Justus Winter --- Manual.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Manual.txt b/Manual.txt index ffda956..9fd294f 100644 --- a/Manual.txt +++ b/Manual.txt @@ -88,7 +88,7 @@ Please read accompanying file COPYING. (gc) Performs garbage collection immediatelly. - (gcverbose) (gcverbose ) + (gc-verbose) (gc-verbose ) The argument (defaulting to #t) controls whether GC produces visible outcome. -- cgit v1.2.3 From 64ab51521f1a5fabee292554d7403113898f1b28 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 23 Jun 2016 14:10:00 +0200 Subject: gpgscm: Fix Scheme initialization. This potentially causes a crash if the garbage collector marks an eof object. * tests/gpgscm/scheme.c (scheme_init_custom_alloc): Initialize 'EOF_OBJ'. Signed-off-by: Justus Winter --- scheme.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/scheme.c b/scheme.c index 3c7910c..3ed5d9b 100644 --- a/scheme.c +++ b/scheme.c @@ -4778,6 +4778,9 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { /* init F */ typeflag(sc->F) = (T_ATOM | MARK); car(sc->F) = cdr(sc->F) = sc->F; + /* init EOF_OBJ */ + typeflag(sc->EOF_OBJ) = (T_ATOM | MARK); + car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; /* init sink */ typeflag(sc->sink) = (T_PAIR | MARK); car(sc->sink) = sc->NIL; -- cgit v1.2.3 From 24df932e5fdda891760b34b7e5fccd5aba62fde8 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 23 Jun 2016 16:14:10 +0200 Subject: gpgscm: Add types for special objects. * tests/gpgscm/scheme.c (enum scheme_types): Add types for boolean, nil, eof, and the sink object. (type_to_string): Handle new types. (scheme_init_custom_alloc): Give special objects a type. Signed-off-by: Justus Winter --- scheme.c | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/scheme.c b/scheme.c index 3ed5d9b..486194c 100644 --- a/scheme.c +++ b/scheme.c @@ -126,7 +126,11 @@ enum scheme_types { T_PROMISE=13, T_ENVIRONMENT=14, T_FOREIGN_OBJECT=15, - T_LAST_SYSTEM_TYPE=15 + T_BOOLEAN=16, + T_NIL=17, + T_EOF_OBJ=18, + T_SINK=19, + T_LAST_SYSTEM_TYPE=19 }; static const char * @@ -149,6 +153,10 @@ type_to_string (enum scheme_types typ) case T_PROMISE: return "promise"; case T_ENVIRONMENT: return "environment"; case T_FOREIGN_OBJECT: return "foreign object"; + case T_BOOLEAN: return "boolean"; + case T_NIL: return "nil"; + case T_EOF_OBJ: return "eof object"; + case T_SINK: return "sink"; } assert (! "not reached"); } @@ -4770,19 +4778,19 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->tracing=0; /* init sc->NIL */ - typeflag(sc->NIL) = (T_ATOM | MARK); + typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK); car(sc->NIL) = cdr(sc->NIL) = sc->NIL; /* init T */ - typeflag(sc->T) = (T_ATOM | MARK); + typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK); car(sc->T) = cdr(sc->T) = sc->T; /* init F */ - typeflag(sc->F) = (T_ATOM | MARK); + typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK); car(sc->F) = cdr(sc->F) = sc->F; /* init EOF_OBJ */ - typeflag(sc->EOF_OBJ) = (T_ATOM | MARK); + typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK); car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; /* init sink */ - typeflag(sc->sink) = (T_PAIR | MARK); + typeflag(sc->sink) = (T_SINK | T_PAIR | MARK); car(sc->sink) = sc->NIL; /* init c_nest */ sc->c_nest = sc->NIL; -- cgit v1.2.3 From 7b6728b7ecf7b0646db2de35625aba3b0cd0bf02 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 23 Jun 2016 17:18:13 +0200 Subject: gpgscm: Handle exceptions in the transformation monad. * tests/gpgscm/tests.scm (pipe:do): Raise errors. (tr:spawn): Catch and return errors. (tr:call-with-content): Likewise. (tr:{open,write-to,pipe-do,assert-identity,assert-weak-identity}): Adapt. Signed-off-by: Justus Winter --- tests.scm | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/tests.scm b/tests.scm index 6c3eb79..ebe1be5 100644 --- a/tests.scm +++ b/tests.scm @@ -364,12 +364,19 @@ (let loop ((tmpfiles '()) (source #f) (cmds commands)) (if (null? cmds) (for-each remove-temporary-file tmpfiles) - (let ((v ((car cmds) tmpfiles source))) - (loop (car v) (cadr v) (cdr cmds)))))) + (let* ((v ((car cmds) tmpfiles source)) + (tmpfiles' (car v)) + (sink (cadr v)) + (error (caddr v))) + (if error + (begin + (for-each remove-temporary-file tmpfiles') + (throw error))) + (loop tmpfiles' sink (cdr cmds)))))) (define (tr:open pathname) (lambda (tmpfiles source) - (list tmpfiles pathname))) + (list tmpfiles pathname #f))) (define (tr:spawn input command) (lambda (tmpfiles source) @@ -381,15 +388,17 @@ ((equal? '**in** x) source) ((equal? '**out** x) t) (else x))) command))) - (call-popen cmd input) - (if (and (member '**out** command) (not (file-exists? t))) - (error (string-append (stringify cmd) " did not produce '" t "'."))) - (list (cons t tmpfiles) t)))) + (catch (list (cons t tmpfiles) t *error*) + (call-popen cmd input) + (if (and (member '**out** command) (not (file-exists? t))) + (error (string-append (stringify cmd) + " did not produce '" t "'."))) + (list (cons t tmpfiles) t #f))))) (define (tr:write-to pathname) (lambda (tmpfiles source) (rename source pathname) - (list tmpfiles pathname))) + (list tmpfiles pathname #f))) (define (tr:pipe-do . commands) (lambda (tmpfiles source) @@ -398,21 +407,22 @@ `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) ,@commands ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) - (list (cons t tmpfiles) t)))) + (list (cons t tmpfiles) t #f)))) (define (tr:assert-identity reference) (lambda (tmpfiles source) (if (not (file=? source reference)) (error "mismatch")) - (list tmpfiles source))) + (list tmpfiles source #f))) (define (tr:assert-weak-identity reference) (lambda (tmpfiles source) (if (not (text-file=? source reference)) (error "mismatch")) - (list tmpfiles source))) + (list tmpfiles source #f))) (define (tr:call-with-content function . args) (lambda (tmpfiles source) - (apply function `(,(call-with-input-file source read-all) ,@args)) - (list tmpfiles source))) + (catch (list tmpfiles source *error*) + (apply function `(,(call-with-input-file source read-all) ,@args))) + (list tmpfiles source #f))) -- cgit v1.2.3 From 73b24ed0cb0ba3271e887d1044a497e53ca90b62 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 28 Jun 2016 18:08:01 +0200 Subject: gpgscm: Fix buffer overflow. * tests/gpgscm/scheme.c (store_string): Avoid writing past allocated buffer. Signed-off-by: Justus Winter --- scheme.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 486194c..aabf400 100644 --- a/scheme.c +++ b/scheme.c @@ -1026,7 +1026,8 @@ static char *store_string(scheme *sc, int len_str, const char *str, char fill) { return sc->strbuff; } if(str!=0) { - snprintf(q, len_str+1, "%s", str); + memcpy (q, str, len_str); + q[len_str]=0; } else { memset(q, fill, len_str); q[len_str]=0; -- cgit v1.2.3 From 9368fd55602a1d36f6bf6bc3797a4f2d7a782ded Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 28 Jun 2016 18:10:01 +0200 Subject: gpgscm: Free file names. * tests/gpgscm/scheme.c (scheme_load_named_file): Free file name. Signed-off-by: Justus Winter --- scheme.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/scheme.c b/scheme.c index aabf400..4c28230 100644 --- a/scheme.c +++ b/scheme.c @@ -4938,6 +4938,11 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { if(sc->retcode==0) { sc->retcode=sc->nesting!=0; } + +#if SHOW_ERROR_LINE + sc->free(sc->load_stack[0].rep.stdio.filename); + sc->load_stack[0].rep.stdio.filename = NULL; +#endif } void scheme_load_string(scheme *sc, const char *cmd) { -- cgit v1.2.3 From b4e31c551b9205684e812e941bd974cc594cf97f Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 28 Jun 2016 18:13:40 +0200 Subject: gpgscm: Fix memory leaks. * tests/gpgscm/ffi-private.h (ffi_schemify_name): Fix prototype. (ffi_define_function_name): Free schemified name. (ffi_define_function): Likewise. (ffi_define_constant): Likewise. (ffi_define_variable_pointer): Likewise. * tests/gpgscm/ffi.c (do_wait_processes): Free arrays. (ffi_schemify_name): Fix type. * tests/gpgscm/main.c (main): Free 'sc'. Signed-off-by: Justus Winter --- ffi-private.h | 40 +++++++++++++++++++++++++++------------- ffi.c | 5 ++++- main.c | 1 + 3 files changed, 32 insertions(+), 14 deletions(-) diff --git a/ffi-private.h b/ffi-private.h index 849d1b7..87f491f 100644 --- a/ffi-private.h +++ b/ffi-private.h @@ -84,7 +84,7 @@ int ffi_bool_value (scheme *sc, pointer p); #define FFI_RETURN_STRING(SC, X) \ FFI_RETURN_POINTER ((SC), mk_string ((SC), (X))) -const char *ffi_schemify_name (const char *s, int macro); +char *ffi_schemify_name (const char *s, int macro); void ffi_scheme_eval (scheme *sc, const char *format, ...) GPGRT_ATTR_PRINTF (2, 3); @@ -93,32 +93,46 @@ pointer ffi_sprintf (scheme *sc, const char *format, ...) #define ffi_define_function_name(SC, NAME, F) \ do { \ + char *_fname = ffi_schemify_name ("_" #F, 0); \ scheme_define ((SC), \ (SC)->global_env, \ - mk_symbol ((SC), ffi_schemify_name ("_" #F, 0)), \ + mk_symbol ((SC), _fname), \ mk_foreign_func ((SC), (do_##F))); \ ffi_scheme_eval ((SC), \ "(define (%s . a) (ffi-apply \"%s\" %s a))", \ - (NAME), (NAME), ffi_schemify_name ("_" #F, 0)); \ + (NAME), (NAME), _fname); \ + free (_fname); \ } while (0) -#define ffi_define_function(SC, F) \ - ffi_define_function_name ((SC), ffi_schemify_name (#F, 0), F) +#define ffi_define_function(SC, F) \ + do { \ + char *_name = ffi_schemify_name (#F, 0); \ + ffi_define_function_name ((SC), _name, F); \ + free (_name); \ + } while (0) #define ffi_define_constant(SC, C) \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), ffi_schemify_name (#C, 1)), \ - mk_integer ((SC), (C))) + do { \ + char *_name = ffi_schemify_name (#C, 1); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + mk_integer ((SC), (C))); \ + free (_name); \ + } while (0) #define ffi_define(SC, SYM, EXP) \ scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP) #define ffi_define_variable_pointer(SC, C, P) \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), ffi_schemify_name (#C, 0)), \ - (P)) + do { \ + char *_name = ffi_schemify_name (#C, 0); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + (P)); \ + free (_name); \ + } while (0) #define ffi_define_variable_integer(SC, C) \ ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C)) diff --git a/ffi.c b/ffi.c index dcdadaa..acfe1c7 100644 --- a/ffi.c +++ b/ffi.c @@ -776,6 +776,9 @@ do_wait_processes (scheme *sc, pointer args) (long) retcodes[count-1-i]), retcodes_list); + xfree (names); + xfree (pids); + xfree (retcodes); FFI_RETURN_POINTER (sc, retcodes_list); } @@ -1098,7 +1101,7 @@ ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) } -const char * +char * ffi_schemify_name (const char *s, int macro) { char *n = strdup (s), *p; diff --git a/main.c b/main.c index 3414e3d..adb4e33 100644 --- a/main.c +++ b/main.c @@ -282,5 +282,6 @@ main (int argc, char **argv) } scheme_deinit (sc); + xfree (sc); return EXIT_SUCCESS; } -- cgit v1.2.3 From 9af66b27499646f6386ab902e75056b961192f50 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 30 Jun 2016 11:46:38 +0200 Subject: gpgscm: Use the allocator from libgcrypt. * tests/gpgscm/main.c (main): Use the allocator from libgcrypt. Signed-off-by: Justus Winter --- main.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main.c b/main.c index adb4e33..5b3792e 100644 --- a/main.c +++ b/main.c @@ -39,6 +39,7 @@ #include "../../common/logging.h" #include "../../common/strlist.h" #include "../../common/sysutils.h" +#include "../../common/util.h" /* The TinyScheme banner. Unfortunately, it isn't in the header file. */ @@ -236,7 +237,7 @@ main (int argc, char **argv) if (log_get_errorcount (0)) exit (2); - sc = scheme_init_new (); + sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free); if (! sc) { fprintf (stderr, "Could not initialize TinyScheme!\n"); return 2; -- cgit v1.2.3 From f103dd1d9dd69eb0a32cf2d91e3a595082f3f41c Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 30 Jun 2016 12:35:27 +0200 Subject: gpgscm: Free memory backing string ports. * tests/gpgscm/scheme.c (finalize_cell): Free memory backing string ports. Signed-off-by: Justus Winter --- scheme.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/scheme.c b/scheme.c index 4c28230..5f2f205 100644 --- a/scheme.c +++ b/scheme.c @@ -1390,6 +1390,8 @@ static void finalize_cell(scheme *sc, pointer a) { if(a->_object._port->kind&port_file && a->_object._port->rep.stdio.closeit) { port_close(sc,a,port_input|port_output); + } else if (a->_object._port->kind & port_srfi6) { + sc->free(a->_object._port->rep.string.start); } sc->free(a->_object._port); } else if(is_foreign_object(a)) { -- cgit v1.2.3 From 27d423b785afa3458e102fa3d7c1220ec50a47fe Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 30 Jun 2016 12:45:15 +0200 Subject: gpgscm: Fix reallocating string ports. * tests/gpgscm/scheme.c (realloc_port_string): Use memcpy because Scheme strings may contain 0s. Signed-off-by: Justus Winter --- scheme.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 5f2f205..0a76205 100644 --- a/scheme.c +++ b/scheme.c @@ -1620,12 +1620,13 @@ static void backchar(scheme *sc, int c) { static int realloc_port_string(scheme *sc, port *p) { char *start=p->rep.string.start; + size_t old_size = p->rep.string.past_the_end - start; size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; char *str=sc->malloc(new_size); if(str) { memset(str,' ',new_size-1); str[new_size-1]='\0'; - strcpy(str,start); + memcpy(str, start, old_size); p->rep.string.start=str; p->rep.string.past_the_end=str+new_size-1; p->rep.string.curr-=start-str; -- cgit v1.2.3 From 1406aa0fdf349b370cc2a5b87ada557455203dd2 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 5 Jul 2016 16:24:13 +0200 Subject: gpgscm: Improve robustness and compatibility. * tests/gpgscm/ffi.c (do_getenv): Avoid gccism. (do_mkdtemp): Handle errors. Signed-off-by: Justus Winter --- ffi.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/ffi.c b/ffi.c index acfe1c7..21beb76 100644 --- a/ffi.c +++ b/ffi.c @@ -219,9 +219,11 @@ do_getenv (scheme *sc, pointer args) { FFI_PROLOG (); char *name; + char *value; FFI_ARG_OR_RETURN (sc, char *, name, string, args); FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_STRING (sc, getenv (name) ?: ""); + value = getenv (name); + FFI_RETURN_STRING (sc, value ? value : ""); } static pointer @@ -313,6 +315,7 @@ do_mkdtemp (scheme *sc, pointer args) FFI_PROLOG (); char *template; char buffer[128]; + char *name; FFI_ARG_OR_RETURN (sc, char *, template, string, args); FFI_ARGS_DONE_OR_RETURN (sc, args); @@ -320,7 +323,10 @@ do_mkdtemp (scheme *sc, pointer args) FFI_RETURN_ERR (sc, EINVAL); strncpy (buffer, template, sizeof buffer); - FFI_RETURN_STRING (sc, gnupg_mkdtemp (buffer)); + name = gnupg_mkdtemp (buffer); + if (name == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_STRING (sc, name); } static pointer -- cgit v1.2.3 From 228b225c412573d73901e3e79b7cab64a05bb26e Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 5 Jul 2016 16:25:21 +0200 Subject: tests: Honor environment variable 'TMP'. This fixes problems with long socket names, e.g. when doing distcheck. * tests/gpgscm/tests.scm (path-join): New function. (with-temporary-working-directory): Honor 'TMP'. (make-temporary-file): Likewise. * tests/migrations/Makefile.am (TMP): Default to '/tmp'. (TESTS_ENVIRONMENT): Set 'TMP'. * tests/openpgp/Makefile.am (TMP): Default to '/tmp'. (TESTS_ENVIRONMENT): Set 'TMP'. Signed-off-by: Justus Winter --- tests.scm | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/tests.scm b/tests.scm index ebe1be5..2728817 100644 --- a/tests.scm +++ b/tests.scm @@ -160,6 +160,18 @@ (sink (open to (logior O_WRONLY O_CREAT) #o600))) (splice source sink))) +(define (path-join . components) + (let loop ((acc #f) (rest (filter (lambda (s) + (not (string=? "" s))) components))) + (if (null? rest) + acc + (loop (if (string? acc) + (string-append acc "/" (car rest)) + (car rest)) + (cdr rest))))) +(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz")) +(assert (string=? (path-join "" "bar" "baz") "bar/baz")) + (define (canonical-path path) (if (char=? #\/ (string-ref path 0)) path @@ -222,7 +234,7 @@ (macro (with-temporary-working-directory form) (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym))) `(let* ((,cwd-sym (getcwd)) - (,tmp-sym (mkdtemp "gpgscm-XXXXXX")) + (,tmp-sym (mkdtemp (path-join (getenv "TMP") "gpgscm-XXXXXX"))) (_ (chdir ,tmp-sym)) (,result-sym (begin ,@(cdr form)))) (chdir ,cwd-sym) @@ -230,9 +242,9 @@ ,result-sym))) (define (make-temporary-file . args) - (canonical-path (string-append (mkdtemp "gpgscm-XXXXXX") - "/" - (if (null? args) "a" (car args))))) + (canonical-path (path-join + (mkdtemp (path-join (getenv "TMP") "gpgscm-XXXXXX")) + (if (null? args) "a" (car args))))) (define (remove-temporary-file filename) (catch '() -- cgit v1.2.3 From 912977e668d59baf39464fab7e93b9a617f9706f Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 7 Jul 2016 16:18:10 +0200 Subject: gpgscm: Capture output of spawned processes. * tests/gpgscm/tests.scm (call-check): Capture stdout and stderr, and return stdout if the child exited successfully, or include stderr in the error. * tests/openpgp/version.scm: Demonstrate this by checking the stdout. Signed-off-by: Justus Winter --- tests.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/tests.scm b/tests.scm index 2728817..c32e2fa 100644 --- a/tests.scm +++ b/tests.scm @@ -94,9 +94,6 @@ CLOSED_FD (if (< *verbose* 0) STDOUT_FILENO CLOSED_FD) (if (< *verbose* 0) STDERR_FILENO CLOSED_FD))) -(define (call-check what) - (if (not (= 0 (call what))) - (throw (list what "failed")))) ;; Accessor functions for the results of 'spawn-process'. (define :stdin car) @@ -119,6 +116,12 @@ ;; ':stderr' can also be used. (define :retcode car) +(define (call-check what) + (let ((result (call-with-io what ""))) + (if (= 0 (:retcode result)) + (:stdout result) + (throw (list what "failed:" (:stderr result)))))) + (define (call-popen command input-string) (let ((result (call-with-io command input-string))) (if (= 0 (:retcode result)) -- cgit v1.2.3 From 95c04eca273fe9bacbbd9666fd6806e0748792ed Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Thu, 14 Jul 2016 10:52:03 +0200 Subject: gpgscm: Use kludge to avoid improper use of ffi_schemify_name. * tests/gpgscm/ffi.c (ffi_schemify_name): Use xstrdup instead of strdup for now. Signed-off-by: Werner Koch --- ffi.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/ffi.c b/ffi.c index 21beb76..5494c4d 100644 --- a/ffi.c +++ b/ffi.c @@ -1110,9 +1110,13 @@ ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) char * ffi_schemify_name (const char *s, int macro) { - char *n = strdup (s), *p; - if (n == NULL) - return s; + /* Fixme: We should use xtrystrdup and return NULL. However, this + * requires a lot more changes. Simply returning S as done + * originally is not an option. */ + char *n = xstrdup (s), *p; + /* if (n == NULL) */ + /* return s; */ + for (p = n; *p; p++) { *p = (char) tolower (*p); -- cgit v1.2.3 From 4932ef5277957153f4d066f17feb47a4db2b923b Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 15 Jul 2016 12:28:46 +0200 Subject: gpgscm: Fix linking. * tests/gpgscm/Makefile.am: Add -lintl. Signed-off-by: Justus Winter --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index e57a4bb..dad30ed 100644 --- a/Makefile.am +++ b/Makefile.am @@ -45,7 +45,7 @@ gpgscm_CFLAGS = -imacros scheme-config.h \ gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ scheme-config.h opdefines.h scheme.c scheme.h scheme-private.h gpgscm_LDADD = $(LDADD) $(common_libs) \ - $(NETLIBS) $(LIBICONV) $(LIBREADLINE) \ + $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \ $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) t_child_SOURCES = t-child.c -- cgit v1.2.3 From 5851aec15309e9137603bf0e564fd5028ff742c1 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 19 Jul 2016 16:17:22 +0200 Subject: tests: Add test for ssh support. * tests/gpgscm/tests.scm (path-expand): New function. * tests/openpgp/Makefile.am (TESTS): Add new test. (sample_keys): Add new keys. (CLEANFILES): Clean ssh socket and control file. * tests/openpgp/fake-pinentry.c (main): Add a default passphrase. * tests/openpgp/gpg-agent.conf.tmpl: Enable ssh support. * tests/openpgp/samplekeys/ssh-dsa.key: New file. * tests/openpgp/samplekeys/ssh-ecdsa.key: Likewise. * tests/openpgp/samplekeys/ssh-ed25519.key: Likewise. * tests/openpgp/samplekeys/ssh-rsa.key: Likewise. * tests/openpgp/ssh.scm: Likewise. Signed-off-by: Justus Winter --- tests.scm | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/tests.scm b/tests.scm index c32e2fa..58b1430 100644 --- a/tests.scm +++ b/tests.scm @@ -183,10 +183,12 @@ (define (in-srcdir what) (canonical-path (string-append (getenv "srcdir") "/" what))) -(define (with-path name) - (let loop ((path (string-split (getenv "GPGSCM_PATH") #\:))) +;; Try to find NAME in PATHS. Returns the full path name on success, +;; or raises an error. +(define (path-expand name paths) + (let loop ((path paths)) (if (null? path) - name + (throw "Could not find" name "in" paths) (let* ((qualified-name (string-append (car path) "/" name)) (file-exists (call-with-input-file qualified-name (lambda (x) #t)))) @@ -194,6 +196,12 @@ qualified-name (loop (cdr path))))))) +;; Expand NAME using the gpgscm load path. Use like this: +;; (load (with-path "library.scm")) +(define (with-path name) + (catch name + (path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*)))) + (define (basename path) (let ((i (string-index path #\/))) (if (equal? i #f) -- cgit v1.2.3 From bc5199d51c45e11c5d9cba828b31ced9381bd27c Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 21 Jul 2016 18:04:57 +0200 Subject: gpgscm: Make error message more useful. * tests/gpgscm/scheme.c (opexe_0): Include names of missing function parameters in the error message. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 0a76205..987f5af 100644 --- a/scheme.c +++ b/scheme.c @@ -2743,7 +2743,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { for (x = car(closure_code(sc->code)), y = sc->args; is_pair(x); x = cdr(x), y = cdr(y)) { if (y == sc->NIL) { - Error_0(sc,"not enough arguments"); + Error_1(sc, "not enough arguments, missing:", x); } else { new_slot_in_env(sc, car(x), car(y)); } -- cgit v1.2.3 From 4f5e0f510d72935ed6bc37f38261efd0ca45e04b Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 21 Jul 2016 18:05:58 +0200 Subject: gpgscm: Make assert macro more accurate. * tests/gpgscm/lib.scm (assert): Print the representation of the failed expression. Signed-off-by: Justus Winter --- lib.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib.scm b/lib.scm index e23977a..fe28262 100644 --- a/lib.scm +++ b/lib.scm @@ -20,7 +20,8 @@ (macro (assert form) `(if (not ,(cadr form)) (begin - (display (list "Assertion failed:" (quote ,(cadr form)))) + (display "Assertion failed: ") + (write (quote ,(cadr form))) (newline) (exit 1)))) (assert #t) -- cgit v1.2.3 From 593c5ac8553922a7cf8055c6f3d4d3ea6d0f8cb6 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 22 Jul 2016 17:42:17 +0200 Subject: gpgscm: Make function more general. * tests/gpgscm/tests.scm (in-srcdir): Accept more path fragments. Signed-off-by: Justus Winter --- tests.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests.scm b/tests.scm index 58b1430..e14e0e3 100644 --- a/tests.scm +++ b/tests.scm @@ -180,8 +180,8 @@ path (string-append (getcwd) "/" path))) -(define (in-srcdir what) - (canonical-path (string-append (getenv "srcdir") "/" what))) +(define (in-srcdir . names) + (canonical-path (apply path-join (cons (getenv "srcdir") names)))) ;; Try to find NAME in PATHS. Returns the full path name on success, ;; or raises an error. -- cgit v1.2.3 From bd958b94ea3cdafa2457fdf0dcf436458fa755f6 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 26 Jul 2016 15:53:50 +0200 Subject: gpgscm: Make the verbose setting more useful. * tests/gpgscm/ffi.c (do_get_verbose): New function. (do_set_verbose): Likewise. (ffi_init): Turn *verbose* into a function, add *set-verbose!*. * tests/gpgscm/tests.scm (call): Adapt accordingly. (call-with-io): Dump output if *verbose* is high. (pipe-do): Adapt accordingly. * tests/openpgp/defs.scm: Set verbosity according to environment. * tests/openpgp/run-tests.scm (test): Adapt accordingly. Signed-off-by: Justus Winter --- ffi.c | 27 ++++++++++++++++++++++++++- tests.scm | 11 ++++++++--- 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/ffi.c b/ffi.c index 5494c4d..c37bf1d 100644 --- a/ffi.c +++ b/ffi.c @@ -1051,6 +1051,30 @@ do_glob (scheme *sc, pointer args) FFI_RETURN_POINTER (sc, result); } + + +static pointer +do_get_verbose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, verbose); +} + +static pointer +do_set_verbose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int new_verbosity, old; + FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + old = verbose; + verbose = new_verbosity; + + FFI_RETURN_INT (sc, old); +} + gpg_error_t ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) @@ -1260,7 +1284,8 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) ffi_define_function (sc, prompt); /* Configuration. */ - ffi_define (sc, "*verbose*", sc->vptr->mk_integer (sc, verbose)); + ffi_define_function_name (sc, "*verbose*", get_verbose); + ffi_define_function_name (sc, "*set-verbose!*", set_verbose); ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); for (i = argc - 1; i >= 0; i--) diff --git a/tests.scm b/tests.scm index e14e0e3..f97b22e 100644 --- a/tests.scm +++ b/tests.scm @@ -92,8 +92,8 @@ (define (call what) (call-with-fds what CLOSED_FD - (if (< *verbose* 0) STDOUT_FILENO CLOSED_FD) - (if (< *verbose* 0) STDERR_FILENO CLOSED_FD))) + (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD) + (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD))) ;; Accessor functions for the results of 'spawn-process'. (define :stdin car) @@ -110,6 +110,11 @@ (result (wait-process (car what) (:pid h) #t))) (es-fclose (:stdout h)) (es-fclose (:stderr h)) + (if (> (*verbose*) 2) + (begin + (echo (stringify what) "returned:" result) + (echo (stringify what) "wrote to stdout:" out) + (echo (stringify what) "wrote to stderr:" err))) (list result out err)))) ;; Accessor function for the results of 'call-with-io'. ':stdout' and @@ -360,7 +365,7 @@ (lambda (M) (define (do-spawn M new-source) (let ((pid (spawn-process-fd command M::source M::sink - (if (> *verbose* 0) + (if (> (*verbose*) 0) STDERR_FILENO CLOSED_FD))) (M' (M::set-source new-source))) (M'::add-proc command pid))) -- cgit v1.2.3 From d764c08a9215ab1c90a97fb019aa99ccf3721e02 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 26 Jul 2016 18:35:58 +0200 Subject: gpgscm: Do not shadow common function name in catch macro. * tests/gpgscm/init.scm (catch): Do not shadow 'exit'. Signed-off-by: Justus Winter --- init.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/init.scm b/init.scm index 0889366..b32172b 100644 --- a/init.scm +++ b/init.scm @@ -572,8 +572,8 @@ (macro (catch form) (let ((label (gensym))) - `(call/cc (lambda (exit) - (push-handler (lambda (*error*) (exit ,(cadr form)))) + `(call/cc (lambda (**exit**) + (push-handler (lambda (*error*) (**exit** ,(cadr form)))) (let ((,label (begin ,@(cddr form)))) (pop-handler) ,label))))) -- cgit v1.2.3 From c609b6e6b08719b86a64fb186f6eee03d0b01b16 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 10 Aug 2016 11:50:12 +0200 Subject: gpgscm: Make the name of foreign functions more unique. * tests/gpgscm/ffi-private.h (ffi_define_function_name): Add another underscore. Signed-off-by: Justus Winter --- ffi-private.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ffi-private.h b/ffi-private.h index 87f491f..0d58c41 100644 --- a/ffi-private.h +++ b/ffi-private.h @@ -93,7 +93,7 @@ pointer ffi_sprintf (scheme *sc, const char *format, ...) #define ffi_define_function_name(SC, NAME, F) \ do { \ - char *_fname = ffi_schemify_name ("_" #F, 0); \ + char *_fname = ffi_schemify_name ("__" #F, 0); \ scheme_define ((SC), \ (SC)->global_env, \ mk_symbol ((SC), _fname), \ -- cgit v1.2.3 From 0b5146376ba4e6ef129ed4a0641591bafa5902f9 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 10 Aug 2016 11:54:11 +0200 Subject: tests: Improve temporary directory handling. * tests/gpgscm/ffi.c (ffi_init): Rename 'mkdtemp'. * tests/gpgscm/tests.scm (mkdtemp): New function that uses a sensible location and template if no arguments are given. (with-temporary-working-directory): Simplify accordingly. (make-temporary-file): Likewise. * tests/openpgp/run-tests.scm (run-tests-parallel-isolated): Likewise. (run-tests-sequential-isolated): Likewise. Signed-off-by: Justus Winter --- ffi.c | 2 +- tests.scm | 13 +++++++++++-- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/ffi.c b/ffi.c index c37bf1d..57de286 100644 --- a/ffi.c +++ b/ffi.c @@ -1248,7 +1248,7 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) ffi_define_function (sc, open); ffi_define_function (sc, fdopen); ffi_define_function (sc, close); - ffi_define_function (sc, mkdtemp); + ffi_define_function_name (sc, "_mkdtemp", mkdtemp); ffi_define_function (sc, unlink); ffi_define_function (sc, unlink_recursively); ffi_define_function (sc, rename); diff --git a/tests.scm b/tests.scm index f97b22e..8283eba 100644 --- a/tests.scm +++ b/tests.scm @@ -247,10 +247,19 @@ (chdir ,cwd-sym) ,result-sym))) +;; Make a temporary directory. If arguments are given, they are +;; joined using path-join, and must end in a component ending in +;; "XXXXXX". If no arguments are given, a suitable location and +;; generic name is used. +(define (mkdtemp . components) + (_mkdtemp (if (null? components) + (path-join (getenv "TMP") "gpgscm-XXXXXX") + (apply path-join components)))) + (macro (with-temporary-working-directory form) (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym))) `(let* ((,cwd-sym (getcwd)) - (,tmp-sym (mkdtemp (path-join (getenv "TMP") "gpgscm-XXXXXX"))) + (,tmp-sym (mkdtemp)) (_ (chdir ,tmp-sym)) (,result-sym (begin ,@(cdr form)))) (chdir ,cwd-sym) @@ -259,7 +268,7 @@ (define (make-temporary-file . args) (canonical-path (path-join - (mkdtemp (path-join (getenv "TMP") "gpgscm-XXXXXX")) + (mkdtemp) (if (null? args) "a" (car args))))) (define (remove-temporary-file filename) -- cgit v1.2.3 From b912b371ffc56b0e657d58e2a891f6bb1affab4b Mon Sep 17 00:00:00 2001 From: Daniel Kahn Gillmor Date: Fri, 12 Aug 2016 01:37:57 -0400 Subject: Call log_set_prefix() with human-readable labels. * agent/preset-passphrase.c, agent/protect-tool.c, dirmngr/dirmngr.c * dirmngr/t-http.c, g10/gpg.c, g10/gpgv.c, g13/g13-syshelp.c * g13/g13.c, kbx/kbxutil.c, scd/scdaemon.c, sm/gpgsm.c * tests/gpgscm/main.c, tools/gpg-check-pattern.c * tools/gpg-connect-agent.c, tools/gpgconf.c, tools/gpgtar.c * tools/symcryptrun.c: Invoke log_set_prefix() with human-readable labels. -- Some invocations of log_set_prefix() were done with raw numeric values instead of values that humans can understand. Use symbolic representations instead of numeric for better readability. Signed-off-by: Daniel Kahn Gillmor --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index 5b3792e..34ebb9f 100644 --- a/main.c +++ b/main.c @@ -216,7 +216,7 @@ main (int argc, char **argv) *p = 0, scmpath_len++; set_strusage (my_strusage); - log_set_prefix ("gpgscm", 1); + log_set_prefix ("gpgscm", GPGRT_LOG_WITH_PREFIX); /* Make sure that our subsystems are ready. */ i18n_init (); -- cgit v1.2.3 From 36405b2d208e5ec4c2c289d99ba4e7e1a29b8321 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 6 Sep 2016 16:35:40 +0200 Subject: gpgscm: Fix detection of unbalanced parenthesis. * tests/gpgscm/main.c (load): Print error message. * tests/gpgscm/scheme.c (opexe_0): Correctly report nesting level when loading files. Signed-off-by: Justus Winter --- main.c | 8 ++++++++ scheme.c | 1 + 2 files changed, 9 insertions(+) diff --git a/main.c b/main.c index 34ebb9f..9aef1f3 100644 --- a/main.c +++ b/main.c @@ -32,6 +32,7 @@ #include "private.h" #include "scheme.h" +#include "scheme-private.h" #include "ffi.h" #include "i18n.h" #include "../../common/argparse.h" @@ -176,6 +177,13 @@ load (scheme *sc, char *file_name, scheme_load_named_file (sc, h, qualified_name); fclose (h); + if (sc->retcode) + { + if (sc->nesting) + fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); + return gpg_error (GPG_ERR_GENERAL); + } + if (file_name != qualified_name) free (qualified_name); return 0; diff --git a/scheme.c b/scheme.c index 987f5af..1fc7643 100644 --- a/scheme.c +++ b/scheme.c @@ -2592,6 +2592,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if(sc->file_i == 0) { sc->args=sc->NIL; + sc->nesting = sc->nesting_stack[0]; s_goto(sc,OP_QUIT); } else -- cgit v1.2.3 From 95f7320a37d3870330a2b1f3493025b4820fa767 Mon Sep 17 00:00:00 2001 From: NIIBE Yutaka Date: Thu, 15 Sep 2016 09:17:59 +0900 Subject: tests/gpgscm: Fix use of pointer. * tests/gpgscm/scheme-private.h (struct scheme): Use (void *) for alloc_seg. * tests/gpgscm/scheme.c (alloc_cellseg): Use (void *) for cp. Use (void *) for coercion of address calculation. -- In old C language, (char *) means an address. In modern C, it's specifically an address with alignment=1. It's good to use (void *) for an address, because newer compiler emits warnings. Note: in this particular case, it is just a warning and the code is safe against invalid alignment, though. Signed-off-by: NIIBE Yutaka --- scheme-private.h | 2 +- scheme.c | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 9eafe76..727e0c0 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -78,7 +78,7 @@ int tracing; #ifndef CELL_NSEGMENT #define CELL_NSEGMENT 10 /* # of segments for cells */ #endif -char *alloc_seg[CELL_NSEGMENT]; +void *alloc_seg[CELL_NSEGMENT]; pointer cell_seg[CELL_NSEGMENT]; int last_cell_seg; diff --git a/scheme.c b/scheme.c index 1fc7643..8833950 100644 --- a/scheme.c +++ b/scheme.c @@ -602,7 +602,7 @@ static int alloc_cellseg(scheme *sc, int n) { pointer newp; pointer last; pointer p; - char *cp; + void *cp; long i; int k; int adj=ADJ; @@ -614,14 +614,14 @@ static int alloc_cellseg(scheme *sc, int n) { for (k = 0; k < n; k++) { if (sc->last_cell_seg >= CELL_NSEGMENT - 1) return k; - cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); + cp = sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); if (cp == 0) return k; i = ++sc->last_cell_seg ; sc->alloc_seg[i] = cp; /* adjust in TYPE_BITS-bit boundary */ if(((unsigned long)cp)%adj!=0) { - cp=(char*)(adj*((unsigned long)cp/adj+1)); + cp=(void *)(adj*((unsigned long)cp/adj+1)); } /* insert new segment in address order */ newp=(pointer)cp; -- cgit v1.2.3 From 42b61e8469179292814fea267ecd7d911396b965 Mon Sep 17 00:00:00 2001 From: Daniel Kahn Gillmor Date: Thu, 15 Sep 2016 14:21:15 -0400 Subject: Fix more spelling * NEWS, acinclude.m4, agent/command-ssh.c, agent/command.c, agent/gpg-agent.c, agent/keyformat.txt, agent/protect-tool.c, common/asshelp.c, common/b64enc.c, common/recsel.c, doc/DETAILS, doc/HACKING, doc/Notes, doc/TRANSLATE, doc/dirmngr.texi, doc/faq.org, doc/gpg-agent.texi, doc/gpg.texi, doc/gpgsm.texi, doc/instguide.texi, g10/armor.c, g10/gpg.c, g10/keyedit.c, g10/mainproc.c, g10/pkclist.c, g10/tofu.c, g13/sh-cmd.c, g13/sh-dmcrypt.c, kbx/keybox-init.c, m4/pkg.m4, sm/call-dirmngr.c, sm/gpgsm.c, tests/Makefile.am, tests/gpgscm/Manual.txt, tests/gpgscm/scheme.c, tests/openpgp/gpgv-forged-keyring.scm, tests/openpgp/multisig.test, tests/openpgp/verify.scm, tests/pkits/README, tools/applygnupgdefaults, tools/gpg-connect-agent.c, tools/mime-maker.c, tools/mime-parser.c: minor spelling cleanup. Signed-off-by: Daniel Kahn Gillmor --- Manual.txt | 2 +- scheme.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Manual.txt b/Manual.txt index 9fd294f..b146926 100644 --- a/Manual.txt +++ b/Manual.txt @@ -86,7 +86,7 @@ Please read accompanying file COPYING. Directives (gc) - Performs garbage collection immediatelly. + Performs garbage collection immediately. (gc-verbose) (gc-verbose ) The argument (defaulting to #t) controls whether GC produces diff --git a/scheme.c b/scheme.c index 8833950..5a85063 100644 --- a/scheme.c +++ b/scheme.c @@ -2777,7 +2777,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { #if 1 case OP_LAMBDA: /* lambda */ /* If the hook is defined, apply it to sc->code, otherwise - set sc->value fall thru */ + set sc->value fall through */ { pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); if(f==sc->NIL) { -- cgit v1.2.3 From a3cdf6ba9987ec2f4b951c3b2519f6beea147126 Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Mon, 19 Sep 2016 08:41:51 +0200 Subject: gpgscm: Fix gcrypt version check. * tests/gpgscm/main.c (main): Check against required and not installed version. Signed-off-by: Werner Koch --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index 9aef1f3..02681ff 100644 --- a/main.c +++ b/main.c @@ -230,7 +230,7 @@ main (int argc, char **argv) i18n_init (); init_common_subsystems (&argc, &argv); - if (!gcry_check_version (GCRYPT_VERSION)) + if (!gcry_check_version (NEED_LIBGCRYPT_VERSION)) { fputs ("libgcrypt version mismatch\n", stderr); exit (2); -- cgit v1.2.3 From 86f421b7de364138d2d066b267b0f08a62c42a42 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Sep 2016 15:59:19 +0200 Subject: tests: Use descriptive temporary file names. * tests/gpgscm/ffi.c (do_get_isotime): New function. (ffi_init): Add parameter 'scriptname', bind new function and scriptname. * tests/gpgscm/ffi.h (ffi_init): Update prototype. * tests/gpgscm/main.c (main): Hand in the script name. * tests/gpgscm/tests.scm (mkdtemp): Use current time and script name for the names of temporary directories. Signed-off-by: Justus Winter --- ffi.c | 15 ++++++++++++++- ffi.h | 2 +- main.c | 3 ++- tests.scm | 5 ++++- 4 files changed, 21 insertions(+), 4 deletions(-) diff --git a/ffi.c b/ffi.c index 57de286..0816067 100644 --- a/ffi.c +++ b/ffi.c @@ -460,6 +460,16 @@ do_rmdir (scheme *sc, pointer args) FFI_RETURN (sc); } +static pointer +do_get_isotime (scheme *sc, pointer args) +{ + FFI_PROLOG (); + gnupg_isotime_t timebuf; + FFI_ARGS_DONE_OR_RETURN (sc, args); + gnupg_get_isotime (timebuf); + FFI_RETURN_STRING (sc, timebuf); +} + /* estream functions. */ @@ -1209,7 +1219,8 @@ ffi_scheme_eval (scheme *sc, const char *format, ...) } gpg_error_t -ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) +ffi_init (scheme *sc, const char *argv0, const char *scriptname, + int argc, const char **argv) { int i; pointer args = sc->NIL; @@ -1255,6 +1266,7 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) ffi_define_function (sc, getcwd); ffi_define_function (sc, mkdir); ffi_define_function (sc, rmdir); + ffi_define_function (sc, get_isotime); /* Process management. */ ffi_define_function (sc, spawn_process); @@ -1288,6 +1300,7 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) ffi_define_function_name (sc, "*set-verbose!*", set_verbose); ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); + ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname)); for (i = argc - 1; i >= 0; i--) { pointer value = sc->vptr->mk_string (sc, argv[i]); diff --git a/ffi.h b/ffi.h index 02dd99d..9bd710f 100644 --- a/ffi.h +++ b/ffi.h @@ -24,7 +24,7 @@ #include #include "scheme.h" -gpg_error_t ffi_init (scheme *sc, const char *argv0, +gpg_error_t ffi_init (scheme *sc, const char *argv0, const char *scriptname, int argc, const char **argv); #endif /* GPGSCM_FFI_H */ diff --git a/main.c b/main.c index 02681ff..f7c6b0d 100644 --- a/main.c +++ b/main.c @@ -263,7 +263,8 @@ main (int argc, char **argv) if (! err) err = load (sc, "ffi.scm", 0, 1); if (! err) - err = ffi_init (sc, argv0, argc, (const char **) argv); + err = ffi_init (sc, argv0, script ? script : "interactive", + argc, (const char **) argv); if (! err) err = load (sc, "lib.scm", 0, 1); if (! err) diff --git a/tests.scm b/tests.scm index 8283eba..0738bc6 100644 --- a/tests.scm +++ b/tests.scm @@ -253,7 +253,10 @@ ;; generic name is used. (define (mkdtemp . components) (_mkdtemp (if (null? components) - (path-join (getenv "TMP") "gpgscm-XXXXXX") + (path-join (getenv "TMP") + (string-append "gpgscm-" (get-isotime) "-" + (basename-suffix *scriptname* ".scm") + "-XXXXXX")) (apply path-join components)))) (macro (with-temporary-working-directory form) -- cgit v1.2.3 From 3fd08ed018f837399564896462f64af8ae389eec Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Sep 2016 17:19:00 +0200 Subject: tests: Refine exception handling. * tests/gpgscm/init.scm (catch): Bind all arguments to '*error*' in the error handler, update and fix comment. (*error-hook*): Revert to original definition. * tests/gpgscm/tests.scm (tr:do): Adapt accordingly. * tests/openpgp/issue2419.scm: Likewise. Signed-off-by: Justus Winter --- init.scm | 10 +++++----- tests.scm | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/init.scm b/init.scm index b32172b..f8fd71a 100644 --- a/init.scm +++ b/init.scm @@ -544,13 +544,14 @@ ; ; "Catch" establishes a scope spanning multiple call-frames until ; another "catch" is encountered. Within the recovery expression -; the thrown exception is bound to *error*. +; the thrown exception is bound to *error*. Errors can be rethrown +; using (apply throw *error*). ; ; Exceptions are thrown with: ; ; (throw "message") ; -; If used outside a (catch ...), reverts to (error "message) +; If used outside a (catch ...), reverts to (error "message") (define *handlers* (list)) @@ -573,13 +574,12 @@ (macro (catch form) (let ((label (gensym))) `(call/cc (lambda (**exit**) - (push-handler (lambda (*error*) (**exit** ,(cadr form)))) + (push-handler (lambda *error* (**exit** ,(cadr form)))) (let ((,label (begin ,@(cddr form)))) (pop-handler) ,label))))) -(define (*error-hook* . args) - (throw args)) +(define *error-hook* throw) ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL diff --git a/tests.scm b/tests.scm index 0738bc6..7b88e0e 100644 --- a/tests.scm +++ b/tests.scm @@ -411,7 +411,7 @@ (if error (begin (for-each remove-temporary-file tmpfiles') - (throw error))) + (apply throw error))) (loop tmpfiles' sink (cdr cmds)))))) (define (tr:open pathname) -- cgit v1.2.3 From ec34346129c77a7011872812567689aa09d99caa Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Sep 2016 17:24:03 +0200 Subject: tests: Correctly handle exceptions in resource handling macros. * tests/gpgscm/tests.scm (letfd): Correctly release resources when an exception is thrown. (with-working-directory): Likewise. (with-temporary-working-directory): Likewise. (lettmp): Likewise. Signed-off-by: Justus Winter --- tests.scm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/tests.scm b/tests.scm index 7b88e0e..71ca369 100644 --- a/tests.scm +++ b/tests.scm @@ -234,7 +234,9 @@ `((lambda (,(caaadr form)) (let ((,result-sym ,(if (= 1 (length (cadr form))) - `(begin ,@(cddr form)) + `(catch (begin (close ,(caaadr form)) + (apply throw *error*)) + ,@(cddr form)) `(letfd ,(cdadr form) ,@(cddr form))))) (close ,(caaadr form)) ,result-sym)) ,@(cdaadr form)))) @@ -243,7 +245,9 @@ (let ((result-sym (gensym)) (cwd-sym (gensym))) `(let* ((,cwd-sym (getcwd)) (_ (if ,(cadr form) (chdir ,(cadr form)))) - (,result-sym (begin ,@(cddr form)))) + (,result-sym (catch (begin (chdir ,cwd-sym) + (apply throw *error*)) + ,@(cddr form)))) (chdir ,cwd-sym) ,result-sym))) @@ -264,7 +268,10 @@ `(let* ((,cwd-sym (getcwd)) (,tmp-sym (mkdtemp)) (_ (chdir ,tmp-sym)) - (,result-sym (begin ,@(cdr form)))) + (,result-sym (catch (begin (chdir ,cwd-sym) + (unlink-recursively ,tmp-sym) + (apply throw *error*)) + ,@(cdr form)))) (chdir ,cwd-sym) (unlink-recursively ,tmp-sym) ,result-sym))) @@ -293,7 +300,9 @@ `((lambda (,(caadr form)) (let ((,result-sym ,(if (= 1 (length (cadr form))) - `(begin ,@(cddr form)) + `(catch (begin (remove-temporary-file ,(caadr form)) + (apply throw *error*)) + ,@(cddr form)) `(lettmp ,(cdadr form) ,@(cddr form))))) (remove-temporary-file ,(caadr form)) ,result-sym)) (make-temporary-file ,(symbol->string (caadr form)))))) -- cgit v1.2.3 From ea399aaaf4c9de92d24ab59cdc3586608bf35698 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Sep 2016 18:42:36 +0200 Subject: tests: Implement interpreter shutdown using exceptions. * tests/gpgscm/ffi.c (ffi_init): Rename 'exit' to '_exit'. * tests/gpgscm/ffi.scm (*interpreter-exit*): New variable. (throw): New function. (exit): New function. -- This allows a proper cleanup of resources. Signed-off-by: Justus Winter --- ffi.c | 2 +- ffi.scm | 22 ++++++++++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/ffi.c b/ffi.c index 0816067..4559f10 100644 --- a/ffi.c +++ b/ffi.c @@ -1255,7 +1255,7 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define_function (sc, strerror); ffi_define_function (sc, getenv); ffi_define_function (sc, setenv); - ffi_define_function (sc, exit); + ffi_define_function_name (sc, "_exit", exit); ffi_define_function (sc, open); ffi_define_function (sc, fdopen); ffi_define_function (sc, close); diff --git a/ffi.scm b/ffi.scm index 7c2f93a..72a2a8f 100644 --- a/ffi.scm +++ b/ffi.scm @@ -42,3 +42,25 @@ ;; Pseudo-definitions for foreign functions. Evaluates to no code, ;; but serves as documentation. (macro (ffi-define form)) + +;; Runtime support. + +;; Low-level mechanism to terminate the process. +(ffi-define (_exit status)) + +;; High-level mechanism to terminate the process is to throw an error +;; of the form (*interpreter-exit* status). This gives automatic +;; resource management a chance to clean up. +(define *interpreter-exit* (gensym)) +(define (throw . x) + (cond + ((more-handlers?) + (apply (pop-handler) x)) + ((and (= 2 (length x)) (equal? *interpreter-exit* (car x))) + (_exit (cadr x))) + (else + (apply error x)))) + +;; Terminate the process returning STATUS to the parent. +(define (exit status) + (throw *interpreter-exit* status)) -- cgit v1.2.3 From a3b6b7643d906264b56d6fa041bcb95e96eb1898 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Sep 2016 18:45:44 +0200 Subject: tests: Refine the repl function. * tests/gpgscm/repl.scm (repl): Add an argument 'environment'. (interactive-repl): Add an optional argument 'environment'. -- With this change, we can drop (interactive-repl (current-environment)) anywhere into the code and do some interactive debugging. Signed-off-by: Justus Winter --- repl.scm | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/repl.scm b/repl.scm index 896554f..78b8151 100644 --- a/repl.scm +++ b/repl.scm @@ -20,25 +20,24 @@ ;; Interactive repl using 'prompt' function. P must be a function ;; that given the current entered prefix returns the prompt to ;; display. -(define (repl p) - (let ((repl-environment (make-environment))) - (call/cc - (lambda (exit) - (let loop ((prefix "")) - (let ((line (prompt (p prefix)))) - (if (and (not (eof-object? line)) (= 0 (string-length line))) - (exit (loop prefix))) - (if (not (eof-object? line)) - (let* ((next (string-append prefix line)) - (c (catch (begin (echo "Parse error:" *error*) - (loop prefix)) - (read (open-input-string next))))) - (if (not (eof-object? c)) - (begin - (catch (echo "Error:" *error*) - (echo " ===>" (eval c repl-environment))) - (exit (loop "")))) - (exit (loop next)))))))))) +(define (repl p environment) + (call/cc + (lambda (exit) + (let loop ((prefix "")) + (let ((line (prompt (p prefix)))) + (if (and (not (eof-object? line)) (= 0 (string-length line))) + (exit (loop prefix))) + (if (not (eof-object? line)) + (let* ((next (string-append prefix line)) + (c (catch (begin (echo "Parse error:" *error*) + (loop prefix)) + (read (open-input-string next))))) + (if (not (eof-object? c)) + (begin + (catch (echo "Error:" *error*) + (echo " ===>" (eval c environment))) + (exit (loop "")))) + (exit (loop next))))))))) (define (prompt-append-prefix prompt prefix) (string-append prompt (if (> (string-length prefix) 0) @@ -46,5 +45,6 @@ "> "))) ;; Default repl run by main.c. -(define (interactive-repl) - (repl (lambda (p) (prompt-append-prefix "gpgscm " p)))) +(define (interactive-repl . environment) + (repl (lambda (p) (prompt-append-prefix "gpgscm " p)) + (if (null? environment) (interaction-environment) (car environment)))) -- cgit v1.2.3 From 7359d7acb687d572dd0a4e40fd979566efbf4e21 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 4 Oct 2016 12:59:18 +0200 Subject: tests,w32: Do not expose 'glob' to gpgscm. * tests/gpgscm/ffi.c (do_glob): Remove function. (ffi_init): Likewise. -- 'glob' is not available on mingw, and portability is the whole point of gpgscm. Signed-off-by: Justus Winter --- ffi.c | 38 -------------------------------------- 1 file changed, 38 deletions(-) diff --git a/ffi.c b/ffi.c index 4559f10..829384a 100644 --- a/ffi.c +++ b/ffi.c @@ -25,7 +25,6 @@ #include #include #include -#include #include #include #include @@ -1025,42 +1024,6 @@ do_string_contains (scheme *sc, pointer args) FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); } -static pointer -do_glob (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer result = sc->NIL; - size_t i; - char *pattern; - glob_t pglob; - FFI_ARG_OR_RETURN (sc, char *, pattern, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - switch (glob (pattern, 0, NULL, &pglob)) - { - case 0: - for (i = 0; i < pglob.gl_pathc; i++) - result = - (sc->vptr->cons) (sc, - sc->vptr->mk_string (sc, pglob.gl_pathv[i]), - result); - globfree (&pglob); - break; - - case GLOB_NOMATCH: - /* Return the empty list. */ - break; - - case GLOB_NOSPACE: - return ffi_sprintf (sc, "out of memory"); - case GLOB_ABORTED: - return ffi_sprintf (sc, "read error"); - default: - assert (! "not reached"); - } - FFI_RETURN_POINTER (sc, result); -} - static pointer @@ -1289,7 +1252,6 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define_function (sc, string_index); ffi_define_function (sc, string_rindex); ffi_define_function_name (sc, "string-contains?", string_contains); - ffi_define_function (sc, glob); /* User interface. */ ffi_define_function (sc, flush_stdio); -- cgit v1.2.3 From bbd3be18ca9feac21963cc7d682f5a7d89fd9aba Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 6 Oct 2016 14:13:18 +0200 Subject: gpgscm: Update callsite of 'gnupg_spawn_process'. * tests/gpgscm/ffi.c (do_spawn_process): Adapt to the changes to 'gnupg_spawn_process'. Fixes-commit: 44a32455 Fixes-commit: 96c7901e Signed-off-by: Justus Winter --- ffi.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ffi.c b/ffi.c index 829384a..44db6bb 100644 --- a/ffi.c +++ b/ffi.c @@ -653,7 +653,7 @@ do_spawn_process (scheme *sc, pointer args) } err = gnupg_spawn_process (argv[0], (const char **) &argv[1], - GPG_ERR_SOURCE_DEFAULT, + NULL, NULL, flags, &infp, &outfp, &errfp, &pid); -- cgit v1.2.3 From ff00a2d792091f35380c9541ee88fbd9c0d76c43 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 7 Oct 2016 12:53:25 +0200 Subject: gpgscm: Improve path handling. * tests/gpgscm/ffi.c (ffi_init): New Scheme variable '*win32*'. * tests/gpgscm/tests.scm (canonical-path): Correctly handle paths with drive letter on Windows. Use 'path-join'. (path-expand): Use 'path-join'. Signed-off-by: Justus Winter --- ffi.c | 9 +++++++++ tests.scm | 12 +++++++++--- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/ffi.c b/ffi.c index 44db6bb..a0fbe2e 100644 --- a/ffi.c +++ b/ffi.c @@ -1276,6 +1276,15 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); #endif + ffi_define (sc, "*win32*", +#if _WIN32 + sc->T +#else + sc->F +#endif + ); + + ffi_define (sc, "*stdin*", sc->vptr->mk_port_from_file (sc, stdin, port_input)); ffi_define (sc, "*stdout*", diff --git a/tests.scm b/tests.scm index 71ca369..8986a70 100644 --- a/tests.scm +++ b/tests.scm @@ -181,9 +181,15 @@ (assert (string=? (path-join "" "bar" "baz") "bar/baz")) (define (canonical-path path) - (if (char=? #\/ (string-ref path 0)) + (if (or (char=? #\/ (string-ref path 0)) + (and *win32* (char=? #\\ (string-ref path 0))) + (and *win32* + (char-alphabetic? (string-ref path 0)) + (char=? #\: (string-ref path 1)) + (or (char=? #\/ (string-ref path 2)) + (char=? #\\ (string-ref path 2))))) path - (string-append (getcwd) "/" path))) + (path-join (getcwd) path))) (define (in-srcdir . names) (canonical-path (apply path-join (cons (getenv "srcdir") names)))) @@ -194,7 +200,7 @@ (let loop ((path paths)) (if (null? path) (throw "Could not find" name "in" paths) - (let* ((qualified-name (string-append (car path) "/" name)) + (let* ((qualified-name (path-join (car path) name)) (file-exists (call-with-input-file qualified-name (lambda (x) #t)))) (if file-exists -- cgit v1.2.3 From 2e47dcf432bc26cbaa1a6ba6716ab74facd06353 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 7 Oct 2016 16:13:08 +0200 Subject: gpgscm: Improve test of low-level functions. * tests/gpgscm/t-child.c: Print large amounts of data. * tests/gpgscm/t-child.scm: Test that this works. Signed-off-by: Justus Winter --- t-child.c | 10 +++++++++- t-child.scm | 25 +++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/t-child.c b/t-child.c index fe2e7b4..ae1a635 100644 --- a/t-child.c +++ b/t-child.c @@ -30,6 +30,8 @@ int main (int argc, char **argv) { + char buffer[4096]; + memset (buffer, 'A', sizeof buffer); #if _WIN32 if (! setmode (stdin, O_BINARY)) return 23; @@ -49,10 +51,16 @@ main (int argc, char **argv) fprintf (stdout, "hello"); else if (strcmp (argv[1], "hello_stderr") == 0) fprintf (stderr, "hello"); + else if (strcmp (argv[1], "stdout4096") == 0) + fwrite (buffer, 1, sizeof buffer, stdout); + else if (strcmp (argv[1], "stdout8192") == 0) + { + fwrite (buffer, 1, sizeof buffer, stdout); + fwrite (buffer, 1, sizeof buffer, stdout); + } else if (strcmp (argv[1], "cat") == 0) while (! feof (stdin)) { - char buffer[4096]; size_t bytes_read; bytes_read = fread (buffer, 1, sizeof buffer, stdin); fwrite (buffer, 1, bytes_read, stdout); diff --git a/t-child.scm b/t-child.scm index 27928f6..93208f4 100644 --- a/t-child.scm +++ b/t-child.scm @@ -22,6 +22,8 @@ (define (qualify executable) (string-append executable (getenv "EXEEXT"))) +(define child (qualify "t-child")) + (assert (= 0 (call `(,(qualify "t-child") "return0")))) (assert (= 1 (call `(,(qualify "t-child") "return1")))) (assert (= 77 (call `(,(qualify "t-child") "return77")))) @@ -51,6 +53,16 @@ (assert (string=? "" (:stdout r))) (assert (string=? "hello" (:stderr r)))) +(let ((r (call-with-io `(,(qualify "t-child") "stdout4096") ""))) + (assert (= 0 (:retcode r))) + (assert (= 4096 (string-length (:stdout r)))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "stdout8192") ""))) + (assert (= 0 (:retcode r))) + (assert (= 8192 (string-length (:stdout r)))) + (assert (string=? "" (:stderr r)))) + (let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello"))) (assert (= 0 (:retcode r))) (assert (string=? "hellohello" (:stdout r))) @@ -90,4 +102,17 @@ (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) (echo " world.") +(tr:do + (tr:pipe-do + (pipe:spawn `(,child stdout4096)) + (pipe:spawn `(,child cat))) + (tr:call-with-content (lambda (c) + (assert (= 4096 (length c)))))) +(tr:do + (tr:pipe-do + (pipe:spawn `(,child stdout8192)) + (pipe:spawn `(,child cat))) + (tr:call-with-content (lambda (c) + (assert (= 8192 (length c)))))) + (echo "All good.") -- cgit v1.2.3 From e8db2ea9542eef0bc7b51c9f69109a056269c048 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 7 Oct 2016 16:16:15 +0200 Subject: tests: Improve handling of Windows newlines. * tests/gpgscm/lib.scm (string-split-newlines): New function. * tests/openpgp/default-key.scm: Use new function. * tests/openpgp/defs.scm: Likewise. * tests/openpgp/export.scm: Likewise. * tests/openpgp/import.scm: Likewise. Signed-off-by: Justus Winter --- lib.scm | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/lib.scm b/lib.scm index fe28262..e4ab483 100644 --- a/lib.scm +++ b/lib.scm @@ -92,6 +92,15 @@ (assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:)))) (assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:)))) +;; Split haystack at newlines. +(define (string-split-newlines haystack) + (if *win32* + (map (lambda (line) (if (string-suffix? line "\r") + (substring line 0 (- (string-length line) 1)) + line)) + (string-split haystack #\newline)) + (string-split haystack #\newline))) + ;; Trim the prefix of S containing only characters that make PREDICATE ;; true. (define (string-ltrim predicate s) -- cgit v1.2.3 From 7a262df038f495d27e2d8ec806ea0d47c925c88b Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 14 Oct 2016 11:17:50 +0200 Subject: gpgscm: Initialize nesting stack. * tests/gpgscm/scheme.c (scheme_init_custom_alloc): Initialize nesting stack. Fixes-commit: f2249b737055f84842778285bbeff5e61fa55225 Signed-off-by: Justus Winter --- scheme.c | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme.c b/scheme.c index 5a85063..0e31dc5 100644 --- a/scheme.c +++ b/scheme.c @@ -4765,6 +4765,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->save_inport=sc->NIL; sc->loadport=sc->NIL; sc->nesting=0; + memset (sc->nesting_stack, 0, sizeof sc->nesting_stack); sc->interactive_repl=0; sc->strbuff = sc->malloc(STRBUFFSIZE); if (sc->strbuff == 0) { -- cgit v1.2.3 From e7ba35f207cb06f6d0e085ab3faf68d118606655 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 20 Oct 2016 16:45:18 +0200 Subject: common,w32: Fix setting environment variables on Windows. * common/sysutils.c (gnupg_setenv): Also update the environment block maintained by the C runtime. (gnupg_unsetenv): Likewise. * tests/gpgscm/ffi.c (do_setenv): Fix error handling. Signed-off-by: Justus Winter --- ffi.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ffi.c b/ffi.c index a0fbe2e..8e21ba6 100644 --- a/ffi.c +++ b/ffi.c @@ -236,7 +236,9 @@ do_setenv (scheme *sc, pointer args) FFI_ARG_OR_RETURN (sc, char *, value, string, args); FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args); FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_ERR (sc, gnupg_setenv (name, value, overwrite)); + if (gnupg_setenv (name, value, overwrite)) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); } static pointer -- cgit v1.2.3 From 0ccc6f5ffccec23587d06e32da88fb0acd80f2c6 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 2 Nov 2016 13:06:06 +0100 Subject: gpgscm: Fix inclusion of readline header. * tests/gpgscm/ffi.c: Define magic macro to prevent the completion function from redefined. GnuPG-bug-id: 2824 Signed-off-by: Justus Winter --- ffi.c | 1 + 1 file changed, 1 insertion(+) diff --git a/ffi.c b/ffi.c index 8e21ba6..305b7a1 100644 --- a/ffi.c +++ b/ffi.c @@ -35,6 +35,7 @@ #include #if HAVE_LIBREADLINE +#define GNUPG_LIBREADLINE_H_INCLUDED #include #include #endif -- cgit v1.2.3 From e4a694eb48a098c3a3983767099dcce4e9157d16 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 3 Nov 2016 14:37:15 +0100 Subject: gpgscm,tests: Add new functions to the test environment. * tests/gpgscm/lib.scm (first, last, powerset): New functions. * tests/gpgscm/tests.scm (interactive-shell): New function. * tests/openpgp/Makefile.am (EXTRA_DIST): Add new file. * tests/openpgp/README: Document 'interactive-shell'. * tests/openpgp/shell.scm: New file. Signed-off-by: Justus Winter --- lib.scm | 18 ++++++++++++++++++ tests.scm | 8 ++++++++ 2 files changed, 26 insertions(+) diff --git a/lib.scm b/lib.scm index e4ab483..316eacf 100644 --- a/lib.scm +++ b/lib.scm @@ -42,6 +42,24 @@ ((not (p (car l))) #f) (else (all p (cdr l))))) +;; Return the first element of a list. +(define first car) + +;; Return the last element of a list. +(define (last lst) + (if (null? (cdr lst)) + (car lst) + (last (cdr lst)))) + +;; Compute the powerset of a list. +(define (powerset set) + (if (null? set) + '(()) + (let ((rst (powerset (cdr set)))) + (append (map (lambda (x) (cons (car set) x)) + rst) + rst)))) + ;; Is PREFIX a prefix of S? (define (string-prefix? s prefix) (and (>= (string-length s) (string-length prefix)) diff --git a/tests.scm b/tests.scm index 8986a70..d89a96f 100644 --- a/tests.scm +++ b/tests.scm @@ -481,3 +481,11 @@ (catch (list tmpfiles source *error*) (apply function `(,(call-with-input-file source read-all) ,@args))) (list tmpfiles source #f))) + +;; +;; Developing and debugging tests. +;; + +;; Spawn an os shell. +(define (interactive-shell) + (call-with-fds `(,(getenv "SHELL")) 0 1 2)) -- cgit v1.2.3 From 97024a0cd0e1f5262ee60bf40a91f169bcc45a23 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 4 Nov 2016 12:08:20 +0100 Subject: gpgscm: Implement 'atexit'. * tests/gpgscm/ffi.scm (throw): Run *run-atexit-handlers* when terminating the interpreter. (*atexit-handlers*): New variable. (*run-atexit-handlers*): New function. (atexit): Likewise. * tests/gpgscm/main.c (main): Run *run-atexit-handlers* at normal interpreter shutdown. Signed-off-by: Justus Winter --- ffi.scm | 18 ++++++++++++++++++ main.c | 1 + 2 files changed, 19 insertions(+) diff --git a/ffi.scm b/ffi.scm index 72a2a8f..fb18538 100644 --- a/ffi.scm +++ b/ffi.scm @@ -57,6 +57,7 @@ ((more-handlers?) (apply (pop-handler) x)) ((and (= 2 (length x)) (equal? *interpreter-exit* (car x))) + (*run-atexit-handlers*) (_exit (cadr x))) (else (apply error x)))) @@ -64,3 +65,20 @@ ;; Terminate the process returning STATUS to the parent. (define (exit status) (throw *interpreter-exit* status)) + +;; A list of functions run at interpreter shutdown. +(define *atexit-handlers* (list)) + +;; Execute all these functions. +(define (*run-atexit-handlers*) + (unless (null? *atexit-handlers*) + (let ((proc (car *atexit-handlers*))) + ;; Drop proc from the list so that it will not get + ;; executed again even if it raises an exception. + (set! *atexit-handlers* (cdr *atexit-handlers*)) + (proc) + (*run-atexit-handlers*)))) + +;; Register a function to be run at interpreter shutdown. +(define (atexit proc) + (set! *atexit-handlers* (cons proc *atexit-handlers*))) diff --git a/main.c b/main.c index f7c6b0d..70ce855 100644 --- a/main.c +++ b/main.c @@ -291,6 +291,7 @@ main (int argc, char **argv) log_fatal ("%s: %s", script, gpg_strerror (err)); } + scheme_load_string (sc, "(*run-atexit-handlers*)"); scheme_deinit (sc); xfree (sc); return EXIT_SUCCESS; -- cgit v1.2.3 From fa221a1d5272eb231393a2cc0173635a5098bb89 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 4 Nov 2016 13:45:30 +0100 Subject: gpgscm: Fix printing strings containing zero bytes. * tests/gpgscm/scheme.c (atom2str): Fix computing the length of Scheme strings. Scheme strings can contain zero bytes. Signed-off-by: Justus Winter --- scheme.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 0e31dc5..44dd165 100644 --- a/scheme.c +++ b/scheme.c @@ -2041,7 +2041,9 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) { } } else if (is_string(l)) { if (!f) { - p = strvalue(l); + *pp = strvalue(l); + *plen = strlength(l); + return; } else { /* Hack, uses the fact that printing is needed */ *pp=sc->strbuff; *plen=0; -- cgit v1.2.3 From dd3683d4427347314932709a631e01ccbc0382c6 Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Sat, 5 Nov 2016 12:02:19 +0100 Subject: Change all http://www.gnu.org in license notices to https:// -- --- Makefile.am | 2 +- ffi-private.h | 2 +- ffi.c | 2 +- ffi.h | 2 +- main.c | 2 +- private.h | 2 +- scheme-config.h | 2 +- t-child.c | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/Makefile.am b/Makefile.am index dad30ed..9a5edc2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -15,7 +15,7 @@ # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License -# along with this program; if not, see . +# along with this program; if not, see . EXTRA_DIST = \ LICENSE.TinySCHEME \ diff --git a/ffi-private.h b/ffi-private.h index 0d58c41..037da56 100644 --- a/ffi-private.h +++ b/ffi-private.h @@ -15,7 +15,7 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this program; if not, see . + * along with this program; if not, see . */ #ifndef GPGSCM_FFI_PRIVATE_H diff --git a/ffi.c b/ffi.c index 305b7a1..49aeb97 100644 --- a/ffi.c +++ b/ffi.c @@ -15,7 +15,7 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this program; if not, see . + * along with this program; if not, see . */ #include diff --git a/ffi.h b/ffi.h index 9bd710f..eba6282 100644 --- a/ffi.h +++ b/ffi.h @@ -15,7 +15,7 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this program; if not, see . + * along with this program; if not, see . */ #ifndef GPGSCM_FFI_H diff --git a/main.c b/main.c index 70ce855..2f77ac5 100644 --- a/main.c +++ b/main.c @@ -15,7 +15,7 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this program; if not, see . + * along with this program; if not, see . */ #include diff --git a/private.h b/private.h index efa0cb0..6e330e0 100644 --- a/private.h +++ b/private.h @@ -15,7 +15,7 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this program; if not, see . + * along with this program; if not, see . */ #ifndef __GPGSCM_PRIVATE_H__ diff --git a/scheme-config.h b/scheme-config.h index fe3d746..2003498 100644 --- a/scheme-config.h +++ b/scheme-config.h @@ -15,7 +15,7 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this program; if not, see . + * along with this program; if not, see . */ #define STANDALONE 0 diff --git a/t-child.c b/t-child.c index ae1a635..547eb17 100644 --- a/t-child.c +++ b/t-child.c @@ -15,7 +15,7 @@ * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License - * along with this program; if not, see . + * along with this program; if not, see . */ #include -- cgit v1.2.3 From 70c5f30074ec996f60f62cd09e67167da78c6d8a Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 7 Nov 2016 12:21:26 +0100 Subject: gpgscm: Add support for pseudo-random numbers. * tests/gpgscm/ffi.c (do_getpid): New function. (do_srandom): Likewise. (random_scaled): Likewise. (do_random): Likewise. (do_make_random_string): Likewise. (ffi_init): Expose the new functions. * tests/gpgscm/lib.scm: Document the new functions. Signed-off-by: Justus Winter --- ffi.c | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ lib.scm | 21 +++++++++++++++++++ 2 files changed, 94 insertions(+) diff --git a/ffi.c b/ffi.c index 49aeb97..8bb2652 100644 --- a/ffi.c +++ b/ffi.c @@ -472,6 +472,73 @@ do_get_isotime (scheme *sc, pointer args) FFI_RETURN_STRING (sc, timebuf); } +static pointer +do_getpid (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, getpid ()); +} + +static pointer +do_srandom (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int seed; + FFI_ARG_OR_RETURN (sc, int, seed, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + srand (seed); + FFI_RETURN (sc); +} + +static int +random_scaled (int scale) +{ + int v; +#ifdef HAVE_RAND + v = rand (); +#else + v = random (); +#endif + +#ifndef RAND_MAX /* for SunOS */ +#define RAND_MAX 32767 +#endif + + return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1); +} + +static pointer +do_random (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int scale; + FFI_ARG_OR_RETURN (sc, int, scale, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, random_scaled (scale)); +} + +static pointer +do_make_random_string (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int size; + pointer chunk; + char *p; + FFI_ARG_OR_RETURN (sc, int, size, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (size < 0) + return ffi_sprintf (sc, "size must be positive"); + + chunk = sc->vptr->mk_counted_string (sc, NULL, size); + if (sc->no_memory) + FFI_RETURN_ERR (sc, ENOMEM); + + for (p = sc->vptr->string_value (chunk); size; p++, size--) + *p = (char) random_scaled (256); + FFI_RETURN_POINTER (sc, chunk); +} + /* estream functions. */ @@ -1233,6 +1300,12 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define_function (sc, mkdir); ffi_define_function (sc, rmdir); ffi_define_function (sc, get_isotime); + ffi_define_function (sc, getpid); + + /* Random numbers. */ + ffi_define_function (sc, srandom); + ffi_define_function (sc, random); + ffi_define_function (sc, make_random_string); /* Process management. */ ffi_define_function (sc, spawn_process); diff --git a/lib.scm b/lib.scm index 316eacf..270189d 100644 --- a/lib.scm +++ b/lib.scm @@ -185,3 +185,24 @@ (else (write-char (apply read-char p) acc) (loop acc)))))) + +;; +;; Libc functions. +;; + +;; Get our process id. +(ffi-define (getpid)) + +;; +;; Random numbers. +;; + +;; Seed the random number generator. +(ffi-define (srandom seed)) + +;; Get a pseudo-random number between 0 (inclusive) and SCALE +;; (exclusive). +(ffi-define (random scale)) + +;; Create a string of the given SIZE containing pseudo-random data. +(ffi-define (make-random-string size)) -- cgit v1.2.3 From fa82512020f8cd91c68bbf1d24a4f6bffe5385ba Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 7 Nov 2016 13:12:01 +0100 Subject: gpgscm,w32: Provide schemish file handling for binary files. * tests/gpgscm/lib.scm (call-with-binary-input-file): New function. (call-with-binary-output-file): Likewise. Signed-off-by: Justus Winter --- lib.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lib.scm b/lib.scm index 270189d..a8ae2f8 100644 --- a/lib.scm +++ b/lib.scm @@ -186,6 +186,20 @@ (write-char (apply read-char p) acc) (loop acc)))))) +;; +;; Windows support. +;; + +;; Like call-with-input-file but opens the file in 'binary' mode. +(define (call-with-binary-input-file filename proc) + (letfd ((fd (open filename (logior O_RDONLY O_BINARY)))) + (proc (fdopen fd "rb")))) + +;; Like call-with-output-file but opens the file in 'binary' mode. +(define (call-with-binary-output-file filename proc) + (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (proc (fdopen fd "wb")))) + ;; ;; Libc functions. ;; -- cgit v1.2.3 From 1564fc3b2ff52e7e5ad9b01a24e1f399934775b8 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 7 Nov 2016 16:21:21 +0100 Subject: tests: Move environment creation and teardown into each test. * tests/gpgscm/tests.scm (log): New function. * tests/openpgp/run-tests.scm (run-tests-parallel): Do not run the startup and teardown scripts. (run-tests-sequential): Likewise. * tests/openpgp/setup.scm: Move all functions... * tests/openpgp/defs.scm: ... here and make them less verbose. (setup-environment): New function. (setup-legacy-environment): Likewise. (start-agent): Make less verbose, run 'stop-agent' at interpreter exit. (stop-agent): Make less verbose. * tests/openpgp/finish.scm: Drop file. * tests/openpgp/Makefile.am (EXTRA_DIST): Drop removed file. * tests/openpgp/4gb-packet.scm: Use 'setup-environment' or 'setup-legacy-environment' as appropriate. * tests/openpgp/armdetach.scm: Likewise. * tests/openpgp/armdetachm.scm: Likewise. * tests/openpgp/armencrypt.scm: Likewise. * tests/openpgp/armencryptp.scm: Likewise. * tests/openpgp/armor.scm: Likewise. * tests/openpgp/armsignencrypt.scm: Likewise. * tests/openpgp/armsigs.scm: Likewise. * tests/openpgp/clearsig.scm: Likewise. * tests/openpgp/conventional-mdc.scm: Likewise. * tests/openpgp/conventional.scm: Likewise. * tests/openpgp/decrypt-dsa.scm: Likewise. * tests/openpgp/decrypt.scm: Likewise. * tests/openpgp/default-key.scm: Likewise. * tests/openpgp/detach.scm: Likewise. * tests/openpgp/detachm.scm: Likewise. * tests/openpgp/ecc.scm: Likewise. * tests/openpgp/encrypt-dsa.scm: Likewise. * tests/openpgp/encrypt.scm: Likewise. * tests/openpgp/encryptp.scm: Likewise. * tests/openpgp/export.scm: Likewise. * tests/openpgp/finish.scm: Likewise. * tests/openpgp/genkey1024.scm: Likewise. * tests/openpgp/gpgtar.scm: Likewise. * tests/openpgp/gpgv-forged-keyring.scm: Likewise. * tests/openpgp/import.scm: Likewise. * tests/openpgp/issue2015.scm: Likewise. * tests/openpgp/issue2417.scm: Likewise. * tests/openpgp/issue2419.scm: Likewise. * tests/openpgp/key-selection.scm: Likewise. * tests/openpgp/mds.scm: Likewise. * tests/openpgp/multisig.scm: Likewise. * tests/openpgp/quick-key-manipulation.scm: Likewise. * tests/openpgp/seat.scm: Likewise. * tests/openpgp/shell.scm: Likewise. * tests/openpgp/signencrypt-dsa.scm: Likewise. * tests/openpgp/signencrypt.scm: Likewise. * tests/openpgp/sigs-dsa.scm: Likewise. * tests/openpgp/sigs.scm: Likewise. * tests/openpgp/ssh.scm: Likewise. * tests/openpgp/tofu.scm: Likewise. * tests/openpgp/use-exact-key.scm: Likewise. * tests/openpgp/verify.scm: Likewise. * tests/openpgp/version.scm: Likewise. * tests/openpgp/issue2346.scm: Likewise and simplify. -- The previous Bourne Shell-based test suite created the environment before running all tests, and tore it down after executing them. When we created the Scheme-based test suite, we kept this design at first, but introduced a way to run each test in its own environment to prevent tests from interfering with each other. Nevertheless, every test started out with the same environment. Move the creation of the test environment into each test. This gives us finer control over the environment each test is run in. It also makes it possible to run each test by simply executing it using gpgscm without the use of the runner. Furthermore, it has the neat side-effect of speeding up the test suite if run in parallel. Signed-off-by: Justus Winter --- tests.scm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests.scm b/tests.scm index d89a96f..72afa99 100644 --- a/tests.scm +++ b/tests.scm @@ -38,6 +38,10 @@ (apply echo msg) (flush-stdio)) +(define (log . msg) + (if (> (*verbose*) 0) + (apply info msg))) + (define (error . msg) (apply info msg) (exit 1)) -- cgit v1.2.3 From 598aeda60bc3e6d49d935927b5ec33145f7af9db Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 7 Nov 2016 16:59:15 +0100 Subject: gpgscm: Drop 'len' argument from splice. * tests/gpgscm/ffi.c (do_splice): Drop 'len' argument, no-one uses it. * tests/gpgscm/lib.scm (splice): Document foreign function. Signed-off-by: Justus Winter --- ffi.c | 13 ++----------- lib.scm | 3 +++ 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/ffi.c b/ffi.c index 8bb2652..18aff98 100644 --- a/ffi.c +++ b/ffi.c @@ -1001,29 +1001,20 @@ do_splice (scheme *sc, pointer args) FFI_PROLOG (); int source; int sink; - ssize_t len = -1; char buffer[1024]; ssize_t bytes_read; FFI_ARG_OR_RETURN (sc, int, source, number, args); FFI_ARG_OR_RETURN (sc, int, sink, number, args); - if (args != sc->NIL) - FFI_ARG_OR_RETURN (sc, ssize_t, len, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); - while (len == -1 || len > 0) + while (1) { - size_t want = sizeof buffer; - if (len > 0 && (ssize_t) want > len) - want = (size_t) len; - - bytes_read = read (source, buffer, want); + bytes_read = read (source, buffer, sizeof buffer); if (bytes_read == 0) break; if (bytes_read < 0) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); if (write (sink, buffer, bytes_read) != bytes_read) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - if (len != -1) - len -= bytes_read; } FFI_RETURN (sc); } diff --git a/lib.scm b/lib.scm index a8ae2f8..7d2d1eb 100644 --- a/lib.scm +++ b/lib.scm @@ -207,6 +207,9 @@ ;; Get our process id. (ffi-define (getpid)) +;; Copy data from file descriptor SOURCE to SINK. +(ffi-define (splice source sink)) + ;; ;; Random numbers. ;; -- cgit v1.2.3 From 1edacbc5a4a0f4dee3ab82c1fda7c7b1c5874761 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 7 Nov 2016 17:40:43 +0100 Subject: gpgscm: Generalize splice to write to multiple sinks. * tests/gpgscm/ffi.c (ordinal_suffix): New function. (do_splice): Generalize splice to write to multiple sinks. * tests/gpgscm/lib.scm (splice): Document this fact. Signed-off-by: Justus Winter --- ffi.c | 44 +++++++++++++++++++++++++++++++++++++++----- lib.scm | 5 +++-- 2 files changed, 42 insertions(+), 7 deletions(-) diff --git a/ffi.c b/ffi.c index 18aff98..d4bf3ef 100644 --- a/ffi.c +++ b/ffi.c @@ -995,17 +995,36 @@ do_file_equal (scheme *sc, pointer args) goto out; } +static const char * +ordinal_suffix (int n) +{ + switch (n) + { + case 1: return "st"; + case 2: return "nd"; + case 3: return "rd"; + default: return "th"; + } + assert (! "reached"); +} + static pointer do_splice (scheme *sc, pointer args) { FFI_PROLOG (); int source; - int sink; char buffer[1024]; ssize_t bytes_read; + pointer sinks, sink; FFI_ARG_OR_RETURN (sc, int, source, number, args); - FFI_ARG_OR_RETURN (sc, int, sink, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); + sinks = args; + if (sinks == sc->NIL) + return ffi_sprintf (sc, "need at least one sink"); + for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++) + if (! sc->vptr->is_number (pair_car (sink))) + return ffi_sprintf (sc, "%d%s argument is not a number", + ffi_arg_index, ordinal_suffix (ffi_arg_index)); + while (1) { bytes_read = read (source, buffer, sizeof buffer); @@ -1013,8 +1032,23 @@ do_splice (scheme *sc, pointer args) break; if (bytes_read < 0) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - if (write (sink, buffer, bytes_read) != bytes_read) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink)) + { + int fd = sc->vptr->ivalue (pair_car (sink)); + char *p = buffer; + ssize_t left = bytes_read; + + while (left) + { + ssize_t written = write (fd, p, left); + if (written < 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + assert (written <= left); + left -= written; + p += written; + } + } } FFI_RETURN (sc); } diff --git a/lib.scm b/lib.scm index 7d2d1eb..27779e2 100644 --- a/lib.scm +++ b/lib.scm @@ -207,8 +207,9 @@ ;; Get our process id. (ffi-define (getpid)) -;; Copy data from file descriptor SOURCE to SINK. -(ffi-define (splice source sink)) +;; Copy data from file descriptor SOURCE to every file descriptor in +;; SINKS. +(ffi-define (splice source . sinks)) ;; ;; Random numbers. -- cgit v1.2.3 From d5458258299889af97e714c15e6a9b859e1a0545 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 8 Nov 2016 14:47:43 +0100 Subject: gpgscm: Fix error message. * tests/gpgscm/ffi.c (do_wait_processes): Fix and improve error messages. Signed-off-by: Justus Winter --- ffi.c | 39 +++++++++++++++++++++------------------ 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/ffi.c b/ffi.c index d4bf3ef..add82f7 100644 --- a/ffi.c +++ b/ffi.c @@ -48,6 +48,20 @@ #include "ffi.h" #include "ffi-private.h" +/* For use in nice error messages. */ +static const char * +ordinal_suffix (int n) +{ + switch (n) + { + case 1: return "st"; + case 2: return "nd"; + case 3: return "rd"; + default: return "th"; + } + assert (! "reached"); +} + int @@ -827,17 +841,19 @@ do_wait_processes (scheme *sc, pointer args) err = ffi_list2argv (sc, list_names, &names, &count); if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%luth element of first argument is " + return ffi_sprintf (sc, "%lu%s element of first argument is " "neither string nor symbol", - (unsigned long) count); + (unsigned long) count, + ordinal_suffix ((int) count)); if (err) FFI_RETURN_ERR (sc, err); err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%luth element of second argument is " - "neither string nor symbol", - (unsigned long) count); + return ffi_sprintf (sc, "%lu%s element of second argument is " + "not a number", + (unsigned long) count, + ordinal_suffix ((int) count)); if (err) FFI_RETURN_ERR (sc, err); @@ -995,19 +1011,6 @@ do_file_equal (scheme *sc, pointer args) goto out; } -static const char * -ordinal_suffix (int n) -{ - switch (n) - { - case 1: return "st"; - case 2: return "nd"; - case 3: return "rd"; - default: return "th"; - } - assert (! "reached"); -} - static pointer do_splice (scheme *sc, pointer args) { -- cgit v1.2.3 From 13831e9cd6839e44a8e32c640589edb8bf17ef51 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 8 Nov 2016 15:11:12 +0100 Subject: gpgscm: Expose seek and associated constants. * tests/gpgscm/ffi.c (do_seek): New function. (ffi_init): Expose 'seek' and 'SEEK_{SET,CUR,END}'. * tests/gpgscm/lib.scm: Document the new function. Signed-off-by: Justus Winter --- ffi.c | 19 +++++++++++++++++++ lib.scm | 8 ++++++++ 2 files changed, 27 insertions(+) diff --git a/ffi.c b/ffi.c index add82f7..c91d4aa 100644 --- a/ffi.c +++ b/ffi.c @@ -325,6 +325,21 @@ do_close (scheme *sc, pointer args) FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); } +static pointer +do_seek (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + off_t offset; + int whence; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARG_OR_RETURN (sc, off_t, offset, number, args); + FFI_ARG_OR_RETURN (sc, int, whence, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1 + ? gpg_error_from_syserror () : 0); +} + static pointer do_mkdtemp (scheme *sc, pointer args) { @@ -1309,6 +1324,9 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define_constant (sc, STDIN_FILENO); ffi_define_constant (sc, STDOUT_FILENO); ffi_define_constant (sc, STDERR_FILENO); + ffi_define_constant (sc, SEEK_SET); + ffi_define_constant (sc, SEEK_CUR); + ffi_define_constant (sc, SEEK_END); ffi_define_function (sc, sleep); ffi_define_function (sc, usleep); @@ -1320,6 +1338,7 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define_function (sc, open); ffi_define_function (sc, fdopen); ffi_define_function (sc, close); + ffi_define_function (sc, seek); ffi_define_function_name (sc, "_mkdtemp", mkdtemp); ffi_define_function (sc, unlink); ffi_define_function (sc, unlink_recursively); diff --git a/lib.scm b/lib.scm index 27779e2..4e19eae 100644 --- a/lib.scm +++ b/lib.scm @@ -204,6 +204,14 @@ ;; Libc functions. ;; +;; Change the read/write offset. +(ffi-define (seek fd offset whence)) + +;; Constants for WHENCE. +(ffi-define SEEK_SET) +(ffi-define SEEK_CUR) +(ffi-define SEEK_END) + ;; Get our process id. (ffi-define (getpid)) -- cgit v1.2.3 From a6ce303f0c69542999c607309128afd6293e2e1b Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 8 Nov 2016 18:08:42 +0100 Subject: gpgscm: Remove dubious stack implementation. * tests/gpgscm/scheme-private.h (struct scheme): Remove related fields. * tests/gpgscm/scheme.c: Drop all !USE_SCHEME_STACK code. * tests/gpgscm/scheme.h (USE_SCHEME_STACK): Remove macro. Signed-off-by: Justus Winter --- scheme-private.h | 2 -- scheme.c | 88 -------------------------------------------------------- scheme.h | 5 ---- 3 files changed, 95 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 727e0c0..f5e4b0a 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -155,8 +155,6 @@ 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 */ diff --git a/scheme.c b/scheme.c index 44dd165..c1340d7 100644 --- a/scheme.c +++ b/scheme.c @@ -2442,93 +2442,6 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #define s_return(sc,a) return _s_return(sc,a) -#ifndef USE_SCHEME_STACK - -/* this structure holds all the interpreter's registers */ -struct dump_stack_frame { - enum scheme_opcodes op; - pointer args; - pointer envir; - pointer code; -}; - -#define STACK_GROWTH 3 - -static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) -{ - int nframes = (int)sc->dump; - struct dump_stack_frame *next_frame; - - /* enough room for the next frame? */ - if (nframes >= sc->dump_size) { - sc->dump_size += STACK_GROWTH; - /* alas there is no sc->realloc */ - sc->dump_base = realloc(sc->dump_base, - sizeof(struct dump_stack_frame) * sc->dump_size); - } - next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; - next_frame->op = op; - next_frame->args = args; - next_frame->envir = sc->envir; - next_frame->code = code; - sc->dump = (pointer)(nframes+1); -} - -static pointer _s_return(scheme *sc, pointer a) -{ - int nframes = (int)sc->dump; - struct dump_stack_frame *frame; - - sc->value = (a); - if (nframes <= 0) { - return sc->NIL; - } - nframes--; - frame = (struct dump_stack_frame *)sc->dump_base + nframes; - sc->op = frame->op; - sc->args = frame->args; - sc->envir = frame->envir; - sc->code = frame->code; - sc->dump = (pointer)nframes; - return sc->T; -} - -static INLINE void dump_stack_reset(scheme *sc) -{ - /* in this implementation, sc->dump is the number of frames on the stack */ - sc->dump = (pointer)0; -} - -static INLINE void dump_stack_initialize(scheme *sc) -{ - sc->dump_size = 0; - sc->dump_base = NULL; - dump_stack_reset(sc); -} - -static void dump_stack_free(scheme *sc) -{ - free(sc->dump_base); - sc->dump_base = NULL; - sc->dump = (pointer)0; - sc->dump_size = 0; -} - -static INLINE void dump_stack_mark(scheme *sc) -{ - int nframes = (int)sc->dump; - int i; - for(i=0; idump_base + i; - mark(frame->args); - mark(frame->envir); - mark(frame->code); - } -} - -#else - static INLINE void dump_stack_reset(scheme *sc) { sc->dump = sc->NIL; @@ -2565,7 +2478,6 @@ static INLINE void dump_stack_mark(scheme *sc) { mark(sc->dump); } -#endif #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) diff --git a/scheme.h b/scheme.h index f4231c4..bd6cda5 100644 --- a/scheme.h +++ b/scheme.h @@ -44,11 +44,6 @@ extern "C" { # 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 -- cgit v1.2.3 From f69a754515f43037da8ac8535967cd825b220be4 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 8 Nov 2016 18:35:42 +0100 Subject: gpgscm: Drop obsolete commented-out code. * tests/gpgscm/scheme.c (opexe_5): Drop obsolete code. Signed-off-by: Justus Winter --- scheme.c | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/scheme.c b/scheme.c index c1340d7..6daa280 100644 --- a/scheme.c +++ b/scheme.c @@ -4056,17 +4056,6 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { case TOK_EOF: s_return(sc,sc->EOF_OBJ); /* NOTREACHED */ -/* - * Commented out because we now skip comments in the scanner - * - case TOK_COMMENT: { - int c; - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - } -*/ case TOK_VEC: s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); /* fall through */ @@ -4135,14 +4124,6 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { case OP_RDLIST: { sc->args = cons(sc, sc->value, sc->args); sc->tok = token(sc); -/* We now skip comments in the scanner - while (sc->tok == TOK_COMMENT) { - int c; - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - sc->tok = token(sc); - } -*/ if (sc->tok == TOK_EOF) { s_return(sc,sc->EOF_OBJ); } else if (sc->tok == TOK_RPAREN) { -- cgit v1.2.3 From a678b9fdf7d48409a32afab5b487322a7fc11e16 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 9 Nov 2016 13:34:54 +0100 Subject: gpgscm: Make the compile-hook configurable. * tests/gpgscm/scheme-private.h (struct scheme): Make field 'COMPILE_HOOK' optional. * tests/gpgscm/scheme.c (opexe_0): Fix guard. (scheme_init_custom_alloc): Conditionally initialize 'COMPILE_HOOK'. * tests/gpgscm/scheme.h (USE_COMPILE_HOOK): Define to 1 by default. Signed-off-by: Justus Winter --- scheme-private.h | 2 ++ scheme.c | 4 +++- scheme.h | 7 +++++++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/scheme-private.h b/scheme-private.h index f5e4b0a..884889c 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -115,7 +115,9 @@ pointer FEED_TO; /* => */ pointer COLON_HOOK; /* *colon-hook* */ pointer ERROR_HOOK; /* *error-hook* */ pointer SHARP_HOOK; /* *sharp-hook* */ +#if USE_COMPILE_HOOK pointer COMPILE_HOOK; /* *compile-hook* */ +#endif pointer free_cell; /* pointer to top of free cells */ long fcells; /* # of free cells */ diff --git a/scheme.c b/scheme.c index 6daa280..884ffd5 100644 --- a/scheme.c +++ b/scheme.c @@ -2688,7 +2688,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->code = sc->value; s_goto(sc,OP_EVAL); -#if 1 +#if USE_COMPILE_HOOK case OP_LAMBDA: /* lambda */ /* If the hook is defined, apply it to sc->code, otherwise set sc->value fall through */ @@ -4737,7 +4737,9 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); +#if USE_COMPILE_HOOK sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); +#endif return !sc->no_memory; } diff --git a/scheme.h b/scheme.h index bd6cda5..8d6fb42 100644 --- a/scheme.h +++ b/scheme.h @@ -40,6 +40,7 @@ extern "C" { # define USE_ERROR_HOOK 0 # define USE_TRACING 0 # define USE_COLON_HOOK 0 +# define USE_COMPILE_HOOK 0 # define USE_DL 0 # define USE_PLIST 0 #endif @@ -83,6 +84,12 @@ extern "C" { # define USE_COLON_HOOK 1 #endif +/* Compile functions using *compile-hook*. The default hook expands + * macros. */ +#ifndef USE_COMPILE_HOOK +# define USE_COMPILE_HOOK 1 +#endif + #ifndef USE_STRCASECMP /* stricmp for Unix */ # define USE_STRCASECMP 0 #endif -- cgit v1.2.3 From f65fb16724712b3d6072f27b47e2658f27398dd4 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 10 Nov 2016 11:47:08 +0100 Subject: gpgscm: Reduce opcode dispatch overhead. * tests/gpgscm/scheme.c (s_thread_to): New macro. (CASE): Likewise. (opexe_[0-6]): Use 'CASE' instead of 'case' statements, replace 's_goto' with 's_thread_to' where applicable. -- This is a straight-forward optimization that replaces 's_goto' in certain cases. Instead of returning to the calling function, and dispatching the next opcode, we can jump to the opcode handler. Signed-off-by: Justus Winter --- scheme.c | 479 +++++++++++++++++++++++++++++++++------------------------------ scheme.h | 5 + 2 files changed, 256 insertions(+), 228 deletions(-) diff --git a/scheme.c b/scheme.c index 884ffd5..90cb8fd 100644 --- a/scheme.c +++ b/scheme.c @@ -2436,10 +2436,33 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { /* Too small to turn into function */ # define BEGIN do { # define END } while (0) + +/* Bounce back to Eval_Cycle and execute A. */ #define s_goto(sc,a) BEGIN \ sc->op = (int)(a); \ return sc->T; END +#if USE_THREADED_CODE + +/* Do not bounce back to Eval_Cycle but execute A by jumping directly + * to it. Only applicable if A is part of the same dispatch + * function. */ +#define s_thread_to(sc, a) \ + BEGIN \ + op = (int) (a); \ + goto a; \ + END + +/* Define a label OP and emit a case statement for OP. For use in the + * dispatch functions. The slightly peculiar goto that is never + * executed avoids warnings about unused labels. */ +#define CASE(OP) if (0) goto OP; OP: case OP + +#else /* USE_THREADED_CODE */ +#define s_thread_to(sc, a) s_goto(sc, a) +#define CASE(OP) case OP +#endif /* USE_THREADED_CODE */ + #define s_return(sc,a) return _s_return(sc,a) static INLINE void dump_stack_reset(scheme *sc) @@ -2485,7 +2508,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { pointer x, y; switch (op) { - case OP_LOAD: /* load */ + CASE(OP_LOAD): /* load */ if(file_interactive(sc)) { fprintf(sc->outport->_object._port->rep.stdio.file, "Loading %s\n", strvalue(car(sc->args))); @@ -2496,10 +2519,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { else { sc->args = mk_integer(sc,sc->file_i); - s_goto(sc,OP_T0LVL); + s_thread_to(sc,OP_T0LVL); } - case OP_T0LVL: /* top level */ + CASE(OP_T0LVL): /* top level */ /* If we reached the end of file, this loop is done. */ if(sc->loadport->_object._port->kind & port_saw_EOF) { @@ -2533,23 +2556,23 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); - s_goto(sc,OP_READ_INTERNAL); + s_thread_to(sc,OP_READ_INTERNAL); - case OP_T1LVL: /* top level */ + CASE(OP_T1LVL): /* top level */ sc->code = sc->value; sc->inport=sc->save_inport; - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); - case OP_READ_INTERNAL: /* internal read */ + CASE(OP_READ_INTERNAL): /* internal read */ sc->tok = token(sc); if(sc->tok==TOK_EOF) { s_return(sc,sc->EOF_OBJ); } s_goto(sc,OP_RDSEXPR); - case OP_GENSYM: + CASE(OP_GENSYM): s_return(sc, gensym(sc)); - case OP_VALUEPRINT: /* print evaluation result */ + CASE(OP_VALUEPRINT): /* print evaluation result */ /* OP_VALUEPRINT is always pushed, because when changing from non-interactive to interactive mode, it needs to be already on the stack */ @@ -2564,7 +2587,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->value); } - case OP_EVAL: /* main part of evaluation */ + CASE(OP_EVAL): /* main part of evaluation */ #if USE_TRACING if(sc->tracing) { /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ @@ -2574,7 +2597,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_goto(sc,OP_P0LIST); } /* fall through */ - case OP_REAL_EVAL: + CASE(OP_REAL_EVAL): #endif if (is_symbol(sc->code)) { /* symbol */ x=find_slot_in_env(sc,sc->envir,sc->code,1); @@ -2591,46 +2614,46 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_E0ARGS, sc->NIL, sc->code); /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } } else { s_return(sc,sc->code); } - case OP_E0ARGS: /* eval arguments */ + CASE(OP_E0ARGS): /* eval arguments */ if (is_macro(sc->value)) { /* macro expansion */ s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); sc->args = cons(sc,sc->code, sc->NIL); sc->code = sc->value; - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); } else { sc->code = cdr(sc->code); - s_goto(sc,OP_E1ARGS); + s_thread_to(sc,OP_E1ARGS); } - case OP_E1ARGS: /* eval arguments */ + CASE(OP_E1ARGS): /* eval arguments */ sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) { /* continue */ s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); sc->code = car(sc->code); sc->args = sc->NIL; - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } else { /* end */ sc->args = reverse_in_place(sc, sc->NIL, sc->args); sc->code = car(sc->args); sc->args = cdr(sc->args); - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); } #if USE_TRACING - case OP_TRACING: { + CASE(OP_TRACING): { int tr=sc->tracing; sc->tracing=ivalue(car(sc->args)); s_return(sc,mk_integer(sc,tr)); } #endif - case OP_APPLY: /* apply 'code' to 'args' */ + CASE(OP_APPLY): /* apply 'code' to 'args' */ #if USE_TRACING if(sc->tracing) { s_save(sc,OP_REAL_APPLY,sc->args,sc->code); @@ -2640,7 +2663,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_goto(sc,OP_P0LIST); } /* fall through */ - case OP_REAL_APPLY: + CASE(OP_REAL_APPLY): #endif if (is_proc(sc->code)) { s_goto(sc,procnum(sc->code)); /* PROCEDURE */ @@ -2676,7 +2699,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } sc->code = cdr(closure_code(sc->code)); sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } else if (is_continuation(sc->code)) { /* CONTINUATION */ sc->dump = cont_dump(sc->code); s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); @@ -2684,12 +2707,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { Error_1(sc,"illegal function",sc->code); } - case OP_DOMACRO: /* do macro */ + CASE(OP_DOMACRO): /* do macro */ sc->code = sc->value; - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); #if USE_COMPILE_HOOK - case OP_LAMBDA: /* lambda */ + CASE(OP_LAMBDA): /* lambda */ /* If the hook is defined, apply it to sc->code, otherwise set sc->value fall through */ { @@ -2701,20 +2724,20 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_LAMBDA1,sc->args,sc->code); sc->args=cons(sc,sc->code,sc->NIL); sc->code=slot_value_in_env(f); - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); } } - case OP_LAMBDA1: + CASE(OP_LAMBDA1): s_return(sc,mk_closure(sc, sc->value, sc->envir)); #else - case OP_LAMBDA: /* lambda */ + CASE(OP_LAMBDA): /* lambda */ s_return(sc,mk_closure(sc, sc->code, sc->envir)); #endif - case OP_MKCLOSURE: /* make-closure */ + CASE(OP_MKCLOSURE): /* make-closure */ x=car(sc->args); if(car(x)==sc->LAMBDA) { x=cdr(x); @@ -2726,10 +2749,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } s_return(sc,mk_closure(sc, x, y)); - case OP_QUOTE: /* quote */ + CASE(OP_QUOTE): /* quote */ s_return(sc,car(sc->code)); - case OP_DEF0: /* define */ + CASE(OP_DEF0): /* define */ if(is_immutable(car(sc->code))) Error_1(sc,"define: unable to alter immutable", car(sc->code)); @@ -2744,9 +2767,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"variable is not a symbol"); } s_save(sc,OP_DEF1, sc->NIL, x); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); - case OP_DEF1: /* define */ + CASE(OP_DEF1): /* define */ x=find_slot_in_env(sc,sc->envir,sc->code,0); if (x != sc->NIL) { set_slot_in_env(sc, x, sc->value); @@ -2756,21 +2779,21 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->code); - case OP_DEFP: /* defined? */ + CASE(OP_DEFP): /* defined? */ x=sc->envir; if(cdr(sc->args)!=sc->NIL) { x=cadr(sc->args); } s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); - case OP_SET0: /* set! */ + CASE(OP_SET0): /* set! */ if(is_immutable(car(sc->code))) Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); s_save(sc,OP_SET1, sc->NIL, car(sc->code)); sc->code = cadr(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); - case OP_SET1: /* set! */ + CASE(OP_SET1): /* set! */ y=find_slot_in_env(sc,sc->envir,sc->code,1); if (y != sc->NIL) { set_slot_in_env(sc, y, sc->value); @@ -2780,7 +2803,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } - case OP_BEGIN: /* begin */ + CASE(OP_BEGIN): /* begin */ if (!is_pair(sc->code)) { s_return(sc,sc->code); } @@ -2788,28 +2811,28 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); } sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); - case OP_IF0: /* if */ + CASE(OP_IF0): /* if */ s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); - case OP_IF1: /* if */ + CASE(OP_IF1): /* if */ if (is_true(sc->value)) sc->code = car(sc->code); else sc->code = cadr(sc->code); /* (if #f 1) ==> () because * car(sc->NIL) = sc->NIL */ - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); - case OP_LET0: /* let */ + CASE(OP_LET0): /* let */ sc->args = sc->NIL; sc->value = sc->code; sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); - s_goto(sc,OP_LET1); + s_thread_to(sc,OP_LET1); - case OP_LET1: /* let (calculate parameters) */ + CASE(OP_LET1): /* let (calculate parameters) */ sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { @@ -2819,15 +2842,15 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_LET1, sc->args, cdr(sc->code)); sc->code = cadar(sc->code); sc->args = sc->NIL; - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } else { /* end */ sc->args = reverse_in_place(sc, sc->NIL, sc->args); sc->code = car(sc->args); sc->args = cdr(sc->args); - s_goto(sc,OP_LET2); + s_thread_to(sc,OP_LET2); } - case OP_LET2: /* let */ + CASE(OP_LET2): /* let */ new_frame_in_env(sc, sc->envir); for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { @@ -2849,37 +2872,37 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->code = cdr(sc->code); sc->args = sc->NIL; } - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); - case OP_LET0AST: /* let* */ + CASE(OP_LET0AST): /* let* */ if (car(sc->code) == sc->NIL) { new_frame_in_env(sc, sc->envir); sc->code = cdr(sc->code); - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code)); } s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); sc->code = cadaar(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); - case OP_LET1AST: /* let* (make new frame) */ + CASE(OP_LET1AST): /* let* (make new frame) */ new_frame_in_env(sc, sc->envir); - s_goto(sc,OP_LET2AST); + s_thread_to(sc,OP_LET2AST); - case OP_LET2AST: /* let* (calculate parameters) */ + CASE(OP_LET2AST): /* let* (calculate parameters) */ new_slot_in_env(sc, caar(sc->code), sc->value); sc->code = cdr(sc->code); if (is_pair(sc->code)) { /* continue */ s_save(sc,OP_LET2AST, sc->args, sc->code); sc->code = cadar(sc->code); sc->args = sc->NIL; - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } else { /* end */ sc->code = sc->args; sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } default: snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); @@ -2892,14 +2915,14 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { pointer x, y; switch (op) { - case OP_LET0REC: /* letrec */ + CASE(OP_LET0REC): /* letrec */ new_frame_in_env(sc, sc->envir); sc->args = sc->NIL; sc->value = sc->code; sc->code = car(sc->code); - s_goto(sc,OP_LET1REC); + s_thread_to(sc,OP_LET1REC); - case OP_LET1REC: /* letrec (calculate parameters) */ + CASE(OP_LET1REC): /* letrec (calculate parameters) */ sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { @@ -2914,10 +2937,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { sc->args = reverse_in_place(sc, sc->NIL, sc->args); sc->code = car(sc->args); sc->args = cdr(sc->args); - s_goto(sc,OP_LET2REC); + s_thread_to(sc,OP_LET2REC); } - case OP_LET2REC: /* letrec */ + CASE(OP_LET2REC): /* letrec */ for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { new_slot_in_env(sc, caar(x), car(y)); } @@ -2925,7 +2948,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { sc->args = sc->NIL; s_goto(sc,OP_BEGIN); - case OP_COND0: /* cond */ + CASE(OP_COND0): /* cond */ if (!is_pair(sc->code)) { Error_0(sc,"syntax error in cond"); } @@ -2933,7 +2956,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { sc->code = caar(sc->code); s_goto(sc,OP_EVAL); - case OP_COND1: /* cond */ + CASE(OP_COND1): /* cond */ if (is_true(sc->value)) { if ((sc->code = cdar(sc->code)) == sc->NIL) { s_return(sc,sc->value); @@ -2957,12 +2980,12 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { } } - case OP_DELAY: /* delay */ + CASE(OP_DELAY): /* delay */ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); typeflag(x)=T_PROMISE; s_return(sc,x); - case OP_AND0: /* and */ + CASE(OP_AND0): /* and */ if (sc->code == sc->NIL) { s_return(sc,sc->T); } @@ -2970,7 +2993,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { sc->code = car(sc->code); s_goto(sc,OP_EVAL); - case OP_AND1: /* and */ + CASE(OP_AND1): /* and */ if (is_false(sc->value)) { s_return(sc,sc->value); } else if (sc->code == sc->NIL) { @@ -2981,7 +3004,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_goto(sc,OP_EVAL); } - case OP_OR0: /* or */ + CASE(OP_OR0): /* or */ if (sc->code == sc->NIL) { s_return(sc,sc->F); } @@ -2989,7 +3012,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { sc->code = car(sc->code); s_goto(sc,OP_EVAL); - case OP_OR1: /* or */ + CASE(OP_OR1): /* or */ if (is_true(sc->value)) { s_return(sc,sc->value); } else if (sc->code == sc->NIL) { @@ -3000,18 +3023,18 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_goto(sc,OP_EVAL); } - case OP_C0STREAM: /* cons-stream */ + CASE(OP_C0STREAM): /* cons-stream */ s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); s_goto(sc,OP_EVAL); - case OP_C1STREAM: /* cons-stream */ + CASE(OP_C1STREAM): /* cons-stream */ sc->args = sc->value; /* save sc->value to register sc->args for gc */ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); typeflag(x)=T_PROMISE; s_return(sc,cons(sc, sc->args, x)); - case OP_MACRO0: /* macro */ + CASE(OP_MACRO0): /* macro */ if (is_pair(car(sc->code))) { x = caar(sc->code); sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); @@ -3025,7 +3048,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_MACRO1, sc->NIL, x); s_goto(sc,OP_EVAL); - case OP_MACRO1: /* macro */ + CASE(OP_MACRO1): /* macro */ typeflag(sc->value) = T_MACRO; x = find_slot_in_env(sc, sc->envir, sc->code, 0); if (x != sc->NIL) { @@ -3035,12 +3058,12 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { } s_return(sc,sc->code); - case OP_CASE0: /* case */ + CASE(OP_CASE0): /* case */ s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); s_goto(sc,OP_EVAL); - case OP_CASE1: /* case */ + CASE(OP_CASE1): /* case */ for (x = sc->code; x != sc->NIL; x = cdr(x)) { if (!is_pair(y = caar(x))) { break; @@ -3067,27 +3090,27 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->NIL); } - case OP_CASE2: /* case */ + CASE(OP_CASE2): /* case */ if (is_true(sc->value)) { s_goto(sc,OP_BEGIN); } else { s_return(sc,sc->NIL); } - case OP_PAPPLY: /* apply */ + CASE(OP_PAPPLY): /* apply */ sc->code = car(sc->args); sc->args = list_star(sc,cdr(sc->args)); /*sc->args = cadr(sc->args);*/ s_goto(sc,OP_APPLY); - case OP_PEVAL: /* eval */ + CASE(OP_PEVAL): /* eval */ if(cdr(sc->args)!=sc->NIL) { sc->envir=cadr(sc->args); } sc->code = car(sc->args); s_goto(sc,OP_EVAL); - case OP_CONTINUATION: /* call-with-current-continuation */ + CASE(OP_CONTINUATION): /* call-with-current-continuation */ sc->code = car(sc->args); sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); s_goto(sc,OP_APPLY); @@ -3108,7 +3131,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { switch (op) { #if USE_MATH - case OP_INEX2EX: /* inexact->exact */ + CASE(OP_INEX2EX): /* inexact->exact */ x=car(sc->args); if(num_is_integer(x)) { s_return(sc,x); @@ -3118,35 +3141,35 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_1(sc,"inexact->exact: not integral:",x); } - case OP_EXP: + CASE(OP_EXP): x=car(sc->args); s_return(sc, mk_real(sc, exp(rvalue(x)))); - case OP_LOG: + CASE(OP_LOG): x=car(sc->args); s_return(sc, mk_real(sc, log(rvalue(x)))); - case OP_SIN: + CASE(OP_SIN): x=car(sc->args); s_return(sc, mk_real(sc, sin(rvalue(x)))); - case OP_COS: + CASE(OP_COS): x=car(sc->args); s_return(sc, mk_real(sc, cos(rvalue(x)))); - case OP_TAN: + CASE(OP_TAN): x=car(sc->args); s_return(sc, mk_real(sc, tan(rvalue(x)))); - case OP_ASIN: + CASE(OP_ASIN): x=car(sc->args); s_return(sc, mk_real(sc, asin(rvalue(x)))); - case OP_ACOS: + CASE(OP_ACOS): x=car(sc->args); s_return(sc, mk_real(sc, acos(rvalue(x)))); - case OP_ATAN: + CASE(OP_ATAN): x=car(sc->args); if(cdr(sc->args)==sc->NIL) { s_return(sc, mk_real(sc, atan(rvalue(x)))); @@ -3155,11 +3178,11 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); } - case OP_SQRT: + CASE(OP_SQRT): x=car(sc->args); s_return(sc, mk_real(sc, sqrt(rvalue(x)))); - case OP_EXPT: { + CASE(OP_EXPT): { double result; int real_result=1; pointer y=cadr(sc->args); @@ -3188,15 +3211,15 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } } - case OP_FLOOR: + CASE(OP_FLOOR): x=car(sc->args); s_return(sc, mk_real(sc, floor(rvalue(x)))); - case OP_CEILING: + CASE(OP_CEILING): x=car(sc->args); s_return(sc, mk_real(sc, ceil(rvalue(x)))); - case OP_TRUNCATE : { + CASE(OP_TRUNCATE ): { double rvalue_of_x ; x=car(sc->args); rvalue_of_x = rvalue(x) ; @@ -3207,28 +3230,28 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } } - case OP_ROUND: + CASE(OP_ROUND): x=car(sc->args); if (num_is_integer(x)) s_return(sc, x); s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); #endif - case OP_ADD: /* + */ + CASE(OP_ADD): /* + */ v=num_zero; for (x = sc->args; x != sc->NIL; x = cdr(x)) { v=num_add(v,nvalue(car(x))); } s_return(sc,mk_number(sc, v)); - case OP_MUL: /* * */ + CASE(OP_MUL): /* * */ v=num_one; for (x = sc->args; x != sc->NIL; x = cdr(x)) { v=num_mul(v,nvalue(car(x))); } s_return(sc,mk_number(sc, v)); - case OP_SUB: /* - */ + CASE(OP_SUB): /* - */ if(cdr(sc->args)==sc->NIL) { x=sc->args; v=num_zero; @@ -3241,7 +3264,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } s_return(sc,mk_number(sc, v)); - case OP_DIV: /* / */ + CASE(OP_DIV): /* / */ if(cdr(sc->args)==sc->NIL) { x=sc->args; v=num_one; @@ -3258,7 +3281,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } s_return(sc,mk_number(sc, v)); - case OP_INTDIV: /* quotient */ + CASE(OP_INTDIV): /* quotient */ if(cdr(sc->args)==sc->NIL) { x=sc->args; v=num_one; @@ -3275,7 +3298,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } s_return(sc,mk_number(sc, v)); - case OP_REM: /* remainder */ + CASE(OP_REM): /* remainder */ v = nvalue(car(sc->args)); if (ivalue(cadr(sc->args)) != 0) v=num_rem(v,nvalue(cadr(sc->args))); @@ -3284,7 +3307,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } s_return(sc,mk_number(sc, v)); - case OP_MOD: /* modulo */ + CASE(OP_MOD): /* modulo */ v = nvalue(car(sc->args)); if (ivalue(cadr(sc->args)) != 0) v=num_mod(v,nvalue(cadr(sc->args))); @@ -3293,17 +3316,17 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } s_return(sc,mk_number(sc, v)); - case OP_CAR: /* car */ + CASE(OP_CAR): /* car */ s_return(sc,caar(sc->args)); - case OP_CDR: /* cdr */ + CASE(OP_CDR): /* cdr */ s_return(sc,cdar(sc->args)); - case OP_CONS: /* cons */ + CASE(OP_CONS): /* cons */ cdr(sc->args) = cadr(sc->args); s_return(sc,sc->args); - case OP_SETCAR: /* set-car! */ + CASE(OP_SETCAR): /* set-car! */ if(!is_immutable(car(sc->args))) { caar(sc->args) = cadr(sc->args); s_return(sc,car(sc->args)); @@ -3311,7 +3334,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"set-car!: unable to alter immutable pair"); } - case OP_SETCDR: /* set-cdr! */ + CASE(OP_SETCDR): /* set-cdr! */ if(!is_immutable(car(sc->args))) { cdar(sc->args) = cadr(sc->args); s_return(sc,car(sc->args)); @@ -3319,36 +3342,36 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"set-cdr!: unable to alter immutable pair"); } - case OP_CHAR2INT: { /* char->integer */ + CASE(OP_CHAR2INT): { /* char->integer */ char c; c=(char)ivalue(car(sc->args)); s_return(sc,mk_integer(sc,(unsigned char)c)); } - case OP_INT2CHAR: { /* integer->char */ + CASE(OP_INT2CHAR): { /* integer->char */ unsigned char c; c=(unsigned char)ivalue(car(sc->args)); s_return(sc,mk_character(sc,(char)c)); } - case OP_CHARUPCASE: { + CASE(OP_CHARUPCASE): { unsigned char c; c=(unsigned char)ivalue(car(sc->args)); c=toupper(c); s_return(sc,mk_character(sc,(char)c)); } - case OP_CHARDNCASE: { + CASE(OP_CHARDNCASE): { unsigned char c; c=(unsigned char)ivalue(car(sc->args)); c=tolower(c); s_return(sc,mk_character(sc,(char)c)); } - case OP_STR2SYM: /* string->symbol */ + CASE(OP_STR2SYM): /* string->symbol */ s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); - case OP_STR2ATOM: /* string->atom */ { + CASE(OP_STR2ATOM): /* string->atom */ { char *s=strvalue(car(sc->args)); long pf = 0; if(cdr(sc->args)!=sc->NIL) { @@ -3383,12 +3406,12 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } } - case OP_SYM2STR: /* symbol->string */ + CASE(OP_SYM2STR): /* symbol->string */ x=mk_string(sc,symname(car(sc->args))); setimmutable(x); s_return(sc,x); - case OP_ATOM2STR: /* atom->string */ { + CASE(OP_ATOM2STR): /* atom->string */ { long pf = 0; x=car(sc->args); if(cdr(sc->args)!=sc->NIL) { @@ -3414,7 +3437,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } } - case OP_MKSTRING: { /* make-string */ + CASE(OP_MKSTRING): { /* make-string */ int fill=' '; int len; @@ -3426,10 +3449,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,mk_empty_string(sc,len,(char)fill)); } - case OP_STRLEN: /* string-length */ + CASE(OP_STRLEN): /* string-length */ s_return(sc,mk_integer(sc,strlength(car(sc->args)))); - case OP_STRREF: { /* string-ref */ + CASE(OP_STRREF): { /* string-ref */ char *str; int index; @@ -3444,7 +3467,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,mk_character(sc,((unsigned char*)str)[index])); } - case OP_STRSET: { /* string-set! */ + CASE(OP_STRSET): { /* string-set! */ char *str; int index; int c; @@ -3465,7 +3488,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,car(sc->args)); } - case OP_STRAPPEND: { /* string-append */ + CASE(OP_STRAPPEND): { /* string-append */ /* in 1.29 string-append was in Scheme in init.scm but was too slow */ int len = 0; pointer newstr; @@ -3484,7 +3507,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc, newstr); } - case OP_SUBSTR: { /* substring */ + CASE(OP_SUBSTR): { /* substring */ char *str; int index0; int index1; @@ -3515,7 +3538,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,x); } - case OP_VECTOR: { /* vector */ + CASE(OP_VECTOR): { /* vector */ int i; pointer vec; int len=list_length(sc,sc->args); @@ -3530,7 +3553,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,vec); } - case OP_MKVECTOR: { /* make-vector */ + CASE(OP_MKVECTOR): { /* make-vector */ pointer fill=sc->NIL; int len; pointer vec; @@ -3548,10 +3571,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,vec); } - case OP_VECLEN: /* vector-length */ + CASE(OP_VECLEN): /* vector-length */ s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); - case OP_VECREF: { /* vector-ref */ + CASE(OP_VECREF): { /* vector-ref */ int index; index=ivalue(cadr(sc->args)); @@ -3563,7 +3586,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { s_return(sc,vector_elem(car(sc->args),index)); } - case OP_VECSET: { /* vector-set! */ + CASE(OP_VECSET): { /* vector-set! */ int index; if(is_immutable(car(sc->args))) { @@ -3634,19 +3657,19 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { int (*comp_func)(num,num)=0; switch (op) { - case OP_NOT: /* not */ + CASE(OP_NOT): /* not */ s_retbool(is_false(car(sc->args))); - case OP_BOOLP: /* boolean? */ + CASE(OP_BOOLP): /* boolean? */ s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); - case OP_EOFOBJP: /* boolean? */ + CASE(OP_EOFOBJP): /* boolean? */ s_retbool(car(sc->args) == sc->EOF_OBJ); - case OP_NULLP: /* null? */ + CASE(OP_NULLP): /* null? */ s_retbool(car(sc->args) == sc->NIL); - case OP_NUMEQ: /* = */ - case OP_LESS: /* < */ - case OP_GRE: /* > */ - case OP_LEQ: /* <= */ - case OP_GEQ: /* >= */ + CASE(OP_NUMEQ): /* = */ + CASE(OP_LESS): /* < */ + CASE(OP_GRE): /* > */ + CASE(OP_LEQ): /* <= */ + CASE(OP_GEQ): /* >= */ switch(op) { case OP_NUMEQ: comp_func=num_eq; break; case OP_LESS: comp_func=num_lt; break; @@ -3666,37 +3689,37 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { v=nvalue(car(x)); } s_retbool(1); - case OP_SYMBOLP: /* symbol? */ + CASE(OP_SYMBOLP): /* symbol? */ s_retbool(is_symbol(car(sc->args))); - case OP_NUMBERP: /* number? */ + CASE(OP_NUMBERP): /* number? */ s_retbool(is_number(car(sc->args))); - case OP_STRINGP: /* string? */ + CASE(OP_STRINGP): /* string? */ s_retbool(is_string(car(sc->args))); - case OP_INTEGERP: /* integer? */ + CASE(OP_INTEGERP): /* integer? */ s_retbool(is_integer(car(sc->args))); - case OP_REALP: /* real? */ + CASE(OP_REALP): /* real? */ s_retbool(is_number(car(sc->args))); /* All numbers are real */ - case OP_CHARP: /* char? */ + CASE(OP_CHARP): /* char? */ s_retbool(is_character(car(sc->args))); #if USE_CHAR_CLASSIFIERS - case OP_CHARAP: /* char-alphabetic? */ + CASE(OP_CHARAP): /* char-alphabetic? */ s_retbool(Cisalpha(ivalue(car(sc->args)))); - case OP_CHARNP: /* char-numeric? */ + CASE(OP_CHARNP): /* char-numeric? */ s_retbool(Cisdigit(ivalue(car(sc->args)))); - case OP_CHARWP: /* char-whitespace? */ + CASE(OP_CHARWP): /* char-whitespace? */ s_retbool(Cisspace(ivalue(car(sc->args)))); - case OP_CHARUP: /* char-upper-case? */ + CASE(OP_CHARUP): /* char-upper-case? */ s_retbool(Cisupper(ivalue(car(sc->args)))); - case OP_CHARLP: /* char-lower-case? */ + CASE(OP_CHARLP): /* char-lower-case? */ s_retbool(Cislower(ivalue(car(sc->args)))); #endif - case OP_PORTP: /* port? */ + CASE(OP_PORTP): /* port? */ s_retbool(is_port(car(sc->args))); - case OP_INPORTP: /* input-port? */ + CASE(OP_INPORTP): /* input-port? */ s_retbool(is_inport(car(sc->args))); - case OP_OUTPORTP: /* output-port? */ + CASE(OP_OUTPORTP): /* output-port? */ s_retbool(is_outport(car(sc->args))); - case OP_PROCP: /* procedure? */ + CASE(OP_PROCP): /* procedure? */ /*-- * continuation should be procedure by the example * (call-with-current-continuation procedure?) ==> #t @@ -3704,18 +3727,18 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { */ s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); - case OP_PAIRP: /* pair? */ + CASE(OP_PAIRP): /* pair? */ s_retbool(is_pair(car(sc->args))); - case OP_LISTP: /* list? */ + CASE(OP_LISTP): /* list? */ s_retbool(list_length(sc,car(sc->args)) >= 0); - case OP_ENVP: /* environment? */ + CASE(OP_ENVP): /* environment? */ s_retbool(is_environment(car(sc->args))); - case OP_VECTORP: /* vector? */ + CASE(OP_VECTORP): /* vector? */ s_retbool(is_vector(car(sc->args))); - case OP_EQ: /* eq? */ + CASE(OP_EQ): /* eq? */ s_retbool(car(sc->args) == cadr(sc->args)); - case OP_EQV: /* eqv? */ + CASE(OP_EQV): /* eqv? */ s_retbool(eqv(car(sc->args), cadr(sc->args))); default: snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); @@ -3728,7 +3751,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { pointer x, y; switch (op) { - case OP_FORCE: /* force */ + CASE(OP_FORCE): /* force */ sc->code = car(sc->args); if (is_promise(sc->code)) { /* Should change type to closure here */ @@ -3739,13 +3762,13 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->code); } - case OP_SAVE_FORCED: /* Save forced value replacing promise */ + CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */ memcpy(sc->code,sc->value,sizeof(struct cell)); s_return(sc,sc->value); - case OP_WRITE: /* write */ - case OP_DISPLAY: /* display */ - case OP_WRITE_CHAR: /* write-char */ + CASE(OP_WRITE): /* write */ + CASE(OP_DISPLAY): /* display */ + CASE(OP_WRITE_CHAR): /* write-char */ if(is_pair(cdr(sc->args))) { if(cadr(sc->args)!=sc->outport) { x=cons(sc,sc->outport,sc->NIL); @@ -3761,7 +3784,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } s_goto(sc,OP_P0LIST); - case OP_NEWLINE: /* newline */ + CASE(OP_NEWLINE): /* newline */ if(is_pair(sc->args)) { if(car(sc->args)!=sc->outport) { x=cons(sc,sc->outport,sc->NIL); @@ -3772,7 +3795,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { putstr(sc, "\n"); s_return(sc,sc->T); - case OP_ERR0: /* error */ + CASE(OP_ERR0): /* error */ sc->retcode=-1; if (!is_string(car(sc->args))) { sc->args=cons(sc,mk_string(sc," -- "),sc->args); @@ -3781,9 +3804,9 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { putstr(sc, "Error: "); putstr(sc, strvalue(car(sc->args))); sc->args = cdr(sc->args); - s_goto(sc,OP_ERR1); + s_thread_to(sc,OP_ERR1); - case OP_ERR1: /* error */ + CASE(OP_ERR1): /* error */ putstr(sc, " "); if (sc->args != sc->NIL) { s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); @@ -3799,13 +3822,13 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } } - case OP_REVERSE: /* reverse */ + CASE(OP_REVERSE): /* reverse */ s_return(sc,reverse(sc, car(sc->args))); - case OP_LIST_STAR: /* list* */ + CASE(OP_LIST_STAR): /* list* */ s_return(sc,list_star(sc,sc->args)); - case OP_APPEND: /* append */ + CASE(OP_APPEND): /* append */ x = sc->NIL; y = sc->args; if (y == x) { @@ -3825,7 +3848,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { s_return(sc, reverse_in_place(sc, car(y), x)); #if USE_PLIST - case OP_PUT: /* put */ + CASE(OP_PUT): /* put */ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { Error_0(sc,"illegal use of put"); } @@ -3841,7 +3864,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { symprop(car(sc->args))); s_return(sc,sc->T); - case OP_GET: /* get */ + CASE(OP_GET): /* get */ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { Error_0(sc,"illegal use of get"); } @@ -3856,42 +3879,42 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->NIL); } #endif /* USE_PLIST */ - case OP_QUIT: /* quit */ + CASE(OP_QUIT): /* quit */ if(is_pair(sc->args)) { sc->retcode=ivalue(car(sc->args)); } return (sc->NIL); - case OP_GC: /* gc */ + CASE(OP_GC): /* gc */ gc(sc, sc->NIL, sc->NIL); s_return(sc,sc->T); - case OP_GCVERB: /* gc-verbose */ + CASE(OP_GCVERB): /* gc-verbose */ { int was = sc->gc_verbose; sc->gc_verbose = (car(sc->args) != sc->F); s_retbool(was); } - case OP_NEWSEGMENT: /* new-segment */ + CASE(OP_NEWSEGMENT): /* new-segment */ if (!is_pair(sc->args) || !is_number(car(sc->args))) { Error_0(sc,"new-segment: argument must be a number"); } alloc_cellseg(sc, (int) ivalue(car(sc->args))); s_return(sc,sc->T); - case OP_OBLIST: /* oblist */ + CASE(OP_OBLIST): /* oblist */ s_return(sc, oblist_all_symbols(sc)); - case OP_CURR_INPORT: /* current-input-port */ + CASE(OP_CURR_INPORT): /* current-input-port */ s_return(sc,sc->inport); - case OP_CURR_OUTPORT: /* current-output-port */ + CASE(OP_CURR_OUTPORT): /* current-output-port */ s_return(sc,sc->outport); - case OP_OPEN_INFILE: /* open-input-file */ - case OP_OPEN_OUTFILE: /* open-output-file */ - case OP_OPEN_INOUTFILE: /* open-input-output-file */ { + CASE(OP_OPEN_INFILE): /* open-input-file */ + CASE(OP_OPEN_OUTFILE): /* open-output-file */ + CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ { int prop=0; pointer p; switch(op) { @@ -3910,8 +3933,8 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } #if USE_STRING_PORTS - case OP_OPEN_INSTRING: /* open-input-string */ - case OP_OPEN_INOUTSTRING: /* open-input-output-string */ { + CASE(OP_OPEN_INSTRING): /* open-input-string */ + CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ { int prop=0; pointer p; switch(op) { @@ -3926,7 +3949,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } s_return(sc,p); } - case OP_OPEN_OUTSTRING: /* open-output-string */ { + CASE(OP_OPEN_OUTSTRING): /* open-output-string */ { pointer p; if(car(sc->args)==sc->NIL) { p=port_from_scratch(sc); @@ -3943,7 +3966,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } s_return(sc,p); } - case OP_GET_OUTSTRING: /* get-output-string */ { + CASE(OP_GET_OUTSTRING): /* get-output-string */ { port *p; if ((p=car(sc->args)->_object._port)->kind&port_string) { @@ -3966,18 +3989,18 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } #endif - case OP_CLOSE_INPORT: /* close-input-port */ + CASE(OP_CLOSE_INPORT): /* close-input-port */ port_close(sc,car(sc->args),port_input); s_return(sc,sc->T); - case OP_CLOSE_OUTPORT: /* close-output-port */ + CASE(OP_CLOSE_OUTPORT): /* close-output-port */ port_close(sc,car(sc->args),port_output); s_return(sc,sc->T); - case OP_INT_ENV: /* interaction-environment */ + CASE(OP_INT_ENV): /* interaction-environment */ s_return(sc,sc->global_env); - case OP_CURR_ENV: /* current-environment */ + CASE(OP_CURR_ENV): /* current-environment */ s_return(sc,sc->envir); } @@ -3996,7 +4019,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { switch (op) { /* ========== reading part ========== */ - case OP_READ: + CASE(OP_READ): if(!is_pair(sc->args)) { s_goto(sc,OP_READ_INTERNAL); } @@ -4012,8 +4035,8 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_SET_INPORT, x, sc->NIL); s_goto(sc,OP_READ_INTERNAL); - case OP_READ_CHAR: /* read-char */ - case OP_PEEK_CHAR: /* peek-char */ { + CASE(OP_READ_CHAR): /* read-char */ + CASE(OP_PEEK_CHAR): /* peek-char */ { int c; if(is_pair(sc->args)) { if(car(sc->args)!=sc->inport) { @@ -4033,7 +4056,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { s_return(sc,mk_character(sc,c)); } - case OP_CHAR_READY: /* char-ready? */ { + CASE(OP_CHAR_READY): /* char-ready? */ { pointer p=sc->inport; int res; if(is_pair(sc->args)) { @@ -4043,15 +4066,15 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { s_retbool(res); } - case OP_SET_INPORT: /* set-input-port */ + CASE(OP_SET_INPORT): /* set-input-port */ sc->inport=car(sc->args); s_return(sc,sc->value); - case OP_SET_OUTPORT: /* set-output-port */ + CASE(OP_SET_OUTPORT): /* set-output-port */ sc->outport=car(sc->args); s_return(sc,sc->value); - case OP_RDSEXPR: + CASE(OP_RDSEXPR): switch (sc->tok) { case TOK_EOF: s_return(sc,sc->EOF_OBJ); @@ -4068,30 +4091,30 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } else { sc->nesting_stack[sc->file_i]++; s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); } case TOK_QUOTE: s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); case TOK_BQUOTE: sc->tok = token(sc); if(sc->tok==TOK_VEC) { s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); sc->tok=TOK_LPAREN; - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); } else { s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); } - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); case TOK_COMMA: s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); case TOK_ATMARK: s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); case TOK_ATOM: s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); case TOK_DQUOTE: @@ -4121,7 +4144,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } break; - case OP_RDLIST: { + CASE(OP_RDLIST): { sc->args = cons(sc, sc->value, sc->args); sc->tok = token(sc); if (sc->tok == TOK_EOF) @@ -4139,14 +4162,14 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } else if (sc->tok == TOK_DOT) { s_save(sc,OP_RDDOT, sc->args, sc->NIL); sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); } else { s_save(sc,OP_RDLIST, sc->args, sc->NIL);; - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); } } - case OP_RDDOT: + CASE(OP_RDDOT): if (token(sc) != TOK_RPAREN) { Error_0(sc,"syntax error: illegal dot expression"); } else { @@ -4154,26 +4177,26 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { s_return(sc,reverse_in_place(sc, sc->value, sc->args)); } - case OP_RDQUOTE: + CASE(OP_RDQUOTE): s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); - case OP_RDQQUOTE: + CASE(OP_RDQQUOTE): s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); - case OP_RDQQUOTEVEC: + CASE(OP_RDQQUOTEVEC): s_return(sc,cons(sc, mk_symbol(sc,"apply"), cons(sc, mk_symbol(sc,"vector"), cons(sc,cons(sc, sc->QQUOTE, cons(sc,sc->value,sc->NIL)), sc->NIL)))); - case OP_RDUNQUOTE: + CASE(OP_RDUNQUOTE): s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); - case OP_RDUQTSP: + CASE(OP_RDUQTSP): s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); - case OP_RDVEC: + CASE(OP_RDVEC): /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); s_goto(sc,OP_EVAL); Cannot be quoted*/ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); @@ -4185,11 +4208,11 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { s_goto(sc,OP_VECTOR); /* ========== printing part ========== */ - case OP_P0LIST: + CASE(OP_P0LIST): if(is_vector(sc->args)) { putstr(sc,"#("); sc->args=cons(sc,sc->args,mk_integer(sc,0)); - s_goto(sc,OP_PVECFROM); + s_thread_to(sc,OP_PVECFROM); } else if(is_environment(sc->args)) { putstr(sc,"#"); s_return(sc,sc->T); @@ -4199,36 +4222,36 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { putstr(sc, "'"); sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { putstr(sc, "`"); sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { putstr(sc, ","); sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { putstr(sc, ",@"); sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else { putstr(sc, "("); s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); sc->args = car(sc->args); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } - case OP_P1LIST: + CASE(OP_P1LIST): if (is_pair(sc->args)) { s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); putstr(sc, " "); sc->args = car(sc->args); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else if(is_vector(sc->args)) { s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); putstr(sc, " . "); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else { if (sc->args != sc->NIL) { putstr(sc, " . "); @@ -4237,7 +4260,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { putstr(sc, ")"); s_return(sc,sc->T); } - case OP_PVECFROM: { + CASE(OP_PVECFROM): { int i=ivalue_unchecked(cdr(sc->args)); pointer vec=car(sc->args); int len=ivalue_unchecked(vec); @@ -4251,7 +4274,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { sc->args=elem; if (i > 0) putstr(sc," "); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } } @@ -4268,14 +4291,14 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { long v; switch (op) { - case OP_LIST_LENGTH: /* length */ /* a.k */ + CASE(OP_LIST_LENGTH): /* length */ /* a.k */ v=list_length(sc,car(sc->args)); if(v<0) { Error_1(sc,"length: not a list:",car(sc->args)); } s_return(sc,mk_integer(sc, v)); - case OP_ASSQ: /* assq */ /* a.k */ + CASE(OP_ASSQ): /* assq */ /* a.k */ x = car(sc->args); for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { if (!is_pair(car(y))) { @@ -4291,7 +4314,7 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { } - case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ + CASE(OP_GET_CLOSURE): /* get-closure-code */ /* a.k */ sc->args = car(sc->args); if (sc->args == sc->NIL) { s_return(sc,sc->F); @@ -4302,13 +4325,13 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { } else { s_return(sc,sc->F); } - case OP_CLOSUREP: /* closure? */ + CASE(OP_CLOSUREP): /* closure? */ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t */ s_retbool(is_closure(car(sc->args))); - case OP_MACROP: /* macro? */ + CASE(OP_MACROP): /* macro? */ s_retbool(is_macro(car(sc->args))); default: snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); diff --git a/scheme.h b/scheme.h index 8d6fb42..8e93177 100644 --- a/scheme.h +++ b/scheme.h @@ -90,6 +90,11 @@ extern "C" { # define USE_COMPILE_HOOK 1 #endif +/* Enable faster opcode dispatch. */ +#ifndef USE_THREADED_CODE +# define USE_THREADED_CODE 1 +#endif + #ifndef USE_STRCASECMP /* stricmp for Unix */ # define USE_STRCASECMP 0 #endif -- cgit v1.2.3 From 85388f1ef82bd0a92e94a463acfa157e6f9356f8 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 10 Nov 2016 14:02:11 +0100 Subject: gpgscm: Recover cells used to maintain interpreter state. * tests/gpgscm/scheme.c (free_cell): New function. (free_cons): Likewise. (_s_return): Use the new function to recover cells used to save the state of the interpreter in 's_save'. This reduces the need to do a garbage collection considerably. Signed-off-by: Justus Winter --- scheme.c | 39 +++++++++++++++++++++++++++++++-------- 1 file changed, 31 insertions(+), 8 deletions(-) diff --git a/scheme.c b/scheme.c index 90cb8fd..105d2a1 100644 --- a/scheme.c +++ b/scheme.c @@ -773,6 +773,26 @@ static pointer find_consecutive_cells(scheme *sc, int n) { return sc->NIL; } +/* Free a cell. This is dangerous. Only free cells that are not + * referenced. */ +static INLINE void +free_cell(scheme *sc, pointer a) +{ + cdr(a) = sc->free_cell; + sc->free_cell = a; + sc->fcells += 1; +} + +/* Free a cell and retrieve its content. This is dangerous. Only + * free cells that are not referenced. */ +static INLINE void +free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr) +{ + *r_car = car(a); + *r_cdr = cdr(a); + free_cell(sc, a); +} + /* To retain recent allocs before interpreter knows about them - Tehom */ @@ -2481,14 +2501,17 @@ static void dump_stack_free(scheme *sc) } static pointer _s_return(scheme *sc, pointer a) { - sc->value = (a); - if(sc->dump==sc->NIL) return sc->NIL; - sc->op = ivalue(car(sc->dump)); - sc->args = cadr(sc->dump); - sc->envir = caddr(sc->dump); - sc->code = cadddr(sc->dump); - sc->dump = cddddr(sc->dump); - return sc->T; + pointer dump = sc->dump; + pointer op; + sc->value = (a); + if (dump == sc->NIL) + return sc->NIL; + free_cons(sc, dump, &op, &dump); + sc->op = ivalue(op); + free_cons(sc, dump, &sc->args, &dump); + free_cons(sc, dump, &sc->envir, &dump); + free_cons(sc, dump, &sc->code, &sc->dump); + return sc->T; } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { -- cgit v1.2.3 From 1659878b827d0a4e041921e0c3a3555d39a742df Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 10 Nov 2016 14:47:00 +0100 Subject: gpgscm: Recover cells from the list of recently allocated cells. * tests/gpgscm/scheme.c (ok_to_freely_gc): Recover cells. Signed-off-by: Justus Winter --- scheme.c | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/scheme.c b/scheme.c index 105d2a1..146b9e6 100644 --- a/scheme.c +++ b/scheme.c @@ -805,6 +805,17 @@ static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) car(sc->sink) = holder; } +static INLINE void ok_to_freely_gc(scheme *sc) +{ + pointer a = car(sc->sink), next; + car(sc->sink) = sc->NIL; + while (a != sc->NIL) + { + next = cdr(a); + free_cell(sc, a); + a = next; + } +} static pointer get_cell(scheme *sc, pointer a, pointer b) { @@ -832,12 +843,6 @@ static pointer get_vector_object(scheme *sc, int len, pointer init) return cells; } -static INLINE void ok_to_freely_gc(scheme *sc) -{ - car(sc->sink) = sc->NIL; -} - - #if defined TSGRIND static void check_cell_alloced(pointer p, int expect_alloced) { -- cgit v1.2.3 From dc1d3a79fa3e7944ea6ef02bc968446f9aa6d648 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 14 Nov 2016 12:37:36 +0100 Subject: gpgscm: Avoid cell allocation overhead. * tests/gpgscm/scheme-private.h (struct scheme): New fields 'inhibit_gc', 'reserved_cells', and 'reserved_lineno'. * tests/gpgscm/scheme.c (GC_ENABLED): New macro. (USE_GC_LOCKING): Likewise. (gc_reservations): Likewise. (gc_reservation_failure): New function. (_gc_disable): Likewise. (gc_disable): New macro. (gc_enable): Likewise. (gc_enabled): Likewise. (gc_consume): Likewise. (get_cell_x): Consume reserved cell if garbage collection is disabled. (_get_cell): Assert that gc is enabled. (get_cell): Only record cell in the list of recently allocated cells if gc is enabled. (get_vector_object): Likewise. (gc): Assert that gc is enabled. (s_return): Add comment, adjust call to '_s_return'. (s_return_enable_gc): New macro. (_s_return): Add flag 'enable_gc' and re-enable gc if set. (oblist_add_by_name): Use the new facilities to protect the allocations. (new_frame_in_env): Likewise. (new_slot_spec_in_env): Likewise. (s_save): Likewise. (opexe_0): Likewise. (opexe_1): Likewise. (opexe_2): Likewise. (opexe_5): Likewise. (opexe_6): Likewise. (scheme_init_custom_alloc): Initialize the new fields. -- Every time a cell is allocated, the interpreter may run out of free cells and do a garbage collection. This is problematic because it might garbage collect objects that have been allocated, but are not yet made available to the interpreter. Previously, we would plug such newly allocated cells into the list of newly allocated objects rooted at car(sc->sink), but that requires allocating yet another cell increasing pressure on the memory management system. A faster alternative is to preallocate the cells needed for an operation and make sure the garbage collection is not run until all allocated objects are plugged in. This can be done with gc_disable and gc_enable. This optimization can be applied incrementally. This commit picks all low-hanging fruits. Signed-off-by: Justus Winter --- scheme-private.h | 5 + scheme.c | 291 ++++++++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 252 insertions(+), 44 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 884889c..aa78894 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -121,6 +121,11 @@ pointer COMPILE_HOOK; /* *compile-hook* */ pointer free_cell; /* pointer to top of free cells */ long fcells; /* # of free cells */ +size_t inhibit_gc; /* nesting of gc_disable */ +size_t reserved_cells; /* # of reserved cells */ +#ifndef NDEBUG +int reserved_lineno; /* location of last reservation */ +#endif pointer inport; pointer outport; diff --git a/scheme.c b/scheme.c index 146b9e6..ce31f8d 100644 --- a/scheme.c +++ b/scheme.c @@ -653,13 +653,119 @@ static int alloc_cellseg(scheme *sc, int n) { return n; } + + +/* Controlling the garbage collector. + * + * Every time a cell is allocated, the interpreter may run out of free + * cells and do a garbage collection. This is problematic because it + * might garbage collect objects that have been allocated, but are not + * yet made available to the interpreter. + * + * Previously, we would plug such newly allocated cells into the list + * of newly allocated objects rooted at car(sc->sink), but that + * requires allocating yet another cell increasing pressure on the + * memory management system. + * + * A faster alternative is to preallocate the cells needed for an + * operation and make sure the garbage collection is not run until all + * allocated objects are plugged in. This can be done with gc_disable + * and gc_enable. + */ + +/* The garbage collector is enabled if the inhibit counter is + * zero. */ +#define GC_ENABLED 0 + +/* For now we provide a way to disable this optimization for + * benchmarking and because it produces slightly smaller code. */ +#ifndef USE_GC_LOCKING +# define USE_GC_LOCKING 1 +#endif + +/* To facilitate nested calls to gc_disable, functions that allocate + * more than one cell may define a macro, e.g. foo_allocates. This + * macro can be used to compute the amount of preallocation at the + * call site with the help of this macro. */ +#define gc_reservations(fn) fn ## _allocates + +#if USE_GC_LOCKING + +/* Report a shortage in reserved cells, and terminate the program. */ +static void +gc_reservation_failure(struct scheme *sc) +{ +#ifdef NDEBUG + fprintf(stderr, + "insufficient reservation\n") +#else + fprintf(stderr, + "insufficient reservation in line %d\n", + sc->reserved_lineno); +#endif + abort(); +} + +/* Disable the garbage collection and reserve the given number of + * cells. gc_disable may be nested, but the enclosing reservation + * must include the reservations of all nested calls. */ +static void +_gc_disable(struct scheme *sc, size_t reserve, int lineno) +{ + if (sc->inhibit_gc == 0) { + reserve_cells(sc, (reserve)); + sc->reserved_cells = (reserve); +#ifndef NDEBUG + (void) lineno; +#else + sc->reserved_lineno = lineno; +#endif + } else if (sc->reserved_cells < (reserve)) + gc_reservation_failure (sc); + sc->inhibit_gc += 1; +} +#define gc_disable(sc, reserve) \ + _gc_disable (sc, reserve, __LINE__) + +/* Enable the garbage collector. */ +#define gc_enable(sc) \ + do { \ + assert(sc->inhibit_gc); \ + sc->inhibit_gc -= 1; \ + } while (0) + +/* Test whether the garbage collector is enabled. */ +#define gc_enabled(sc) \ + (sc->inhibit_gc == GC_ENABLED) + +/* Consume a reserved cell. */ +#define gc_consume(sc) \ + do { \ + assert(! gc_enabled (sc)); \ + if (sc->reserved_cells == 0) \ + gc_reservation_failure (sc); \ + sc->reserved_cells -= 1; \ + } while (0) + +#else /* USE_GC_LOCKING */ + +#define gc_disable(sc, reserve) (void) 0 +#define gc_enable(sc) (void) 0 +#define gc_enabled(sc) 1 +#define gc_consume(sc) (void) 0 + +#endif /* USE_GC_LOCKING */ + static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { - if (sc->free_cell != sc->NIL) { + if (! gc_enabled (sc) || sc->free_cell != sc->NIL) { pointer x = sc->free_cell; + if (! gc_enabled (sc)) + gc_consume (sc); sc->free_cell = cdr(x); --sc->fcells; return (x); } + assert (gc_enabled (sc)); return _get_cell (sc, a, b); } @@ -672,6 +778,7 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) { return sc->sink; } + assert (gc_enabled (sc)); if (sc->free_cell == sc->NIL) { const int min_to_be_recovered = sc->last_cell_seg*8; gc(sc,a, b); @@ -826,7 +933,8 @@ static pointer get_cell(scheme *sc, pointer a, pointer b) typeflag(cell) = T_PAIR; car(cell) = a; cdr(cell) = b; - push_recent_alloc(sc, cell, sc->NIL); + if (gc_enabled (sc)) + push_recent_alloc(sc, cell, sc->NIL); return cell; } @@ -839,7 +947,8 @@ static pointer get_vector_object(scheme *sc, int len, pointer init) ivalue_unchecked(cells)=len; set_num_integer(cells); fill_vector(cells,init); - push_recent_alloc(sc, cells, sc->NIL); + if (gc_enabled (sc)) + push_recent_alloc(sc, cells, sc->NIL); return cells; } @@ -896,9 +1005,11 @@ static pointer oblist_initial_value(scheme *sc) /* returns the new symbol */ static pointer oblist_add_by_name(scheme *sc, const char *name) { +#define oblist_add_by_name_allocates 3 pointer x; int location; + gc_disable(sc, gc_reservations (oblist_add_by_name)); x = immutable_cons(sc, mk_string(sc, name), sc->NIL); typeflag(x) = T_SYMBOL; setimmutable(car(x)); @@ -906,6 +1017,7 @@ static pointer oblist_add_by_name(scheme *sc, const char *name) location = hash_fn(name, ivalue_unchecked(sc->oblist)); set_vector_elem(sc->oblist, location, immutable_cons(sc, x, vector_elem(sc->oblist, location))); + gc_enable(sc); return x; } @@ -1115,6 +1227,7 @@ INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { /* get new symbol */ INTERFACE pointer mk_symbol(scheme *sc, const char *name) { +#define mk_symbol_allocates oblist_add_by_name_allocates pointer x; /* first check oblist */ @@ -1345,6 +1458,8 @@ static void gc(scheme *sc, pointer a, pointer b) { pointer p; int i; + assert (gc_enabled (sc)); + if(sc->gc_verbose) { putstr(sc, "gc..."); } @@ -2296,14 +2411,19 @@ static void new_frame_in_env(scheme *sc, pointer old_env) new_frame = sc->NIL; } + gc_disable(sc, 1); sc->envir = immutable_cons(sc, new_frame, old_env); + gc_enable(sc); setenvironment(sc->envir); } static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, pointer variable, pointer value) { - pointer slot = immutable_cons(sc, variable, value); +#define new_slot_spec_in_env_allocates 2 + pointer slot; + gc_disable(sc, gc_reservations (new_slot_spec_in_env)); + slot = immutable_cons(sc, variable, value); if (is_vector(car(env))) { int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); @@ -2313,6 +2433,7 @@ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, } else { car(env) = immutable_cons(sc, slot, car(env)); } + gc_enable(sc); } static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) @@ -2385,6 +2506,7 @@ static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) { +#define new_slot_in_env_allocates new_slot_spec_in_env_allocates new_slot_spec_in_env(sc, sc->envir, variable, value); } @@ -2488,7 +2610,13 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #define CASE(OP) case OP #endif /* USE_THREADED_CODE */ -#define s_return(sc,a) return _s_return(sc,a) +/* Return to the previous frame on the dump stack, setting the current + * value to A. */ +#define s_return(sc, a) return _s_return(sc, a, 0) + +/* Return to the previous frame on the dump stack, setting the current + * value to A, and re-enable the garbage collector. */ +#define s_return_enable_gc(sc, a) return _s_return(sc, a, 1) static INLINE void dump_stack_reset(scheme *sc) { @@ -2505,10 +2633,12 @@ static void dump_stack_free(scheme *sc) sc->dump = sc->NIL; } -static pointer _s_return(scheme *sc, pointer a) { +static pointer _s_return(scheme *sc, pointer a, int enable_gc) { pointer dump = sc->dump; pointer op; sc->value = (a); + if (enable_gc) + gc_enable(sc); if (dump == sc->NIL) return sc->NIL; free_cons(sc, dump, &op, &dump); @@ -2520,9 +2650,13 @@ static pointer _s_return(scheme *sc, pointer a) { } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { - sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); - sc->dump = cons(sc, (args), sc->dump); - sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); +#define s_save_allocates 5 + pointer dump; + gc_disable(sc, gc_reservations (s_save)); + dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); + dump = cons(sc, (args), dump); + sc->dump = cons(sc, mk_integer(sc, (long)(op)), dump); + gc_enable(sc); } static INLINE void dump_stack_mark(scheme *sc) @@ -2650,8 +2784,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_E0ARGS): /* eval arguments */ if (is_macro(sc->value)) { /* macro expansion */ + gc_disable(sc, 1 + gc_reservations (s_save)); s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); sc->args = cons(sc,sc->code, sc->NIL); + gc_enable(sc); sc->code = sc->value; s_thread_to(sc,OP_APPLY); } else { @@ -2660,7 +2796,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } CASE(OP_E1ARGS): /* eval arguments */ - sc->args = cons(sc, sc->value, sc->args); + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); if (is_pair(sc->code)) { /* continue */ s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); sc->code = car(sc->code); @@ -2677,7 +2815,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_TRACING): { int tr=sc->tracing; sc->tracing=ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,tr)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, tr)); } #endif @@ -2749,19 +2888,23 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->value = sc->code; /* Fallthru */ } else { + gc_disable(sc, 1 + gc_reservations (s_save)); s_save(sc,OP_LAMBDA1,sc->args,sc->code); sc->args=cons(sc,sc->code,sc->NIL); + gc_enable(sc); sc->code=slot_value_in_env(f); s_thread_to(sc,OP_APPLY); } } CASE(OP_LAMBDA1): - s_return(sc,mk_closure(sc, sc->value, sc->envir)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); #else CASE(OP_LAMBDA): /* lambda */ - s_return(sc,mk_closure(sc, sc->code, sc->envir)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, sc->code, sc->envir)); #endif @@ -2775,7 +2918,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } else { y=cadr(sc->args); } - s_return(sc,mk_closure(sc, x, y)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, x, y)); CASE(OP_QUOTE): /* quote */ s_return(sc,car(sc->code)); @@ -2786,7 +2930,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (is_pair(car(sc->code))) { x = caar(sc->code); + gc_disable(sc, 2); sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); } else { x = car(sc->code); sc->code = cadr(sc->code); @@ -2861,6 +3007,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_LET1); CASE(OP_LET1): /* let (calculate parameters) */ + gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0)); sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { @@ -2868,10 +3015,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { car(sc->code)); } s_save(sc,OP_LET1, sc->args, cdr(sc->code)); + gc_enable(sc); sc->code = cadar(sc->code); sc->args = sc->NIL; s_thread_to(sc,OP_EVAL); } else { /* end */ + gc_enable(sc); sc->args = reverse_in_place(sc, sc->NIL, sc->args); sc->code = car(sc->args); sc->args = cdr(sc->args); @@ -2890,10 +3039,14 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { Error_1(sc, "Bad syntax of binding in let :", x); if (!is_list(sc, car(x))) Error_1(sc, "Bad syntax of binding in let :", car(x)); + gc_disable(sc, 1); sc->args = cons(sc, caar(x), sc->args); + gc_enable(sc); } + gc_disable(sc, 2 + gc_reservations (new_slot_in_env)); x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); new_slot_in_env(sc, car(sc->code), x); + gc_enable(sc); sc->code = cddr(sc->code); sc->args = sc->NIL; } else { @@ -2951,7 +3104,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_LET1REC); CASE(OP_LET1REC): /* letrec (calculate parameters) */ + gc_disable(sc, 1); sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { Error_1(sc, "Bad syntax of binding spec in letrec :", @@ -2993,8 +3148,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if(!is_pair(cdr(sc->code))) { Error_0(sc,"syntax error in cond"); } + gc_disable(sc, 4); x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); + gc_enable(sc); s_goto(sc,OP_EVAL); } s_goto(sc,OP_BEGIN); @@ -3009,9 +3166,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { } CASE(OP_DELAY): /* delay */ + gc_disable(sc, 2); x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); typeflag(x)=T_PROMISE; - s_return(sc,x); + s_return_enable_gc(sc,x); CASE(OP_AND0): /* and */ if (sc->code == sc->NIL) { @@ -3058,14 +3216,17 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { CASE(OP_C1STREAM): /* cons-stream */ sc->args = sc->value; /* save sc->value to register sc->args for gc */ + gc_disable(sc, 3); x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); typeflag(x)=T_PROMISE; - s_return(sc,cons(sc, sc->args, x)); + s_return_enable_gc(sc, cons(sc, sc->args, x)); CASE(OP_MACRO0): /* macro */ if (is_pair(car(sc->code))) { x = caar(sc->code); + gc_disable(sc, 2); sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); } else { x = car(sc->code); sc->code = cadr(sc->code); @@ -3140,7 +3301,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { CASE(OP_CONTINUATION): /* call-with-current-continuation */ sc->code = car(sc->args); + gc_disable(sc, 2); sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); + gc_enable(sc); s_goto(sc,OP_APPLY); default: @@ -3270,14 +3433,16 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { for (x = sc->args; x != sc->NIL; x = cdr(x)) { v=num_add(v,nvalue(car(x))); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_MUL): /* * */ v=num_one; for (x = sc->args; x != sc->NIL; x = cdr(x)) { v=num_mul(v,nvalue(car(x))); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_SUB): /* - */ if(cdr(sc->args)==sc->NIL) { @@ -3290,7 +3455,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { for (; x != sc->NIL; x = cdr(x)) { v=num_sub(v,nvalue(car(x))); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_DIV): /* / */ if(cdr(sc->args)==sc->NIL) { @@ -3307,7 +3473,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"/: division by zero"); } } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_INTDIV): /* quotient */ if(cdr(sc->args)==sc->NIL) { @@ -3324,7 +3491,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"quotient: division by zero"); } } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_REM): /* remainder */ v = nvalue(car(sc->args)); @@ -3333,7 +3501,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { else { Error_0(sc,"remainder: division by zero"); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_MOD): /* modulo */ v = nvalue(car(sc->args)); @@ -3342,7 +3511,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { else { Error_0(sc,"modulo: division by zero"); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_CAR): /* car */ s_return(sc,caar(sc->args)); @@ -3373,31 +3543,36 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { CASE(OP_CHAR2INT): { /* char->integer */ char c; c=(char)ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,(unsigned char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c)); } CASE(OP_INT2CHAR): { /* integer->char */ unsigned char c; c=(unsigned char)ivalue(car(sc->args)); - s_return(sc,mk_character(sc,(char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); } CASE(OP_CHARUPCASE): { unsigned char c; c=(unsigned char)ivalue(car(sc->args)); c=toupper(c); - s_return(sc,mk_character(sc,(char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); } CASE(OP_CHARDNCASE): { unsigned char c; c=(unsigned char)ivalue(car(sc->args)); c=tolower(c); - s_return(sc,mk_character(sc,(char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); } CASE(OP_STR2SYM): /* string->symbol */ - s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); + gc_disable(sc, gc_reservations (mk_symbol)); + s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args)))); CASE(OP_STR2ATOM): /* string->atom */ { char *s=strvalue(car(sc->args)); @@ -3435,9 +3610,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } CASE(OP_SYM2STR): /* symbol->string */ + gc_disable(sc, 1); x=mk_string(sc,symname(car(sc->args))); setimmutable(x); - s_return(sc,x); + s_return_enable_gc(sc, x); CASE(OP_ATOM2STR): /* atom->string */ { long pf = 0; @@ -3459,7 +3635,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { char *p; int len; atom2str(sc,x,(int )pf,&p,&len); - s_return(sc,mk_counted_string(sc,p,len)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_counted_string(sc, p, len)); } else { Error_1(sc, "atom->string: not an atom:", x); } @@ -3474,11 +3651,13 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { if(cdr(sc->args)!=sc->NIL) { fill=charvalue(cadr(sc->args)); } - s_return(sc,mk_empty_string(sc,len,(char)fill)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill)); } CASE(OP_STRLEN): /* string-length */ - s_return(sc,mk_integer(sc,strlength(car(sc->args)))); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args)))); CASE(OP_STRREF): { /* string-ref */ char *str; @@ -3492,7 +3671,9 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); } - s_return(sc,mk_character(sc,((unsigned char*)str)[index])); + gc_disable(sc, 1); + s_return_enable_gc(sc, + mk_character(sc, ((unsigned char*) str)[index])); } CASE(OP_STRSET): { /* string-set! */ @@ -3526,13 +3707,14 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { for (x = sc->args; x != sc->NIL; x = cdr(x)) { len += strlength(car(x)); } + gc_disable(sc, 1); newstr = mk_empty_string(sc, len, ' '); /* store the contents of the argument strings into the new string */ for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; pos += strlength(car(x)), x = cdr(x)) { memcpy(pos, strvalue(car(x)), strlength(car(x))); } - s_return(sc, newstr); + s_return_enable_gc(sc, newstr); } CASE(OP_SUBSTR): { /* substring */ @@ -3559,11 +3741,12 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } len=index1-index0; + gc_disable(sc, 1); x=mk_empty_string(sc,len,' '); memcpy(strvalue(x),str+index0,len); strvalue(x)[len]=0; - s_return(sc,x); + s_return_enable_gc(sc, x); } CASE(OP_VECTOR): { /* vector */ @@ -3600,7 +3783,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } CASE(OP_VECLEN): /* vector-length */ - s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args)))); CASE(OP_VECREF): { /* vector-ref */ int index; @@ -4173,7 +4357,9 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { break; CASE(OP_RDLIST): { + gc_disable(sc, 1); sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); sc->tok = token(sc); if (sc->tok == TOK_EOF) { s_return(sc,sc->EOF_OBJ); } @@ -4206,23 +4392,32 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } CASE(OP_RDQUOTE): - s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QUOTE, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDQQUOTE): - s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QQUOTE, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDQQUOTEVEC): - s_return(sc,cons(sc, mk_symbol(sc,"apply"), + gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol)); + s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"), cons(sc, mk_symbol(sc,"vector"), cons(sc,cons(sc, sc->QQUOTE, cons(sc,sc->value,sc->NIL)), sc->NIL)))); CASE(OP_RDUNQUOTE): - s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTE, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDUQTSP): - s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDVEC): /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); @@ -4324,7 +4519,8 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { if(v<0) { Error_1(sc,"length: not a list:",car(sc->args)); } - s_return(sc,mk_integer(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, v)); CASE(OP_ASSQ): /* assq */ /* a.k */ x = car(sc->args); @@ -4347,9 +4543,13 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { if (sc->args == sc->NIL) { s_return(sc,sc->F); } else if (is_closure(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); } else if (is_macro(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); } else { s_return(sc,sc->F); } @@ -4705,6 +4905,9 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->EOF_OBJ=&sc->_EOF_OBJ; sc->free_cell = &sc->_NIL; sc->fcells = 0; + sc->inhibit_gc = GC_ENABLED; + sc->reserved_cells = 0; + sc->reserved_lineno = 0; sc->no_memory=0; sc->inport=sc->NIL; sc->outport=sc->NIL; -- cgit v1.2.3 From dd6bd1bf2a767e22bb7c1bd470ce94527a9fae3d Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 15 Nov 2016 11:07:57 +0100 Subject: gpgscm: Recover more cells. * tests/gpgscm/scheme.c (_s_return): Recover the cell holding the opcode. Fixes-commit: e0cbd3389e2dd6ec19ee3a4c7bad81fa0f1907f5 Signed-off-by: Justus Winter --- scheme.c | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme.c b/scheme.c index ce31f8d..3ed1a00 100644 --- a/scheme.c +++ b/scheme.c @@ -2643,6 +2643,7 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) { return sc->NIL; free_cons(sc, dump, &op, &dump); sc->op = ivalue(op); + free_cell(sc, op); free_cons(sc, dump, &sc->args, &dump); free_cons(sc, dump, &sc->envir, &dump); free_cons(sc, dump, &sc->code, &sc->dump); -- cgit v1.2.3 From ad10069af6b0d247f27b7dbf891029eb34d264e0 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 15 Nov 2016 11:03:30 +0100 Subject: gpgscm: Mark cells requiring finalization. * tests/gpgscm/scheme.c (T_FINALIZE): New macro. (mk_port): Use the new macro. (mk_foreign_object): Likewise. (mk_counted_string): Likewise. (mk_empty_string): Likewise. (gc): Only call 'finalize_cell' for cells with the new flag. -- This speeds up the sweep phase of the garbage collector considerably because most cells do not require finalization. Signed-off-by: Justus Winter --- scheme.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/scheme.c b/scheme.c index 3ed1a00..1db6456 100644 --- a/scheme.c +++ b/scheme.c @@ -165,6 +165,7 @@ type_to_string (enum scheme_types typ) #define ADJ 32 #define TYPE_BITS 5 #define T_MASKTYPE 31 /* 0000000000011111 */ +#define T_FINALIZE 2048 /* 0000100000000000 */ #define T_SYNTAX 4096 /* 0001000000000000 */ #define T_IMMUTABLE 8192 /* 0010000000000000 */ #define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ @@ -1095,7 +1096,7 @@ static pointer oblist_all_symbols(scheme *sc) static pointer mk_port(scheme *sc, port *p) { pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = T_PORT|T_ATOM; + typeflag(x) = T_PORT|T_ATOM|T_FINALIZE; x->_object._port=p; return (x); } @@ -1111,7 +1112,7 @@ pointer mk_foreign_func(scheme *sc, foreign_func f) { pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) { pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM); + typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE); x->_object._foreign_object._vtable=vtable; x->_object._foreign_object._data = data; return (x); @@ -1179,7 +1180,7 @@ INTERFACE pointer mk_string(scheme *sc, const char *str) { INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = (T_STRING | T_ATOM); + typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); strvalue(x) = store_string(sc,len,str,0); strlength(x) = len; return (x); @@ -1187,7 +1188,7 @@ INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = (T_STRING | T_ATOM); + typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); strvalue(x) = store_string(sc,len,0,fill); strlength(x) = len; return (x); @@ -1504,7 +1505,7 @@ static void gc(scheme *sc, pointer a, pointer b) { clrmark(p); } else { /* reclaim cell */ - if (typeflag(p) != 0) { + if (typeflag(p) & T_FINALIZE) { finalize_cell(sc, p); typeflag(p) = 0; car(p) = sc->NIL; -- cgit v1.2.3 From 63cad2c16fdd343be89b576901c8f34de7cb74bf Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 16 Nov 2016 09:26:37 +0100 Subject: gpgscm: Fix string. * tests/gpgscm/scheme.c (type_to_string): Fix string. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 1db6456..fe8b9dd 100644 --- a/scheme.c +++ b/scheme.c @@ -144,7 +144,7 @@ type_to_string (enum scheme_types typ) case T_PROC: return "proc"; case T_PAIR: return "pair"; case T_CLOSURE: return "closure"; - case T_CONTINUATION: return "configuration"; + case T_CONTINUATION: return "continuation"; case T_FOREIGN: return "foreign"; case T_CHARACTER: return "character"; case T_PORT: return "port"; -- cgit v1.2.3 From d2a75dc5ae2b172a232dad88639b15b4930b9151 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 17 Nov 2016 11:58:34 +0100 Subject: gpgscm: Re-enable the garbage collector in case of errors. * tests/gpgscm/scheme.c (opexe_0): Enable gc before calling 'Error_1'. Fixes-commit: 83c184a66b73f312425b01008f0495610e5329a4 Signed-off-by: Justus Winter --- scheme.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index fe8b9dd..ee8992e 100644 --- a/scheme.c +++ b/scheme.c @@ -709,7 +709,8 @@ gc_reservation_failure(struct scheme *sc) /* Disable the garbage collection and reserve the given number of * cells. gc_disable may be nested, but the enclosing reservation - * must include the reservations of all nested calls. */ + * must include the reservations of all nested calls. Note: You must + * re-enable the gc before calling Error_X. */ static void _gc_disable(struct scheme *sc, size_t reserve, int lineno) { @@ -3013,6 +3014,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + gc_enable(sc); Error_1(sc, "Bad syntax of binding spec in let :", car(sc->code)); } -- cgit v1.2.3 From eca7b9bbee2986157ec6c078c998bd8a25becd8f Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 16 Nov 2016 11:29:34 +0100 Subject: gpgscm: Use a static pool of cells for small integers. * tests/gpgscm/scheme-private.h (struct scheme): New fields for the static integer cells. * tests/gpgscm/scheme.c (_alloc_cellseg): New function. (alloc_cellseg): Use the new function. (MAX_SMALL_INTEGER): New macro. (initialize_small_integers): New function. (mk_small_integer): Likewise. (mk_integer): Return a small integer if possible. (_s_return): Do not free 'op' if it is a small integer. (s_save): Use a small integer to box the opcode. (scheme_init_custom_alloc): Initialize small integers. (scheme_deinit): Free chunk of small integers. * tests/gpgscm/scheme.h (USE_SMALL_INTEGERS): New macro. Signed-off-by: Justus Winter --- scheme-private.h | 6 +++ scheme.c | 113 +++++++++++++++++++++++++++++++++++++++++++++---------- scheme.h | 8 ++++ 3 files changed, 108 insertions(+), 19 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index aa78894..2c5c749 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -119,6 +119,12 @@ pointer SHARP_HOOK; /* *sharp-hook* */ pointer COMPILE_HOOK; /* *compile-hook* */ #endif +#if USE_SMALL_INTEGERS +/* A fixed allocation of small integers. */ +void *integer_alloc; +pointer integer_cells; +#endif + pointer free_cell; /* pointer to top of free cells */ long fcells; /* # of free cells */ size_t inhibit_gc; /* nesting of gc_disable */ diff --git a/scheme.c b/scheme.c index ee8992e..a7d3fd7 100644 --- a/scheme.c +++ b/scheme.c @@ -598,34 +598,47 @@ static long binary_decode(const char *s) { return x; } +/* Allocate a new cell segment but do not make it available yet. */ +static int +_alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells) +{ + int adj = ADJ; + void *cp; + + if (adj < sizeof(struct cell)) + adj = sizeof(struct cell); + + cp = sc->malloc(len * sizeof(struct cell) + adj); + if (cp == NULL) + return 1; + + *alloc = cp; + + /* adjust in TYPE_BITS-bit boundary */ + if (((unsigned long) cp) % adj != 0) + cp = (void *) (adj * ((unsigned long) cp / adj + 1)); + + *cells = cp; + return 0; +} + /* allocate new cell segment */ static int alloc_cellseg(scheme *sc, int n) { pointer newp; pointer last; pointer p; - void *cp; long i; int k; - int adj=ADJ; - - if(adjlast_cell_seg >= CELL_NSEGMENT - 1) return k; - cp = sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); - if (cp == 0) - return k; - i = ++sc->last_cell_seg ; - sc->alloc_seg[i] = cp; - /* adjust in TYPE_BITS-bit boundary */ - if(((unsigned long)cp)%adj!=0) { - cp=(void *)(adj*((unsigned long)cp/adj+1)); - } + i = ++sc->last_cell_seg; + if (_alloc_cellseg(sc, CELL_SEGSIZE, &sc->alloc_seg[i], &newp)) { + sc->last_cell_seg--; + return k; + } /* insert new segment in address order */ - newp=(pointer)cp; sc->cell_seg[i] = newp; while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { p = sc->cell_seg[i]; @@ -1128,16 +1141,64 @@ INTERFACE pointer mk_character(scheme *sc, int c) { return (x); } + + +#if USE_SMALL_INTEGERS + +/* s_save assumes that all opcodes can be expressed as a small + * integer. */ +#define MAX_SMALL_INTEGER OP_MAXDEFINED + +static int +initialize_small_integers(scheme *sc) +{ + int i; + if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc, + &sc->integer_cells)) + return 1; + + for (i = 0; i < MAX_SMALL_INTEGER; i++) { + pointer x = &sc->integer_cells[i]; + typeflag(x) = T_NUMBER | T_ATOM | MARK; + ivalue_unchecked(x) = i; + set_num_integer(x); + } + + return 0; +} + +static INLINE pointer +mk_small_integer(scheme *sc, long n) +{ +#define mk_small_integer_allocates 0 + assert(0 <= n && n < MAX_SMALL_INTEGER); + return &sc->integer_cells[n]; +} +#else + +#define mk_small_integer_allocates 1 +#define mk_small_integer mk_integer + +#endif + /* get number atom (integer) */ INTERFACE pointer mk_integer(scheme *sc, long n) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); + pointer x; + +#if USE_SMALL_INTEGERS + if (0 <= n && n < MAX_SMALL_INTEGER) + return mk_small_integer(sc, n); +#endif + x = get_cell(sc,sc->NIL, sc->NIL); typeflag(x) = (T_NUMBER | T_ATOM); ivalue_unchecked(x)= n; set_num_integer(x); return (x); } + + INTERFACE pointer mk_real(scheme *sc, double n) { pointer x = get_cell(sc,sc->NIL, sc->NIL); @@ -2645,7 +2706,9 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) { return sc->NIL; free_cons(sc, dump, &op, &dump); sc->op = ivalue(op); +#ifndef USE_SMALL_INTEGERS free_cell(sc, op); +#endif free_cons(sc, dump, &sc->args, &dump); free_cons(sc, dump, &sc->envir, &dump); free_cons(sc, dump, &sc->code, &sc->dump); @@ -2653,12 +2716,12 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) { } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { -#define s_save_allocates 5 +#define s_save_allocates (4 + mk_small_integer_allocates) pointer dump; gc_disable(sc, gc_reservations (s_save)); dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); dump = cons(sc, (args), dump); - sc->dump = cons(sc, mk_integer(sc, (long)(op)), dump); + sc->dump = cons(sc, mk_small_integer(sc, (long)(op)), dump); gc_enable(sc); } @@ -4907,6 +4970,14 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->T = &sc->_HASHT; sc->F = &sc->_HASHF; sc->EOF_OBJ=&sc->_EOF_OBJ; + +#if USE_SMALL_INTEGERS + if (initialize_small_integers(sc)) { + sc->no_memory=1; + return 0; + } +#endif + sc->free_cell = &sc->_NIL; sc->fcells = 0; sc->inhibit_gc = GC_ENABLED; @@ -5052,6 +5123,10 @@ void scheme_deinit(scheme *sc) { sc->gc_verbose=0; gc(sc,sc->NIL,sc->NIL); +#if USE_SMALL_INTEGERS + sc->free(sc->integer_alloc); +#endif + for(i=0; i<=sc->last_cell_seg; i++) { sc->free(sc->alloc_seg[i]); } diff --git a/scheme.h b/scheme.h index 8e93177..2b5b066 100644 --- a/scheme.h +++ b/scheme.h @@ -43,6 +43,7 @@ extern "C" { # define USE_COMPILE_HOOK 0 # define USE_DL 0 # define USE_PLIST 0 +# define USE_SMALL_INTEGERS 0 #endif @@ -95,6 +96,13 @@ extern "C" { # define USE_THREADED_CODE 1 #endif +/* Use a static set of cells to represent small numbers. This set + * notably includes all opcodes, and hence saves a cell reservation + * during 's_save'. */ +#ifndef USE_SMALL_INTEGERS +# define USE_SMALL_INTEGERS 1 +#endif + #ifndef USE_STRCASECMP /* stricmp for Unix */ # define USE_STRCASECMP 0 #endif -- cgit v1.2.3 From 185ba177abeaf2f8ad66529a42966362107a2d8b Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 17 Nov 2016 15:47:26 +0100 Subject: gpgscm: Fix installation of error handler. * tests/gpgscm/ffi.scm: Set '*error-hook*' again so that the interpreter will use our function. Signed-off-by: Justus Winter --- ffi.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/ffi.scm b/ffi.scm index fb18538..c5f373c 100644 --- a/ffi.scm +++ b/ffi.scm @@ -61,6 +61,7 @@ (_exit (cadr x))) (else (apply error x)))) +(set! *error-hook* throw) ;; Terminate the process returning STATUS to the parent. (define (exit status) -- cgit v1.2.3 From 08f16887de9d6f6dcb0b7a377407dbd4f541fe13 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 17 Nov 2016 18:03:22 +0100 Subject: gpgscm: Fix property lists. * tests/gpgscm/opdefines.h (put, get): Check arguments. Also rename to 'set-symbol-property' and 'symbol-property', the names used by Guile, because put and get are too unspecific. * tests/gpgscm/scheme.c (hasprop): Only symbols have property lists. (get_property): New function. (set_property): Likewise. (opexe_4): Use the new functions. Signed-off-by: Justus Winter --- opdefines.h | 4 +-- scheme.c | 84 +++++++++++++++++++++++++++++++++++++++---------------------- 2 files changed, 56 insertions(+), 32 deletions(-) diff --git a/opdefines.h b/opdefines.h index ceb4d0e..c7347fd 100644 --- a/opdefines.h +++ b/opdefines.h @@ -146,8 +146,8 @@ _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 ) + _OP_DEF(opexe_4, "set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) + _OP_DEF(opexe_4, "symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) #endif _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) diff --git a/scheme.c b/scheme.c index a7d3fd7..4a83cd5 100644 --- a/scheme.c +++ b/scheme.c @@ -250,7 +250,7 @@ INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } #if USE_PLIST -SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } +SCHEME_EXPORT INLINE int hasprop(pointer p) { return (is_symbol(p)); } #define symprop(p) cdr(p) #endif @@ -3380,6 +3380,52 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { return sc->T; } +#if USE_PLIST +static pointer +get_property(scheme *sc, pointer obj, pointer key) +{ + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + return cdar(x); + + return sc->NIL; +} + +static pointer +set_property(scheme *sc, pointer obj, pointer key, pointer value) +{ +#define set_property_allocates 2 + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + cdar(x) = value; + else { + gc_disable(sc, gc_reservations(set_property)); + symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); + gc_enable(sc); + } + + return sc->T; +} +#endif + static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { pointer x; num v; @@ -4127,36 +4173,14 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { s_return(sc, reverse_in_place(sc, car(y), x)); #if USE_PLIST - CASE(OP_PUT): /* put */ - if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { - Error_0(sc,"illegal use of put"); - } - for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { - if (caar(x) == y) { - break; - } - } - if (x != sc->NIL) - cdar(x) = caddr(sc->args); - else - symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), - symprop(car(sc->args))); - s_return(sc,sc->T); + CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */ + gc_disable(sc, gc_reservations(set_property)); + s_return_enable_gc(sc, + set_property(sc, car(sc->args), + cadr(sc->args), caddr(sc->args))); - CASE(OP_GET): /* get */ - if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { - Error_0(sc,"illegal use of get"); - } - for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { - if (caar(x) == y) { - break; - } - } - if (x != sc->NIL) { - s_return(sc,cdar(x)); - } else { - s_return(sc,sc->NIL); - } + CASE(OP_SYMBOL_PROPERTY): /* symbol-property */ + s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); #endif /* USE_PLIST */ CASE(OP_QUIT): /* quit */ if(is_pair(sc->args)) { -- cgit v1.2.3 From b18458f3dfd53627994783d0f2ad835ae70a05af Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 18 Nov 2016 12:51:00 +0100 Subject: gpgscm: Refactor. * tests/gpgscm/scheme.c (opexe_0): Reduce code duplication. Signed-off-by: Justus Winter --- scheme.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/scheme.c b/scheme.c index 4a83cd5..e011dea 100644 --- a/scheme.c +++ b/scheme.c @@ -2963,16 +2963,16 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } } - CASE(OP_LAMBDA1): - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); - #else CASE(OP_LAMBDA): /* lambda */ + sc->value = sc->code; + /* Fallthrough. */ +#endif + + CASE(OP_LAMBDA1): gc_disable(sc, 1); - s_return_enable_gc(sc, mk_closure(sc, sc->code, sc->envir)); + s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); -#endif CASE(OP_MKCLOSURE): /* make-closure */ x=car(sc->args); -- cgit v1.2.3 From 95db0d64ac0ccab6cf0e6d6ec25251ccb0fab9d3 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 22 Nov 2016 14:49:27 +0100 Subject: gpgscm: Fix initialization of 'sink'. * tests/gpgscm/scheme.c (scheme_init_custom_alloc): Also initialize cdr. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index e011dea..673d199 100644 --- a/scheme.c +++ b/scheme.c @@ -5045,7 +5045,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; /* init sink */ typeflag(sc->sink) = (T_SINK | T_PAIR | MARK); - car(sc->sink) = sc->NIL; + car(sc->sink) = cdr(sc->sink) = sc->NIL; /* init c_nest */ sc->c_nest = sc->NIL; -- cgit v1.2.3 From a078d448415c74ee5169d548a901d27380d933f3 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 23 Nov 2016 12:35:15 +0100 Subject: gpgscm: Clean sweeped cells. * tests/gpgscm/scheme.c (gc): Zero typeflag and car of free cells. Signed-off-by: Justus Winter --- scheme.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index 673d199..d088931 100644 --- a/scheme.c +++ b/scheme.c @@ -1569,10 +1569,10 @@ static void gc(scheme *sc, pointer a, pointer b) { /* reclaim cell */ if (typeflag(p) & T_FINALIZE) { finalize_cell(sc, p); - typeflag(p) = 0; - car(p) = sc->NIL; } ++sc->fcells; + typeflag(p) = 0; + car(p) = sc->NIL; cdr(p) = sc->free_cell; sc->free_cell = p; } -- cgit v1.2.3 From 7f7869357cae0f75c5976ece12a1d94a659b904a Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 23 Nov 2016 12:27:41 +0100 Subject: gpgscm: Make 'reverse' compatible with 'reverse_in_place'. * tests/gpgscm/scheme.c (reverse): Update prototype, add terminator argument. (opexe_4): Update callsite. Signed-off-by: Justus Winter --- scheme.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/scheme.c b/scheme.c index d088931..8666548 100644 --- a/scheme.c +++ b/scheme.c @@ -409,7 +409,7 @@ static void printatom(scheme *sc, pointer l, int f); static pointer mk_proc(scheme *sc, enum scheme_opcodes op); static pointer mk_closure(scheme *sc, pointer c, pointer e); static pointer mk_continuation(scheme *sc, pointer d); -static pointer reverse(scheme *sc, pointer a); +static pointer reverse(scheme *sc, pointer term, pointer list); static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); @@ -2356,9 +2356,9 @@ static pointer list_star(scheme *sc, pointer d) { } /* reverse list -- produce new list */ -static pointer reverse(scheme *sc, pointer a) { +static pointer reverse(scheme *sc, pointer term, pointer list) { /* a must be checked by gc */ - pointer p = sc->NIL; + pointer a = list, p = term; for ( ; is_pair(a); a = cdr(a)) { p = cons(sc, car(a), p); @@ -4148,7 +4148,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } CASE(OP_REVERSE): /* reverse */ - s_return(sc,reverse(sc, car(sc->args))); + s_return(sc,reverse(sc, sc->NIL, car(sc->args))); CASE(OP_LIST_STAR): /* list* */ s_return(sc,list_star(sc,sc->args)); -- cgit v1.2.3 From 941c0efdf826717aae88ea448ec60801f74bb476 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 29 Nov 2016 13:31:38 +0100 Subject: gpgscm: Avoid truncating pointers. * tests/gpgscm/scheme.c (_alloc_cellseg): Avoid truncating pointers on systems where sizeof(unsigned long) < sizeof(void *). Signed-off-by: Justus Winter --- scheme.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index 8666548..30b5915 100644 --- a/scheme.c +++ b/scheme.c @@ -29,6 +29,7 @@ #include #include +#include #include #include @@ -615,8 +616,8 @@ _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells) *alloc = cp; /* adjust in TYPE_BITS-bit boundary */ - if (((unsigned long) cp) % adj != 0) - cp = (void *) (adj * ((unsigned long) cp / adj + 1)); + if (((uintptr_t) cp) % adj != 0) + cp = (void *) (adj * ((uintptr_t) cp / adj + 1)); *cells = cp; return 0; -- cgit v1.2.3 From 0d27b63f35c1e3a36631874fd111d3df2a1d51db Mon Sep 17 00:00:00 2001 From: "Neal H. Walfield" Date: Tue, 6 Dec 2016 12:13:22 +0100 Subject: tests: Change (interactive-shell) to start an interactive shell * tests/gpgscm/tests.scm (interactive-shell): Start an interactive shell. Signed-off-by: Neal H. Walfield --- tests.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests.scm b/tests.scm index 72afa99..1c170b0 100644 --- a/tests.scm +++ b/tests.scm @@ -492,4 +492,4 @@ ;; Spawn an os shell. (define (interactive-shell) - (call-with-fds `(,(getenv "SHELL")) 0 1 2)) + (call-with-fds `(,(getenv "SHELL") -i) 0 1 2)) -- cgit v1.2.3 From 85613efd8d49b39c1310d84484cb1647db83b4d5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 6 Dec 2016 15:21:30 +0100 Subject: tests: Rename 'error' to 'fail'. * tests/gpgscm/tests.scm (error): Rename to 'fail'. 'error' is a primitive function (an opcode) of the TinySCHEME vm, and 'error' is also defined by R6RS. Better avoid redefining that. Fix all call sites. * tests/openpgp/4gb-packet.scm: Adapt. * tests/openpgp/decrypt-multifile.scm: Likewise. * tests/openpgp/ecc.scm: Likewise. * tests/openpgp/export.scm: Likewise. * tests/openpgp/gpgtar.scm: Likewise. * tests/openpgp/gpgv-forged-keyring.scm: Likewise. * tests/openpgp/import.scm: Likewise. * tests/openpgp/issue2015.scm: Likewise. * tests/openpgp/issue2346.scm: Likewise. * tests/openpgp/issue2419.scm: Likewise. * tests/openpgp/key-selection.scm: Likewise. * tests/openpgp/mds.scm: Likewise. * tests/openpgp/multisig.scm: Likewise. * tests/openpgp/setup.scm: Likewise. * tests/openpgp/signencrypt.scm: Likewise. * tests/openpgp/ssh-import.scm: Likewise. * tests/openpgp/tofu.scm: Likewise. * tests/openpgp/verify.scm: Likewise. Signed-off-by: Justus Winter --- tests.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests.scm b/tests.scm index 1c170b0..e2b38f5 100644 --- a/tests.scm +++ b/tests.scm @@ -42,7 +42,7 @@ (if (> (*verbose*) 0) (apply info msg))) -(define (error . msg) +(define (fail . msg) (apply info msg) (exit 1)) @@ -325,7 +325,7 @@ (lettmp (sink) (transformer source sink) (if (not (file=? source sink)) - (error "mismatch")))) + (fail "mismatch")))) ;; ;; Monadic pipe support. @@ -440,7 +440,7 @@ (define (tr:spawn input command) (lambda (tmpfiles source) (if (and (member '**in** command) (not source)) - (error (string-append (stringify cmd) " needs an input"))) + (fail (string-append (stringify cmd) " needs an input"))) (let* ((t (make-temporary-file)) (cmd (map (lambda (x) (cond @@ -450,7 +450,7 @@ (catch (list (cons t tmpfiles) t *error*) (call-popen cmd input) (if (and (member '**out** command) (not (file-exists? t))) - (error (string-append (stringify cmd) + (fail (string-append (stringify cmd) " did not produce '" t "'."))) (list (cons t tmpfiles) t #f))))) @@ -471,13 +471,13 @@ (define (tr:assert-identity reference) (lambda (tmpfiles source) (if (not (file=? source reference)) - (error "mismatch")) + (fail "mismatch")) (list tmpfiles source #f))) (define (tr:assert-weak-identity reference) (lambda (tmpfiles source) (if (not (text-file=? source reference)) - (error "mismatch")) + (fail "mismatch")) (list tmpfiles source #f))) (define (tr:call-with-content function . args) -- cgit v1.2.3 From 94e8811cb2fd0cb56b330a811d13075d54681e38 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 8 Dec 2016 15:39:05 +0100 Subject: gpgscm: Generalize 'for-each-p'. * tests/gpgscm/tests.scm (for-each-p): Generalize to N lists like for-each. (for-each-p'): Likewise. Signed-off-by: Justus Winter --- tests.scm | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/tests.scm b/tests.scm index e2b38f5..bd51819 100644 --- a/tests.scm +++ b/tests.scm @@ -77,17 +77,18 @@ (flush-stdio))) (set! *progress-nesting* (- *progress-nesting* 1))) -(define (for-each-p msg proc lst) - (for-each-p' msg proc (lambda (x) x) lst)) +(define (for-each-p msg proc lst . lsts) + (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts))) -(define (for-each-p' msg proc fmt lst) +(define (for-each-p' msg proc fmt lst . lsts) (call-with-progress msg (lambda (progress) - (for-each (lambda (a) - (progress (fmt a)) - (proc a)) - lst)))) + (apply for-each + `(,(lambda args + (progress (apply fmt args)) + (apply proc args)) + ,lst ,@lsts))))) ;; Process management. (define CLOSED_FD -1) -- cgit v1.2.3 From 88753eea0d9b1ea40a46f3b3969d418ba75cccf9 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 18 Nov 2016 13:23:11 +0100 Subject: gpgscm: Implement tags. * tests/gpgscm/opdefines.h: Add opcodes to create and retrieve tags. * tests/gpgscm/scheme.c (T_TAGGED): New macro. (mk_tagged_value): New function. (has_tag): Likewise. (get_tag): Likewise. (mark): Mark tag. (opexe_4): Implement new opcodes. * tests/gpgscm/scheme.h (USE_TAGS): New macro. -- Tags are similar to property lists, but property lists can only be attached to symbols. Tags can not be attached to an existing object, but a tagged copy can be created. Once done, the tag can be manipulated in constant time. Using this during parsing will enable us to produce meaningful error messages. Signed-off-by: Justus Winter --- opdefines.h | 5 ++++ scheme.c | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ scheme.h | 6 +++++ 3 files changed, 91 insertions(+) diff --git a/opdefines.h b/opdefines.h index c7347fd..a2328fa 100644 --- a/opdefines.h +++ b/opdefines.h @@ -148,6 +148,11 @@ #if USE_PLIST _OP_DEF(opexe_4, "set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) _OP_DEF(opexe_4, "symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) +#endif +#if USE_TAGS + _OP_DEF(opexe_4, NULL, 0, 0, TST_NONE, OP_TAG_VALUE ) + _OP_DEF(opexe_4, "make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) + _OP_DEF(opexe_4, "get-tag", 1, 1, TST_ANY, OP_GET_TAG ) #endif _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) diff --git a/scheme.c b/scheme.c index 30b5915..c73a832 100644 --- a/scheme.c +++ b/scheme.c @@ -166,6 +166,7 @@ type_to_string (enum scheme_types typ) #define ADJ 32 #define TYPE_BITS 5 #define T_MASKTYPE 31 /* 0000000000011111 */ +#define T_TAGGED 1024 /* 0000010000000000 */ #define T_FINALIZE 2048 /* 0000100000000000 */ #define T_SYNTAX 4096 /* 0001000000000000 */ #define T_IMMUTABLE 8192 /* 0010000000000000 */ @@ -599,6 +600,59 @@ static long binary_decode(const char *s) { return x; } + + +/* Tags are like property lists, but can be attached to arbitrary + * values. */ + +#if USE_TAGS + +static pointer +mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) +{ + pointer r, t; + + assert(! is_vector(v)); + + r = get_consecutive_cells(sc, 2); + if (r == sc->sink) + return sc->sink; + + memcpy(r, v, sizeof *v); + typeflag(r) |= T_TAGGED; + + t = r + 1; + typeflag(t) = T_PAIR; + car(t) = tag_car; + cdr(t) = tag_cdr; + + return r; +} + +static INLINE int +has_tag(pointer v) +{ + return !! (typeflag(v) & T_TAGGED); +} + +static INLINE pointer +get_tag(scheme *sc, pointer v) +{ + if (has_tag(v)) + return v + 1; + return sc->NIL; +} + +#else + +#define mk_tagged_value(SC, X, A, B) (X) +#define has_tag(V) 0 +#define get_tag(SC, V) (SC)->NIL + +#endif + + + /* Allocate a new cell segment but do not make it available yet. */ static int _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells) @@ -1481,6 +1535,9 @@ E2: setmark(p); mark(p+1+i); } } + /* Mark tag if p has one. */ + if (has_tag(p)) + mark(p + 1); if (is_atom(p)) goto E6; /* E4: down car */ @@ -4183,6 +4240,29 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { CASE(OP_SYMBOL_PROPERTY): /* symbol-property */ s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); #endif /* USE_PLIST */ + +#if USE_TAGS + CASE(OP_TAG_VALUE): { /* not exposed */ + /* This tags sc->value with car(sc->args). Useful to tag + * results of opcode evaluations. */ + pointer a, b, c; + free_cons(sc, sc->args, &a, &b); + free_cons(sc, b, &b, &c); + assert(c == sc->NIL); + s_return(sc, mk_tagged_value(sc, sc->value, a, b)); + } + + CASE(OP_MK_TAGGED): /* make-tagged-value */ + if (is_vector(car(sc->args))) + Error_0(sc, "cannot tag vector"); + s_return(sc, mk_tagged_value(sc, car(sc->args), + car(cadr(sc->args)), + cdr(cadr(sc->args)))); + + CASE(OP_GET_TAG): /* get-tag */ + s_return(sc, get_tag(sc, car(sc->args))); +#endif /* USE_TAGS */ + CASE(OP_QUIT): /* quit */ if(is_pair(sc->args)) { sc->retcode=ivalue(car(sc->args)); diff --git a/scheme.h b/scheme.h index 2b5b066..5e7d90d 100644 --- a/scheme.h +++ b/scheme.h @@ -44,6 +44,7 @@ extern "C" { # define USE_DL 0 # define USE_PLIST 0 # define USE_SMALL_INTEGERS 0 +# define USE_TAGS 0 #endif @@ -76,6 +77,11 @@ extern "C" { # define USE_PLIST 0 #endif +/* If set, then every object can be tagged. */ +#ifndef USE_TAGS +# define USE_TAGS 1 +#endif + /* To force system errors through user-defined error handling (see *error-hook*) */ #ifndef USE_ERROR_HOOK # define USE_ERROR_HOOK 1 -- cgit v1.2.3 From 14d9ea4bd43e077fab4c756b513557cad76aacd2 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 21 Nov 2016 12:38:44 +0100 Subject: gpgscm: Add flags to the interpreter. * tests/gpgscm/scheme-private.h (struct scheme): Add field 'flags'. * tests/gpgscm/scheme.c (S_OP_MASK): New macro. (S_FLAG_MASK, s_set_flag, s_clear_flag, s_get_flag): Likewise. (_s_return): Unpack the encoded opcode and flags. (s_save): Encode the flags along with the opcode. Use normal integers to encode the result. (scheme_init_custom_alloc): Initialize 'op' and 'flags'. Signed-off-by: Justus Winter --- scheme-private.h | 1 + scheme.c | 48 +++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 44 insertions(+), 5 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 2c5c749..40a4211 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -163,6 +163,7 @@ int tok; int print_flag; pointer value; int op; +unsigned int flags; void *ext_data; /* For the benefit of foreign functions */ long gensym_cnt; diff --git a/scheme.c b/scheme.c index c73a832..ab3491b 100644 --- a/scheme.c +++ b/scheme.c @@ -2705,6 +2705,34 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { # define BEGIN do { # define END } while (0) + + +/* Flags. The interpreter has a flags field. When the interpreter + * pushes a frame to the dump stack, it is encoded with the opcode. + * Therefore, we do not use the least significant byte. */ + +/* Masks used to encode and decode opcode and flags. */ +#define S_OP_MASK 0x000000ff +#define S_FLAG_MASK 0xffffff00 + +/* Set flag F. */ +#define s_set_flag(sc, f) \ + BEGIN \ + (sc)->flags |= S_FLAG_ ## f; \ + END + +/* Clear flag F. */ +#define s_clear_flag(sc, f) \ + BEGIN \ + (sc)->flags &= ~ S_FLAG_ ## f; \ + END + +/* Check if flag F is set. */ +#define s_get_flag(sc, f) \ + !!((sc)->flags & S_FLAG_ ## f) + + + /* Bounce back to Eval_Cycle and execute A. */ #define s_goto(sc,a) BEGIN \ sc->op = (int)(a); \ @@ -2757,16 +2785,23 @@ static void dump_stack_free(scheme *sc) static pointer _s_return(scheme *sc, pointer a, int enable_gc) { pointer dump = sc->dump; pointer op; + unsigned long v; sc->value = (a); if (enable_gc) gc_enable(sc); if (dump == sc->NIL) return sc->NIL; free_cons(sc, dump, &op, &dump); - sc->op = ivalue(op); -#ifndef USE_SMALL_INTEGERS - free_cell(sc, op); + v = (unsigned long) ivalue_unchecked(op); + sc->op = (int) (v & S_OP_MASK); + sc->flags = v & S_FLAG_MASK; +#ifdef USE_SMALL_INTEGERS + if (v < MAX_SMALL_INTEGER) { + /* This is a small integer, we must not free it. */ + } else + /* Normal integer. Recover the cell. */ #endif + free_cell(sc, op); free_cons(sc, dump, &sc->args, &dump); free_cons(sc, dump, &sc->envir, &dump); free_cons(sc, dump, &sc->code, &sc->dump); @@ -2774,12 +2809,13 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) { } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { -#define s_save_allocates (4 + mk_small_integer_allocates) +#define s_save_allocates 5 pointer dump; + unsigned long v = sc->flags | ((unsigned long) op); gc_disable(sc, gc_reservations (s_save)); dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); dump = cons(sc, (args), dump); - sc->dump = cons(sc, mk_small_integer(sc, (long)(op)), dump); + sc->dump = cons(sc, mk_integer(sc, (long) v), dump); gc_enable(sc); } @@ -5111,6 +5147,8 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { dump_stack_initialize(sc); sc->code = sc->NIL; sc->tracing=0; + sc->op = -1; + sc->flags = 0; /* init sc->NIL */ typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK); -- cgit v1.2.3 From 83175b317dccceb149906cda721aa33178797f3e Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 21 Nov 2016 17:25:10 +0100 Subject: gpgscm: Add flag TAIL_CONTEXT. * tests/gpgscm/scheme.c (S_FLAG_TAIL_CONTEXT): New macro. This flag indicates that the interpreter is evaluating an expression in a tail context (see R5RS, section 3.5). (opexe_0): Clear and set the flag according to the rules layed out in R5RS, section 3.5. (opexe_1): Likewise. Signed-off-by: Justus Winter --- scheme.c | 52 ++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 44 insertions(+), 8 deletions(-) diff --git a/scheme.c b/scheme.c index ab3491b..8cec9cf 100644 --- a/scheme.c +++ b/scheme.c @@ -2715,6 +2715,12 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #define S_OP_MASK 0x000000ff #define S_FLAG_MASK 0xffffff00 +/* Set if the interpreter evaluates an expression in a tail context + * (see R5RS, section 3.5). If a function, procedure, or continuation + * is invoked while this flag is set, the call is recorded as tail + * call in the history buffer. */ +#define S_FLAG_TAIL_CONTEXT 0x00000100 + /* Set flag F. */ #define s_set_flag(sc, f) \ BEGIN \ @@ -2936,6 +2942,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_E0ARGS, sc->NIL, sc->code); /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_EVAL); } } else { @@ -2949,6 +2956,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->args = cons(sc,sc->code, sc->NIL); gc_enable(sc); sc->code = sc->value; + s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_APPLY); } else { sc->code = cdr(sc->code); @@ -2963,6 +2971,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); sc->code = car(sc->code); sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_EVAL); } else { /* end */ sc->args = reverse_in_place(sc, sc->NIL, sc->args); @@ -3026,6 +3035,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } sc->code = cdr(closure_code(sc->code)); sc->args = sc->NIL; + s_set_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_BEGIN); } else if (is_continuation(sc->code)) { /* CONTINUATION */ sc->dump = cont_dump(sc->code); @@ -3138,18 +3148,29 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_BEGIN): /* begin */ - if (!is_pair(sc->code)) { - s_return(sc,sc->code); - } - if (cdr(sc->code) != sc->NIL) { - s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); - } - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); + { + int last; + + if (!is_pair(sc->code)) { + s_return(sc,sc->code); + } + + last = cdr(sc->code) == sc->NIL; + if (!last) { + s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); + } + sc->code = car(sc->code); + if (! last) + /* This is not the end of the list. This is not a tail + * position. */ + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } CASE(OP_IF0): /* if */ s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_EVAL); CASE(OP_IF1): /* if */ @@ -3179,6 +3200,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { gc_enable(sc); sc->code = cadar(sc->code); sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_EVAL); } else { /* end */ gc_enable(sc); @@ -3227,6 +3249,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); sc->code = cadaar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_EVAL); CASE(OP_LET1AST): /* let* (make new frame) */ @@ -3240,6 +3263,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_LET2AST, sc->args, sc->code); sc->code = cadar(sc->code); sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_EVAL); } else { /* end */ sc->code = sc->args; @@ -3276,6 +3300,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); sc->code = cadar(sc->code); sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); s_goto(sc,OP_EVAL); } else { /* end */ sc->args = reverse_in_place(sc, sc->NIL, sc->args); @@ -3298,6 +3323,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { } s_save(sc,OP_COND1, sc->NIL, sc->code); sc->code = caar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); s_goto(sc,OP_EVAL); CASE(OP_COND1): /* cond */ @@ -3322,6 +3348,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { } else { s_save(sc,OP_COND1, sc->NIL, sc->code); sc->code = caar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); s_goto(sc,OP_EVAL); } } @@ -3337,6 +3364,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->T); } s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); s_goto(sc,OP_EVAL); @@ -3347,6 +3376,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->value); } else { s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); s_goto(sc,OP_EVAL); } @@ -3356,6 +3387,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->F); } s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); s_goto(sc,OP_EVAL); @@ -3366,6 +3399,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->value); } else { s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); s_goto(sc,OP_EVAL); } @@ -3411,6 +3446,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { CASE(OP_CASE0): /* case */ s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); s_goto(sc,OP_EVAL); CASE(OP_CASE1): /* case */ -- cgit v1.2.3 From 81c95b26e769a1ed4933fdf598a3df42d0416928 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 18 Nov 2016 10:58:18 +0100 Subject: gpgscm: Keep a history of calls for error messages. * tests/gpgscm/init.scm (vm-history-print): New function. * tests/gpgscm/opdefines.h: New opcodes 'CALLSTACK_POP', 'APPLY_CODE', and 'VM_HISTORY'. * tests/gpgscm/scheme-private.h (struct history): New definition. (struct scheme): New field 'history'. * tests/gpgscm/scheme.c (gc): Mark objects in the history. (history_free): New function. (history_init): Likewise. (history_mark): Likewise. (add_mod): New macro. (sub_mod): Likewise. (tailstack_clear): New function. (callstack_pop): Likewise. (callstack_push): Likewise. (tailstack_push): Likewise. (tailstack_flatten): Likewise. (callstack_flatten): Likewise. (history_flatten): Likewise. (opexe_0): New variable 'callsite', keep track of the expression if it is a call, implement the new opcodes, record function applications in the history. (opexe_6): Implement new opcode. (scheme_init_custom_alloc): Initialize history. (scheme_deinit): Free history. * tests/gpgscm/scheme.h (USE_HISTORY): New macro. -- This patch makes TinySCHEME keep a history of function calls. This history can be used to produce helpful error messages. The history data structure is inspired by MIT/GNU Scheme. Signed-off-by: Justus Winter fu history --- init.scm | 22 +++++ opdefines.h | 6 ++ scheme-private.h | 33 +++++++ scheme.c | 275 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- scheme.h | 7 ++ 5 files changed, 339 insertions(+), 4 deletions(-) diff --git a/init.scm b/init.scm index f8fd71a..b03eb43 100644 --- a/init.scm +++ b/init.scm @@ -534,6 +534,28 @@ `(define ,(cadr form) (call/cc (lambda (return) ,@(cddr form))))) +;; Print the given history. +(define (vm-history-print history) + (let loop ((n 0) (skip 0) (frames history)) + (cond + ((null? frames) + #t) + ((> skip 0) + (loop 0 (- skip 1) (cdr frames))) + (else + (let ((f (car frames))) + (display n) + (display ": ") + (let ((tag (get-tag f))) + (unless (null? tag) + (display (basename (car tag))) + (display ":") + (display (+ 1 (cdr tag))) + (display ": "))) + (write f)) + (newline) + (loop (+ n 1) skip (cdr frames)))))) + ;;;; Simple exception handling ; ; Exceptions are caught as follows: diff --git a/opdefines.h b/opdefines.h index a2328fa..2d17720 100644 --- a/opdefines.h +++ b/opdefines.h @@ -10,6 +10,10 @@ #endif _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS ) _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS ) +#if USE_HISTORY + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CALLSTACK_POP ) +#endif + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY_CODE ) _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) #if USE_TRACING _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY ) @@ -197,4 +201,6 @@ _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 ) + _OP_DEF(opexe_6, "*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) + #undef _OP_DEF diff --git a/scheme-private.h b/scheme-private.h index 40a4211..7f19a6e 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -62,6 +62,34 @@ struct cell { } _object; }; +#if USE_HISTORY +/* The history is a two-dimensional ring buffer. A donut-shaped data + * structure. This data structure is inspired by MIT/GNU Scheme. */ +struct history { + /* Number of calls to store. Must be a power of two. */ + size_t N; + + /* Number of tail-calls to store in each call frame. Must be a + * power of two. */ + size_t M; + + /* Masks for fast index calculations. */ + size_t mask_N; + size_t mask_M; + + /* A vector of size N containing calls. */ + pointer callstack; + + /* A vector of size N containing vectors of size M containing tail + * calls. */ + pointer tailstacks; + + /* Our current position. */ + size_t n; + size_t *m; +}; +#endif + struct scheme { /* arrays for segments */ func_alloc malloc; @@ -88,6 +116,11 @@ pointer envir; /* stack register for current environment */ pointer code; /* register for current code */ pointer dump; /* stack register for next evaluation */ +#if USE_HISTORY +struct history history; /* we keep track of the call history for + * error messages */ +#endif + int interactive_repl; /* are we in an interactive REPL? */ struct cell _sink; diff --git a/scheme.c b/scheme.c index 8cec9cf..60b5a41 100644 --- a/scheme.c +++ b/scheme.c @@ -308,6 +308,14 @@ INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } #define cadddr(p) car(cdr(cdr(cdr(p)))) #define cddddr(p) cdr(cdr(cdr(cdr(p)))) +#if USE_HISTORY +static pointer history_flatten(scheme *sc); +static void history_mark(scheme *sc); +#else +# define history_mark(SC) (void) 0 +# define history_flatten(SC) (SC)->NIL +#endif + #if USE_CHAR_CLASSIFIERS static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } @@ -1593,6 +1601,7 @@ static void gc(scheme *sc, pointer a, pointer b) { mark(sc->args); mark(sc->envir); mark(sc->code); + history_mark(sc); dump_stack_mark(sc); mark(sc->value); mark(sc->inport); @@ -2830,10 +2839,236 @@ static INLINE void dump_stack_mark(scheme *sc) mark(sc->dump); } + + +#if USE_HISTORY + +static void +history_free(scheme *sc) +{ + sc->free(sc->history.m); + sc->history.tailstacks = sc->NIL; + sc->history.callstack = sc->NIL; +} + +static pointer +history_init(scheme *sc, size_t N, size_t M) +{ + size_t i; + struct history *h = &sc->history; + + h->N = N; + h->mask_N = N - 1; + h->n = N - 1; + assert ((N & h->mask_N) == 0); + + h->M = M; + h->mask_M = M - 1; + assert ((M & h->mask_M) == 0); + + h->callstack = mk_vector(sc, N); + if (h->callstack == sc->sink) + goto fail; + + h->tailstacks = mk_vector(sc, N); + for (i = 0; i < N; i++) { + pointer tailstack = mk_vector(sc, M); + if (tailstack == sc->sink) + goto fail; + set_vector_elem(h->tailstacks, i, tailstack); + } + + h->m = sc->malloc(N * sizeof *h->m); + if (h->m == NULL) + goto fail; + + for (i = 0; i < N; i++) + h->m[i] = 0; + + return sc->T; + +fail: + history_free(sc); + return sc->F; +} + +static void +history_mark(scheme *sc) +{ + struct history *h = &sc->history; + mark(h->callstack); + mark(h->tailstacks); +} + +#define add_mod(a, b, mask) (((a) + (b)) & (mask)) +#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask) + +static INLINE void +tailstack_clear(scheme *sc, pointer v) +{ + assert(is_vector(v)); + /* XXX optimize */ + fill_vector(v, sc->NIL); +} + +static pointer +callstack_pop(scheme *sc) +{ + struct history *h = &sc->history; + size_t n = h->n; + pointer item; + + if (h->callstack == sc->NIL) + return sc->NIL; + + item = vector_elem(h->callstack, n); + /* Clear our frame so that it can be gc'ed and we don't run into it + * when walking the history. */ + set_vector_elem(h->callstack, n, sc->NIL); + tailstack_clear(sc, vector_elem(h->tailstacks, n)); + + /* Exit from the frame. */ + h->n = sub_mod(h->n, 1, h->mask_N); + + return item; +} + +static void +callstack_push(scheme *sc, pointer item) +{ + struct history *h = &sc->history; + size_t n = h->n; + + if (h->callstack == sc->NIL) + return; + + /* Enter a new frame. */ + n = h->n = add_mod(n, 1, h->mask_N); + + /* Initialize tail stack. */ + tailstack_clear(sc, vector_elem(h->tailstacks, n)); + h->m[n] = h->mask_M; + + set_vector_elem(h->callstack, n, item); +} + +static void +tailstack_push(scheme *sc, pointer item) +{ + struct history *h = &sc->history; + size_t n = h->n; + size_t m = h->m[n]; + + if (h->callstack == sc->NIL) + return; + + /* Enter a new tail frame. */ + m = h->m[n] = add_mod(m, 1, h->mask_M); + set_vector_elem(vector_elem(h->tailstacks, n), m, item); +} + +static pointer +tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n, + pointer acc) +{ + struct history *h = &sc->history; + pointer frame; + + assert(i <= h->M); + assert(n < h->M); + + if (acc == sc->sink) + return sc->sink; + + if (i == 0) { + /* We reached the end, but we did not see a unused frame. Signal + this using '... . */ + return cons(sc, mk_symbol(sc, "..."), acc); + } + + frame = vector_elem(tailstack, n); + if (frame == sc->NIL) { + /* A unused frame. We reached the end of the history. */ + return acc; + } + + /* Add us. */ + acc = cons(sc, frame, acc); + + return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M), + acc); +} + +static pointer +callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc) +{ + struct history *h = &sc->history; + pointer frame; + + assert(i <= h->N); + assert(n < h->N); + + if (acc == sc->sink) + return sc->sink; + + if (i == 0) { + /* We reached the end, but we did not see a unused frame. Signal + this using '... . */ + return cons(sc, mk_symbol(sc, "..."), acc); + } + + frame = vector_elem(h->callstack, n); + if (frame == sc->NIL) { + /* A unused frame. We reached the end of the history. */ + return acc; + } + + /* First, emit the tail calls. */ + acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n], + acc); + + /* Then us. */ + acc = cons(sc, frame, acc); + + return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc); +} + +static pointer +history_flatten(scheme *sc) +{ + struct history *h = &sc->history; + pointer history; + + if (h->callstack == sc->NIL) + return sc->NIL; + + history = callstack_flatten(sc, h->N, h->n, sc->NIL); + if (history == sc->sink) + return sc->sink; + + return reverse_in_place(sc, sc->NIL, history); +} + +#undef add_mod +#undef sub_mod + +#else /* USE_HISTORY */ + +#define history_init(SC, A, B) (void) 0 +#define history_free(SC) (void) 0 +#define callstack_pop(SC) (void) 0 +#define callstack_push(SC, X) (void) 0 +#define tailstack_push(SC, X) (void) 0 + +#endif /* USE_HISTORY */ + + + #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { pointer x, y; + pointer callsite; switch (op) { CASE(OP_LOAD): /* load */ @@ -2959,7 +3194,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_clear_flag(sc, TAIL_CONTEXT); s_thread_to(sc,OP_APPLY); } else { - sc->code = cdr(sc->code); + gc_disable(sc, 1); + sc->args = cons(sc, sc->code, sc->NIL); + gc_enable(sc); + sc->code = cdr(sc->code); s_thread_to(sc,OP_E1ARGS); } @@ -2975,9 +3213,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_EVAL); } else { /* end */ sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_thread_to(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY_CODE); } #if USE_TRACING @@ -2989,6 +3225,20 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } #endif +#if USE_HISTORY + CASE(OP_CALLSTACK_POP): /* pop the call stack */ + callstack_pop(sc); + s_return(sc, sc->value); +#endif + + CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)', + * record in the history as invoked from + * 'car(args)' */ + free_cons(sc, sc->args, &callsite, &sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + /* Fallthrough. */ + CASE(OP_APPLY): /* apply 'code' to 'args' */ #if USE_TRACING if(sc->tracing) { @@ -3001,6 +3251,18 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { /* fall through */ CASE(OP_REAL_APPLY): #endif +#if USE_HISTORY + if (op != OP_APPLY_CODE) + callsite = sc->code; + if (s_get_flag(sc, TAIL_CONTEXT)) { + /* We are evaluating a tail call. */ + tailstack_push(sc, callsite); + } else { + callstack_push(sc, callsite); + s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL); + } +#endif + if (is_proc(sc->code)) { s_goto(sc,procnum(sc->code)); /* PROCEDURE */ } else if (is_foreign(sc->code)) @@ -4805,6 +5067,8 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { s_retbool(is_closure(car(sc->args))); CASE(OP_MACROP): /* macro? */ s_retbool(is_macro(car(sc->args))); + CASE(OP_VM_HISTORY): /* *vm-history* */ + s_return(sc, history_flatten(sc)); default: snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); Error_0(sc,sc->strbuff); @@ -5235,6 +5499,8 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { } } + history_init(sc, 8, 8); + /* initialization of global pointers to special symbols */ sc->LAMBDA = mk_symbol(sc, "lambda"); sc->QUOTE = mk_symbol(sc, "quote"); @@ -5284,6 +5550,7 @@ void scheme_deinit(scheme *sc) { dump_stack_free(sc); sc->envir=sc->NIL; sc->code=sc->NIL; + history_free(sc); sc->args=sc->NIL; sc->value=sc->NIL; if(is_port(sc->inport)) { diff --git a/scheme.h b/scheme.h index 5e7d90d..8560f7d 100644 --- a/scheme.h +++ b/scheme.h @@ -45,6 +45,7 @@ extern "C" { # define USE_PLIST 0 # define USE_SMALL_INTEGERS 0 # define USE_TAGS 0 +# define USE_HISTORY 0 #endif @@ -82,6 +83,12 @@ extern "C" { # define USE_TAGS 1 #endif +/* Keep a history of function calls. This enables a feature similar + * to stack traces. */ +#ifndef USE_HISTORY +# define USE_HISTORY 1 +#endif + /* To force system errors through user-defined error handling (see *error-hook*) */ #ifndef USE_ERROR_HOOK # define USE_ERROR_HOOK 1 -- cgit v1.2.3 From 735c66bd2d5672de8cc7573fe9d6af4615b86fe2 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 18 Nov 2016 13:36:23 +0100 Subject: gpgscm: Better error reporting. * tests/gpgscm/ffi.scm: Move the customized exception handling and atexit logic... * tests/gpgscm/init.scm: ... here. (throw): Record the current history. (throw'): New function that is history-aware. (rethrow): New function. (*error-hook*): Use the new throw'. * tests/gpgscm/main.c (load): Fix error handling. (main): Save and use the 'sc->retcode' as exit code. * tests/gpgscm/repl.scm (repl): Print call history. * tests/gpgscm/scheme.c (_Error_1): Make a snapshot of the history, use it to provide a accurate location of the expression causing the error at runtime, and hand the history trace to the '*error-hook*'. (opexe_5): Tag all lists at parse time with the current location. * tests/gpgscm/tests.scm: Update calls to 'throw', use 'rethrow'. Signed-off-by: Justus Winter --- ffi.scm | 36 ------------------------------------ init.scm | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++------ main.c | 21 +++++++++++++-------- repl.scm | 9 ++++++++- scheme.c | 45 +++++++++++++++++++++++++++++++++++++++------ tests.scm | 11 ++++++----- 6 files changed, 122 insertions(+), 62 deletions(-) diff --git a/ffi.scm b/ffi.scm index c5f373c..b62fd1f 100644 --- a/ffi.scm +++ b/ffi.scm @@ -47,39 +47,3 @@ ;; Low-level mechanism to terminate the process. (ffi-define (_exit status)) - -;; High-level mechanism to terminate the process is to throw an error -;; of the form (*interpreter-exit* status). This gives automatic -;; resource management a chance to clean up. -(define *interpreter-exit* (gensym)) -(define (throw . x) - (cond - ((more-handlers?) - (apply (pop-handler) x)) - ((and (= 2 (length x)) (equal? *interpreter-exit* (car x))) - (*run-atexit-handlers*) - (_exit (cadr x))) - (else - (apply error x)))) -(set! *error-hook* throw) - -;; Terminate the process returning STATUS to the parent. -(define (exit status) - (throw *interpreter-exit* status)) - -;; A list of functions run at interpreter shutdown. -(define *atexit-handlers* (list)) - -;; Execute all these functions. -(define (*run-atexit-handlers*) - (unless (null? *atexit-handlers*) - (let ((proc (car *atexit-handlers*))) - ;; Drop proc from the list so that it will not get - ;; executed again even if it raises an exception. - (set! *atexit-handlers* (cdr *atexit-handlers*)) - (proc) - (*run-atexit-handlers*)))) - -;; Register a function to be run at interpreter shutdown. -(define (atexit proc) - (set! *atexit-handlers* (cons proc *atexit-handlers*))) diff --git a/init.scm b/init.scm index b03eb43..04f088c 100644 --- a/init.scm +++ b/init.scm @@ -567,7 +567,7 @@ ; "Catch" establishes a scope spanning multiple call-frames until ; another "catch" is encountered. Within the recovery expression ; the thrown exception is bound to *error*. Errors can be rethrown -; using (apply throw *error*). +; using (rethrow *error*). ; ; Exceptions are thrown with: ; @@ -588,10 +588,30 @@ (define (more-handlers?) (pair? *handlers*)) -(define (throw . x) - (if (more-handlers?) - (apply (pop-handler) x) - (apply error x))) +;; This throws an exception. +(define (throw message . args) + (throw' message args (cdr (*vm-history*)))) + +;; This is used by the vm to throw exceptions. +(define (throw' message args history) + (cond + ((more-handlers?) + ((pop-handler) message args history)) + ((and args (= 2 (length args)) (equal? *interpreter-exit* (car args))) + (*run-atexit-handlers*) + (quit (cadr args))) + (else + (display message) + (if args (begin + (display ": ") + (write args))) + (newline) + (vm-history-print history) + (quit 1)))) + +;; Convenience function to rethrow the error. +(define (rethrow e) + (apply throw' e)) (macro (catch form) (let ((label (gensym))) @@ -601,8 +621,38 @@ (pop-handler) ,label))))) -(define *error-hook* throw) +;; Make the vm use throw'. +(define *error-hook* throw') + + + +;; High-level mechanism to terminate the process is to throw an error +;; of the form (*interpreter-exit* status). This gives automatic +;; resource management a chance to clean up. +(define *interpreter-exit* (gensym)) + +;; Terminate the process returning STATUS to the parent. +(define (exit status) + (throw "interpreter exit" *interpreter-exit* status)) + +;; A list of functions run at interpreter shutdown. +(define *atexit-handlers* (list)) + +;; Execute all these functions. +(define (*run-atexit-handlers*) + (unless (null? *atexit-handlers*) + (let ((proc (car *atexit-handlers*))) + ;; Drop proc from the list so that it will not get + ;; executed again even if it raises an exception. + (set! *atexit-handlers* (cdr *atexit-handlers*)) + (proc) + (*run-atexit-handlers*)))) + +;; Register a function to be run at interpreter shutdown. +(define (atexit proc) + (set! *atexit-handlers* (cons proc *atexit-handlers*))) + ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL diff --git a/main.c b/main.c index 2f77ac5..c96dcf1 100644 --- a/main.c +++ b/main.c @@ -150,7 +150,10 @@ load (scheme *sc, char *file_name, h = fopen (qualified_name, "r"); if (h) - break; + { + err = 0; + break; + } if (n > 1) { @@ -170,23 +173,23 @@ load (scheme *sc, char *file_name, fprintf (stderr, "Consider using GPGSCM_PATH to specify the location " "of the Scheme library.\n"); - return err; + goto leave; } if (verbose > 1) fprintf (stderr, "Loading %s...\n", qualified_name); scheme_load_named_file (sc, h, qualified_name); fclose (h); - if (sc->retcode) + if (sc->retcode && sc->nesting) { - if (sc->nesting) - fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); - return gpg_error (GPG_ERR_GENERAL); + fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); + err = gpg_error (GPG_ERR_GENERAL); } + leave: if (file_name != qualified_name) free (qualified_name); - return 0; + return err; } @@ -194,6 +197,7 @@ load (scheme *sc, char *file_name, int main (int argc, char **argv) { + int retcode; gpg_error_t err; char *argv0; ARGPARSE_ARGS pargs; @@ -291,8 +295,9 @@ main (int argc, char **argv) log_fatal ("%s: %s", script, gpg_strerror (err)); } + retcode = sc->retcode; scheme_load_string (sc, "(*run-atexit-handlers*)"); scheme_deinit (sc); xfree (sc); - return EXIT_SUCCESS; + return retcode; } diff --git a/repl.scm b/repl.scm index 78b8151..84454dc 100644 --- a/repl.scm +++ b/repl.scm @@ -34,7 +34,14 @@ (read (open-input-string next))))) (if (not (eof-object? c)) (begin - (catch (echo "Error:" *error*) + (catch (begin + (display (car *error*)) + (when (and (cadr *error*) + (not (null? (cadr *error*)))) + (display ": ") + (write (cadr *error*))) + (newline) + (vm-history-print (caddr *error*))) (echo " ===>" (eval c environment))) (exit (loop "")))) (exit (loop next))))))))) diff --git a/scheme.c b/scheme.c index 60b5a41..3abe12a 100644 --- a/scheme.c +++ b/scheme.c @@ -2656,6 +2656,7 @@ static INLINE pointer slot_value_in_env(pointer slot) static pointer _Error_1(scheme *sc, const char *s, pointer a) { const char *str = s; + pointer history; #if USE_ERROR_HOOK pointer x; pointer hdl=sc->ERROR_HOOK; @@ -2663,19 +2664,34 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #if SHOW_ERROR_LINE char sbuf[STRBUFFSIZE]; +#endif + + history = history_flatten(sc); +#if SHOW_ERROR_LINE /* make sure error is not in REPL */ if (sc->load_stack[sc->file_i].kind & port_file && sc->load_stack[sc->file_i].rep.stdio.file != stdin) { - int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line; - const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename; + pointer tag; + const char *fname; + int ln; + + if (history != sc->NIL && has_tag(car(history)) + && (tag = get_tag(sc, car(history))) + && is_string(car(tag)) && is_integer(cdr(tag))) { + fname = string_value(car(tag)); + ln = ivalue_unchecked(cdr(tag)); + } else { + fname = sc->load_stack[sc->file_i].rep.stdio.filename; + ln = sc->load_stack[sc->file_i].rep.stdio.curr_line; + } /* should never happen */ if(!fname) fname = ""; /* we started from 0 */ ln++; - snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s); + snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s); str = (const char*)sbuf; } @@ -2684,11 +2700,15 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #if USE_ERROR_HOOK x=find_slot_in_env(sc,sc->envir,hdl,1); if (x != sc->NIL) { + sc->code = cons(sc, cons(sc, sc->QUOTE, + cons(sc, history, sc->NIL)), + sc->NIL); if(a!=0) { - sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); + sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)), + sc->code); } else { - sc->code = sc->NIL; - } + sc->code = cons(sc, sc->F, sc->code); + } sc->code = cons(sc, mk_string(sc, str), sc->code); setimmutable(car(sc->code)); sc->code = cons(sc, slot_value_in_env(x), sc->code); @@ -4808,6 +4828,19 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"syntax error: illegal dot expression"); } else { sc->nesting_stack[sc->file_i]++; +#if USE_TAGS && SHOW_ERROR_LINE + { + const char *filename = + sc->load_stack[sc->file_i].rep.stdio.filename; + int lineno = + sc->load_stack[sc->file_i].rep.stdio.curr_line; + + s_save(sc, OP_TAG_VALUE, + cons(sc, mk_string(sc, filename), + cons(sc, mk_integer(sc, lineno), sc->NIL)), + sc->NIL); + } +#endif s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); s_thread_to(sc,OP_RDSEXPR); } diff --git a/tests.scm b/tests.scm index bd51819..bec1922 100644 --- a/tests.scm +++ b/tests.scm @@ -130,7 +130,8 @@ (let ((result (call-with-io what ""))) (if (= 0 (:retcode result)) (:stdout result) - (throw (list what "failed:" (:stderr result)))))) + (throw (string-append (stringify what) " failed") + (:stderr result))))) (define (call-popen command input-string) (let ((result (call-with-io command input-string))) @@ -246,7 +247,7 @@ (let ((,result-sym ,(if (= 1 (length (cadr form))) `(catch (begin (close ,(caaadr form)) - (apply throw *error*)) + (rethrow *error*)) ,@(cddr form)) `(letfd ,(cdadr form) ,@(cddr form))))) (close ,(caaadr form)) @@ -257,7 +258,7 @@ `(let* ((,cwd-sym (getcwd)) (_ (if ,(cadr form) (chdir ,(cadr form)))) (,result-sym (catch (begin (chdir ,cwd-sym) - (apply throw *error*)) + (rethrow *error*)) ,@(cddr form)))) (chdir ,cwd-sym) ,result-sym))) @@ -281,7 +282,7 @@ (_ (chdir ,tmp-sym)) (,result-sym (catch (begin (chdir ,cwd-sym) (unlink-recursively ,tmp-sym) - (apply throw *error*)) + (rethrow *error*)) ,@(cdr form)))) (chdir ,cwd-sym) (unlink-recursively ,tmp-sym) @@ -312,7 +313,7 @@ (let ((,result-sym ,(if (= 1 (length (cadr form))) `(catch (begin (remove-temporary-file ,(caadr form)) - (apply throw *error*)) + (rethrow *error*)) ,@(cddr form)) `(lettmp ,(cdadr form) ,@(cddr form))))) (remove-temporary-file ,(caadr form)) -- cgit v1.2.3 From f745dcab2b1789c8f64c2be4b5dcc7322212e1d2 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 16 Nov 2016 12:02:03 +0100 Subject: gpgscm: Improve library functions. * tests/gpgscm/tests.scm (absolute-path?): New function. (canonical-path): Use the new function. * tests/gpgscm/lib.scm (string-split-pln): New function. (string-indexp, string-splitp): Likewise. (string-splitn): Express using the above function. (string-ltrim, string-rtrim): Fix corner case. (list->string-reversed): New function. (read-line): Fix performance. Signed-off-by: Justus Winter --- lib.scm | 101 ++++++++++++++++++++++++++++++++++++++++++++++---------------- tests.scm | 21 +++++++------ 2 files changed, 88 insertions(+), 34 deletions(-) diff --git a/lib.scm b/lib.scm index 4e19eae..fabbef8 100644 --- a/lib.scm +++ b/lib.scm @@ -86,18 +86,47 @@ (assert (equal? #f (string-rindex "Hallo" #\a 2))) (assert (equal? #f (string-rindex "Hallo" #\.))) -;; Split haystack at delimiter at most n times. -(define (string-splitn haystack delimiter n) +;; Split HAYSTACK at each character that makes PREDICATE true at most +;; N times. +(define (string-split-pln haystack predicate lookahead n) (let ((length (string-length haystack))) - (define (split acc delimiter offset n) + (define (split acc offset n) (if (>= offset length) (reverse acc) - (let ((i (string-index haystack delimiter offset))) + (let ((i (lookahead haystack offset))) (if (or (eq? i #f) (= 0 n)) (reverse (cons (substring haystack offset length) acc)) (split (cons (substring haystack offset i) acc) - delimiter (+ i 1) (- n 1)))))) - (split '() delimiter 0 n))) + (+ i 1) (- n 1)))))) + (split '() 0 n))) + +(define (string-indexp haystack offset predicate) + (cond + ((= (string-length haystack) offset) + #f) + ((predicate (string-ref haystack offset)) + offset) + (else + (string-indexp haystack (+ 1 offset) predicate)))) + +;; Split HAYSTACK at each character that makes PREDICATE true at most +;; N times. +(define (string-splitp haystack predicate n) + (string-split-pln haystack predicate + (lambda (haystack offset) + (string-indexp haystack offset predicate)) + n)) +(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1))) +(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1))) +(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1))) + +;; Split haystack at delimiter at most n times. +(define (string-splitn haystack delimiter n) + (string-split-pln haystack + (lambda (c) (char=? c delimiter)) + (lambda (haystack offset) + (string-index haystack delimiter offset)) + n)) (assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1)))) (assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1)))) (assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1)))) @@ -122,25 +151,32 @@ ;; Trim the prefix of S containing only characters that make PREDICATE ;; true. (define (string-ltrim predicate s) - (let loop ((s' (string->list s))) - (if (predicate (car s')) - (loop (cdr s')) - (list->string s')))) + (if (string=? s "") + "" + (let loop ((s' (string->list s))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string s'))))) +(assert (string=? "" (string-ltrim char-whitespace? ""))) (assert (string=? "foo" (string-ltrim char-whitespace? " foo"))) ;; Trim the suffix of S containing only characters that make PREDICATE ;; true. (define (string-rtrim predicate s) - (let loop ((s' (reverse (string->list s)))) - (if (predicate (car s')) - (loop (cdr s')) - (list->string (reverse s'))))) + (if (string=? s "") + "" + (let loop ((s' (reverse (string->list s)))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string (reverse s')))))) +(assert (string=? "" (string-rtrim char-whitespace? ""))) (assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) ;; Trim both the prefix and suffix of S containing only characters ;; that make PREDICATE true. (define (string-trim predicate s) (string-ltrim predicate (string-rtrim predicate s))) +(assert (string=? "" (string-trim char-whitespace? ""))) (assert (string=? "foo" (string-trim char-whitespace? " foo "))) ;; Check if needle is contained in haystack. @@ -162,19 +198,34 @@ (apply read-char p) '())))))) +(define (list->string-reversed lst) + (let* ((len (length lst)) + (str (make-string len))) + (let loop ((i (- len 1)) + (l lst)) + (if (< i 0) + (begin + (assert (null? l)) + str) + (begin + (string-set! str i (car l)) + (loop (- i 1) (cdr l))))))) + ;; Read a line from port P. (define (read-line . p) - (list->string - (let f () - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) '()) - ((char=? c #\newline) - (apply read-char p) - '()) - (else - (apply read-char p) - (cons c (f)))))))) + (let loop ((acc '())) + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) + (if (null? acc) + c ;; #eof + (list->string-reversed acc))) + ((char=? c #\newline) + (apply read-char p) + (list->string-reversed acc)) + (else + (apply read-char p) + (loop (cons c acc))))))) ;; Read everything from port P. (define (read-all . p) diff --git a/tests.scm b/tests.scm index bec1922..d360272 100644 --- a/tests.scm +++ b/tests.scm @@ -186,16 +186,19 @@ (assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz")) (assert (string=? (path-join "" "bar" "baz") "bar/baz")) +;; Is PATH an absolute path? +(define (absolute-path? path) + (or (char=? #\/ (string-ref path 0)) + (and *win32* (char=? #\\ (string-ref path 0))) + (and *win32* + (char-alphabetic? (string-ref path 0)) + (char=? #\: (string-ref path 1)) + (or (char=? #\/ (string-ref path 2)) + (char=? #\\ (string-ref path 2)))))) + +;; Make PATH absolute. (define (canonical-path path) - (if (or (char=? #\/ (string-ref path 0)) - (and *win32* (char=? #\\ (string-ref path 0))) - (and *win32* - (char-alphabetic? (string-ref path 0)) - (char=? #\: (string-ref path 1)) - (or (char=? #\/ (string-ref path 2)) - (char=? #\\ (string-ref path 2))))) - path - (path-join (getcwd) path))) + (if (absolute-path? path) path (path-join (getcwd) path))) (define (in-srcdir . names) (canonical-path (apply path-join (cons (getenv "srcdir") names)))) -- cgit v1.2.3 From 0031a4d4d8a1851f0c32ad1af2f42f59bd016001 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 16 Nov 2016 12:32:17 +0100 Subject: gpgscm: Move the test runner to the Scheme library. * tests/openpgp/run-tests.scm: Move most of the code... * tests/gpgscm/tests.scm: ... here. Signed-off-by: Justus Winter --- tests.scm | 151 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 151 insertions(+) diff --git a/tests.scm b/tests.scm index d360272..dd4c69f 100644 --- a/tests.scm +++ b/tests.scm @@ -498,3 +498,154 @@ ;; Spawn an os shell. (define (interactive-shell) (call-with-fds `(,(getenv "SHELL") -i) 0 1 2)) + +;; +;; The main test framework. +;; + +;; A pool of tests. +(define test-pool + (package + (define (new procs) + (package + (define (add test) + (new (cons test procs))) + (define (wait) + (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) + (if (null? unfinished) + (package) + (let* ((names (map (lambda (t) t::name) unfinished)) + (pids (map (lambda (t) t::pid) unfinished)) + (results + (map (lambda (pid retcode) (list pid retcode)) + pids + (wait-processes (map stringify names) pids #t)))) + (new + (map (lambda (t) + (if t::retcode + t + (t::set-retcode (cadr (assoc t::pid results))))) + procs)))))) + (define (passed) + (filter (lambda (p) (= 0 p::retcode)) procs)) + (define (skipped) + (filter (lambda (p) (= 77 p::retcode)) procs)) + (define (hard-errored) + (filter (lambda (p) (= 99 p::retcode)) procs)) + (define (failed) + (filter (lambda (p) + (not (or (= 0 p::retcode) (= 77 p::retcode) + (= 99 p::retcode)))) + procs)) + (define (report) + (echo (length procs) "tests run," + (length (passed)) "succeeded," + (length (failed)) "failed," + (length (skipped)) "skipped.") + (length (failed))))))) + +(define (verbosity n) + (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) + +(define (locate-test path) + (if (absolute-path? path) path (in-srcdir path))) + +;; A single test. +(define test + (package + (define (scm path . args) + ;; Start the process. + (define (spawn-scm args in out err) + (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) + ,(locate-test path) ,@args) in out err)) + (new (basename path) #f spawn-scm #f #f CLOSED_FD)) + + (define (binary path . args) + ;; Start the process. + (define (spawn-binary args in out err) + (spawn-process-fd `(path ,@args) in out err)) + (new (basename path) #f spawn-binary #f #f CLOSED_FD)) + + (define (new name directory spawn pid retcode logfd) + (package + (define (set-directory x) + (new name x spawn pid retcode logfd)) + (define (set-retcode x) + (new name directory spawn pid x logfd)) + (define (set-pid x) + (new name directory spawn x retcode logfd)) + (define (set-logfd x) + (new name directory spawn pid retcode x)) + (define (open-log-file) + (let ((filename (string-append (basename name) ".log"))) + (catch '() (unlink filename)) + (open filename (logior O_RDWR O_BINARY O_CREAT) #o600))) + (define (run-sync . args) + (letfd ((log (open-log-file))) + (with-working-directory directory + (let* ((p (inbound-pipe)) + (pid (spawn args 0 (:write-end p) (:write-end p)))) + (close (:write-end p)) + (splice (:read-end p) STDERR_FILENO log) + (close (:read-end p)) + (let ((t' (set-retcode (wait-process name pid #t)))) + (t'::report) + t'))))) + (define (run-sync-quiet . args) + (with-working-directory directory + (set-retcode + (wait-process + name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t)))) + (define (run-async . args) + (let ((log (open-log-file))) + (with-working-directory directory + (new name directory spawn + (spawn args CLOSED_FD log log) + retcode log)))) + (define (status) + (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) + (if (not t) "FAIL" (cadr t)))) + (define (report) + (unless (= logfd CLOSED_FD) + (seek logfd 0 SEEK_SET) + (splice logfd STDERR_FILENO) + (close logfd)) + (echo (string-append (status retcode) ":") name)))))) + +;; Run the setup target to create an environment, then run all given +;; tests in parallel. +(define (run-tests-parallel setup tests) + (lettmp (gpghome-tar) + (setup::run-sync '--create-tarball gpghome-tar) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (catch (echo "Removing" t::directory "failed:" *error*) + (unlink-recursively t::directory)) + (t::report)) (reverse results::procs)) + (exit (results::report))) + (let* ((wd (mkdtemp)) + (test (car tests')) + (test' (test::set-directory wd))) + (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar)) + (cdr tests'))))))) + +;; Run the setup target to create an environment, then run all given +;; tests in sequence. +(define (run-tests-sequential setup tests) + (lettmp (gpghome-tar) + (setup::run-sync '--create-tarball gpghome-tar) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (catch (echo "Removing" t::directory "failed:" *error*) + (unlink-recursively t::directory))) + results::procs) + (exit (results::report))) + (let* ((wd (mkdtemp)) + (test (car tests')) + (test' (test::set-directory wd))) + (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar)) + (cdr tests'))))))) -- cgit v1.2.3 From b1e67a725d17ff1605ba79d8bb61f37c4a48f0a5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 17 Nov 2016 11:06:42 +0100 Subject: gpgscm: Generalize the test runner. * tests/gpgscm/tests.scm (test::scm) Add explicit name argument. (test::binary): Likewise. Also, add missing unquote. * tests/openpgp/run-tests.scm: Adapt accordingly. Signed-off-by: Justus Winter --- tests.scm | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/tests.scm b/tests.scm index dd4c69f..b5df9b7 100644 --- a/tests.scm +++ b/tests.scm @@ -553,18 +553,19 @@ ;; A single test. (define test (package - (define (scm path . args) + (define (scm name path . args) ;; Start the process. - (define (spawn-scm args in out err) + (define (spawn-scm args' in out err) (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) - ,(locate-test path) ,@args) in out err)) - (new (basename path) #f spawn-scm #f #f CLOSED_FD)) + ,(locate-test path) + ,@args' ,@args) in out err)) + (new name #f spawn-scm #f #f CLOSED_FD)) - (define (binary path . args) + (define (binary name path . args) ;; Start the process. - (define (spawn-binary args in out err) - (spawn-process-fd `(path ,@args) in out err)) - (new (basename path) #f spawn-binary #f #f CLOSED_FD)) + (define (spawn-binary args' in out err) + (spawn-process-fd `(,path ,@args' ,@args) in out err)) + (new name #f spawn-binary #f #f CLOSED_FD)) (define (new name directory spawn pid retcode logfd) (package -- cgit v1.2.3 From e8c5871609dd3ff3b2aa3d21ab5c3651ba683ed7 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 17 Nov 2016 13:12:38 +0100 Subject: gpgscm: Print failed and skipped tests. * tests/gpgscm/tests.scm (test-pool::report): Print failed and skipped tests at the end. Signed-off-by: Justus Winter --- tests.scm | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/tests.scm b/tests.scm index b5df9b7..7b8d489 100644 --- a/tests.scm +++ b/tests.scm @@ -538,11 +538,19 @@ (= 99 p::retcode)))) procs)) (define (report) - (echo (length procs) "tests run," - (length (passed)) "succeeded," - (length (failed)) "failed," - (length (skipped)) "skipped.") - (length (failed))))))) + (define (print-tests tests message) + (unless (null? tests) + (apply echo (cons message + (map (lambda (t) t::name) tests))))) + + (let ((failed' (failed)) (skipped' (skipped))) + (echo (length procs) "tests run," + (length (passed)) "succeeded," + (length failed') "failed," + (length skipped') "skipped.") + (print-tests failed' "Failed tests:") + (print-tests skipped' "Skipped tests:") + (length failed'))))))) (define (verbosity n) (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) -- cgit v1.2.3 From 5221e0b2a3bd2dbb4f997e3c2118b176e10e116e Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Dec 2016 15:25:52 +0100 Subject: gpgscm: Make exception handling more robust. * tests/gpgscm/init.scm (throw'): Check that args is a list. Signed-off-by: Justus Winter --- init.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/init.scm b/init.scm index 04f088c..106afd5 100644 --- a/init.scm +++ b/init.scm @@ -597,7 +597,8 @@ (cond ((more-handlers?) ((pop-handler) message args history)) - ((and args (= 2 (length args)) (equal? *interpreter-exit* (car args))) + ((and args (list? args) (= 2 (length args)) + (equal? *interpreter-exit* (car args))) (*run-atexit-handlers*) (quit (cadr args))) (else -- cgit v1.2.3 From b852ac097f3dfe4e62c3d27e18a22f1b9f704530 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Dec 2016 15:28:07 +0100 Subject: gpgscm: Display location when assertions fail. * tests/gpgscm/lib.scm (assert): Use location information if available. Signed-off-by: Justus Winter --- lib.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/lib.scm b/lib.scm index fabbef8..6959aa4 100644 --- a/lib.scm +++ b/lib.scm @@ -18,13 +18,16 @@ ;; along with this program; if not, see . (macro (assert form) - `(if (not ,(cadr form)) - (begin - (display "Assertion failed: ") - (write (quote ,(cadr form))) - (newline) - (exit 1)))) + (let ((tag (get-tag form))) + `(if (not ,(cadr form)) + (throw ,(if (pair? tag) + `(string-append ,(car tag) ":" + ,(number->string (+ 1 (cdr tag))) + ": Assertion failed: ") + "Assertion failed: ") + (quote ,(cadr form)))))) (assert #t) +(assert (not #f)) (define (filter pred lst) (cond ((null? lst) '()) -- cgit v1.2.3 From 3ae0b5d9af063e7af03558be2bf8f32e5bb4e5cd Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Dec 2016 15:29:07 +0100 Subject: gpgscm: Change associativity of ::. * tests/gpgscm/scheme.c (mk_atom): Change associativity of the :: infix-operator. This makes it possible to naturally express accessing nested structures (e.g. a::b::c). Signed-off-by: Justus Winter --- scheme.c | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/scheme.c b/scheme.c index 3abe12a..a5b7691 100644 --- a/scheme.c +++ b/scheme.c @@ -1409,14 +1409,23 @@ static pointer mk_atom(scheme *sc, char *q) { int has_fp_exp = 0; #if USE_COLON_HOOK - if((p=strstr(q,"::"))!=0) { + char *next; + next = p = q; + while ((next = strstr(next, "::")) != 0) { + /* Keep looking for the last occurrence. */ + p = next; + next = next + 2; + } + + if (p != q) { *p=0; return cons(sc, sc->COLON_HOOK, cons(sc, cons(sc, sc->QUOTE, - cons(sc, mk_atom(sc,p+2), sc->NIL)), - cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); + cons(sc, mk_symbol(sc, strlwr(p + 2)), + sc->NIL)), + cons(sc, mk_atom(sc, q), sc->NIL))); } #endif -- cgit v1.2.3 From 5f16dec938ac6e337c6ff72981285385d75ec455 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 20 Dec 2016 14:01:35 +0100 Subject: tests: Move argument parser. * tests/gpgme/gpgme-defs.scm (flag): Move... * tests/gpgscm/tests.scm: ... over here. Signed-off-by: Justus Winter --- tests.scm | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/tests.scm b/tests.scm index 7b8d489..f127a93 100644 --- a/tests.scm +++ b/tests.scm @@ -658,3 +658,28 @@ (test' (test::set-directory wd))) (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar)) (cdr tests'))))))) + +;; Command line flag handling. Returns the elements following KEY in +;; ARGUMENTS up to the next argument, or #f if KEY is not in +;; ARGUMENTS. +(define (flag key arguments) + (cond + ((null? arguments) + #f) + ((string=? key (car arguments)) + (let loop ((acc '()) + (args (cdr arguments))) + (if (or (null? args) (string-prefix? (car args) "--")) + (reverse acc) + (loop (cons (car args) acc) (cdr args))))) + ((string=? "--" (car arguments)) + #f) + (else + (flag key (cdr arguments))))) +(assert (equal? (flag "--xxx" '("--yyy")) #f)) +(assert (equal? (flag "--xxx" '("--xxx")) '())) +(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy"))) +(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy"))) -- cgit v1.2.3 From aa6b3449bf1b42703b4c6466d87f91620743a5d2 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 21 Dec 2016 16:14:45 +0100 Subject: gpgscm: Guard use of union member. * tests/gpgscm/scheme.c (opexe_5): Check that we have a file port before accessing filename. Fixes a crash on 32-bit architectures. Fixes-commit: e7429b1ced0c69fa7901f888f8dc25f00fc346a4 Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index a5b7691..2844545 100644 --- a/scheme.c +++ b/scheme.c @@ -4838,7 +4838,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } else { sc->nesting_stack[sc->file_i]++; #if USE_TAGS && SHOW_ERROR_LINE - { + if (sc->load_stack[sc->file_i].kind & port_file) { const char *filename = sc->load_stack[sc->file_i].rep.stdio.filename; int lineno = -- cgit v1.2.3 From 4165c9303d894179c0da3a1b12316d3df8d4ce82 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 22 Dec 2016 10:36:56 +0100 Subject: gpgscm: Use boxed values for source locations. * tests/gpgscm/scheme-private.h (struct port): Use boxed values for filename and current line. This allows us to use the same Scheme object for labeling all expressions in a file. * tests/gpgscm/scheme.c (file_push): Use boxed type for filename. (mark): Mark location objects of port objects. (gc): Mark location objects in the load stack. (port_clear_location): New function. (port_reset_current_line): Likewise. (port_increment_current_line): Likewise. (file_pop): Adapt accordingly. (port_rep_from_filename): Likewise. (port_rep_from_file): Likewise. (port_close): Likewise. (skipspace): Likewise. (token): Likewise. (_Error_1): Likewise. (opexe_0): Likewise. (opexe_5): Likewise. (scheme_deinit): Likewise. (scheme_load_file): Likewise. (scheme_load_named_file): Likewise. Signed-off-by: Justus Winter --- scheme-private.h | 4 +- scheme.c | 131 ++++++++++++++++++++++++++++++++++++------------------- 2 files changed, 89 insertions(+), 46 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 7f19a6e..aba2319 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -28,8 +28,8 @@ typedef struct port { FILE *file; int closeit; #if SHOW_ERROR_LINE - int curr_line; - char *filename; + pointer curr_line; + pointer filename; #endif } stdio; struct { diff --git a/scheme.c b/scheme.c index 2844545..7cd5217 100644 --- a/scheme.c +++ b/scheme.c @@ -377,7 +377,7 @@ static int is_ascii_name(const char *name, int *pc) { #endif -static int file_push(scheme *sc, const char *fname); +static int file_push(scheme *sc, pointer fname); static void file_pop(scheme *sc); static int file_interactive(scheme *sc); static INLINE int is_one_of(char *s, int c); @@ -1552,6 +1552,15 @@ E2: setmark(p); mark(p+1+i); } } +#if SHOW_ERROR_LINE + else if (is_port(p)) { + port *pt = p->_object._port; + if (pt->kind & port_file) { + mark(pt->rep.stdio.curr_line); + mark(pt->rep.stdio.filename); + } + } +#endif /* Mark tag if p has one. */ if (has_tag(p)) mark(p + 1); @@ -1617,6 +1626,13 @@ static void gc(scheme *sc, pointer a, pointer b) { mark(sc->save_inport); mark(sc->outport); mark(sc->loadport); + for (i = 0; i <= sc->file_i; i++) { + if (! (sc->load_stack[i].kind & port_file)) + continue; + + mark(sc->load_stack[i].rep.stdio.filename); + mark(sc->load_stack[i].rep.stdio.curr_line); + } /* Mark recent objects the interpreter doesn't know about yet. */ mark(car(sc->sink)); @@ -1678,14 +1694,39 @@ static void finalize_cell(scheme *sc, pointer a) { } } +#if SHOW_ERROR_LINE +static void +port_clear_location (scheme *sc, port *p) +{ + assert(p->kind & port_file); + p->rep.stdio.curr_line = sc->NIL; + p->rep.stdio.filename = sc->NIL; +} + +static void +port_reset_current_line (scheme *sc, port *p) +{ + assert(p->kind & port_file); + p->rep.stdio.curr_line = mk_integer(sc, 0); +} + +static void +port_increment_current_line (scheme *sc, port *p, long delta) +{ + assert(p->kind & port_file); + p->rep.stdio.curr_line = + mk_integer(sc, ivalue_unchecked(p->rep.stdio.curr_line) + delta); +} +#endif + /* ========== Routines for Reading ========== */ -static int file_push(scheme *sc, const char *fname) { +static int file_push(scheme *sc, pointer fname) { FILE *fin = NULL; if (sc->file_i == MAXFIL-1) return 0; - fin=fopen(fname,"r"); + fin = fopen(string_value(fname), "r"); if(fin!=0) { sc->file_i++; sc->load_stack[sc->file_i].kind=port_file|port_input; @@ -1695,9 +1736,8 @@ static int file_push(scheme *sc, const char *fname) { sc->loadport->_object._port=sc->load_stack+sc->file_i; #if SHOW_ERROR_LINE - sc->load_stack[sc->file_i].rep.stdio.curr_line = 0; - if(fname) - sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0); + port_reset_current_line(sc, &sc->load_stack[sc->file_i]); + sc->load_stack[sc->file_i].rep.stdio.filename = fname; #endif } return fin!=0; @@ -1707,6 +1747,10 @@ static void file_pop(scheme *sc) { if(sc->file_i != 0) { sc->nesting=sc->nesting_stack[sc->file_i]; port_close(sc,sc->loadport,port_input); +#if SHOW_ERROR_LINE + if (sc->load_stack[sc->file_i].kind & port_file) + port_clear_location(sc, &sc->load_stack[sc->file_i]); +#endif sc->file_i--; sc->loadport->_object._port=sc->load_stack+sc->file_i; } @@ -1736,10 +1780,12 @@ static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { pt->rep.stdio.closeit=1; #if SHOW_ERROR_LINE - if(fn) - pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0); + if (fn) + pt->rep.stdio.filename = mk_string(sc, fn); + else + pt->rep.stdio.filename = mk_string(sc, ""); - pt->rep.stdio.curr_line = 0; + port_reset_current_line(sc, pt); #endif return pt; } @@ -1764,6 +1810,10 @@ static port *port_rep_from_file(scheme *sc, FILE *f, int prop) pt->kind = port_file | prop; pt->rep.stdio.file = f; pt->rep.stdio.closeit = 0; +#if SHOW_ERROR_LINE + pt->rep.stdio.filename = mk_string(sc, ""); + port_reset_current_line(sc, pt); +#endif return pt; } @@ -1837,10 +1887,7 @@ static void port_close(scheme *sc, pointer p, int flag) { #if SHOW_ERROR_LINE /* Cleanup is here so (close-*-port) functions could work too */ - pt->rep.stdio.curr_line = 0; - - if(pt->rep.stdio.filename) - sc->free(pt->rep.stdio.filename); + port_clear_location(sc, pt); #endif fclose(pt->rep.stdio.file); @@ -2119,8 +2166,11 @@ static INLINE int skipspace(scheme *sc) { /* record it */ #if SHOW_ERROR_LINE - if (sc->load_stack[sc->file_i].kind & port_file) - sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line; + { + port *p = &sc->load_stack[sc->file_i]; + if (p->kind & port_file) + port_increment_current_line(sc, p, curr_line); + } #endif if(c!=EOF) { @@ -2160,7 +2210,7 @@ static int token(scheme *sc) { #if SHOW_ERROR_LINE if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) - sc->load_stack[sc->file_i].rep.stdio.curr_line++; + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); #endif if(c == EOF) @@ -2188,7 +2238,7 @@ static int token(scheme *sc) { #if SHOW_ERROR_LINE if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) - sc->load_stack[sc->file_i].rep.stdio.curr_line++; + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); #endif if(c == EOF) @@ -2691,8 +2741,8 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { fname = string_value(car(tag)); ln = ivalue_unchecked(cdr(tag)); } else { - fname = sc->load_stack[sc->file_i].rep.stdio.filename; - ln = sc->load_stack[sc->file_i].rep.stdio.curr_line; + fname = string_value(sc->load_stack[sc->file_i].rep.stdio.filename); + ln = ivalue_unchecked(sc->load_stack[sc->file_i].rep.stdio.curr_line); } /* should never happen */ @@ -3105,7 +3155,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { fprintf(sc->outport->_object._port->rep.stdio.file, "Loading %s\n", strvalue(car(sc->args))); } - if (!file_push(sc,strvalue(car(sc->args)))) { + if (!file_push(sc, car(sc->args))) { Error_1(sc,"unable to open", car(sc->args)); } else @@ -4839,14 +4889,13 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { sc->nesting_stack[sc->file_i]++; #if USE_TAGS && SHOW_ERROR_LINE if (sc->load_stack[sc->file_i].kind & port_file) { - const char *filename = + pointer filename = sc->load_stack[sc->file_i].rep.stdio.filename; - int lineno = + pointer lineno = sc->load_stack[sc->file_i].rep.stdio.curr_line; s_save(sc, OP_TAG_VALUE, - cons(sc, mk_string(sc, filename), - cons(sc, mk_integer(sc, lineno), sc->NIL)), + cons(sc, filename, cons(sc, lineno, sc->NIL)), sc->NIL); } #endif @@ -4917,7 +4966,8 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { backchar(sc,c); #if SHOW_ERROR_LINE else if (sc->load_stack[sc->file_i].kind & port_file) - sc->load_stack[sc->file_i].rep.stdio.curr_line++; + port_increment_current_line(sc, + &sc->load_stack[sc->file_i], 1); #endif sc->nesting_stack[sc->file_i]--; s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); @@ -5583,10 +5633,6 @@ void scheme_set_external_data(scheme *sc, void *p) { void scheme_deinit(scheme *sc) { int i; -#if SHOW_ERROR_LINE - char *fname; -#endif - sc->oblist=sc->NIL; sc->global_env=sc->NIL; dump_stack_free(sc); @@ -5608,6 +5654,14 @@ void scheme_deinit(scheme *sc) { typeflag(sc->loadport) = T_ATOM; } sc->loadport=sc->NIL; + +#if SHOW_ERROR_LINE + for(i=0; i<=sc->file_i; i++) { + if (sc->load_stack[i].kind & port_file) + port_clear_location(sc, &sc->load_stack[i]); + } +#endif + sc->gc_verbose=0; gc(sc,sc->NIL,sc->NIL); @@ -5619,16 +5673,6 @@ void scheme_deinit(scheme *sc) { sc->free(sc->alloc_seg[i]); } sc->free(sc->strbuff); - -#if SHOW_ERROR_LINE - for(i=0; i<=sc->file_i; i++) { - if (sc->load_stack[i].kind & port_file) { - fname = sc->load_stack[i].rep.stdio.filename; - if(fname) - sc->free(fname); - } - } -#endif } void scheme_load_file(scheme *sc, FILE *fin) @@ -5647,11 +5691,11 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { } #if SHOW_ERROR_LINE - sc->load_stack[0].rep.stdio.curr_line = 0; + port_reset_current_line(sc, &sc->load_stack[0]); if(fin!=stdin && filename) - sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0); + sc->load_stack[0].rep.stdio.filename = mk_string(sc, filename); else - sc->load_stack[0].rep.stdio.filename = NULL; + sc->load_stack[0].rep.stdio.filename = mk_string(sc, ""); #endif sc->inport=sc->loadport; @@ -5663,8 +5707,7 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { } #if SHOW_ERROR_LINE - sc->free(sc->load_stack[0].rep.stdio.filename); - sc->load_stack[0].rep.stdio.filename = NULL; + port_clear_location(sc, &sc->load_stack[0]); #endif } -- cgit v1.2.3 From 7d95db002aac773e596c551b8fcba2d983244495 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 22 Dec 2016 14:42:50 +0100 Subject: gpgscm: Add 'finally', rework all macros. * tests/gpgscm/init.scm (finally): New macro. * tests/gpgscm/tests.scm (letfd): Rewrite. (with-working-directory): Likewise. (with-temporary-working-directory): Likewise. (lettmp): Likewise. -- Rewrite all our macros using 'define-macro'. Use the new control flow mechanism 'finally', or 'dynamic-wind' where appropriate. Make sure the macros are hygienic. Reduce code duplication. Signed-off-by: Justus Winter --- init.scm | 17 ++++++++++++++ tests.scm | 79 ++++++++++++++++++++++++++++----------------------------------- 2 files changed, 52 insertions(+), 44 deletions(-) diff --git a/init.scm b/init.scm index 106afd5..83261b0 100644 --- a/init.scm +++ b/init.scm @@ -569,6 +569,16 @@ ; the thrown exception is bound to *error*. Errors can be rethrown ; using (rethrow *error*). ; +; Finalization can be expressed using "finally": +; +; (finally (finalize-something called-purely-for side-effects) +; (whether-or-not something goes-wrong) +; (with-these calls)) +; +; The final expression is executed purely for its side-effects, +; both when the function exits successfully, and when an exception +; is thrown. +; ; Exceptions are thrown with: ; ; (throw "message") @@ -622,6 +632,13 @@ (pop-handler) ,label))))) +(define-macro (finally final-expression . expressions) + (let ((result (gensym))) + `(let ((,result (catch (begin ,final-expression (rethrow *error*)) + ,@expressions))) + ,final-expression + ,result))) + ;; Make the vm use throw'. (define *error-hook* throw') diff --git a/tests.scm b/tests.scm index f127a93..5954704 100644 --- a/tests.scm +++ b/tests.scm @@ -244,27 +244,26 @@ ;; ;; Bind all variables given in and initialize each of them ;; to the given initial value, and close them after evaluting . -(macro (letfd form) - (let ((result-sym (gensym))) - `((lambda (,(caaadr form)) - (let ((,result-sym - ,(if (= 1 (length (cadr form))) - `(catch (begin (close ,(caaadr form)) - (rethrow *error*)) - ,@(cddr form)) - `(letfd ,(cdadr form) ,@(cddr form))))) - (close ,(caaadr form)) - ,result-sym)) ,@(cdaadr form)))) - -(macro (with-working-directory form) - (let ((result-sym (gensym)) (cwd-sym (gensym))) - `(let* ((,cwd-sym (getcwd)) - (_ (if ,(cadr form) (chdir ,(cadr form)))) - (,result-sym (catch (begin (chdir ,cwd-sym) - (rethrow *error*)) - ,@(cddr form)))) - (chdir ,cwd-sym) - ,result-sym))) +(define-macro (letfd bindings . body) + (let bind ((bindings' bindings)) + (if (null? bindings') + `(begin ,@body) + (let* ((binding (car bindings')) + (name (car binding)) + (initializer (cadr binding))) + `(let ((,name ,initializer)) + (finally (close ,name) + ,(bind (cdr bindings')))))))) + +(define-macro (with-working-directory new-directory . expressions) + (let ((new-dir (gensym)) + (old-dir (gensym))) + `(let* ((,new-dir ,new-directory) + (,old-dir (getcwd))) + (dynamic-wind + (lambda () (if ,new-dir (chdir ,new-dir))) + (lambda () ,@expressions) + (lambda () (chdir ,old-dir)))))) ;; Make a temporary directory. If arguments are given, they are ;; joined using path-join, and must end in a component ending in @@ -278,18 +277,12 @@ "-XXXXXX")) (apply path-join components)))) -(macro (with-temporary-working-directory form) - (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym))) - `(let* ((,cwd-sym (getcwd)) - (,tmp-sym (mkdtemp)) - (_ (chdir ,tmp-sym)) - (,result-sym (catch (begin (chdir ,cwd-sym) - (unlink-recursively ,tmp-sym) - (rethrow *error*)) - ,@(cdr form)))) - (chdir ,cwd-sym) - (unlink-recursively ,tmp-sym) - ,result-sym))) +(define-macro (with-temporary-working-directory . expressions) + (let ((tmp-sym (gensym))) + `(let* ((,tmp-sym (mkdtemp))) + (finally (unlink-recursively ,tmp-sym) + (with-working-directory ,tmp-sym + ,@expressions))))) (define (make-temporary-file . args) (canonical-path (path-join @@ -310,17 +303,15 @@ ;; Bind all variables given in , initialize each of them to ;; a string representing an unique path in the filesystem, and delete ;; them after evaluting . -(macro (lettmp form) - (let ((result-sym (gensym))) - `((lambda (,(caadr form)) - (let ((,result-sym - ,(if (= 1 (length (cadr form))) - `(catch (begin (remove-temporary-file ,(caadr form)) - (rethrow *error*)) - ,@(cddr form)) - `(lettmp ,(cdadr form) ,@(cddr form))))) - (remove-temporary-file ,(caadr form)) - ,result-sym)) (make-temporary-file ,(symbol->string (caadr form)))))) +(define-macro (lettmp bindings . body) + (let bind ((bindings' bindings)) + (if (null? bindings') + `(begin ,@body) + (let ((name (car bindings')) + (rest (cdr bindings'))) + `(let ((,name (make-temporary-file ,(symbol->string name)))) + (finally (remove-temporary-file ,name) + ,(bind rest))))))) (define (check-execution source transformer) (lettmp (sink) -- cgit v1.2.3 From 56787d898a6911e62b35c3054a22df1a913c26cf Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 22 Dec 2016 15:48:07 +0100 Subject: gpgscm: Fail if too many arguments are given. * tests/gpgscm/scheme.c (opexe_0): Enable check. * tests/gpgscm/tests.scm (test::report): Remove superfluous argument. Signed-off-by: Justus Winter --- scheme.c | 8 +++----- tests.scm | 2 +- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/scheme.c b/scheme.c index 7cd5217..c4725db 100644 --- a/scheme.c +++ b/scheme.c @@ -3364,11 +3364,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } } if (x == sc->NIL) { - /*-- - * if (y != sc->NIL) { - * Error_0(sc,"too many arguments"); - * } - */ + if (y != sc->NIL) { + Error_0(sc, "too many arguments"); + } } else if (is_symbol(x)) new_slot_in_env(sc, x, y); else { diff --git a/tests.scm b/tests.scm index 5954704..e5858d9 100644 --- a/tests.scm +++ b/tests.scm @@ -610,7 +610,7 @@ (seek logfd 0 SEEK_SET) (splice logfd STDERR_FILENO) (close logfd)) - (echo (string-append (status retcode) ":") name)))))) + (echo (string-append (status) ":") name)))))) ;; Run the setup target to create an environment, then run all given ;; tests in parallel. -- cgit v1.2.3 From e2caaa957b56f20cfe09bc6ca5a595b37a860b51 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 30 Jan 2017 15:39:57 +0100 Subject: gpgscm: Introduce macro for the vector length. * tests/gpgscm/scheme.c (vector_length): New macro. (get_vector_object): Use the new macro. (oblist_add_by_name): Likewise. (oblist_find_by_name): Likewise. (oblist_all_symbols): Likewise. (mk_vector): Likewise. (mark): Likewise. (new_slot_spec_in_env): Likewise. (find_slot_spec_in_env): Likewise. (opexe_2): Likewise. (opexe_5): Likewise. -- Introducing an abstraction reduces the coupling between code using vectors and the implementation of vectors. Signed-off-by: Justus Winter --- scheme.c | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/scheme.c b/scheme.c index c4725db..7bb03e8 100644 --- a/scheme.c +++ b/scheme.c @@ -210,6 +210,7 @@ INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } INTERFACE static int is_list(scheme *sc, pointer p); INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } +#define vector_length(v) ivalue_unchecked(v) INTERFACE static void fill_vector(pointer vec, pointer obj); INTERFACE static pointer vector_elem(pointer vec, int ielem); INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); @@ -1022,7 +1023,7 @@ static pointer get_vector_object(scheme *sc, int len, pointer init) if(sc->no_memory) { return sc->sink; } /* Record it as a vector so that gc understands it. */ typeflag(cells) = (T_VECTOR | T_ATOM); - ivalue_unchecked(cells)=len; + vector_length(cells) = len; set_num_integer(cells); fill_vector(cells,init); if (gc_enabled (sc)) @@ -1092,7 +1093,7 @@ static pointer oblist_add_by_name(scheme *sc, const char *name) typeflag(x) = T_SYMBOL; setimmutable(car(x)); - location = hash_fn(name, ivalue_unchecked(sc->oblist)); + location = hash_fn(name, vector_length(sc->oblist)); set_vector_elem(sc->oblist, location, immutable_cons(sc, x, vector_elem(sc->oblist, location))); gc_enable(sc); @@ -1105,7 +1106,7 @@ static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) pointer x; char *s; - location = hash_fn(name, ivalue_unchecked(sc->oblist)); + location = hash_fn(name, vector_length(sc->oblist)); for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { s = symname(car(x)); /* case-insensitive, per R5RS section 2. */ @@ -1122,7 +1123,7 @@ static pointer oblist_all_symbols(scheme *sc) pointer x; pointer ob_list = sc->NIL; - for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { + for (i = 0; i < vector_length(sc->oblist); i++) { for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { ob_list = cons(sc, x, ob_list); } @@ -1324,7 +1325,7 @@ INTERFACE static pointer mk_vector(scheme *sc, int len) INTERFACE static void fill_vector(pointer vec, pointer obj) { int i; - int n = ivalue(vec)/2+ivalue(vec)%2; + int n = vector_length(vec) / 2 + vector_length(vec) % 2; for(i=0; i < n; i++) { typeflag(vec+1+i) = T_PAIR; setimmutable(vec+1+i); @@ -1546,7 +1547,7 @@ static void mark(pointer a) { E2: setmark(p); if(is_vector(p)) { int i; - int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; + int n = vector_length(p) / 2 + vector_length(p) % 2; for(i=0; i < n; i++) { /* Vector cells will be treated like ordinary cells */ mark(p+1+i); @@ -2615,7 +2616,7 @@ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, slot = immutable_cons(sc, variable, value); if (is_vector(car(env))) { - int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); + int location = hash_fn(symname(variable), vector_length(car(env))); set_vector_elem(car(env), location, immutable_cons(sc, slot, vector_elem(car(env), location))); @@ -2632,7 +2633,7 @@ static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) for (x = env; x != sc->NIL; x = cdr(x)) { if (is_vector(car(x))) { - location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); + location = hash_fn(symname(hdl), vector_length(car(x))); y = vector_elem(car(x), location); } else { y = car(x); @@ -4366,14 +4367,14 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { CASE(OP_VECLEN): /* vector-length */ gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args)))); + s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args)))); CASE(OP_VECREF): { /* vector-ref */ int index; index=ivalue(cadr(sc->args)); - if(index>=ivalue(car(sc->args))) { + if(index >= vector_length(car(sc->args))) { Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); } @@ -4388,7 +4389,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } index=ivalue(cadr(sc->args)); - if(index>=ivalue(car(sc->args))) { + if(index >= vector_length(car(sc->args))) { Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); } @@ -5082,7 +5083,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { CASE(OP_PVECFROM): { int i=ivalue_unchecked(cdr(sc->args)); pointer vec=car(sc->args); - int len=ivalue_unchecked(vec); + int len = vector_length(vec); if(i==len) { putstr(sc,")"); s_return(sc,sc->T); -- cgit v1.2.3 From c587e6a038fc532df064eec7bea2ad1db31238ad Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 30 Jan 2017 17:08:27 +0100 Subject: gpgscm: Fix setting the line of the first gc reservation. * tests/gpgscm/scheme.c (_gc_disable): Negate guard. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 7bb03e8..311f606 100644 --- a/scheme.c +++ b/scheme.c @@ -794,7 +794,7 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno) if (sc->inhibit_gc == 0) { reserve_cells(sc, (reserve)); sc->reserved_cells = (reserve); -#ifndef NDEBUG +#ifdef NDEBUG (void) lineno; #else sc->reserved_lineno = lineno; -- cgit v1.2.3 From e1dc204ac465498436f463d419b9583011026807 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 30 Jan 2017 15:45:13 +0100 Subject: gpgscm: Provide framework for immediate values. * tests/gpgscm/scheme.c (IMMEDIATE_TAG): New macro. ({is,set,clr}_immediate): Likewise. (enum scheme_types): Make type tags disjoint from immediate values. (TYPE_BITS): We need one more bit now. (ADJ,T_MASKTYPE): Compute values. -- Immediate values are disjoint from all type tags and pointers, allowing us to store immediate values in all memory locations. Signed-off-by: Justus Winter --- scheme.c | 62 +++++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 39 insertions(+), 23 deletions(-) diff --git a/scheme.c b/scheme.c index 311f606..32d8032 100644 --- a/scheme.c +++ b/scheme.c @@ -111,27 +111,43 @@ static const char *strlwr(char *s) { # define FIRST_CELLSEGS 3 #endif + + +/* Support for immediate values. + * + * Immediate values are tagged with IMMEDIATE_TAG, which is neither + * used in types, nor in pointer values. + * + * XXX: Currently, we only use this to tag pointers in vectors. */ +#define IMMEDIATE_TAG 1 +#define is_immediate(p) ((pointer) ((uintptr_t) (p) & IMMEDIATE_TAG)) +#define set_immediate(p) ((pointer) ((uintptr_t) (p) | IMMEDIATE_TAG)) +#define clr_immediate(p) ((pointer) ((uintptr_t) (p) & ~IMMEDIATE_TAG)) + + + enum scheme_types { - T_STRING=1, - T_NUMBER=2, - T_SYMBOL=3, - T_PROC=4, - T_PAIR=5, - T_CLOSURE=6, - T_CONTINUATION=7, - T_FOREIGN=8, - T_CHARACTER=9, - T_PORT=10, - T_VECTOR=11, - T_MACRO=12, - T_PROMISE=13, - T_ENVIRONMENT=14, - T_FOREIGN_OBJECT=15, - T_BOOLEAN=16, - T_NIL=17, - T_EOF_OBJ=18, - T_SINK=19, - T_LAST_SYSTEM_TYPE=19 + T_STRING=1 << 1, /* Do not use the lsb, it is used for + * immediate values. */ + T_NUMBER=2 << 1, + T_SYMBOL=3 << 1, + T_PROC=4 << 1, + T_PAIR=5 << 1, + T_CLOSURE=6 << 1, + T_CONTINUATION=7 << 1, + T_FOREIGN=8 << 1, + T_CHARACTER=9 << 1, + T_PORT=10 << 1, + T_VECTOR=11 << 1, + T_MACRO=12 << 1, + T_PROMISE=13 << 1, + T_ENVIRONMENT=14 << 1, + T_FOREIGN_OBJECT=15 << 1, + T_BOOLEAN=16 << 1, + T_NIL=17 << 1, + T_EOF_OBJ=18 << 1, + T_SINK=19 << 1, + T_LAST_SYSTEM_TYPE=19 << 1 }; static const char * @@ -163,9 +179,9 @@ type_to_string (enum scheme_types typ) } /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ -#define ADJ 32 -#define TYPE_BITS 5 -#define T_MASKTYPE 31 /* 0000000000011111 */ +#define TYPE_BITS 6 +#define ADJ (1 << TYPE_BITS) +#define T_MASKTYPE (ADJ - 1) #define T_TAGGED 1024 /* 0000010000000000 */ #define T_FINALIZE 2048 /* 0000100000000000 */ #define T_SYNTAX 4096 /* 0001000000000000 */ -- cgit v1.2.3 From 5809edef40acf1f8f0e71b69dcb10e1d5464f2a5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 30 Jan 2017 15:51:19 +0100 Subject: gpgscm: Use a compact vector representation. * tests/gpgscm/scheme-private.h (struct cell): Add a compact vector representation. * tests/gpgscm/scheme.c (vector_length): Use new representation. (vector_size): New macro. (get_vector_object): Use the new representation. (fill_vector): Likewise. (vector_elem): Likewise. (set_vector_elem): Likewise. (mark): Likewise. (gc): Likewise. Be careful not to confuse immediate values for type flags. (finalize_cell): Vectors now require finalization. -- Previously, vectors were represented using consecutive cons cells, wasting one word per cell for the type information. Fix that by using a flat array. Previously, a vector of size N required 1 + (n + 1) / 2 cells. Now it uses 1 + (n - 1 + 2) / 3 cells. Signed-off-by: Justus Winter --- scheme-private.h | 4 ++++ scheme.c | 59 ++++++++++++++++++++++++++++++-------------------------- 2 files changed, 36 insertions(+), 27 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index aba2319..ad8f571 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -55,6 +55,10 @@ struct cell { struct cell *_car; struct cell *_cdr; } _cons; + struct { + size_t _length; + pointer _elements[0]; + } _vector; struct { char *_data; const foreign_object_vtable *_vtable; diff --git a/scheme.c b/scheme.c index 32d8032..86df851 100644 --- a/scheme.c +++ b/scheme.c @@ -226,7 +226,11 @@ INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } INTERFACE static int is_list(scheme *sc, pointer p); INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } -#define vector_length(v) ivalue_unchecked(v) +/* Given a vector, return it's length. */ +#define vector_length(v) (v)->_object._vector._length +/* Given a vector length, compute the amount of cells required to + * represent it. */ +#define vector_size(len) (1 + ((len) - 1 + 2) / 3) INTERFACE static void fill_vector(pointer vec, pointer obj); INTERFACE static pointer vector_elem(pointer vec, int ielem); INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); @@ -1035,12 +1039,11 @@ static pointer get_cell(scheme *sc, pointer a, pointer b) static pointer get_vector_object(scheme *sc, int len, pointer init) { - pointer cells = get_consecutive_cells(sc,len/2+len%2+1); + pointer cells = get_consecutive_cells(sc, vector_size(len)); if(sc->no_memory) { return sc->sink; } /* Record it as a vector so that gc understands it. */ - typeflag(cells) = (T_VECTOR | T_ATOM); + typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE); vector_length(cells) = len; - set_num_integer(cells); fill_vector(cells,init); if (gc_enabled (sc)) push_recent_alloc(sc, cells, sc->NIL); @@ -1340,32 +1343,24 @@ INTERFACE static pointer mk_vector(scheme *sc, int len) { return get_vector_object(sc,len,sc->NIL); } INTERFACE static void fill_vector(pointer vec, pointer obj) { - int i; - int n = vector_length(vec) / 2 + vector_length(vec) % 2; - for(i=0; i < n; i++) { - typeflag(vec+1+i) = T_PAIR; - setimmutable(vec+1+i); - car(vec+1+i)=obj; - cdr(vec+1+i)=obj; + size_t i; + assert (is_vector (vec)); + for(i = 0; i < vector_length(vec); i++) { + vec->_object._vector._elements[i] = set_immediate(obj); } } INTERFACE static pointer vector_elem(pointer vec, int ielem) { - int n=ielem/2; - if(ielem%2==0) { - return car(vec+1+n); - } else { - return cdr(vec+1+n); - } + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + return clr_immediate(vec->_object._vector._elements[ielem]); } INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { - int n=ielem/2; - if(ielem%2==0) { - return car(vec+1+n)=a; - } else { - return cdr(vec+1+n)=a; - } + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + vec->_object._vector._elements[ielem] = set_immediate(a); + return a; } /* get new symbol */ @@ -1563,10 +1558,8 @@ static void mark(pointer a) { E2: setmark(p); if(is_vector(p)) { int i; - int n = vector_length(p) / 2 + vector_length(p) % 2; - for(i=0; i < n; i++) { - /* Vector cells will be treated like ordinary cells */ - mark(p+1+i); + for (i = 0; i < vector_length(p); i++) { + mark(clr_immediate(p->_object._vector._elements[i])); } } #if SHOW_ERROR_LINE @@ -1672,6 +1665,8 @@ static void gc(scheme *sc, pointer a, pointer b) { for (i = sc->last_cell_seg; i >= 0; i--) { p = sc->cell_seg[i] + CELL_SEGSIZE; while (--p >= sc->cell_seg[i]) { + if (typeflag(p) & IMMEDIATE_TAG) + continue; if (is_mark(p)) { clrmark(p); } else { @@ -1708,6 +1703,16 @@ static void finalize_cell(scheme *sc, pointer a) { sc->free(a->_object._port); } else if(is_foreign_object(a)) { a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); + } else if (is_vector(a)) { + int i; + for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { + pointer p = a + i; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + sc->fcells += 1; + } } } -- cgit v1.2.3 From 92e929d4b91cbb5e36d6cb89aabf2211a7185a65 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 31 Jan 2017 12:09:42 +0100 Subject: gpgscm: Remove unused functions. * tests/gpgscm/scheme.c (check_cell_alloced): Remove function. (check_range_alloced): Likewise. Signed-off-by: Justus Winter --- scheme.c | 24 ------------------------ 1 file changed, 24 deletions(-) diff --git a/scheme.c b/scheme.c index 86df851..27beb3a 100644 --- a/scheme.c +++ b/scheme.c @@ -1050,30 +1050,6 @@ static pointer get_vector_object(scheme *sc, int len, pointer init) return cells; } -#if defined TSGRIND -static void check_cell_alloced(pointer p, int expect_alloced) -{ - /* Can't use putstr(sc,str) because callers have no access to - sc. */ - if(typeflag(p) & !expect_alloced) - { - fprintf(stderr,"Cell is already allocated!\n"); - } - if(!(typeflag(p)) & expect_alloced) - { - fprintf(stderr,"Cell is not allocated!\n"); - } - -} -static void check_range_alloced(pointer p, int n, int expect_alloced) -{ - int i; - for(i = 0;i Date: Tue, 31 Jan 2017 12:43:00 +0100 Subject: gpgscm: Fix build with object list. * tests/gpgscm/scheme.c (oblist_add_by_name): Provide preallocation information if USE_OBJECT_LIST. Signed-off-by: Justus Winter --- scheme.c | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme.c b/scheme.c index 27beb3a..1801ffc 100644 --- a/scheme.c +++ b/scheme.c @@ -1151,6 +1151,7 @@ static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) /* returns the new symbol */ static pointer oblist_add_by_name(scheme *sc, const char *name) { +#define oblist_add_by_name_allocates 3 pointer x; x = immutable_cons(sc, mk_string(sc, name), sc->NIL); -- cgit v1.2.3 From d374a1271326e503bd7cabe11cf5fd10a970d9fc Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 31 Jan 2017 13:22:40 +0100 Subject: gpgscm: Optimize symbol lookups and insertions. * tests/gpgscm/scheme.c (oblist_find_by_name): Keep the list of symbols sorted, return the slot where a new symbol must be inserted on lookup failures. (oblist_add_by_name): Add the new symbol at the given slot. (mk_symbol): Adjust callsite. (gensym): Likewise. (assign_syntax): Likewise. -- Optimize symbol lookups by keeping the lists in the hash table (or the list if compiled with USE_OBJECT_LIST) sorted by the symbol names. Optimize the insertions by passing the slot computed by the lookup to the insertion. Signed-off-by: Justus Winter --- scheme.c | 84 ++++++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 61 insertions(+), 23 deletions(-) diff --git a/scheme.c b/scheme.c index 1801ffc..fe16d48 100644 --- a/scheme.c +++ b/scheme.c @@ -1076,8 +1076,14 @@ static pointer oblist_initial_value(scheme *sc) return mk_vector(sc, 461); /* probably should be bigger */ } -/* returns the new symbol */ -static pointer oblist_add_by_name(scheme *sc, const char *name) +/* Add a new symbol NAME at SLOT. SLOT must be obtained using + * oblist_find_by_name, and no insertion must be done between + * obtaining the SLOT and calling this function. Returns the new + * symbol. + * + * If SLOT is NULL, the new symbol is be placed at the appropriate + * place in the vector. */ +static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) { #define oblist_add_by_name_allocates 3 pointer x; @@ -1088,26 +1094,42 @@ static pointer oblist_add_by_name(scheme *sc, const char *name) typeflag(x) = T_SYMBOL; setimmutable(car(x)); - location = hash_fn(name, vector_length(sc->oblist)); - set_vector_elem(sc->oblist, location, - immutable_cons(sc, x, vector_elem(sc->oblist, location))); + if (slot == NULL) { + location = hash_fn(name, vector_length(sc->oblist)); + set_vector_elem(sc->oblist, location, + immutable_cons(sc, x, vector_elem(sc->oblist, location))); + } else { + *slot = immutable_cons(sc, x, *slot); + } + gc_enable(sc); return x; } -static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not + * exist. In that case, SLOT points to the point where the new symbol + * is to be inserted. + * + * SLOT may be set to NULL if the new symbol should be placed at the + * appropriate place in the vector. */ +static INLINE pointer +oblist_find_by_name(scheme *sc, const char *name, pointer **slot) { int location; pointer x; char *s; + int d; location = hash_fn(name, vector_length(sc->oblist)); - for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { + for (*slot = NULL, x = vector_elem(sc->oblist, location); + x != sc->NIL; *slot = &cdr(x), x = **slot) { s = symname(car(x)); /* case-insensitive, per R5RS section 2. */ - if(stricmp(name, s) == 0) { - return car(x); - } + d = stricmp(name, s); + if (d == 0) + return car(x); /* Hit. */ + else if (d > 0) + break; /* Miss. */ } return sc->NIL; } @@ -1133,23 +1155,33 @@ static pointer oblist_initial_value(scheme *sc) return sc->NIL; } -static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not + * exist. In that case, SLOT points to the point where the new symbol + * is to be inserted. */ +static INLINE pointer +oblist_find_by_name(scheme *sc, const char *name, pointer **slot) { pointer x; char *s; + int d; - for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { + for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) { s = symname(car(x)); /* case-insensitive, per R5RS section 2. */ - if(stricmp(name, s) == 0) { - return car(x); - } + d = stricmp(name, s); + if (d == 0) + return car(x); /* Hit. */ + else if (d > 0) + break; /* Miss. */ } return sc->NIL; } -/* returns the new symbol */ -static pointer oblist_add_by_name(scheme *sc, const char *name) +/* Add a new symbol NAME at SLOT. SLOT must be obtained using + * oblist_find_by_name, and no insertion must be done between + * obtaining the SLOT and calling this function. Returns the new + * symbol. */ +static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) { #define oblist_add_by_name_allocates 3 pointer x; @@ -1157,7 +1189,7 @@ static pointer oblist_add_by_name(scheme *sc, const char *name) x = immutable_cons(sc, mk_string(sc, name), sc->NIL); typeflag(x) = T_SYMBOL; setimmutable(car(x)); - sc->oblist = immutable_cons(sc, x, sc->oblist); + *slot = immutable_cons(sc, x, *slot); return x; } static pointer oblist_all_symbols(scheme *sc) @@ -1344,31 +1376,33 @@ INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { INTERFACE pointer mk_symbol(scheme *sc, const char *name) { #define mk_symbol_allocates oblist_add_by_name_allocates pointer x; + pointer *slot; /* first check oblist */ - x = oblist_find_by_name(sc, name); + x = oblist_find_by_name(sc, name, &slot); if (x != sc->NIL) { return (x); } else { - x = oblist_add_by_name(sc, name); + x = oblist_add_by_name(sc, name, slot); return (x); } } INTERFACE pointer gensym(scheme *sc) { pointer x; + pointer *slot; char name[40]; for(; sc->gensym_cntgensym_cnt++) { snprintf(name,40,"gensym-%ld",sc->gensym_cnt); /* first check oblist */ - x = oblist_find_by_name(sc, name); + x = oblist_find_by_name(sc, name, &slot); if (x != sc->NIL) { continue; } else { - x = oblist_add_by_name(sc, name); + x = oblist_add_by_name(sc, name, slot); return (x); } } @@ -5319,8 +5353,12 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { static void assign_syntax(scheme *sc, char *name) { pointer x; + pointer *slot; + + x = oblist_find_by_name(sc, name, &slot); + assert (x == sc->NIL); - x = oblist_add_by_name(sc, name); + x = oblist_add_by_name(sc, name, slot); typeflag(x) |= T_SYNTAX; } -- cgit v1.2.3 From e982432ba66652bc9bc16e334e1d4d184e1b68bd Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 31 Jan 2017 13:53:28 +0100 Subject: gpgscm: Fix build with list environments. * tests/gpgscm/scheme.c (new_slot_spec_in_env): Provide preallocation inforomation if USE_ALIST_ENV. Signed-off-by: Justus Winter --- scheme.c | 1 + 1 file changed, 1 insertion(+) diff --git a/scheme.c b/scheme.c index fe16d48..d2c3dfc 100644 --- a/scheme.c +++ b/scheme.c @@ -2699,6 +2699,7 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env) static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, pointer variable, pointer value) { +#define new_slot_spec_in_env_allocates 2 car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); } -- cgit v1.2.3 From fa2363d9d903dfc9885f7d2f290fb4d7738bb737 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 31 Jan 2017 18:16:46 +0100 Subject: gpgscm: Optimize environment lookups and insertions. * tests/gpgscm/scheme.c (pointercmp): New function. (new_slot_spec_in_env): Add and use slot for insertions. (find_slot_spec_in_env): New variant of 'find_slot_in_env' that returns the slot on failures. (find_slot_in_env): Express using the new function. (new_slot_in_env): Update callsite. (opexe_0): Optimize lookup-or-insert. (opexe_1): Likewise. (scheme_define): Likewise. -- Optimize environment lookups by keeping the lists in the hash table or the list sorted. Optimize the insertions by passing the slot computed by the lookup to the insertion. Signed-off-by: Justus Winter --- scheme.c | 166 ++++++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 116 insertions(+), 50 deletions(-) diff --git a/scheme.c b/scheme.c index d2c3dfc..c4af94d 100644 --- a/scheme.c +++ b/scheme.c @@ -2612,6 +2612,22 @@ static int hash_fn(const char *key, int table_size) } #endif +/* Compares A and B. Returns an integer less than, equal to, or + * greater than zero if A is stored at a memory location that is + * numerical less than, equal to, or greater than that of B. */ +static int +pointercmp(pointer a, pointer b) +{ + uintptr_t a_n = (uintptr_t) a; + uintptr_t b_n = (uintptr_t) b; + + if (a_n < b_n) + return -1; + if (a_n > b_n) + return 1; + return 0; +} + #ifndef USE_ALIST_ENV /* @@ -2639,53 +2655,75 @@ static void new_frame_in_env(scheme *sc, pointer old_env) setenvironment(sc->envir); } +/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using + * find_slot_spec_in_env, and no insertion must be done between + * obtaining SSLOT and the call to this function. + * + * If SSLOT is NULL, the new slot is put into the appropriate place in + * the environment vector. */ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, - pointer variable, pointer value) + pointer variable, pointer value, + pointer *sslot) { #define new_slot_spec_in_env_allocates 2 pointer slot; gc_disable(sc, gc_reservations (new_slot_spec_in_env)); slot = immutable_cons(sc, variable, value); - if (is_vector(car(env))) { - int location = hash_fn(symname(variable), vector_length(car(env))); + if (sslot == NULL) { + int location; + assert(is_vector(car(env))); + location = hash_fn(symname(variable), vector_length(car(env))); set_vector_elem(car(env), location, immutable_cons(sc, slot, vector_elem(car(env), location))); } else { - car(env) = immutable_cons(sc, slot, car(env)); + *sslot = immutable_cons(sc, slot, *sslot); } gc_enable(sc); } -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +/* Find the slot in ENV under the key HDL. If ALL is given, look in + * all environments enclosing ENV. If the lookup fails, and SSLOT is + * given, the position where the new slot has to be inserted is stored + * at SSLOT. + * + * SSLOT may be set to NULL if the new symbol should be placed at the + * appropriate place in the vector. */ +static pointer +find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) { pointer x,y; int location; + pointer *sl; + int d; + assert(is_symbol(hdl)); for (x = env; x != sc->NIL; x = cdr(x)) { if (is_vector(car(x))) { location = hash_fn(symname(hdl), vector_length(car(x))); + sl = NULL; y = vector_elem(car(x), location); } else { - y = car(x); - } - for ( ; y != sc->NIL; y = cdr(y)) { - if (caar(y) == hdl) { - break; - } - } - if (y != sc->NIL) { - break; - } - if(!all) { - return sc->NIL; - } + sl = &car(x); + y = *sl; } - if (x != sc->NIL) { - return car(y); + for ( ; y != sc->NIL; sl = &cdr(y), y = *sl) { + d = pointercmp(caar(y), hdl); + if (d == 0) + return car(y); /* Hit. */ + else if (d > 0) + break; /* Miss. */ } - return sc->NIL; + + if (x == env && sslot) + *sslot = sl; /* Insert here. */ + + if (!all) + return sc->NIL; /* Miss, and stop looking. */ + } + + return sc->NIL; /* Not found in any environment. */ } #else /* USE_ALIST_ENV */ @@ -2696,41 +2734,66 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env) setenvironment(sc->envir); } +/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using + * find_slot_spec_in_env, and no insertion must be done between + * obtaining SSLOT and the call to this function. */ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, - pointer variable, pointer value) + pointer variable, pointer value, + pointer *sslot) { #define new_slot_spec_in_env_allocates 2 - car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); + (void) env; + assert(is_symbol(variable)); + *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot); } -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +/* Find the slot in ENV under the key HDL. If ALL is given, look in + * all environments enclosing ENV. If the lookup fails, and SSLOT is + * given, the position where the new slot has to be inserted is stored + * at SSLOT. */ +static pointer +find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) { pointer x,y; + pointer *sl; + int d; + assert(is_symbol(hdl)); + for (x = env; x != sc->NIL; x = cdr(x)) { - for (y = car(x); y != sc->NIL; y = cdr(y)) { - if (caar(y) == hdl) { - break; - } - } - if (y != sc->NIL) { - break; - } - if(!all) { - return sc->NIL; - } - } - if (x != sc->NIL) { - return car(y); + for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) { + d = pointercmp(caar(y), hdl); + if (d == 0) + return car(y); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + + if (x == env && sslot) + *sslot = sl; /* Insert here. */ + + if (!all) + return sc->NIL; /* Miss, and stop looking. */ } - return sc->NIL; + + return sc->NIL; /* Not found in any environment. */ } #endif /* USE_ALIST_ENV else */ +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + return find_slot_spec_in_env(sc, env, hdl, all, NULL); +} + static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) { #define new_slot_in_env_allocates new_slot_spec_in_env_allocates - new_slot_spec_in_env(sc, sc->envir, variable, value); + pointer slot; + pointer *sslot; + assert(is_symbol(variable)); + slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot); + assert(slot == sc->NIL); + new_slot_spec_in_env(sc, sc->envir, variable, value, sslot); } static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) @@ -3486,15 +3549,16 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_DEF1, sc->NIL, x); s_thread_to(sc,OP_EVAL); - CASE(OP_DEF1): /* define */ - x=find_slot_in_env(sc,sc->envir,sc->code,0); + CASE(OP_DEF1): { /* define */ + pointer *sslot; + x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); if (x != sc->NIL) { set_slot_in_env(sc, x, sc->value); } else { - new_slot_in_env(sc, sc->code, sc->value); + new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot); } s_return(sc,sc->code); - + } CASE(OP_DEFP): /* defined? */ x=sc->envir; @@ -3806,15 +3870,17 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_MACRO1, sc->NIL, x); s_goto(sc,OP_EVAL); - CASE(OP_MACRO1): /* macro */ + CASE(OP_MACRO1): { /* macro */ + pointer *sslot; typeflag(sc->value) = T_MACRO; - x = find_slot_in_env(sc, sc->envir, sc->code, 0); + x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); if (x != sc->NIL) { set_slot_in_env(sc, x, sc->value); } else { - new_slot_in_env(sc, sc->code, sc->value); + new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot); } s_return(sc,sc->code); + } CASE(OP_CASE0): /* case */ s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); @@ -5769,12 +5835,12 @@ void scheme_load_string(scheme *sc, const char *cmd) { void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { pointer x; - - x=find_slot_in_env(sc,envir,symbol,0); + pointer *sslot; + x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot); if (x != sc->NIL) { set_slot_in_env(sc, x, value); } else { - new_slot_spec_in_env(sc, envir, symbol, value); + new_slot_spec_in_env(sc, envir, symbol, value, sslot); } } -- cgit v1.2.3 From 1c99db04ed62d395c1c88171ef147a580e0bb4ab Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 31 Jan 2017 18:45:57 +0100 Subject: gpgscm: Tune the hash tables. * tests/gpgscm/scheme.c (oblist_initial_value): Increase the size of the hash table based on the number of symbols used after initializing the interpreter. (new_frame_in_env): Increase the size of the hash table based on the number of variables in the global environement. Signed-off-by: Justus Winter --- scheme.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/scheme.c b/scheme.c index c4af94d..1265c62 100644 --- a/scheme.c +++ b/scheme.c @@ -1073,7 +1073,9 @@ static int hash_fn(const char *key, int table_size); static pointer oblist_initial_value(scheme *sc) { - return mk_vector(sc, 461); /* probably should be bigger */ + /* There are about 768 symbols used after loading the + * interpreter. */ + return mk_vector(sc, 1009); } /* Add a new symbol NAME at SLOT. SLOT must be obtained using @@ -2642,9 +2644,9 @@ static void new_frame_in_env(scheme *sc, pointer old_env) { pointer new_frame; - /* The interaction-environment has about 300 variables in it. */ + /* The interaction-environment has about 480 variables in it. */ if (old_env == sc->NIL) { - new_frame = mk_vector(sc, 461); + new_frame = mk_vector(sc, 751); } else { new_frame = sc->NIL; } -- cgit v1.2.3 From b2db15dfe894a27246236ed416c8e2c2fc0e73c4 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 15 Feb 2017 14:50:44 +0100 Subject: tests: Check expiration times of created keys. * tests/gpgscm/ffi.c (do_get_time): New function. (ffi_init): Expose new function. * tests/gpgscm/ffi.scm (get-time): Document new function. * tests/gpgscm/time.scm: New file. * tests/openpgp/quick-key-manipulation.scm: Use the new facilities to check the expiration times of created keys. * tests/openpgp/tofu.scm: Use the new module. Signed-off-by: Justus Winter --- ffi.c | 9 +++++++++ ffi.scm | 3 +++ time.scm | 42 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 54 insertions(+) create mode 100644 time.scm diff --git a/ffi.c b/ffi.c index c91d4aa..42facee 100644 --- a/ffi.c +++ b/ffi.c @@ -501,6 +501,14 @@ do_get_isotime (scheme *sc, pointer args) FFI_RETURN_STRING (sc, timebuf); } +static pointer +do_get_time (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, gnupg_get_time ()); +} + static pointer do_getpid (scheme *sc, pointer args) { @@ -1347,6 +1355,7 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define_function (sc, mkdir); ffi_define_function (sc, rmdir); ffi_define_function (sc, get_isotime); + ffi_define_function (sc, get_time); ffi_define_function (sc, getpid); /* Random numbers. */ diff --git a/ffi.scm b/ffi.scm index b62fd1f..3f2e553 100644 --- a/ffi.scm +++ b/ffi.scm @@ -47,3 +47,6 @@ ;; Low-level mechanism to terminate the process. (ffi-define (_exit status)) + +;; Get the current time in seconds since the epoch. +(ffi-define (get-time)) diff --git a/time.scm b/time.scm new file mode 100644 index 0000000..a9b06d0 --- /dev/null +++ b/time.scm @@ -0,0 +1,42 @@ +;; Simple time manipulation library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; This library mimics what GnuPG thinks about expiration times. +;; Granularity is one second. Its focus is not on correctness. + +;; Conversion functions. +(define (minutes->seconds minutes) + (* minutes 60)) +(define (hours->seconds hours) + (* hours 60 60)) +(define (days->seconds days) + (* days 24 60 60)) +(define (weeks->seconds weeks) + (days->seconds (* weeks 7))) +(define (months->seconds months) + (days->seconds (* months 30))) +(define (years->seconds years) + (days->seconds (* years 365))) + +(define (time-matches? a b slack) + (< (abs (- a b)) slack)) +(assert (time-matches? (hours->seconds 1) (hours->seconds 2) (hours->seconds 2))) +(assert (time-matches? (hours->seconds 2) (hours->seconds 1) (hours->seconds 2))) +(assert (not (time-matches? (hours->seconds 4) (hours->seconds 1) (hours->seconds 2)))) +(assert (not (time-matches? (hours->seconds 1) (hours->seconds 4) (hours->seconds 2)))) -- cgit v1.2.3 From 52748cd96c70c9da01c35de10dd1627f7897d085 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 15 Feb 2017 16:03:12 +0100 Subject: tests,build: Fix distcheck. * tests/gpgscm/Makefile.am (EXTRA_DIST): Add 'time.scm'. Fixes-commit: 127e1e532da4083ccd3c307555b6177fab16f408 Signed-off-by: Justus Winter --- Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 9a5edc2..8942c7c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -25,7 +25,8 @@ EXTRA_DIST = \ lib.scm \ repl.scm \ t-child.scm \ - tests.scm + tests.scm \ + time.scm AM_CPPFLAGS = -I$(top_srcdir)/common include $(top_srcdir)/am/cmacros.am -- cgit v1.2.3 From 86082852350810afa548c607241df95f9cac777a Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 17 Feb 2017 10:43:20 +0100 Subject: gpgscm: Guard use of tagged expressions. * tests/gpgscm/init.scm (vm-history-print): Check that the tag added to expressions when parsing source files matches the expected format. * tests/gpgscm/lib.scm (assert): Likewise. -- This makes the error handling more robust. We saw the assumption about the format of the tags being violated on one build system, and it obscured the view on the underlying problem. Signed-off-by: Justus Winter --- init.scm | 10 +++++----- lib.scm | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/init.scm b/init.scm index 83261b0..87d3c88 100644 --- a/init.scm +++ b/init.scm @@ -547,11 +547,11 @@ (display n) (display ": ") (let ((tag (get-tag f))) - (unless (null? tag) - (display (basename (car tag))) - (display ":") - (display (+ 1 (cdr tag))) - (display ": "))) + (when (and (pair? tag) (string? (car tag)) (number? (cdr tag))) + (display (basename (car tag))) + (display ":") + (display (+ 1 (cdr tag))) + (display ": "))) (write f)) (newline) (loop (+ n 1) skip (cdr frames)))))) diff --git a/lib.scm b/lib.scm index 6959aa4..2cfe725 100644 --- a/lib.scm +++ b/lib.scm @@ -20,7 +20,7 @@ (macro (assert form) (let ((tag (get-tag form))) `(if (not ,(cadr form)) - (throw ,(if (pair? tag) + (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag))) `(string-append ,(car tag) ":" ,(number->string (+ 1 (cdr tag))) ": Assertion failed: ") -- cgit v1.2.3 From 27b2743eaf96edbd624715f0ca6a655100a2bc79 Mon Sep 17 00:00:00 2001 From: Yuri Chornoivan Date: Mon, 20 Feb 2017 16:19:50 -0500 Subject: Clean up word replication. -- This fixes extra word repetitions (like "the the" or "is is") in the code and docs. Signed-off-by: Daniel Kahn Gillmor --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index c96dcf1..3191e05 100644 --- a/main.c +++ b/main.c @@ -88,7 +88,7 @@ parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) } } -/* Print usage information and and provide strings for help. */ +/* Print usage information and provide strings for help. */ static const char * my_strusage( int level ) { -- cgit v1.2.3 From 9b23e71a6b41cd11b39ab1e1d18c140eaf63c3e7 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 28 Feb 2017 09:40:01 +0100 Subject: gpgscm: Track source locations in every kind of ports. * tests/gpgscm/scheme-private.h (struct port): Move location information out of the union. * tests/gpgscm/scheme.c (mark): All ports need marking now. (gc): Likewise all ports on the load stack. (port_clear_location): Adapt accordingly. Also, add an empty function for !SHOW_ERROR_LINE. (port_increment_current_line): Likewise. (port_reset_current_line): Drop function in favor of... (port_init_location): ... this new function. (file_push): Simplify. (file_pop): Likewise. (port_rep_from_filename): Likewise. (port_rep_from_file): Likewise. (port_rep_from_string): Also initialize the location. (port_rep_from_scratch): Likewise. (port_close): Simplify and generalize. (skipspace): Likewise. (token): Likewise. (_Error_1): Generalize. (opexe_5): Likewise. (scheme_deinit): Simplify and generalize. (scheme_load_named_file): Likewise. (scheme_load_string): Also initialize the location. -- This change tracks the location of source code loaded from non-file ports that is used in error messages. It also simplifies the code quite a bit. Signed-off-by: Justus Winter --- scheme-private.h | 8 +-- scheme.c | 157 +++++++++++++++++++++++-------------------------------- 2 files changed, 69 insertions(+), 96 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index ad8f571..abd89e8 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -27,10 +27,6 @@ typedef struct port { struct { FILE *file; int closeit; -#if SHOW_ERROR_LINE - pointer curr_line; - pointer filename; -#endif } stdio; struct { char *start; @@ -38,6 +34,10 @@ typedef struct port { char *curr; } string; } rep; +#if SHOW_ERROR_LINE + pointer curr_line; + pointer filename; +#endif } port; /* cell structure */ diff --git a/scheme.c b/scheme.c index 1265c62..405dee4 100644 --- a/scheme.c +++ b/scheme.c @@ -1578,10 +1578,8 @@ E2: setmark(p); #if SHOW_ERROR_LINE else if (is_port(p)) { port *pt = p->_object._port; - if (pt->kind & port_file) { - mark(pt->rep.stdio.curr_line); - mark(pt->rep.stdio.filename); - } + mark(pt->curr_line); + mark(pt->filename); } #endif /* Mark tag if p has one. */ @@ -1650,11 +1648,8 @@ static void gc(scheme *sc, pointer a, pointer b) { mark(sc->outport); mark(sc->loadport); for (i = 0; i <= sc->file_i; i++) { - if (! (sc->load_stack[i].kind & port_file)) - continue; - - mark(sc->load_stack[i].rep.stdio.filename); - mark(sc->load_stack[i].rep.stdio.curr_line); + mark(sc->load_stack[i].filename); + mark(sc->load_stack[i].curr_line); } /* Mark recent objects the interpreter doesn't know about yet. */ @@ -1733,25 +1728,41 @@ static void finalize_cell(scheme *sc, pointer a) { static void port_clear_location (scheme *sc, port *p) { - assert(p->kind & port_file); - p->rep.stdio.curr_line = sc->NIL; - p->rep.stdio.filename = sc->NIL; + p->curr_line = sc->NIL; + p->filename = sc->NIL; +} + +static void +port_increment_current_line (scheme *sc, port *p, long delta) +{ + p->curr_line = + mk_integer(sc, ivalue_unchecked(p->curr_line) + delta); } static void -port_reset_current_line (scheme *sc, port *p) +port_init_location (scheme *sc, port *p, pointer name) +{ + p->curr_line = mk_integer(sc, 0); + p->filename = name ? name : mk_string(sc, ""); +} + +#else + +static void +port_clear_location (scheme *sc, port *p) { - assert(p->kind & port_file); - p->rep.stdio.curr_line = mk_integer(sc, 0); } static void port_increment_current_line (scheme *sc, port *p, long delta) { - assert(p->kind & port_file); - p->rep.stdio.curr_line = - mk_integer(sc, ivalue_unchecked(p->rep.stdio.curr_line) + delta); } + +static void +port_init_location (scheme *sc, port *p, pointer name) +{ +} + #endif /* ========== Routines for Reading ========== */ @@ -1769,11 +1780,7 @@ static int file_push(scheme *sc, pointer fname) { sc->load_stack[sc->file_i].rep.stdio.closeit=1; sc->nesting_stack[sc->file_i]=0; sc->loadport->_object._port=sc->load_stack+sc->file_i; - -#if SHOW_ERROR_LINE - port_reset_current_line(sc, &sc->load_stack[sc->file_i]); - sc->load_stack[sc->file_i].rep.stdio.filename = fname; -#endif + port_init_location(sc, &sc->load_stack[sc->file_i], fname); } return fin!=0; } @@ -1782,10 +1789,7 @@ static void file_pop(scheme *sc) { if(sc->file_i != 0) { sc->nesting=sc->nesting_stack[sc->file_i]; port_close(sc,sc->loadport,port_input); -#if SHOW_ERROR_LINE - if (sc->load_stack[sc->file_i].kind & port_file) - port_clear_location(sc, &sc->load_stack[sc->file_i]); -#endif + port_clear_location(sc, &sc->load_stack[sc->file_i]); sc->file_i--; sc->loadport->_object._port=sc->load_stack+sc->file_i; } @@ -1813,15 +1817,7 @@ static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { } pt=port_rep_from_file(sc,f,prop); pt->rep.stdio.closeit=1; - -#if SHOW_ERROR_LINE - if (fn) - pt->rep.stdio.filename = mk_string(sc, fn); - else - pt->rep.stdio.filename = mk_string(sc, ""); - - port_reset_current_line(sc, pt); -#endif + port_init_location(sc, pt, mk_string(sc, fn)); return pt; } @@ -1845,10 +1841,7 @@ static port *port_rep_from_file(scheme *sc, FILE *f, int prop) pt->kind = port_file | prop; pt->rep.stdio.file = f; pt->rep.stdio.closeit = 0; -#if SHOW_ERROR_LINE - pt->rep.stdio.filename = mk_string(sc, ""); - port_reset_current_line(sc, pt); -#endif + port_init_location(sc, pt, NULL); return pt; } @@ -1871,6 +1864,7 @@ static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, i pt->rep.string.start=start; pt->rep.string.curr=start; pt->rep.string.past_the_end=past_the_end; + port_init_location(sc, pt, NULL); return pt; } @@ -1902,6 +1896,7 @@ static port *port_rep_from_scratch(scheme *sc) { pt->rep.string.start=start; pt->rep.string.curr=start; pt->rep.string.past_the_end=start+BLOCK_SIZE-1; + port_init_location(sc, pt, NULL); return pt; } @@ -1918,13 +1913,9 @@ static void port_close(scheme *sc, pointer p, int flag) { port *pt=p->_object._port; pt->kind&=~flag; if((pt->kind & (port_input|port_output))==0) { + /* Cleanup is here so (close-*-port) functions could work too */ + port_clear_location(sc, pt); if(pt->kind&port_file) { - -#if SHOW_ERROR_LINE - /* Cleanup is here so (close-*-port) functions could work too */ - port_clear_location(sc, pt); -#endif - fclose(pt->rep.stdio.file); } pt->kind=port_free; @@ -2199,14 +2190,8 @@ static INLINE int skipspace(scheme *sc) { #endif } while (isspace(c)); -/* record it */ -#if SHOW_ERROR_LINE - { - port *p = &sc->load_stack[sc->file_i]; - if (p->kind & port_file) - port_increment_current_line(sc, p, curr_line); - } -#endif + /* record it */ + port_increment_current_line(sc, &sc->load_stack[sc->file_i], curr_line); if(c!=EOF) { backchar(sc,c); @@ -2243,10 +2228,8 @@ static int token(scheme *sc) { while ((c=inchar(sc)) != '\n' && c!=EOF) ; -#if SHOW_ERROR_LINE - if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) + if(c == '\n') port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); -#endif if(c == EOF) { return (TOK_EOF); } @@ -2271,10 +2254,8 @@ static int token(scheme *sc) { while ((c=inchar(sc)) != '\n' && c!=EOF) ; -#if SHOW_ERROR_LINE - if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) + if(c == '\n') port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); -#endif if(c == EOF) { return (TOK_EOF); } @@ -2828,8 +2809,8 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #if SHOW_ERROR_LINE /* make sure error is not in REPL */ - if (sc->load_stack[sc->file_i].kind & port_file && - sc->load_stack[sc->file_i].rep.stdio.file != stdin) { + if (((sc->load_stack[sc->file_i].kind & port_file) == 0 + || sc->load_stack[sc->file_i].rep.stdio.file != stdin)) { pointer tag; const char *fname; int ln; @@ -2840,8 +2821,8 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { fname = string_value(car(tag)); ln = ivalue_unchecked(cdr(tag)); } else { - fname = string_value(sc->load_stack[sc->file_i].rep.stdio.filename); - ln = ivalue_unchecked(sc->load_stack[sc->file_i].rep.stdio.curr_line); + fname = string_value(sc->load_stack[sc->file_i].filename); + ln = ivalue_unchecked(sc->load_stack[sc->file_i].curr_line); } /* should never happen */ @@ -4986,18 +4967,18 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } else if (sc->tok == TOK_DOT) { Error_0(sc,"syntax error: illegal dot expression"); } else { +#if USE_TAGS && SHOW_ERROR_LINE + pointer filename; + pointer lineno; +#endif sc->nesting_stack[sc->file_i]++; #if USE_TAGS && SHOW_ERROR_LINE - if (sc->load_stack[sc->file_i].kind & port_file) { - pointer filename = - sc->load_stack[sc->file_i].rep.stdio.filename; - pointer lineno = - sc->load_stack[sc->file_i].rep.stdio.curr_line; - - s_save(sc, OP_TAG_VALUE, - cons(sc, filename, cons(sc, lineno, sc->NIL)), - sc->NIL); - } + filename = sc->load_stack[sc->file_i].filename; + lineno = sc->load_stack[sc->file_i].curr_line; + + s_save(sc, OP_TAG_VALUE, + cons(sc, filename, cons(sc, lineno, sc->NIL)), + sc->NIL); #endif s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); s_thread_to(sc,OP_RDSEXPR); @@ -5064,11 +5045,8 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { int c = inchar(sc); if (c != '\n') backchar(sc,c); -#if SHOW_ERROR_LINE - else if (sc->load_stack[sc->file_i].kind & port_file) - port_increment_current_line(sc, - &sc->load_stack[sc->file_i], 1); -#endif + port_increment_current_line(sc, + &sc->load_stack[sc->file_i], 1); sc->nesting_stack[sc->file_i]--; s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); } else if (sc->tok == TOK_DOT) { @@ -5759,12 +5737,9 @@ void scheme_deinit(scheme *sc) { } sc->loadport=sc->NIL; -#if SHOW_ERROR_LINE for(i=0; i<=sc->file_i; i++) { - if (sc->load_stack[i].kind & port_file) - port_clear_location(sc, &sc->load_stack[i]); + port_clear_location(sc, &sc->load_stack[i]); } -#endif sc->gc_verbose=0; gc(sc,sc->NIL,sc->NIL); @@ -5794,13 +5769,10 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { sc->interactive_repl=1; } -#if SHOW_ERROR_LINE - port_reset_current_line(sc, &sc->load_stack[0]); - if(fin!=stdin && filename) - sc->load_stack[0].rep.stdio.filename = mk_string(sc, filename); - else - sc->load_stack[0].rep.stdio.filename = mk_string(sc, ""); -#endif + port_init_location(sc, &sc->load_stack[0], + (fin != stdin && filename) + ? mk_string(sc, filename) + : NULL); sc->inport=sc->loadport; sc->args = mk_integer(sc,sc->file_i); @@ -5810,9 +5782,7 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { sc->retcode=sc->nesting!=0; } -#if SHOW_ERROR_LINE port_clear_location(sc, &sc->load_stack[0]); -#endif } void scheme_load_string(scheme *sc, const char *cmd) { @@ -5823,6 +5793,7 @@ void scheme_load_string(scheme *sc, const char *cmd) { sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); sc->load_stack[0].rep.string.curr=(char*)cmd; + port_init_location(sc, &sc->load_stack[0], NULL); sc->loadport=mk_port(sc,sc->load_stack); sc->retcode=0; sc->interactive_repl=0; @@ -5833,6 +5804,8 @@ void scheme_load_string(scheme *sc, const char *cmd) { if(sc->retcode==0) { sc->retcode=sc->nesting!=0; } + + port_clear_location(sc, &sc->load_stack[0]); } void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { -- cgit v1.2.3 From 08e1cfddc94a6aae79b21d7795accf3e100a1f2f Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 28 Feb 2017 16:17:33 +0100 Subject: gpgscm: Fix calculating the line number. * tests/gpgscm/scheme.c (opexe_5): Only increment the line number on newlines. Fixes-commit: 7cc57e2c63d0fa97569736419db5c76117e7685b Signed-off-by: Justus Winter --- scheme.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index 405dee4..0453754 100644 --- a/scheme.c +++ b/scheme.c @@ -5045,8 +5045,8 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { int c = inchar(sc); if (c != '\n') backchar(sc,c); - port_increment_current_line(sc, - &sc->load_stack[sc->file_i], 1); + else + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); sc->nesting_stack[sc->file_i]--; s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); } else if (sc->tok == TOK_DOT) { -- cgit v1.2.3 From 9467f3c7758864f3c025c14166c9d099bea6fe62 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 28 Feb 2017 16:19:18 +0100 Subject: gpgscm: Improve parsing. * tests/gpgscm/scheme.c (port_increment_current_line): Avoid creating the same integer if the delta is zero. This happens a lot during parsing, and puts pressure on the memory allocator. Signed-off-by: Justus Winter --- scheme.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/scheme.c b/scheme.c index 0453754..b2ff721 100644 --- a/scheme.c +++ b/scheme.c @@ -1735,6 +1735,9 @@ port_clear_location (scheme *sc, port *p) static void port_increment_current_line (scheme *sc, port *p, long delta) { + if (delta == 0) + return; + p->curr_line = mk_integer(sc, ivalue_unchecked(p->curr_line) + delta); } -- cgit v1.2.3 From 9e29af900544fe4210a72cae87be78186d03e231 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 6 Mar 2017 17:14:58 +0100 Subject: gpgscm: Fix creation of temporary directories. * tests/gpgscm/ffi.c (do_mkdtemp): Use a larger buffer for the template. Signed-off-by: Justus Winter --- ffi.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/ffi.c b/ffi.c index 42facee..34e573f 100644 --- a/ffi.c +++ b/ffi.c @@ -26,6 +26,7 @@ #include #include #include +#include #include #include #include @@ -345,7 +346,11 @@ do_mkdtemp (scheme *sc, pointer args) { FFI_PROLOG (); char *template; - char buffer[128]; +#ifdef PATH_MAX + char buffer[PATH_MAX]; +#else + char buffer[1024]; +#endif char *name; FFI_ARG_OR_RETURN (sc, char *, template, string, args); FFI_ARGS_DONE_OR_RETURN (sc, args); -- cgit v1.2.3 From 490c5d5afeaae66dc061295afbc254e57abd20c8 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 6 Mar 2017 17:16:41 +0100 Subject: tests: Harmonize temporary and socket directory handling. * tests/gpgscm/tests.scm (mkdtemp): Do not magically obey the environment variable 'TMP', make sure to always return an absolute path. * tests/gpgme/Makefile.am (TMP): Drop variable. (TESTS_ENVIRONMENT): Drop 'TMP'. * tests/gpgme/gpgme-defs.scm (create-gpgmehome): Start the agent. Do not create private key store, the agent does that for us. * tests/gpgsm/Makefile.am (TMP): Drop variable. (TESTS_ENVIRONMENT): Drop 'TMP'. * tests/gpgme/gpgme-defs.scm (create-gpgsmhome): Start the agent. Do not create private key store, the agent does that for us. * tests/migrations/Makefile.am (TMP): Drop variable. (TESTS_ENVIRONMENT): Drop 'TMP'. * tests/migrations/common.scm (gpgconf): New variable. (run-test): Create and remove socket directory. * tests/migrations/extended-pkf.scm (src-tarball): Remove variable. (setup): Remove function. (trigger-migration): Likewise. Use 'run-test' to execute the test. * tests/migrations/from-classic.scm (src-tarball): Remove variable. (setup): Remove function. Use 'run-test' to execute the tests. * tests/openpgp/Makefile.am (TMP): Drop variable. (TESTS_ENVIRONMENT): Drop 'TMP'. * tests/openpgp/README: Do not mention 'TMP'. * tests/openpgp/defs.scm (with-home-directory): New macro. (create-legacy-gpghome): Do not create private key store, the agent does that for us. (start-agent): Make sure to terminate the right agent with 'atexit'. -- Previously, the test suite relied upon creating home directories in '/tmp'. This has been problematic in some build environments, although POSIX mandates that '/tmp' must be available. We now rely on 'gpgconf --create-socketdir' to create a suitable socket directory for us. This allows us to get rid of some cruft. It also aligns the environment the tests are run in closer with the environment that we intend that GnuPG runs in. Signed-off-by: Justus Winter --- tests.scm | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/tests.scm b/tests.scm index e5858d9..b3da919 100644 --- a/tests.scm +++ b/tests.scm @@ -268,14 +268,13 @@ ;; Make a temporary directory. If arguments are given, they are ;; joined using path-join, and must end in a component ending in ;; "XXXXXX". If no arguments are given, a suitable location and -;; generic name is used. +;; generic name is used. Returns an absolute path. (define (mkdtemp . components) - (_mkdtemp (if (null? components) - (path-join (getenv "TMP") - (string-append "gpgscm-" (get-isotime) "-" - (basename-suffix *scriptname* ".scm") - "-XXXXXX")) - (apply path-join components)))) + (canonical-path (_mkdtemp (if (null? components) + (string-append "gpgscm-" (get-isotime) "-" + (basename-suffix *scriptname* ".scm") + "-XXXXXX") + (apply path-join components))))) (define-macro (with-temporary-working-directory . expressions) (let ((tmp-sym (gensym))) -- cgit v1.2.3 From d372378d28b2504225aae6819d056330e7ac0674 Mon Sep 17 00:00:00 2001 From: NIIBE Yutaka Date: Tue, 7 Mar 2017 20:32:09 +0900 Subject: More change for common. * g10, scd, test, tools: Follow the change of removal of -Icommon. Signed-off-by: NIIBE Yutaka --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index 3191e05..65929f0 100644 --- a/main.c +++ b/main.c @@ -34,7 +34,7 @@ #include "scheme.h" #include "scheme-private.h" #include "ffi.h" -#include "i18n.h" +#include "../common/i18n.h" #include "../../common/argparse.h" #include "../../common/init.h" #include "../../common/logging.h" -- cgit v1.2.3 From ca3d31ec77612cecc16c376ac7c06ce09541b28e Mon Sep 17 00:00:00 2001 From: Michael Haubenwallner Date: Tue, 7 Mar 2017 13:54:49 +0100 Subject: gpgscm: Use system strlwr if available. * tests/gpgscm/scheme.c: Define local strlwr only when HAVE_STRLWR is not defined in config.h. * tests/gpgscm/scheme-config.h: Remove hack. Signed-off-by: Justus Winter --- scheme-config.h | 4 ---- scheme.c | 6 +++++- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/scheme-config.h b/scheme-config.h index 2003498..15ca969 100644 --- a/scheme-config.h +++ b/scheme-config.h @@ -30,7 +30,3 @@ #define USE_PLIST 0 #define USE_INTERFACE 1 #define SHOW_ERROR_LINE 1 - -#if __MINGW32__ -# define USE_STRLWR 0 -#endif /* __MINGW32__ */ diff --git a/scheme.c b/scheme.c index b2ff721..af97c27 100644 --- a/scheme.c +++ b/scheme.c @@ -12,6 +12,10 @@ * */ +#ifdef HAVE_CONFIG_H +# include +#endif + #define _SCHEME_SOURCE #include "scheme-private.h" #ifndef WIN32 @@ -88,7 +92,7 @@ static int stricmp(const char *s1, const char *s2) } #endif /* __APPLE__ */ -#if USE_STRLWR +#if USE_STRLWR && !defined(HAVE_STRLWR) static const char *strlwr(char *s) { const char *p=s; while(*s) { -- cgit v1.2.3 From 14fcdcabb25d975f0f91be86b0571694fb533e7a Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 9 Mar 2017 13:26:06 +0100 Subject: tests: Rework environment setup. * tests/gpgscm/tests.scm (test::scm): Add a setup argument. (test::binary): Likewise. (run-tests-parallel): Remove setup parameter. (run-tests-sequential): Likewise. (make-environment-cache): New function that handles the cache protocol. * tests/gpgme/run-tests.scm: Adapt accordingly. * tests/gpgsm/run-tests.scm: Likewise. * tests/migrations/run-tests.scm: Likewise. * tests/openpgp/run-tests.scm: Likewise. -- This change allows us to have different environments for tests. This is needed to run more GPGME tests, and to increase concurrency while running all tests. Signed-off-by: Justus Winter --- tests.scm | 78 +++++++++++++++++++++++++++++++++++---------------------------- 1 file changed, 43 insertions(+), 35 deletions(-) diff --git a/tests.scm b/tests.scm index b3da919..0c02c34 100644 --- a/tests.scm +++ b/tests.scm @@ -551,18 +551,20 @@ ;; A single test. (define test (package - (define (scm name path . args) + (define (scm setup name path . args) ;; Start the process. (define (spawn-scm args' in out err) (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) ,(locate-test path) + ,@(if setup (force setup) '()) ,@args' ,@args) in out err)) (new name #f spawn-scm #f #f CLOSED_FD)) - (define (binary name path . args) + (define (binary setup name path . args) ;; Start the process. (define (spawn-binary args' in out err) - (spawn-process-fd `(,path ,@args' ,@args) in out err)) + (spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args) + in out err)) (new name #f spawn-binary #f #f CLOSED_FD)) (define (new name directory spawn pid retcode logfd) @@ -613,41 +615,47 @@ ;; Run the setup target to create an environment, then run all given ;; tests in parallel. -(define (run-tests-parallel setup tests) - (lettmp (gpghome-tar) - (setup::run-sync '--create-tarball gpghome-tar) - (let loop ((pool (test-pool::new '())) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - (for-each (lambda (t) - (catch (echo "Removing" t::directory "failed:" *error*) - (unlink-recursively t::directory)) - (t::report)) (reverse results::procs)) - (exit (results::report))) - (let* ((wd (mkdtemp)) - (test (car tests')) - (test' (test::set-directory wd))) - (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar)) - (cdr tests'))))))) +(define (run-tests-parallel tests) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (catch (echo "Removing" t::directory "failed:" *error*) + (unlink-recursively t::directory)) + (t::report)) (reverse results::procs)) + (exit (results::report))) + (let* ((wd (mkdtemp)) + (test (car tests')) + (test' (test::set-directory wd))) + (loop (pool::add (test'::run-async)) + (cdr tests')))))) ;; Run the setup target to create an environment, then run all given ;; tests in sequence. -(define (run-tests-sequential setup tests) - (lettmp (gpghome-tar) - (setup::run-sync '--create-tarball gpghome-tar) - (let loop ((pool (test-pool::new '())) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - (for-each (lambda (t) - (catch (echo "Removing" t::directory "failed:" *error*) - (unlink-recursively t::directory))) - results::procs) - (exit (results::report))) - (let* ((wd (mkdtemp)) - (test (car tests')) - (test' (test::set-directory wd))) - (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar)) - (cdr tests'))))))) +(define (run-tests-sequential tests) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (catch (echo "Removing" t::directory "failed:" *error*) + (unlink-recursively t::directory))) + results::procs) + (exit (results::report))) + (let* ((wd (mkdtemp)) + (test (car tests')) + (test' (test::set-directory wd))) + (loop (pool::add (test'::run-sync)) + (cdr tests')))))) + +;; Helper to create environment caches from test functions. SETUP +;; must be a test implementing the producer side cache protocol. +;; Returns a promise containing the arguments that must be passed to a +;; test implementing the consumer side of the cache protocol. +(define (make-environment-cache setup) + (delay (let* ((tarball (make-temporary-file "environment-cache"))) + (atexit (lambda () (remove-temporary-file tarball))) + (setup::run-sync '--create-tarball tarball) + `(--unpack-tarball ,tarball)))) ;; Command line flag handling. Returns the elements following KEY in ;; ARGUMENTS up to the next argument, or #f if KEY is not in -- cgit v1.2.3 From a1ed4b6ab25f28114d8ba6f704824a456d4fdc0c Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 16 Mar 2017 16:58:00 +0100 Subject: gpgscm: Remove framework for immediate values. * tests/gpgscm/scheme.c (IMMEDIATE_TAG): Remove macro. (is_immediate): Likewise. (set_immediate): Likewise. (clr_immediate): Likewise. (enum scheme_types): Set the LSB in every value. (fill_vector): Adapt. (vector_elem): Likewise. (set_vector_elem): Likewise. (mark): Likewise. (gc): Test for the LSB to tell typeflags apart from pointers stored in the same memory location. -- Supporting immediate values would require invasive changes to the interpreter and is likely not worth the trouble. On the other hand, tagging pointers in vectors complicated the hash table implementation needlessly. Therefore, I remove this again. This fixes a crash on big endian architectures. GnuPG-bug-id: 2996 Signed-off-by: Justus Winter --- scheme.c | 69 +++++++++++++++++++++++++++------------------------------------- 1 file changed, 29 insertions(+), 40 deletions(-) diff --git a/scheme.c b/scheme.c index af97c27..ff91fc0 100644 --- a/scheme.c +++ b/scheme.c @@ -117,41 +117,29 @@ static const char *strlwr(char *s) { -/* Support for immediate values. - * - * Immediate values are tagged with IMMEDIATE_TAG, which is neither - * used in types, nor in pointer values. - * - * XXX: Currently, we only use this to tag pointers in vectors. */ -#define IMMEDIATE_TAG 1 -#define is_immediate(p) ((pointer) ((uintptr_t) (p) & IMMEDIATE_TAG)) -#define set_immediate(p) ((pointer) ((uintptr_t) (p) | IMMEDIATE_TAG)) -#define clr_immediate(p) ((pointer) ((uintptr_t) (p) & ~IMMEDIATE_TAG)) - - - +/* All types have the LSB set. The garbage collector takes advantage + * of that to identify types. */ enum scheme_types { - T_STRING=1 << 1, /* Do not use the lsb, it is used for - * immediate values. */ - T_NUMBER=2 << 1, - T_SYMBOL=3 << 1, - T_PROC=4 << 1, - T_PAIR=5 << 1, - T_CLOSURE=6 << 1, - T_CONTINUATION=7 << 1, - T_FOREIGN=8 << 1, - T_CHARACTER=9 << 1, - T_PORT=10 << 1, - T_VECTOR=11 << 1, - T_MACRO=12 << 1, - T_PROMISE=13 << 1, - T_ENVIRONMENT=14 << 1, - T_FOREIGN_OBJECT=15 << 1, - T_BOOLEAN=16 << 1, - T_NIL=17 << 1, - T_EOF_OBJ=18 << 1, - T_SINK=19 << 1, - T_LAST_SYSTEM_TYPE=19 << 1 + T_STRING = 1 << 1 | 1, + T_NUMBER = 2 << 1 | 1, + T_SYMBOL = 3 << 1 | 1, + T_PROC = 4 << 1 | 1, + T_PAIR = 5 << 1 | 1, + T_CLOSURE = 6 << 1 | 1, + T_CONTINUATION = 7 << 1 | 1, + T_FOREIGN = 8 << 1 | 1, + T_CHARACTER = 9 << 1 | 1, + T_PORT = 10 << 1 | 1, + T_VECTOR = 11 << 1 | 1, + T_MACRO = 12 << 1 | 1, + T_PROMISE = 13 << 1 | 1, + T_ENVIRONMENT = 14 << 1 | 1, + T_FOREIGN_OBJECT = 15 << 1 | 1, + T_BOOLEAN = 16 << 1 | 1, + T_NIL = 17 << 1 | 1, + T_EOF_OBJ = 18 << 1 | 1, + T_SINK = 19 << 1 | 1, + T_LAST_SYSTEM_TYPE = 19 << 1 | 1 }; static const char * @@ -1361,20 +1349,20 @@ INTERFACE static void fill_vector(pointer vec, pointer obj) { size_t i; assert (is_vector (vec)); for(i = 0; i < vector_length(vec); i++) { - vec->_object._vector._elements[i] = set_immediate(obj); + vec->_object._vector._elements[i] = obj; } } INTERFACE static pointer vector_elem(pointer vec, int ielem) { assert (is_vector (vec)); assert (ielem < vector_length(vec)); - return clr_immediate(vec->_object._vector._elements[ielem]); + return vec->_object._vector._elements[ielem]; } INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { assert (is_vector (vec)); assert (ielem < vector_length(vec)); - vec->_object._vector._elements[ielem] = set_immediate(a); + vec->_object._vector._elements[ielem] = a; return a; } @@ -1576,7 +1564,7 @@ E2: setmark(p); if(is_vector(p)) { int i; for (i = 0; i < vector_length(p); i++) { - mark(clr_immediate(p->_object._vector._elements[i])); + mark(p->_object._vector._elements[i]); } } #if SHOW_ERROR_LINE @@ -1677,8 +1665,9 @@ static void gc(scheme *sc, pointer a, pointer b) { for (i = sc->last_cell_seg; i >= 0; i--) { p = sc->cell_seg[i] + CELL_SEGSIZE; while (--p >= sc->cell_seg[i]) { - if (typeflag(p) & IMMEDIATE_TAG) - continue; + if ((typeflag(p) & 1) == 0) + /* All types have the LSB set. This is not a typeflag. */ + continue; if (is_mark(p)) { clrmark(p); } else { -- cgit v1.2.3 From 053a3f9a61a2918131b9dec60149b93861c04a51 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 16 Mar 2017 17:18:01 +0100 Subject: gpgscm: Simplify hash tables. * tests/gpgscm/scheme.c (oblist_add_by_name): We now always get a slot. Simplify accordingly. (oblist_find_by_name): Always return the slot. (vector_elem_slot): New function. (new_slot_spec_in_env): We now always get a slot. Remove parameter 'env'. Simplify accordingly. (find_slot_spec_in_env): Always return a slot. (new_slot_in_env): Adapt callsite. (opexe_0): Likewise. (opexe_1): Likewise. (scheme_define): Likewise. -- Now that the ill-devised immediate values framework is gone, there is no need to tag the pointers in vectors anymore. Therefore, we can always return a pointer to the slot in the hash table lookup functions. Signed-off-by: Justus Winter --- scheme.c | 71 ++++++++++++++++++++-------------------------------------------- 1 file changed, 22 insertions(+), 49 deletions(-) diff --git a/scheme.c b/scheme.c index ff91fc0..b76e83c 100644 --- a/scheme.c +++ b/scheme.c @@ -224,6 +224,7 @@ INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } * represent it. */ #define vector_size(len) (1 + ((len) - 1 + 2) / 3) INTERFACE static void fill_vector(pointer vec, pointer obj); +INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem); INTERFACE static pointer vector_elem(pointer vec, int ielem); INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } @@ -1073,39 +1074,24 @@ static pointer oblist_initial_value(scheme *sc) /* Add a new symbol NAME at SLOT. SLOT must be obtained using * oblist_find_by_name, and no insertion must be done between * obtaining the SLOT and calling this function. Returns the new - * symbol. - * - * If SLOT is NULL, the new symbol is be placed at the appropriate - * place in the vector. */ + * symbol. */ static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) { #define oblist_add_by_name_allocates 3 pointer x; - int location; gc_disable(sc, gc_reservations (oblist_add_by_name)); x = immutable_cons(sc, mk_string(sc, name), sc->NIL); typeflag(x) = T_SYMBOL; setimmutable(car(x)); - - if (slot == NULL) { - location = hash_fn(name, vector_length(sc->oblist)); - set_vector_elem(sc->oblist, location, - immutable_cons(sc, x, vector_elem(sc->oblist, location))); - } else { - *slot = immutable_cons(sc, x, *slot); - } - + *slot = immutable_cons(sc, x, *slot); gc_enable(sc); return x; } /* Lookup the symbol NAME. Returns the symbol, or NIL if it does not * exist. In that case, SLOT points to the point where the new symbol - * is to be inserted. - * - * SLOT may be set to NULL if the new symbol should be placed at the - * appropriate place in the vector. */ + * is to be inserted. */ static INLINE pointer oblist_find_by_name(scheme *sc, const char *name, pointer **slot) { @@ -1115,7 +1101,7 @@ oblist_find_by_name(scheme *sc, const char *name, pointer **slot) int d; location = hash_fn(name, vector_length(sc->oblist)); - for (*slot = NULL, x = vector_elem(sc->oblist, location); + for (*slot = vector_elem_slot(sc->oblist, location), x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) { s = symname(car(x)); /* case-insensitive, per R5RS section 2. */ @@ -1353,6 +1339,12 @@ INTERFACE static void fill_vector(pointer vec, pointer obj) { } } +INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) { + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + return &vec->_object._vector._elements[ielem]; +} + INTERFACE static pointer vector_elem(pointer vec, int ielem) { assert (is_vector (vec)); assert (ielem < vector_length(vec)); @@ -2636,11 +2628,8 @@ static void new_frame_in_env(scheme *sc, pointer old_env) /* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using * find_slot_spec_in_env, and no insertion must be done between - * obtaining SSLOT and the call to this function. - * - * If SSLOT is NULL, the new slot is put into the appropriate place in - * the environment vector. */ -static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, + * obtaining SSLOT and the call to this function. */ +static INLINE void new_slot_spec_in_env(scheme *sc, pointer variable, pointer value, pointer *sslot) { @@ -2648,27 +2637,14 @@ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, pointer slot; gc_disable(sc, gc_reservations (new_slot_spec_in_env)); slot = immutable_cons(sc, variable, value); - - if (sslot == NULL) { - int location; - assert(is_vector(car(env))); - location = hash_fn(symname(variable), vector_length(car(env))); - - set_vector_elem(car(env), location, - immutable_cons(sc, slot, vector_elem(car(env), location))); - } else { - *sslot = immutable_cons(sc, slot, *sslot); - } + *sslot = immutable_cons(sc, slot, *sslot); gc_enable(sc); } /* Find the slot in ENV under the key HDL. If ALL is given, look in * all environments enclosing ENV. If the lookup fails, and SSLOT is * given, the position where the new slot has to be inserted is stored - * at SSLOT. - * - * SSLOT may be set to NULL if the new symbol should be placed at the - * appropriate place in the vector. */ + * at SSLOT. */ static pointer find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) { @@ -2681,13 +2657,11 @@ find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **s for (x = env; x != sc->NIL; x = cdr(x)) { if (is_vector(car(x))) { location = hash_fn(symname(hdl), vector_length(car(x))); - sl = NULL; - y = vector_elem(car(x), location); + sl = vector_elem_slot(car(x), location); } else { sl = &car(x); - y = *sl; } - for ( ; y != sc->NIL; sl = &cdr(y), y = *sl) { + for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) { d = pointercmp(caar(y), hdl); if (d == 0) return car(y); /* Hit. */ @@ -2716,12 +2690,11 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env) /* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using * find_slot_spec_in_env, and no insertion must be done between * obtaining SSLOT and the call to this function. */ -static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, +static INLINE void new_slot_spec_in_env(scheme *sc, pointer variable, pointer value, pointer *sslot) { #define new_slot_spec_in_env_allocates 2 - (void) env; assert(is_symbol(variable)); *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot); } @@ -2772,7 +2745,7 @@ static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) assert(is_symbol(variable)); slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot); assert(slot == sc->NIL); - new_slot_spec_in_env(sc, sc->envir, variable, value, sslot); + new_slot_spec_in_env(sc, variable, value, sslot); } static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) @@ -3534,7 +3507,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (x != sc->NIL) { set_slot_in_env(sc, x, sc->value); } else { - new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot); + new_slot_spec_in_env(sc, sc->code, sc->value, sslot); } s_return(sc,sc->code); } @@ -3856,7 +3829,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if (x != sc->NIL) { set_slot_in_env(sc, x, sc->value); } else { - new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot); + new_slot_spec_in_env(sc, sc->code, sc->value, sslot); } s_return(sc,sc->code); } @@ -5811,7 +5784,7 @@ void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { if (x != sc->NIL) { set_slot_in_env(sc, x, value); } else { - new_slot_spec_in_env(sc, envir, symbol, value, sslot); + new_slot_spec_in_env(sc, symbol, value, sslot); } } -- cgit v1.2.3 From cfc49428a427d1a140424c687cb45ba00117d443 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 21 Mar 2017 13:15:38 +0100 Subject: tests: Create temporary directories in '/tmp'. * tests/gpgscm/tests.scm (mkdtemp): Create temporary directories in '/tmp' on UNIX, or in '%Temp' on Windows. * tests/migrations/common.scm (run-test): Turn error into a warning. * tests/openpgp/defs.scm (start-agent): Likewise. -- This fixes the problem of GnuPG components being unable to communicate because of too long GnuPG home directories in important build environments like the Debian build servers despite the use of socket directories. This reverts d75d20909d9f60d33ffd210def92278c0f383aad. Signed-off-by: Justus Winter --- tests.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/tests.scm b/tests.scm index 0c02c34..329a31a 100644 --- a/tests.scm +++ b/tests.scm @@ -271,9 +271,11 @@ ;; generic name is used. Returns an absolute path. (define (mkdtemp . components) (canonical-path (_mkdtemp (if (null? components) - (string-append "gpgscm-" (get-isotime) "-" - (basename-suffix *scriptname* ".scm") - "-XXXXXX") + (path-join + (if *win32* (getenv "Temp") "/tmp") + (string-append "gpgscm-" (get-isotime) "-" + (basename-suffix *scriptname* ".scm") + "-XXXXXX")) (apply path-join components))))) (define-macro (with-temporary-working-directory . expressions) -- cgit v1.2.3 From 8835ee681f5ae92ded982b51f5808935d227b126 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 21 Mar 2017 15:52:47 +0100 Subject: tests,w32: Use GetTempPath to get the path for temporary files. * tests/gpgscm/ffi.c (do_get_temp_path): New function. (ffi_init): Make function available. * tests/gpgscm/tests.scm (mkdtemp): Use the new function. Fixes-commit: 06f1f163e96f1039304fd3cf565cf9de1ca45849 Signed-off-by: Justus Winter --- ffi.c | 19 +++++++++++++++++++ tests.scm | 2 +- 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/ffi.c b/ffi.c index 34e573f..3af3328 100644 --- a/ffi.c +++ b/ffi.c @@ -341,6 +341,24 @@ do_seek (scheme *sc, pointer args) ? gpg_error_from_syserror () : 0); } +static pointer +do_get_temp_path (scheme *sc, pointer args) +{ + FFI_PROLOG (); +#ifdef HAVE_W32_SYSTEM + char buffer[MAX_PATH+1]; +#endif + FFI_ARGS_DONE_OR_RETURN (sc, args); + +#ifdef HAVE_W32_SYSTEM + if (GetTempPath (MAX_PATH+1, buffer) == 0) + FFI_RETURN_STRING (sc, "/temp"); + FFI_RETURN_STRING (sc, buffer); +#else + FFI_RETURN_STRING (sc, "/tmp"); +#endif +} + static pointer do_mkdtemp (scheme *sc, pointer args) { @@ -1352,6 +1370,7 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define_function (sc, fdopen); ffi_define_function (sc, close); ffi_define_function (sc, seek); + ffi_define_function (sc, get_temp_path); ffi_define_function_name (sc, "_mkdtemp", mkdtemp); ffi_define_function (sc, unlink); ffi_define_function (sc, unlink_recursively); diff --git a/tests.scm b/tests.scm index 329a31a..a4339ca 100644 --- a/tests.scm +++ b/tests.scm @@ -272,7 +272,7 @@ (define (mkdtemp . components) (canonical-path (_mkdtemp (if (null? components) (path-join - (if *win32* (getenv "Temp") "/tmp") + (get-temp-path) (string-append "gpgscm-" (get-isotime) "-" (basename-suffix *scriptname* ".scm") "-XXXXXX")) -- cgit v1.2.3 From e1780b2f981d3fd48bbf2672b35f2f33152f6c32 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 23 Mar 2017 10:55:34 +0100 Subject: gpgscm: Make test cleanup more robust. * tests/gpgscm/tests.scm (mkdtemp-autoremove): New function that cleans up at interpreter shutdown. (run-tests-parallel): Use the new function. (run-tests-sequential): Likewise. (make-environment-cache): Execute setup with an temporary working directory. -- Make sure to remove all resources created in the filesystem even if the test runner is interrupted. Make sure to remove anything that the setup script creates. Signed-off-by: Justus Winter --- tests.scm | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/tests.scm b/tests.scm index a4339ca..592b36f 100644 --- a/tests.scm +++ b/tests.scm @@ -278,6 +278,15 @@ "-XXXXXX")) (apply path-join components))))) +;; Make a temporary directory and remove it at interpreter shutdown. +;; Note that there are macros that limit the lifetime of temporary +;; directories and files to a lexical scope. Use those if possible. +;; Otherwise this works like mkdtemp. +(define (mkdtemp-autoremove . components) + (let ((dir (apply mkdtemp components))) + (atexit (lambda () (unlink-recursively dir))) + dir)) + (define-macro (with-temporary-working-directory . expressions) (let ((tmp-sym (gensym))) `(let* ((,tmp-sym (mkdtemp))) @@ -621,12 +630,9 @@ (let loop ((pool (test-pool::new '())) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) - (for-each (lambda (t) - (catch (echo "Removing" t::directory "failed:" *error*) - (unlink-recursively t::directory)) - (t::report)) (reverse results::procs)) + (for-each (lambda (t) (t::report)) (reverse results::procs)) (exit (results::report))) - (let* ((wd (mkdtemp)) + (let* ((wd (mkdtemp-autoremove)) (test (car tests')) (test' (test::set-directory wd))) (loop (pool::add (test'::run-async)) @@ -638,12 +644,8 @@ (let loop ((pool (test-pool::new '())) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) - (for-each (lambda (t) - (catch (echo "Removing" t::directory "failed:" *error*) - (unlink-recursively t::directory))) - results::procs) (exit (results::report))) - (let* ((wd (mkdtemp)) + (let* ((wd (mkdtemp-autoremove)) (test (car tests')) (test' (test::set-directory wd))) (loop (pool::add (test'::run-sync)) @@ -654,10 +656,11 @@ ;; Returns a promise containing the arguments that must be passed to a ;; test implementing the consumer side of the cache protocol. (define (make-environment-cache setup) - (delay (let* ((tarball (make-temporary-file "environment-cache"))) - (atexit (lambda () (remove-temporary-file tarball))) - (setup::run-sync '--create-tarball tarball) - `(--unpack-tarball ,tarball)))) + (delay (with-temporary-working-directory + (let ((tarball (make-temporary-file "environment-cache"))) + (atexit (lambda () (remove-temporary-file tarball))) + (setup::run-sync '--create-tarball tarball) + `(--unpack-tarball ,tarball))))) ;; Command line flag handling. Returns the elements following KEY in ;; ARGUMENTS up to the next argument, or #f if KEY is not in -- cgit v1.2.3 From 9a4283ed6aafc1e43d8f7a5fd9cef6118615f284 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 30 Mar 2017 12:19:01 +0200 Subject: gpgscm: Slightly improve the procedure dispatch. * tests/gpgscm/scheme.c (procnum): Procedures always have an integer number, so we can safely use the cheaper 'ivalue_unchecked'. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index b76e83c..fbc562d 100644 --- a/scheme.c +++ b/scheme.c @@ -274,7 +274,7 @@ INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } -#define procnum(p) ivalue(p) +#define procnum(p) ivalue_unchecked(p) static const char *procname(pointer x); INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } -- cgit v1.2.3 From 6900f118303962262923f9d103b802508d5f469f Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 4 Apr 2017 14:28:45 +0200 Subject: gpgscm: Simplify substring operation. * tests/gpgscm/scheme.c (opexe_2): Simplify 'substring'. Signed-off-by: Justus Winter --- scheme.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/scheme.c b/scheme.c index fbc562d..3c7afa3 100644 --- a/scheme.c +++ b/scheme.c @@ -4355,7 +4355,6 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { char *str; int index0; int index1; - int len; str=strvalue(car(sc->args)); @@ -4374,13 +4373,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { index1=strlength(car(sc->args)); } - len=index1-index0; gc_disable(sc, 1); - x=mk_empty_string(sc,len,' '); - memcpy(strvalue(x),str+index0,len); - strvalue(x)[len]=0; - - s_return_enable_gc(sc, x); + s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0)); } CASE(OP_VECTOR): { /* vector */ -- cgit v1.2.3 From c9244b2eb43e0f06928b709ac35127966e1d24ce Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 4 Apr 2017 17:38:50 +0200 Subject: gpgscm: Simplify get-output-string operation. * tests/gpgscm/scheme.c (opexe_4): Simplify 'get-output-string'. Signed-off-by: Justus Winter --- scheme.c | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/scheme.c b/scheme.c index 3c7afa3..736486f 100644 --- a/scheme.c +++ b/scheme.c @@ -4811,20 +4811,12 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { port *p; if ((p=car(sc->args)->_object._port)->kind&port_string) { - off_t size; - char *str; - - size=p->rep.string.curr-p->rep.string.start+1; - str=sc->malloc(size); - if(str != NULL) { - pointer s; - - memcpy(str,p->rep.string.start,size-1); - str[size-1]='\0'; - s=mk_string(sc,str); - sc->free(str); - s_return(sc,s); - } + gc_disable(sc, 1); + s_return_enable_gc( + sc, + mk_counted_string(sc, + p->rep.string.start, + p->rep.string.curr - p->rep.string.start)); } s_return(sc,sc->F); } -- cgit v1.2.3 From 52d0423e48dfe4dd51dc0acbf119431701280a70 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 4 Apr 2017 17:36:45 +0200 Subject: gpgscm: Fix copying values. * tests/gpgscm/scheme.c (copy_value): New function. (mk_tagged_value): Use new function. (opexe_4): Likewise for OP_SAVE_FORCED. -- Occasionally, we need to copy a value from one location in the storage to another. Scheme objects are fine. Some primitive objects, however, require finalization, usually to free resources. For these values, we either make a copy or acquire a reference. Fixes e.g. a double free if a delayed expression evaluating to a string is forced. Signed-off-by: Justus Winter --- scheme.c | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index 736486f..51fdef0 100644 --- a/scheme.c +++ b/scheme.c @@ -624,6 +624,56 @@ static long binary_decode(const char *s) { +/* + * Copying values. + * + * Occasionally, we need to copy a value from one location in the + * storage to another. Scheme objects are fine. Some primitive + * objects, however, require finalization, usually to free resources. + * + * For these values, we either make a copy or acquire a reference. + */ + +/* + * Copy SRC to DST. + * + * Copies the representation of SRC to DST. This makes SRC + * indistinguishable from DST from the perspective of a Scheme + * expression modulo the fact that they reside at a different location + * in the store. + * + * Conditions: + * + * - SRC must not be a vector. + * - Caller must ensure that any resources associated with the + * value currently stored in DST is accounted for. + */ +static void +copy_value(scheme *sc, pointer dst, pointer src) +{ + memcpy(dst, src, sizeof *src); + + /* We may need to make a copy or acquire a reference. */ + if (typeflag(dst) & T_FINALIZE) + switch (type(dst)) { + case T_STRING: + strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0); + break; + case T_PORT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_FOREIGN_OBJECT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_VECTOR: + assert (!"vectors cannot be copied"); + } +} + + + /* Tags are like property lists, but can be attached to arbitrary * values. */ @@ -640,7 +690,7 @@ mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) if (r == sc->sink) return sc->sink; - memcpy(r, v, sizeof *v); + copy_value(sc, r, v); typeflag(r) |= T_TAGGED; t = r + 1; @@ -4603,7 +4653,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */ - memcpy(sc->code,sc->value,sizeof(struct cell)); + copy_value(sc, sc->code, sc->value); s_return(sc,sc->value); CASE(OP_WRITE): /* write */ -- cgit v1.2.3 From 54ea82c2e7e5700b9644c663142c2d46441a3f4e Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 6 Apr 2017 16:21:48 +0200 Subject: gpgscm: Initialize unused slots in vectors. * tests/gpgscm/scheme.c (get_vector_object): Initialize unused slots at the end of vectors. -- They should not be used for anything, but let's just initialize them to something benign to be sure. GnuPG-bug-id: 3014 Signed-off-by: Justus Winter --- scheme.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/scheme.c b/scheme.c index 51fdef0..3719e53 100644 --- a/scheme.c +++ b/scheme.c @@ -1083,11 +1083,19 @@ static pointer get_cell(scheme *sc, pointer a, pointer b) static pointer get_vector_object(scheme *sc, int len, pointer init) { pointer cells = get_consecutive_cells(sc, vector_size(len)); + int i; + int alloc_len = 1 + 3 * (vector_size(len) - 1); if(sc->no_memory) { return sc->sink; } /* Record it as a vector so that gc understands it. */ typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE); vector_length(cells) = len; fill_vector(cells,init); + + /* Initialize the unused slots at the end. */ + assert (alloc_len - len < 3); + for (i = len; i < alloc_len; i++) + cells->_object._vector._elements[i] = sc->NIL; + if (gc_enabled (sc)) push_recent_alloc(sc, cells, sc->NIL); return cells; -- cgit v1.2.3 From 00de0fd1cebd89330765470bbb6e1e8bf5f3dfc9 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 6 Apr 2017 16:24:49 +0200 Subject: gpgscm: Avoid mutating integer. * tests/gpgscm/scheme.c (opexe_5): Do not modify the integer in-place while printing an vector. Integer objects may be shared, so they must not be mutated. Signed-off-by: Justus Winter --- scheme.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 3719e53..aa0cf69 100644 --- a/scheme.c +++ b/scheme.c @@ -5181,7 +5181,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->T); } else { pointer elem=vector_elem(vec,i); - ivalue_unchecked(cdr(sc->args))=i+1; + cdr(sc->args) = mk_integer(sc, i + 1); s_save(sc,OP_PVECFROM, sc->args, sc->NIL); sc->args=elem; if (i > 0) -- cgit v1.2.3 From a493ad44b6a67026aeae08d25575fee8c0f137b4 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 7 Apr 2017 12:27:47 +0200 Subject: gpgscm: Fix compact vector encoding. * tests/gpgscm/scheme-private.h (struct cell): Use uintptr_t for '_flags'. This way, '_flags' has the size of a machine word. -- The compact vector representation introduced in 49e2ae65 requires that we can tell apart pointers and type flags. This did not work on 64-bit big-endian architectures. Fixes a crash on 64-bit big-endian architectures. Hat-tip-to: gniibe Fixes-commit: 49e2ae65e892f93be7f87cfaae3392b50a99e4b1 Signed-off-by: Justus Winter --- scheme-private.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/scheme-private.h b/scheme-private.h index abd89e8..fe50135 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -3,6 +3,7 @@ #ifndef _SCHEME_PRIVATE_H #define _SCHEME_PRIVATE_H +#include #include "scheme.h" /*------------------ Ugly internals -----------------------------------*/ /*------------------ Of interest only to FFI users --------------------*/ @@ -42,7 +43,7 @@ typedef struct port { /* cell structure */ struct cell { - unsigned int _flag; + uintptr_t _flag; union { struct { char *_svalue; -- cgit v1.2.3 From 961f3b3a3001384d5df1d5a9963c5f67f800cd4d Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 22 Mar 2017 16:22:57 +0100 Subject: gpgscm: Remove arbitrary limit on number of cell segments. * tests/gpgscm/scheme-private.h (struct scheme): Remove fixed-size arrays for cell segments, replace them with a pointer to the new 'struct cell_segment' instead. * tests/gpgscm/scheme.c (struct cell_segment): New definition. (_alloc_cellseg): Allocate the header within the segment, return a pointer to the header. (_dealloc_cellseg): New function. (alloc_cellseg): Insert the segments into a list. (_get_cell): Allocate a new segment if less than a quarter of CELL_SIGSIZE is recovered during garbage collection. (initialize_small_integers): Adapt callsite. (gc): Walk the list of segments. (scheme_init_custom_alloc): Remove initialization of removed field. (scheme_deinit): Adapt deallocation. -- Previously the number of cells that could be allocated was a compile-time limit. Remove this limit. Signed-off-by: Justus Winter --- scheme-private.h | 10 ++---- scheme.c | 108 ++++++++++++++++++++++++++++++++++++------------------- 2 files changed, 74 insertions(+), 44 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index fe50135..093442f 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -108,12 +108,7 @@ 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 -void *alloc_seg[CELL_NSEGMENT]; -pointer cell_seg[CELL_NSEGMENT]; -int last_cell_seg; +struct cell_segment *cell_segments; /* We use 4 registers. */ pointer args; /* register for arguments of function */ @@ -159,8 +154,7 @@ pointer COMPILE_HOOK; /* *compile-hook* */ #if USE_SMALL_INTEGERS /* A fixed allocation of small integers. */ -void *integer_alloc; -pointer integer_cells; +struct cell_segment *integer_segment; #endif pointer free_cell; /* pointer to top of free cells */ diff --git a/scheme.c b/scheme.c index aa0cf69..08b53a1 100644 --- a/scheme.c +++ b/scheme.c @@ -725,9 +725,26 @@ get_tag(scheme *sc, pointer v) +/* Low-level allocator. + * + * Memory is allocated in segments. Every segment holds a fixed + * number of cells. Segments are linked into a list, sorted in + * reverse address order (i.e. those with a higher address first). + * This is used in the garbage collector to build the freelist in + * address order. + */ + +struct cell_segment +{ + struct cell_segment *next; + void *alloc; + pointer cells; + size_t cells_len; +}; + /* Allocate a new cell segment but do not make it available yet. */ static int -_alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells) +_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment) { int adj = ADJ; void *cp; @@ -735,46 +752,64 @@ _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells) if (adj < sizeof(struct cell)) adj = sizeof(struct cell); - cp = sc->malloc(len * sizeof(struct cell) + adj); + /* The segment header is conveniently allocated with the cells. */ + cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj); if (cp == NULL) return 1; - *alloc = cp; + *segment = cp; + (*segment)->next = NULL; + (*segment)->alloc = cp; + cp = (void *) ((uintptr_t) cp + sizeof **segment); /* adjust in TYPE_BITS-bit boundary */ if (((uintptr_t) cp) % adj != 0) cp = (void *) (adj * ((uintptr_t) cp / adj + 1)); - *cells = cp; + (*segment)->cells = cp; + (*segment)->cells_len = len; return 0; } +/* Deallocate a cell segment. Returns the next cell segment. + * Convenient for deallocation in a loop. */ +static struct cell_segment * +_dealloc_cellseg(scheme *sc, struct cell_segment *segment) +{ + + struct cell_segment *next; + + if (segment == NULL) + return NULL; + + next = segment->next; + sc->free(segment->alloc); + return next; +} + /* allocate new cell segment */ static int alloc_cellseg(scheme *sc, int n) { - pointer newp; pointer last; pointer p; - long i; int k; for (k = 0; k < n; k++) { - if (sc->last_cell_seg >= CELL_NSEGMENT - 1) - return k; - i = ++sc->last_cell_seg; - if (_alloc_cellseg(sc, CELL_SEGSIZE, &sc->alloc_seg[i], &newp)) { - sc->last_cell_seg--; + struct cell_segment *new, **s; + if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) { return k; } - /* insert new segment in address order */ - sc->cell_seg[i] = newp; - while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { - p = sc->cell_seg[i]; - sc->cell_seg[i] = sc->cell_seg[i - 1]; - sc->cell_seg[--i] = p; - } - sc->fcells += CELL_SEGSIZE; - last = newp + CELL_SEGSIZE - 1; - for (p = newp; p <= last; p++) { + /* insert new segment in reverse address order */ + for (s = &sc->cell_segments; + *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc; + s = &(*s)->next) { + /* walk */ + } + new->next = *s; + *s = new; + + sc->fcells += new->cells_len; + last = new->cells + new->cells_len - 1; + for (p = new->cells; p <= last; p++) { typeflag(p) = 0; cdr(p) = p + 1; car(p) = sc->NIL; @@ -782,13 +817,13 @@ static int alloc_cellseg(scheme *sc, int n) { /* insert new cells in address order on free list */ if (sc->free_cell == sc->NIL || p < sc->free_cell) { cdr(last) = sc->free_cell; - sc->free_cell = newp; + sc->free_cell = new->cells; } else { p = sc->free_cell; - while (cdr(p) != sc->NIL && newp > cdr(p)) + while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p)) p = cdr(p); cdr(last) = cdr(p); - cdr(p) = newp; + cdr(p) = new->cells; } } return n; @@ -922,7 +957,7 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) { assert (gc_enabled (sc)); if (sc->free_cell == sc->NIL) { - const int min_to_be_recovered = sc->last_cell_seg*8; + const int min_to_be_recovered = CELL_SEGSIZE / 4; gc(sc,a, b); if (sc->fcells < min_to_be_recovered || sc->free_cell == sc->NIL) { @@ -1283,12 +1318,11 @@ static int initialize_small_integers(scheme *sc) { int i; - if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc, - &sc->integer_cells)) + if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_segment)) return 1; for (i = 0; i < MAX_SMALL_INTEGER; i++) { - pointer x = &sc->integer_cells[i]; + pointer x = &sc->integer_segment->cells[i]; typeflag(x) = T_NUMBER | T_ATOM | MARK; ivalue_unchecked(x) = i; set_num_integer(x); @@ -1302,7 +1336,7 @@ mk_small_integer(scheme *sc, long n) { #define mk_small_integer_allocates 0 assert(0 <= n && n < MAX_SMALL_INTEGER); - return &sc->integer_cells[n]; + return &sc->integer_segment->cells[n]; } #else @@ -1666,6 +1700,7 @@ E6: /* up. Undo the link switching from steps E4 and E5. */ /* garbage collection. parameter a, b is marked. */ static void gc(scheme *sc, pointer a, pointer b) { pointer p; + struct cell_segment *s; int i; assert (gc_enabled (sc)); @@ -1712,9 +1747,9 @@ static void gc(scheme *sc, pointer a, pointer b) { (which are also kept sorted by address) downwards to build the free-list in sorted order. */ - for (i = sc->last_cell_seg; i >= 0; i--) { - p = sc->cell_seg[i] + CELL_SEGSIZE; - while (--p >= sc->cell_seg[i]) { + for (s = sc->cell_segments; s; s = s->next) { + p = s->cells + s->cells_len; + while (--p >= s->cells) { if ((typeflag(p) & 1) == 0) /* All types have the LSB set. This is not a typeflag. */ continue; @@ -5592,7 +5627,6 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->gensym_cnt=0; sc->malloc=malloc; sc->free=free; - sc->last_cell_seg = -1; sc->sink = &sc->_sink; sc->NIL = &sc->_NIL; sc->T = &sc->_HASHT; @@ -5626,6 +5660,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { } sc->strbuff_size = STRBUFFSIZE; + sc->cell_segments = NULL; if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { sc->no_memory=1; return 0; @@ -5726,6 +5761,7 @@ void scheme_set_external_data(scheme *sc, void *p) { } void scheme_deinit(scheme *sc) { + struct cell_segment *s; int i; sc->oblist=sc->NIL; @@ -5758,11 +5794,11 @@ void scheme_deinit(scheme *sc) { gc(sc,sc->NIL,sc->NIL); #if USE_SMALL_INTEGERS - sc->free(sc->integer_alloc); + _dealloc_cellseg(sc, sc->integer_segment); #endif - for(i=0; i<=sc->last_cell_seg; i++) { - sc->free(sc->alloc_seg[i]); + for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) { + /* nop */ } sc->free(sc->strbuff); } -- cgit v1.2.3 From 9fc4e6cbe6d5d3f2dd1c61ded15e2ad42f8f9460 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 23 Mar 2017 12:50:27 +0100 Subject: gpgscm: Make global data constant when possible. * tests/gpgscm/scheme-private.h (struct scheme): Make 'vptr' const. * tests/gpgscm/scheme.c (num_zero): Statically initialize and turn into constant. (num_one): Likewise. (charnames): Change type so that it can be stored in rodata. (is_ascii_name): Adapt slightly. (assign_proc): Make argument const char *. (op_code_info): Make some fields const char *. (tests): Make const. (dispatch_table): Make const. At least it can be made read-only after relocation. (Eval_Cycle): Adapt slightly. (vtbl): Make const. Signed-off-by: Justus Winter --- scheme-private.h | 2 +- scheme.c | 32 ++++++++++++++------------------ 2 files changed, 15 insertions(+), 19 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 093442f..69b78f2 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -200,7 +200,7 @@ unsigned int flags; void *ext_data; /* For the benefit of foreign functions */ long gensym_cnt; -struct scheme_interface *vptr; +const struct scheme_interface *vptr; }; /* operator code */ diff --git a/scheme.c b/scheme.c index 08b53a1..c37b568 100644 --- a/scheme.c +++ b/scheme.c @@ -205,8 +205,8 @@ static INLINE int num_is_integer(pointer p) { return ((p)->_object._number.is_fixnum); } -static num num_zero; -static num num_one; +static const struct num num_zero = { 1, {0} }; +static const struct num num_one = { 1, {1} }; /* macros for cell operations */ #define typeflag(p) ((p)->_flag) @@ -339,7 +339,7 @@ static INLINE int Cislower(int c) { return isascii(c) && islower(c); } #endif #if USE_ASCII_NAMES -static const char *charnames[32]={ +static const char charnames[32][3]={ "nul", "soh", "stx", @@ -377,12 +377,12 @@ static const char *charnames[32]={ static int is_ascii_name(const char *name, int *pc) { int i; for(i=0; i<32; i++) { - if(stricmp(name,charnames[i])==0) { + if (strncasecmp(name, charnames[i], 3) == 0) { *pc=i; return 1; } } - if(stricmp(name,"del")==0) { + if (strcasecmp(name, "del") == 0) { *pc=127; return 1; } @@ -447,7 +447,7 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op); static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); static void assign_syntax(scheme *sc, char *name); static int syntaxnum(pointer p); -static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); +static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name); #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) #define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) @@ -5308,7 +5308,7 @@ static int is_nonneg(pointer p) { } /* Correspond carefully with following defines! */ -static struct { +static const struct { test_predicate fct; const char *kind; } tests[]={ @@ -5347,17 +5347,18 @@ static struct { typedef struct { dispatch_func func; - char *name; + const char *name; int min_arity; int max_arity; - char *arg_tests_encoding; + const char *arg_tests_encoding; } op_code_info; #define INF_ARG 0xffff -static op_code_info dispatch_table[]= { +static const op_code_info dispatch_table[]= { #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, #include "opdefines.h" +#undef _OP_DEF { 0 } }; @@ -5374,7 +5375,7 @@ static const char *procname(pointer x) { static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { sc->op = op; for (;;) { - op_code_info *pcd=dispatch_table+sc->op; + const op_code_info *pcd=dispatch_table+sc->op; if (pcd->name!=0) { /* if built-in function, check arguments */ char msg[STRBUFFSIZE]; int ok=1; @@ -5457,7 +5458,7 @@ static void assign_syntax(scheme *sc, char *name) { typeflag(x) |= T_SYNTAX; } -static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { +static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) { pointer x, y; x = mk_symbol(sc, name); @@ -5519,7 +5520,7 @@ INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { return immutable_cons(sc,a,b); } -static struct scheme_interface vtbl ={ +static const struct scheme_interface vtbl = { scheme_define, s_cons, s_immutable_cons, @@ -5616,11 +5617,6 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); pointer x; - num_zero.is_fixnum=1; - num_zero.value.ivalue=0; - num_one.is_fixnum=1; - num_one.value.ivalue=1; - #if USE_INTERFACE sc->vptr=&vtbl; #endif -- cgit v1.2.3 From 7cee693e31fa1196161d5fbe7149a176049735ac Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 23 Mar 2017 15:21:36 +0100 Subject: gpgscm: Allocate small integers in the rodata section. * tests/gpgscm/Makefile.am (gpgscm_SOURCES): Add new file. * tests/gpgscm/scheme-private.h (struct cell): Move number to the top of the union so that we can initialize it. (struct scheme): Remove 'integer_segment'. * tests/gpgscm/scheme.c (initialize_small_integers): Remove function. (small_integers): New variable. (MAX_SMALL_INTEGER): Compute. (mk_small_integer): Adapt. (mark): Avoid marking objects already marked. This allows us to run the algorithm over objects in the rodata section if they are already marked. (scheme_init_custom_alloc): Remove initialization. (scheme_deinit): Remove deallocation. * tests/gpgscm/small-integers.h: New file. -- Allocate small integers from a fixed pool in the rodata section. This spares us the initialization, and deduplicates integers across different processes. It also makes the integers immutable, increasing memory safety. Signed-off-by: Justus Winter --- Makefile.am | 3 +- scheme-private.h | 7 +- scheme.c | 41 +-- small-integers.h | 847 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 861 insertions(+), 37 deletions(-) create mode 100644 small-integers.h diff --git a/Makefile.am b/Makefile.am index 8942c7c..15fc883 100644 --- a/Makefile.am +++ b/Makefile.am @@ -44,7 +44,8 @@ commonpth_libs = ../$(libcommonpth) gpgscm_CFLAGS = -imacros scheme-config.h \ $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ - scheme-config.h opdefines.h scheme.c scheme.h scheme-private.h + scheme-config.h scheme.c scheme.h scheme-private.h \ + opdefines.h small-integers.h gpgscm_LDADD = $(LDADD) $(common_libs) \ $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \ $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) diff --git a/scheme-private.h b/scheme-private.h index 69b78f2..abe65e7 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -45,11 +45,11 @@ typedef struct port { struct cell { uintptr_t _flag; union { + num _number; struct { char *_svalue; int _length; } _string; - num _number; port *_port; foreign_func _ff; struct { @@ -152,11 +152,6 @@ pointer SHARP_HOOK; /* *sharp-hook* */ pointer COMPILE_HOOK; /* *compile-hook* */ #endif -#if USE_SMALL_INTEGERS -/* A fixed allocation of small integers. */ -struct cell_segment *integer_segment; -#endif - pointer free_cell; /* pointer to top of free cells */ long fcells; /* # of free cells */ size_t inhibit_gc; /* nesting of gc_disable */ diff --git a/scheme.c b/scheme.c index c37b568..e04394d 100644 --- a/scheme.c +++ b/scheme.c @@ -1312,31 +1312,22 @@ INTERFACE pointer mk_character(scheme *sc, int c) { /* s_save assumes that all opcodes can be expressed as a small * integer. */ -#define MAX_SMALL_INTEGER OP_MAXDEFINED - -static int -initialize_small_integers(scheme *sc) -{ - int i; - if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_segment)) - return 1; - - for (i = 0; i < MAX_SMALL_INTEGER; i++) { - pointer x = &sc->integer_segment->cells[i]; - typeflag(x) = T_NUMBER | T_ATOM | MARK; - ivalue_unchecked(x) = i; - set_num_integer(x); - } +static const struct cell small_integers[] = { +#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}}, +#include "small-integers.h" +#undef DEFINE_INTEGER + {0} +}; - return 0; -} +#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1) static INLINE pointer mk_small_integer(scheme *sc, long n) { #define mk_small_integer_allocates 0 + (void) sc; assert(0 <= n && n < MAX_SMALL_INTEGER); - return &sc->integer_segment->cells[n]; + return (pointer) &small_integers[n]; } #else @@ -1644,7 +1635,8 @@ static void mark(pointer a) { t = (pointer) 0; p = a; -E2: setmark(p); +E2: if (! is_mark(p)) + setmark(p); if(is_vector(p)) { int i; for (i = 0; i < vector_length(p); i++) { @@ -5629,13 +5621,6 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->F = &sc->_HASHF; sc->EOF_OBJ=&sc->_EOF_OBJ; -#if USE_SMALL_INTEGERS - if (initialize_small_integers(sc)) { - sc->no_memory=1; - return 0; - } -#endif - sc->free_cell = &sc->_NIL; sc->fcells = 0; sc->inhibit_gc = GC_ENABLED; @@ -5789,10 +5774,6 @@ void scheme_deinit(scheme *sc) { sc->gc_verbose=0; gc(sc,sc->NIL,sc->NIL); -#if USE_SMALL_INTEGERS - _dealloc_cellseg(sc, sc->integer_segment); -#endif - for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) { /* nop */ } diff --git a/small-integers.h b/small-integers.h new file mode 100644 index 0000000..46eda34 --- /dev/null +++ b/small-integers.h @@ -0,0 +1,847 @@ +/* Constant integer objects for TinySCHEME. + * + * Copyright (C) 2017 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +/* + * Ohne Worte. Generated using: + * + * $ n=0; while read line ; do \ + * echo "DEFINE_INTEGER($n)" ; \ + * n="$(expr $n + 1)" ; \ + * done <./init.scm >> small-integers.h + */ + +DEFINE_INTEGER(0) +DEFINE_INTEGER(1) +DEFINE_INTEGER(2) +DEFINE_INTEGER(3) +DEFINE_INTEGER(4) +DEFINE_INTEGER(5) +DEFINE_INTEGER(6) +DEFINE_INTEGER(7) +DEFINE_INTEGER(8) +DEFINE_INTEGER(9) +DEFINE_INTEGER(10) +DEFINE_INTEGER(11) +DEFINE_INTEGER(12) +DEFINE_INTEGER(13) +DEFINE_INTEGER(14) +DEFINE_INTEGER(15) +DEFINE_INTEGER(16) +DEFINE_INTEGER(17) +DEFINE_INTEGER(18) +DEFINE_INTEGER(19) +DEFINE_INTEGER(20) +DEFINE_INTEGER(21) +DEFINE_INTEGER(22) +DEFINE_INTEGER(23) +DEFINE_INTEGER(24) +DEFINE_INTEGER(25) +DEFINE_INTEGER(26) +DEFINE_INTEGER(27) +DEFINE_INTEGER(28) +DEFINE_INTEGER(29) +DEFINE_INTEGER(30) +DEFINE_INTEGER(31) +DEFINE_INTEGER(32) +DEFINE_INTEGER(33) +DEFINE_INTEGER(34) +DEFINE_INTEGER(35) +DEFINE_INTEGER(36) +DEFINE_INTEGER(37) +DEFINE_INTEGER(38) +DEFINE_INTEGER(39) +DEFINE_INTEGER(40) +DEFINE_INTEGER(41) +DEFINE_INTEGER(42) +DEFINE_INTEGER(43) +DEFINE_INTEGER(44) +DEFINE_INTEGER(45) +DEFINE_INTEGER(46) +DEFINE_INTEGER(47) +DEFINE_INTEGER(48) +DEFINE_INTEGER(49) +DEFINE_INTEGER(50) +DEFINE_INTEGER(51) +DEFINE_INTEGER(52) +DEFINE_INTEGER(53) +DEFINE_INTEGER(54) +DEFINE_INTEGER(55) +DEFINE_INTEGER(56) +DEFINE_INTEGER(57) +DEFINE_INTEGER(58) +DEFINE_INTEGER(59) +DEFINE_INTEGER(60) +DEFINE_INTEGER(61) +DEFINE_INTEGER(62) +DEFINE_INTEGER(63) +DEFINE_INTEGER(64) +DEFINE_INTEGER(65) +DEFINE_INTEGER(66) +DEFINE_INTEGER(67) +DEFINE_INTEGER(68) +DEFINE_INTEGER(69) +DEFINE_INTEGER(70) +DEFINE_INTEGER(71) +DEFINE_INTEGER(72) +DEFINE_INTEGER(73) +DEFINE_INTEGER(74) +DEFINE_INTEGER(75) +DEFINE_INTEGER(76) +DEFINE_INTEGER(77) +DEFINE_INTEGER(78) +DEFINE_INTEGER(79) +DEFINE_INTEGER(80) +DEFINE_INTEGER(81) +DEFINE_INTEGER(82) +DEFINE_INTEGER(83) +DEFINE_INTEGER(84) +DEFINE_INTEGER(85) +DEFINE_INTEGER(86) +DEFINE_INTEGER(87) +DEFINE_INTEGER(88) +DEFINE_INTEGER(89) +DEFINE_INTEGER(90) +DEFINE_INTEGER(91) +DEFINE_INTEGER(92) +DEFINE_INTEGER(93) +DEFINE_INTEGER(94) +DEFINE_INTEGER(95) +DEFINE_INTEGER(96) +DEFINE_INTEGER(97) +DEFINE_INTEGER(98) +DEFINE_INTEGER(99) +DEFINE_INTEGER(100) +DEFINE_INTEGER(101) +DEFINE_INTEGER(102) +DEFINE_INTEGER(103) +DEFINE_INTEGER(104) +DEFINE_INTEGER(105) +DEFINE_INTEGER(106) +DEFINE_INTEGER(107) +DEFINE_INTEGER(108) +DEFINE_INTEGER(109) +DEFINE_INTEGER(110) +DEFINE_INTEGER(111) +DEFINE_INTEGER(112) +DEFINE_INTEGER(113) +DEFINE_INTEGER(114) +DEFINE_INTEGER(115) +DEFINE_INTEGER(116) +DEFINE_INTEGER(117) +DEFINE_INTEGER(118) +DEFINE_INTEGER(119) +DEFINE_INTEGER(120) +DEFINE_INTEGER(121) +DEFINE_INTEGER(122) +DEFINE_INTEGER(123) +DEFINE_INTEGER(124) +DEFINE_INTEGER(125) +DEFINE_INTEGER(126) +DEFINE_INTEGER(127) +DEFINE_INTEGER(128) +DEFINE_INTEGER(129) +DEFINE_INTEGER(130) +DEFINE_INTEGER(131) +DEFINE_INTEGER(132) +DEFINE_INTEGER(133) +DEFINE_INTEGER(134) +DEFINE_INTEGER(135) +DEFINE_INTEGER(136) +DEFINE_INTEGER(137) +DEFINE_INTEGER(138) +DEFINE_INTEGER(139) +DEFINE_INTEGER(140) +DEFINE_INTEGER(141) +DEFINE_INTEGER(142) +DEFINE_INTEGER(143) +DEFINE_INTEGER(144) +DEFINE_INTEGER(145) +DEFINE_INTEGER(146) +DEFINE_INTEGER(147) +DEFINE_INTEGER(148) +DEFINE_INTEGER(149) +DEFINE_INTEGER(150) +DEFINE_INTEGER(151) +DEFINE_INTEGER(152) +DEFINE_INTEGER(153) +DEFINE_INTEGER(154) +DEFINE_INTEGER(155) +DEFINE_INTEGER(156) +DEFINE_INTEGER(157) +DEFINE_INTEGER(158) +DEFINE_INTEGER(159) +DEFINE_INTEGER(160) +DEFINE_INTEGER(161) +DEFINE_INTEGER(162) +DEFINE_INTEGER(163) +DEFINE_INTEGER(164) +DEFINE_INTEGER(165) +DEFINE_INTEGER(166) +DEFINE_INTEGER(167) +DEFINE_INTEGER(168) +DEFINE_INTEGER(169) +DEFINE_INTEGER(170) +DEFINE_INTEGER(171) +DEFINE_INTEGER(172) +DEFINE_INTEGER(173) +DEFINE_INTEGER(174) +DEFINE_INTEGER(175) +DEFINE_INTEGER(176) +DEFINE_INTEGER(177) +DEFINE_INTEGER(178) +DEFINE_INTEGER(179) +DEFINE_INTEGER(180) +DEFINE_INTEGER(181) +DEFINE_INTEGER(182) +DEFINE_INTEGER(183) +DEFINE_INTEGER(184) +DEFINE_INTEGER(185) +DEFINE_INTEGER(186) +DEFINE_INTEGER(187) +DEFINE_INTEGER(188) +DEFINE_INTEGER(189) +DEFINE_INTEGER(190) +DEFINE_INTEGER(191) +DEFINE_INTEGER(192) +DEFINE_INTEGER(193) +DEFINE_INTEGER(194) +DEFINE_INTEGER(195) +DEFINE_INTEGER(196) +DEFINE_INTEGER(197) +DEFINE_INTEGER(198) +DEFINE_INTEGER(199) +DEFINE_INTEGER(200) +DEFINE_INTEGER(201) +DEFINE_INTEGER(202) +DEFINE_INTEGER(203) +DEFINE_INTEGER(204) +DEFINE_INTEGER(205) +DEFINE_INTEGER(206) +DEFINE_INTEGER(207) +DEFINE_INTEGER(208) +DEFINE_INTEGER(209) +DEFINE_INTEGER(210) +DEFINE_INTEGER(211) +DEFINE_INTEGER(212) +DEFINE_INTEGER(213) +DEFINE_INTEGER(214) +DEFINE_INTEGER(215) +DEFINE_INTEGER(216) +DEFINE_INTEGER(217) +DEFINE_INTEGER(218) +DEFINE_INTEGER(219) +DEFINE_INTEGER(220) +DEFINE_INTEGER(221) +DEFINE_INTEGER(222) +DEFINE_INTEGER(223) +DEFINE_INTEGER(224) +DEFINE_INTEGER(225) +DEFINE_INTEGER(226) +DEFINE_INTEGER(227) +DEFINE_INTEGER(228) +DEFINE_INTEGER(229) +DEFINE_INTEGER(230) +DEFINE_INTEGER(231) +DEFINE_INTEGER(232) +DEFINE_INTEGER(233) +DEFINE_INTEGER(234) +DEFINE_INTEGER(235) +DEFINE_INTEGER(236) +DEFINE_INTEGER(237) +DEFINE_INTEGER(238) +DEFINE_INTEGER(239) +DEFINE_INTEGER(240) +DEFINE_INTEGER(241) +DEFINE_INTEGER(242) +DEFINE_INTEGER(243) +DEFINE_INTEGER(244) +DEFINE_INTEGER(245) +DEFINE_INTEGER(246) +DEFINE_INTEGER(247) +DEFINE_INTEGER(248) +DEFINE_INTEGER(249) +DEFINE_INTEGER(250) +DEFINE_INTEGER(251) +DEFINE_INTEGER(252) +DEFINE_INTEGER(253) +DEFINE_INTEGER(254) +DEFINE_INTEGER(255) +DEFINE_INTEGER(256) +DEFINE_INTEGER(257) +DEFINE_INTEGER(258) +DEFINE_INTEGER(259) +DEFINE_INTEGER(260) +DEFINE_INTEGER(261) +DEFINE_INTEGER(262) +DEFINE_INTEGER(263) +DEFINE_INTEGER(264) +DEFINE_INTEGER(265) +DEFINE_INTEGER(266) +DEFINE_INTEGER(267) +DEFINE_INTEGER(268) +DEFINE_INTEGER(269) +DEFINE_INTEGER(270) +DEFINE_INTEGER(271) +DEFINE_INTEGER(272) +DEFINE_INTEGER(273) +DEFINE_INTEGER(274) +DEFINE_INTEGER(275) +DEFINE_INTEGER(276) +DEFINE_INTEGER(277) +DEFINE_INTEGER(278) +DEFINE_INTEGER(279) +DEFINE_INTEGER(280) +DEFINE_INTEGER(281) +DEFINE_INTEGER(282) +DEFINE_INTEGER(283) +DEFINE_INTEGER(284) +DEFINE_INTEGER(285) +DEFINE_INTEGER(286) +DEFINE_INTEGER(287) +DEFINE_INTEGER(288) +DEFINE_INTEGER(289) +DEFINE_INTEGER(290) +DEFINE_INTEGER(291) +DEFINE_INTEGER(292) +DEFINE_INTEGER(293) +DEFINE_INTEGER(294) +DEFINE_INTEGER(295) +DEFINE_INTEGER(296) +DEFINE_INTEGER(297) +DEFINE_INTEGER(298) +DEFINE_INTEGER(299) +DEFINE_INTEGER(300) +DEFINE_INTEGER(301) +DEFINE_INTEGER(302) +DEFINE_INTEGER(303) +DEFINE_INTEGER(304) +DEFINE_INTEGER(305) +DEFINE_INTEGER(306) +DEFINE_INTEGER(307) +DEFINE_INTEGER(308) +DEFINE_INTEGER(309) +DEFINE_INTEGER(310) +DEFINE_INTEGER(311) +DEFINE_INTEGER(312) +DEFINE_INTEGER(313) +DEFINE_INTEGER(314) +DEFINE_INTEGER(315) +DEFINE_INTEGER(316) +DEFINE_INTEGER(317) +DEFINE_INTEGER(318) +DEFINE_INTEGER(319) +DEFINE_INTEGER(320) +DEFINE_INTEGER(321) +DEFINE_INTEGER(322) +DEFINE_INTEGER(323) +DEFINE_INTEGER(324) +DEFINE_INTEGER(325) +DEFINE_INTEGER(326) +DEFINE_INTEGER(327) +DEFINE_INTEGER(328) +DEFINE_INTEGER(329) +DEFINE_INTEGER(330) +DEFINE_INTEGER(331) +DEFINE_INTEGER(332) +DEFINE_INTEGER(333) +DEFINE_INTEGER(334) +DEFINE_INTEGER(335) +DEFINE_INTEGER(336) +DEFINE_INTEGER(337) +DEFINE_INTEGER(338) +DEFINE_INTEGER(339) +DEFINE_INTEGER(340) +DEFINE_INTEGER(341) +DEFINE_INTEGER(342) +DEFINE_INTEGER(343) +DEFINE_INTEGER(344) +DEFINE_INTEGER(345) +DEFINE_INTEGER(346) +DEFINE_INTEGER(347) +DEFINE_INTEGER(348) +DEFINE_INTEGER(349) +DEFINE_INTEGER(350) +DEFINE_INTEGER(351) +DEFINE_INTEGER(352) +DEFINE_INTEGER(353) +DEFINE_INTEGER(354) +DEFINE_INTEGER(355) +DEFINE_INTEGER(356) +DEFINE_INTEGER(357) +DEFINE_INTEGER(358) +DEFINE_INTEGER(359) +DEFINE_INTEGER(360) +DEFINE_INTEGER(361) +DEFINE_INTEGER(362) +DEFINE_INTEGER(363) +DEFINE_INTEGER(364) +DEFINE_INTEGER(365) +DEFINE_INTEGER(366) +DEFINE_INTEGER(367) +DEFINE_INTEGER(368) +DEFINE_INTEGER(369) +DEFINE_INTEGER(370) +DEFINE_INTEGER(371) +DEFINE_INTEGER(372) +DEFINE_INTEGER(373) +DEFINE_INTEGER(374) +DEFINE_INTEGER(375) +DEFINE_INTEGER(376) +DEFINE_INTEGER(377) +DEFINE_INTEGER(378) +DEFINE_INTEGER(379) +DEFINE_INTEGER(380) +DEFINE_INTEGER(381) +DEFINE_INTEGER(382) +DEFINE_INTEGER(383) +DEFINE_INTEGER(384) +DEFINE_INTEGER(385) +DEFINE_INTEGER(386) +DEFINE_INTEGER(387) +DEFINE_INTEGER(388) +DEFINE_INTEGER(389) +DEFINE_INTEGER(390) +DEFINE_INTEGER(391) +DEFINE_INTEGER(392) +DEFINE_INTEGER(393) +DEFINE_INTEGER(394) +DEFINE_INTEGER(395) +DEFINE_INTEGER(396) +DEFINE_INTEGER(397) +DEFINE_INTEGER(398) +DEFINE_INTEGER(399) +DEFINE_INTEGER(400) +DEFINE_INTEGER(401) +DEFINE_INTEGER(402) +DEFINE_INTEGER(403) +DEFINE_INTEGER(404) +DEFINE_INTEGER(405) +DEFINE_INTEGER(406) +DEFINE_INTEGER(407) +DEFINE_INTEGER(408) +DEFINE_INTEGER(409) +DEFINE_INTEGER(410) +DEFINE_INTEGER(411) +DEFINE_INTEGER(412) +DEFINE_INTEGER(413) +DEFINE_INTEGER(414) +DEFINE_INTEGER(415) +DEFINE_INTEGER(416) +DEFINE_INTEGER(417) +DEFINE_INTEGER(418) +DEFINE_INTEGER(419) +DEFINE_INTEGER(420) +DEFINE_INTEGER(421) +DEFINE_INTEGER(422) +DEFINE_INTEGER(423) +DEFINE_INTEGER(424) +DEFINE_INTEGER(425) +DEFINE_INTEGER(426) +DEFINE_INTEGER(427) +DEFINE_INTEGER(428) +DEFINE_INTEGER(429) +DEFINE_INTEGER(430) +DEFINE_INTEGER(431) +DEFINE_INTEGER(432) +DEFINE_INTEGER(433) +DEFINE_INTEGER(434) +DEFINE_INTEGER(435) +DEFINE_INTEGER(436) +DEFINE_INTEGER(437) +DEFINE_INTEGER(438) +DEFINE_INTEGER(439) +DEFINE_INTEGER(440) +DEFINE_INTEGER(441) +DEFINE_INTEGER(442) +DEFINE_INTEGER(443) +DEFINE_INTEGER(444) +DEFINE_INTEGER(445) +DEFINE_INTEGER(446) +DEFINE_INTEGER(447) +DEFINE_INTEGER(448) +DEFINE_INTEGER(449) +DEFINE_INTEGER(450) +DEFINE_INTEGER(451) +DEFINE_INTEGER(452) +DEFINE_INTEGER(453) +DEFINE_INTEGER(454) +DEFINE_INTEGER(455) +DEFINE_INTEGER(456) +DEFINE_INTEGER(457) +DEFINE_INTEGER(458) +DEFINE_INTEGER(459) +DEFINE_INTEGER(460) +DEFINE_INTEGER(461) +DEFINE_INTEGER(462) +DEFINE_INTEGER(463) +DEFINE_INTEGER(464) +DEFINE_INTEGER(465) +DEFINE_INTEGER(466) +DEFINE_INTEGER(467) +DEFINE_INTEGER(468) +DEFINE_INTEGER(469) +DEFINE_INTEGER(470) +DEFINE_INTEGER(471) +DEFINE_INTEGER(472) +DEFINE_INTEGER(473) +DEFINE_INTEGER(474) +DEFINE_INTEGER(475) +DEFINE_INTEGER(476) +DEFINE_INTEGER(477) +DEFINE_INTEGER(478) +DEFINE_INTEGER(479) +DEFINE_INTEGER(480) +DEFINE_INTEGER(481) +DEFINE_INTEGER(482) +DEFINE_INTEGER(483) +DEFINE_INTEGER(484) +DEFINE_INTEGER(485) +DEFINE_INTEGER(486) +DEFINE_INTEGER(487) +DEFINE_INTEGER(488) +DEFINE_INTEGER(489) +DEFINE_INTEGER(490) +DEFINE_INTEGER(491) +DEFINE_INTEGER(492) +DEFINE_INTEGER(493) +DEFINE_INTEGER(494) +DEFINE_INTEGER(495) +DEFINE_INTEGER(496) +DEFINE_INTEGER(497) +DEFINE_INTEGER(498) +DEFINE_INTEGER(499) +DEFINE_INTEGER(500) +DEFINE_INTEGER(501) +DEFINE_INTEGER(502) +DEFINE_INTEGER(503) +DEFINE_INTEGER(504) +DEFINE_INTEGER(505) +DEFINE_INTEGER(506) +DEFINE_INTEGER(507) +DEFINE_INTEGER(508) +DEFINE_INTEGER(509) +DEFINE_INTEGER(510) +DEFINE_INTEGER(511) +DEFINE_INTEGER(512) +DEFINE_INTEGER(513) +DEFINE_INTEGER(514) +DEFINE_INTEGER(515) +DEFINE_INTEGER(516) +DEFINE_INTEGER(517) +DEFINE_INTEGER(518) +DEFINE_INTEGER(519) +DEFINE_INTEGER(520) +DEFINE_INTEGER(521) +DEFINE_INTEGER(522) +DEFINE_INTEGER(523) +DEFINE_INTEGER(524) +DEFINE_INTEGER(525) +DEFINE_INTEGER(526) +DEFINE_INTEGER(527) +DEFINE_INTEGER(528) +DEFINE_INTEGER(529) +DEFINE_INTEGER(530) +DEFINE_INTEGER(531) +DEFINE_INTEGER(532) +DEFINE_INTEGER(533) +DEFINE_INTEGER(534) +DEFINE_INTEGER(535) +DEFINE_INTEGER(536) +DEFINE_INTEGER(537) +DEFINE_INTEGER(538) +DEFINE_INTEGER(539) +DEFINE_INTEGER(540) +DEFINE_INTEGER(541) +DEFINE_INTEGER(542) +DEFINE_INTEGER(543) +DEFINE_INTEGER(544) +DEFINE_INTEGER(545) +DEFINE_INTEGER(546) +DEFINE_INTEGER(547) +DEFINE_INTEGER(548) +DEFINE_INTEGER(549) +DEFINE_INTEGER(550) +DEFINE_INTEGER(551) +DEFINE_INTEGER(552) +DEFINE_INTEGER(553) +DEFINE_INTEGER(554) +DEFINE_INTEGER(555) +DEFINE_INTEGER(556) +DEFINE_INTEGER(557) +DEFINE_INTEGER(558) +DEFINE_INTEGER(559) +DEFINE_INTEGER(560) +DEFINE_INTEGER(561) +DEFINE_INTEGER(562) +DEFINE_INTEGER(563) +DEFINE_INTEGER(564) +DEFINE_INTEGER(565) +DEFINE_INTEGER(566) +DEFINE_INTEGER(567) +DEFINE_INTEGER(568) +DEFINE_INTEGER(569) +DEFINE_INTEGER(570) +DEFINE_INTEGER(571) +DEFINE_INTEGER(572) +DEFINE_INTEGER(573) +DEFINE_INTEGER(574) +DEFINE_INTEGER(575) +DEFINE_INTEGER(576) +DEFINE_INTEGER(577) +DEFINE_INTEGER(578) +DEFINE_INTEGER(579) +DEFINE_INTEGER(580) +DEFINE_INTEGER(581) +DEFINE_INTEGER(582) +DEFINE_INTEGER(583) +DEFINE_INTEGER(584) +DEFINE_INTEGER(585) +DEFINE_INTEGER(586) +DEFINE_INTEGER(587) +DEFINE_INTEGER(588) +DEFINE_INTEGER(589) +DEFINE_INTEGER(590) +DEFINE_INTEGER(591) +DEFINE_INTEGER(592) +DEFINE_INTEGER(593) +DEFINE_INTEGER(594) +DEFINE_INTEGER(595) +DEFINE_INTEGER(596) +DEFINE_INTEGER(597) +DEFINE_INTEGER(598) +DEFINE_INTEGER(599) +DEFINE_INTEGER(600) +DEFINE_INTEGER(601) +DEFINE_INTEGER(602) +DEFINE_INTEGER(603) +DEFINE_INTEGER(604) +DEFINE_INTEGER(605) +DEFINE_INTEGER(606) +DEFINE_INTEGER(607) +DEFINE_INTEGER(608) +DEFINE_INTEGER(609) +DEFINE_INTEGER(610) +DEFINE_INTEGER(611) +DEFINE_INTEGER(612) +DEFINE_INTEGER(613) +DEFINE_INTEGER(614) +DEFINE_INTEGER(615) +DEFINE_INTEGER(616) +DEFINE_INTEGER(617) +DEFINE_INTEGER(618) +DEFINE_INTEGER(619) +DEFINE_INTEGER(620) +DEFINE_INTEGER(621) +DEFINE_INTEGER(622) +DEFINE_INTEGER(623) +DEFINE_INTEGER(624) +DEFINE_INTEGER(625) +DEFINE_INTEGER(626) +DEFINE_INTEGER(627) +DEFINE_INTEGER(628) +DEFINE_INTEGER(629) +DEFINE_INTEGER(630) +DEFINE_INTEGER(631) +DEFINE_INTEGER(632) +DEFINE_INTEGER(633) +DEFINE_INTEGER(634) +DEFINE_INTEGER(635) +DEFINE_INTEGER(636) +DEFINE_INTEGER(637) +DEFINE_INTEGER(638) +DEFINE_INTEGER(639) +DEFINE_INTEGER(640) +DEFINE_INTEGER(641) +DEFINE_INTEGER(642) +DEFINE_INTEGER(643) +DEFINE_INTEGER(644) +DEFINE_INTEGER(645) +DEFINE_INTEGER(646) +DEFINE_INTEGER(647) +DEFINE_INTEGER(648) +DEFINE_INTEGER(649) +DEFINE_INTEGER(650) +DEFINE_INTEGER(651) +DEFINE_INTEGER(652) +DEFINE_INTEGER(653) +DEFINE_INTEGER(654) +DEFINE_INTEGER(655) +DEFINE_INTEGER(656) +DEFINE_INTEGER(657) +DEFINE_INTEGER(658) +DEFINE_INTEGER(659) +DEFINE_INTEGER(660) +DEFINE_INTEGER(661) +DEFINE_INTEGER(662) +DEFINE_INTEGER(663) +DEFINE_INTEGER(664) +DEFINE_INTEGER(665) +DEFINE_INTEGER(666) +DEFINE_INTEGER(667) +DEFINE_INTEGER(668) +DEFINE_INTEGER(669) +DEFINE_INTEGER(670) +DEFINE_INTEGER(671) +DEFINE_INTEGER(672) +DEFINE_INTEGER(673) +DEFINE_INTEGER(674) +DEFINE_INTEGER(675) +DEFINE_INTEGER(676) +DEFINE_INTEGER(677) +DEFINE_INTEGER(678) +DEFINE_INTEGER(679) +DEFINE_INTEGER(680) +DEFINE_INTEGER(681) +DEFINE_INTEGER(682) +DEFINE_INTEGER(683) +DEFINE_INTEGER(684) +DEFINE_INTEGER(685) +DEFINE_INTEGER(686) +DEFINE_INTEGER(687) +DEFINE_INTEGER(688) +DEFINE_INTEGER(689) +DEFINE_INTEGER(690) +DEFINE_INTEGER(691) +DEFINE_INTEGER(692) +DEFINE_INTEGER(693) +DEFINE_INTEGER(694) +DEFINE_INTEGER(695) +DEFINE_INTEGER(696) +DEFINE_INTEGER(697) +DEFINE_INTEGER(698) +DEFINE_INTEGER(699) +DEFINE_INTEGER(700) +DEFINE_INTEGER(701) +DEFINE_INTEGER(702) +DEFINE_INTEGER(703) +DEFINE_INTEGER(704) +DEFINE_INTEGER(705) +DEFINE_INTEGER(706) +DEFINE_INTEGER(707) +DEFINE_INTEGER(708) +DEFINE_INTEGER(709) +DEFINE_INTEGER(710) +DEFINE_INTEGER(711) +DEFINE_INTEGER(712) +DEFINE_INTEGER(713) +DEFINE_INTEGER(714) +DEFINE_INTEGER(715) +DEFINE_INTEGER(716) +DEFINE_INTEGER(717) +DEFINE_INTEGER(718) +DEFINE_INTEGER(719) +DEFINE_INTEGER(720) +DEFINE_INTEGER(721) +DEFINE_INTEGER(722) +DEFINE_INTEGER(723) +DEFINE_INTEGER(724) +DEFINE_INTEGER(725) +DEFINE_INTEGER(726) +DEFINE_INTEGER(727) +DEFINE_INTEGER(728) +DEFINE_INTEGER(729) +DEFINE_INTEGER(730) +DEFINE_INTEGER(731) +DEFINE_INTEGER(732) +DEFINE_INTEGER(733) +DEFINE_INTEGER(734) +DEFINE_INTEGER(735) +DEFINE_INTEGER(736) +DEFINE_INTEGER(737) +DEFINE_INTEGER(738) +DEFINE_INTEGER(739) +DEFINE_INTEGER(740) +DEFINE_INTEGER(741) +DEFINE_INTEGER(742) +DEFINE_INTEGER(743) +DEFINE_INTEGER(744) +DEFINE_INTEGER(745) +DEFINE_INTEGER(746) +DEFINE_INTEGER(747) +DEFINE_INTEGER(748) +DEFINE_INTEGER(749) +DEFINE_INTEGER(750) +DEFINE_INTEGER(751) +DEFINE_INTEGER(752) +DEFINE_INTEGER(753) +DEFINE_INTEGER(754) +DEFINE_INTEGER(755) +DEFINE_INTEGER(756) +DEFINE_INTEGER(757) +DEFINE_INTEGER(758) +DEFINE_INTEGER(759) +DEFINE_INTEGER(760) +DEFINE_INTEGER(761) +DEFINE_INTEGER(762) +DEFINE_INTEGER(763) +DEFINE_INTEGER(764) +DEFINE_INTEGER(765) +DEFINE_INTEGER(766) +DEFINE_INTEGER(767) +DEFINE_INTEGER(768) +DEFINE_INTEGER(769) +DEFINE_INTEGER(770) +DEFINE_INTEGER(771) +DEFINE_INTEGER(772) +DEFINE_INTEGER(773) +DEFINE_INTEGER(774) +DEFINE_INTEGER(775) +DEFINE_INTEGER(776) +DEFINE_INTEGER(777) +DEFINE_INTEGER(778) +DEFINE_INTEGER(779) +DEFINE_INTEGER(780) +DEFINE_INTEGER(781) +DEFINE_INTEGER(782) +DEFINE_INTEGER(783) +DEFINE_INTEGER(784) +DEFINE_INTEGER(785) +DEFINE_INTEGER(786) +DEFINE_INTEGER(787) +DEFINE_INTEGER(788) +DEFINE_INTEGER(789) +DEFINE_INTEGER(790) +DEFINE_INTEGER(791) +DEFINE_INTEGER(792) +DEFINE_INTEGER(793) +DEFINE_INTEGER(794) +DEFINE_INTEGER(795) +DEFINE_INTEGER(796) +DEFINE_INTEGER(797) +DEFINE_INTEGER(798) +DEFINE_INTEGER(799) +DEFINE_INTEGER(800) +DEFINE_INTEGER(801) +DEFINE_INTEGER(802) +DEFINE_INTEGER(803) +DEFINE_INTEGER(804) +DEFINE_INTEGER(805) +DEFINE_INTEGER(806) +DEFINE_INTEGER(807) +DEFINE_INTEGER(808) +DEFINE_INTEGER(809) +DEFINE_INTEGER(810) +DEFINE_INTEGER(811) +DEFINE_INTEGER(812) +DEFINE_INTEGER(813) +DEFINE_INTEGER(814) +DEFINE_INTEGER(815) +DEFINE_INTEGER(816) +DEFINE_INTEGER(817) -- cgit v1.2.3 From 19a1be5ac3c9f3e26c453cf2ddc6d88af19e2d43 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 13:32:38 +0200 Subject: gpgscm: Merge 'opexe_1'. * tests/gpgscm/scheme.c (opexe_1): Merge into 'opexe_0'. * tests/gpgscm/opdefines.h: Adapt. -- Having separate functions to execute opcodes reduces our ability to thread the code and prevents the dispatch_table from being moved to rodata. Signed-off-by: Justus Winter --- opdefines.h | 40 ++++++++++++++++++++-------------------- scheme.c | 11 ----------- 2 files changed, 20 insertions(+), 31 deletions(-) diff --git a/opdefines.h b/opdefines.h index 2d17720..affc788 100644 --- a/opdefines.h +++ b/opdefines.h @@ -38,26 +38,26 @@ _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 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0REC ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1REC ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2REC ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_COND0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_COND1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DELAY ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_AND0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_AND1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_OR0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_OR1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_C0STREAM ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_C1STREAM ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_MACRO0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_MACRO1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CASE0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CASE1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CASE2 ) + _OP_DEF(opexe_0, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) + _OP_DEF(opexe_0, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) + _OP_DEF(opexe_0, "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 ) diff --git a/scheme.c b/scheme.c index e04394d..c3c88d0 100644 --- a/scheme.c +++ b/scheme.c @@ -438,7 +438,6 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_1(scheme *sc, enum scheme_opcodes op); static pointer opexe_2(scheme *sc, enum scheme_opcodes op); static pointer opexe_3(scheme *sc, enum scheme_opcodes op); static pointer opexe_4(scheme *sc, enum scheme_opcodes op); @@ -3744,17 +3743,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->args = sc->NIL; s_thread_to(sc,OP_BEGIN); } - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - switch (op) { CASE(OP_LET0REC): /* letrec */ new_frame_in_env(sc, sc->envir); sc->args = sc->NIL; -- cgit v1.2.3 From 7bc96831c7156fa07cfd55259f309ca4fa676c2e Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 13:40:01 +0200 Subject: gpgscm: Merge 'opexe_2'. * tests/gpgscm/scheme.c (opexe_2): Merge into 'opexe_0'. * tests/gpgscm/opdefines.h: Adapt. -- Having separate functions to execute opcodes reduces our ability to thread the code and prevents the dispatch_table from being moved to rodata. Signed-off-by: Justus Winter --- opdefines.h | 92 ++++++++++++++++++++++++------------------------ scheme.c | 114 +++++++++++++++++++++++++++--------------------------------- 2 files changed, 98 insertions(+), 108 deletions(-) diff --git a/opdefines.h b/opdefines.h index affc788..bb99698 100644 --- a/opdefines.h +++ b/opdefines.h @@ -59,53 +59,53 @@ _OP_DEF(opexe_0, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) _OP_DEF(opexe_0, "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 ) + _OP_DEF(opexe_0, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) + _OP_DEF(opexe_0, "exp", 1, 1, TST_NUMBER, OP_EXP ) + _OP_DEF(opexe_0, "log", 1, 1, TST_NUMBER, OP_LOG ) + _OP_DEF(opexe_0, "sin", 1, 1, TST_NUMBER, OP_SIN ) + _OP_DEF(opexe_0, "cos", 1, 1, TST_NUMBER, OP_COS ) + _OP_DEF(opexe_0, "tan", 1, 1, TST_NUMBER, OP_TAN ) + _OP_DEF(opexe_0, "asin", 1, 1, TST_NUMBER, OP_ASIN ) + _OP_DEF(opexe_0, "acos", 1, 1, TST_NUMBER, OP_ACOS ) + _OP_DEF(opexe_0, "atan", 1, 2, TST_NUMBER, OP_ATAN ) + _OP_DEF(opexe_0, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) + _OP_DEF(opexe_0, "expt", 2, 2, TST_NUMBER, OP_EXPT ) + _OP_DEF(opexe_0, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) + _OP_DEF(opexe_0, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) + _OP_DEF(opexe_0, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) + _OP_DEF(opexe_0, "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_0, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) + _OP_DEF(opexe_0, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) + _OP_DEF(opexe_0, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) + _OP_DEF(opexe_0, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) + _OP_DEF(opexe_0, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) + _OP_DEF(opexe_0, "remainder", 2, 2, TST_INTEGER, OP_REM ) + _OP_DEF(opexe_0, "modulo", 2, 2, TST_INTEGER, OP_MOD ) + _OP_DEF(opexe_0, "car", 1, 1, TST_PAIR, OP_CAR ) + _OP_DEF(opexe_0, "cdr", 1, 1, TST_PAIR, OP_CDR ) + _OP_DEF(opexe_0, "cons", 2, 2, TST_NONE, OP_CONS ) + _OP_DEF(opexe_0, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) + _OP_DEF(opexe_0, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) + _OP_DEF(opexe_0, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) + _OP_DEF(opexe_0, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) + _OP_DEF(opexe_0, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) + _OP_DEF(opexe_0, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) + _OP_DEF(opexe_0, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) + _OP_DEF(opexe_0, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) + _OP_DEF(opexe_0, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) + _OP_DEF(opexe_0, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) + _OP_DEF(opexe_0, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) + _OP_DEF(opexe_0, "string-length", 1, 1, TST_STRING, OP_STRLEN ) + _OP_DEF(opexe_0, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) + _OP_DEF(opexe_0, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) + _OP_DEF(opexe_0, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) + _OP_DEF(opexe_0, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) + _OP_DEF(opexe_0, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) + _OP_DEF(opexe_0, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) + _OP_DEF(opexe_0, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) + _OP_DEF(opexe_0, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) + _OP_DEF(opexe_0, "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 ) diff --git a/scheme.c b/scheme.c index c3c88d0..31baed2 100644 --- a/scheme.c +++ b/scheme.c @@ -438,7 +438,6 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_2(scheme *sc, enum scheme_opcodes op); static pointer opexe_3(scheme *sc, enum scheme_opcodes op); static pointer opexe_4(scheme *sc, enum scheme_opcodes op); static pointer opexe_5(scheme *sc, enum scheme_opcodes op); @@ -3276,11 +3275,63 @@ history_flatten(scheme *sc) +#if USE_PLIST +static pointer +get_property(scheme *sc, pointer obj, pointer key) +{ + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + return cdar(x); + + return sc->NIL; +} + +static pointer +set_property(scheme *sc, pointer obj, pointer key, pointer value) +{ +#define set_property_allocates 2 + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + cdar(x) = value; + else { + gc_disable(sc, gc_reservations(set_property)); + symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); + gc_enable(sc); + } + + return sc->T; +} +#endif + + + #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { pointer x, y; pointer callsite; + num v; +#if USE_MATH + double dd; +#endif switch (op) { CASE(OP_LOAD): /* load */ @@ -3968,67 +4019,6 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { gc_enable(sc); s_goto(sc,OP_APPLY); - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -#if USE_PLIST -static pointer -get_property(scheme *sc, pointer obj, pointer key) -{ - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - return cdar(x); - - return sc->NIL; -} - -static pointer -set_property(scheme *sc, pointer obj, pointer key, pointer value) -{ -#define set_property_allocates 2 - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - cdar(x) = value; - else { - gc_disable(sc, gc_reservations(set_property)); - symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); - gc_enable(sc); - } - - return sc->T; -} -#endif - -static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; -#if USE_MATH - double dd; -#endif - - switch (op) { #if USE_MATH CASE(OP_INEX2EX): /* inexact->exact */ x=car(sc->args); -- cgit v1.2.3 From b13610ec7bf2bf199eb22f936bc2f2d4ac240fde Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 13:45:25 +0200 Subject: gpgscm: Merge 'opexe_3'. * tests/gpgscm/scheme.c (opexe_3): Merge into 'opexe_0'. * tests/gpgscm/opdefines.h: Adapt. -- Having separate functions to execute opcodes reduces our ability to thread the code and prevents the dispatch_table from being moved to rodata. Signed-off-by: Justus Winter --- opdefines.h | 60 ++++++++++++++++++------------------ scheme.c | 101 +++++++++++++++++++++++++++--------------------------------- 2 files changed, 75 insertions(+), 86 deletions(-) diff --git a/opdefines.h b/opdefines.h index bb99698..f4e5280 100644 --- a/opdefines.h +++ b/opdefines.h @@ -106,38 +106,38 @@ _OP_DEF(opexe_0, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) _OP_DEF(opexe_0, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) _OP_DEF(opexe_0, "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 ) + _OP_DEF(opexe_0, "not", 1, 1, TST_NONE, OP_NOT ) + _OP_DEF(opexe_0, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) + _OP_DEF(opexe_0, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) + _OP_DEF(opexe_0, "null?", 1, 1, TST_NONE, OP_NULLP ) + _OP_DEF(opexe_0, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) + _OP_DEF(opexe_0, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) + _OP_DEF(opexe_0, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) + _OP_DEF(opexe_0, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) + _OP_DEF(opexe_0, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) + _OP_DEF(opexe_0, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) + _OP_DEF(opexe_0, "number?", 1, 1, TST_ANY, OP_NUMBERP ) + _OP_DEF(opexe_0, "string?", 1, 1, TST_ANY, OP_STRINGP ) + _OP_DEF(opexe_0, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) + _OP_DEF(opexe_0, "real?", 1, 1, TST_ANY, OP_REALP ) + _OP_DEF(opexe_0, "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 ) + _OP_DEF(opexe_0, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) + _OP_DEF(opexe_0, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) + _OP_DEF(opexe_0, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) + _OP_DEF(opexe_0, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) + _OP_DEF(opexe_0, "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_0, "port?", 1, 1, TST_ANY, OP_PORTP ) + _OP_DEF(opexe_0, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) + _OP_DEF(opexe_0, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) + _OP_DEF(opexe_0, "procedure?", 1, 1, TST_ANY, OP_PROCP ) + _OP_DEF(opexe_0, "pair?", 1, 1, TST_ANY, OP_PAIRP ) + _OP_DEF(opexe_0, "list?", 1, 1, TST_ANY, OP_LISTP ) + _OP_DEF(opexe_0, "environment?", 1, 1, TST_ANY, OP_ENVP ) + _OP_DEF(opexe_0, "vector?", 1, 1, TST_ANY, OP_VECTORP ) + _OP_DEF(opexe_0, "eq?", 2, 2, TST_ANY, OP_EQ ) + _OP_DEF(opexe_0, "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 ) diff --git a/scheme.c b/scheme.c index 31baed2..e3f06de 100644 --- a/scheme.c +++ b/scheme.c @@ -438,7 +438,6 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_3(scheme *sc, enum scheme_opcodes op); static pointer opexe_4(scheme *sc, enum scheme_opcodes op); static pointer opexe_5(scheme *sc, enum scheme_opcodes op); static pointer opexe_6(scheme *sc, enum scheme_opcodes op); @@ -3323,6 +3322,50 @@ set_property(scheme *sc, pointer obj, pointer key, pointer value) +static int is_list(scheme *sc, pointer a) +{ return list_length(sc,a) >= 0; } + +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +int list_length(scheme *sc, pointer a) { + int i=0; + pointer slow, fast; + + slow = fast = a; + while (1) + { + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + fast = cdr(fast); + ++i; + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + ++i; + fast = cdr(fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr(slow); + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + + + #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { @@ -3332,6 +3375,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { #if USE_MATH double dd; #endif + int (*comp_func)(num, num) = NULL; switch (op) { CASE(OP_LOAD): /* load */ @@ -4506,61 +4550,6 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_return(sc,car(sc->args)); } - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static int is_list(scheme *sc, pointer a) -{ return list_length(sc,a) >= 0; } - -/* Result is: - proper list: length - circular list: -1 - not even a pair: -2 - dotted list: -2 minus length before dot -*/ -int list_length(scheme *sc, pointer a) { - int i=0; - pointer slow, fast; - - slow = fast = a; - while (1) - { - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - fast = cdr(fast); - ++i; - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - ++i; - fast = cdr(fast); - - /* Safe because we would have already returned if `fast' - encountered a non-pair. */ - slow = cdr(slow); - if (fast == slow) - { - /* the fast pointer has looped back around and caught up - with the slow pointer, hence the structure is circular, - not of finite length, and therefore not a list */ - return -1; - } - } -} - -static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; - int (*comp_func)(num,num)=0; - - switch (op) { CASE(OP_NOT): /* not */ s_retbool(is_false(car(sc->args))); CASE(OP_BOOLP): /* boolean? */ -- cgit v1.2.3 From 5898ead4a99d3bc9e23859daf2cca9632d92f1f7 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 13:47:54 +0200 Subject: gpgscm: Merge 'opexe_4'. * tests/gpgscm/scheme.c (opexe_4): Merge into 'opexe_0'. * tests/gpgscm/opdefines.h: Adapt. -- Having separate functions to execute opcodes reduces our ability to thread the code and prevents the dispatch_table from being moved to rodata. Signed-off-by: Justus Winter --- opdefines.h | 68 ++++++++++++++++++++++++++++++------------------------------- scheme.c | 15 +++----------- 2 files changed, 37 insertions(+), 46 deletions(-) diff --git a/opdefines.h b/opdefines.h index f4e5280..7bdaefb 100644 --- a/opdefines.h +++ b/opdefines.h @@ -138,46 +138,46 @@ _OP_DEF(opexe_0, "vector?", 1, 1, TST_ANY, OP_VECTORP ) _OP_DEF(opexe_0, "eq?", 2, 2, TST_ANY, OP_EQ ) _OP_DEF(opexe_0, "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 ) + _OP_DEF(opexe_0, "force", 1, 1, TST_ANY, OP_FORCE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SAVE_FORCED ) + _OP_DEF(opexe_0, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) + _OP_DEF(opexe_0, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) + _OP_DEF(opexe_0, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) + _OP_DEF(opexe_0, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) + _OP_DEF(opexe_0, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_ERR1 ) + _OP_DEF(opexe_0, "reverse", 1, 1, TST_LIST, OP_REVERSE ) + _OP_DEF(opexe_0, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) + _OP_DEF(opexe_0, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) #if USE_PLIST - _OP_DEF(opexe_4, "set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) - _OP_DEF(opexe_4, "symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) + _OP_DEF(opexe_0, "set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) + _OP_DEF(opexe_0, "symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) #endif #if USE_TAGS - _OP_DEF(opexe_4, NULL, 0, 0, TST_NONE, OP_TAG_VALUE ) - _OP_DEF(opexe_4, "make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) - _OP_DEF(opexe_4, "get-tag", 1, 1, TST_ANY, OP_GET_TAG ) + _OP_DEF(opexe_0, NULL, 0, 0, TST_NONE, OP_TAG_VALUE ) + _OP_DEF(opexe_0, "make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) + _OP_DEF(opexe_0, "get-tag", 1, 1, TST_ANY, OP_GET_TAG ) #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 ) + _OP_DEF(opexe_0, "quit", 0, 1, TST_NUMBER, OP_QUIT ) + _OP_DEF(opexe_0, "gc", 0, 0, 0, OP_GC ) + _OP_DEF(opexe_0, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) + _OP_DEF(opexe_0, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) + _OP_DEF(opexe_0, "oblist", 0, 0, 0, OP_OBLIST ) + _OP_DEF(opexe_0, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) + _OP_DEF(opexe_0, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) + _OP_DEF(opexe_0, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) + _OP_DEF(opexe_0, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) + _OP_DEF(opexe_0, "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 ) + _OP_DEF(opexe_0, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) + _OP_DEF(opexe_0, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) + _OP_DEF(opexe_0, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) + _OP_DEF(opexe_0, "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_0, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) + _OP_DEF(opexe_0, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) + _OP_DEF(opexe_0, "interaction-environment", 0, 0, 0, OP_INT_ENV ) + _OP_DEF(opexe_0, "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 ) diff --git a/scheme.c b/scheme.c index e3f06de..48e0f3f 100644 --- a/scheme.c +++ b/scheme.c @@ -438,7 +438,6 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_4(scheme *sc, enum scheme_opcodes op); static pointer opexe_5(scheme *sc, enum scheme_opcodes op); static pointer opexe_6(scheme *sc, enum scheme_opcodes op); static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); @@ -4633,17 +4632,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_retbool(car(sc->args) == cadr(sc->args)); CASE(OP_EQV): /* eqv? */ s_retbool(eqv(car(sc->args), cadr(sc->args))); - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} -static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { CASE(OP_FORCE): /* force */ sc->code = car(sc->args); if (is_promise(sc->code)) { @@ -4823,7 +4812,6 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { } s_return(sc,p); break; - default: assert (! "reached"); } #if USE_STRING_PORTS @@ -4889,6 +4877,9 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { CASE(OP_CURR_ENV): /* current-environment */ s_return(sc,sc->envir); + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); } return sc->T; } -- cgit v1.2.3 From 72674f169386d68a6d0fc2ba4bc5a065435802a0 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 13:57:54 +0200 Subject: gpgscm: Merge 'opexe_5'. * tests/gpgscm/scheme.c (opexe_5): Merge into 'opexe_0'. * tests/gpgscm/opdefines.h: Adapt. -- Having separate functions to execute opcodes reduces our ability to thread the code and prevents the dispatch_table from being moved to rodata. Signed-off-by: Justus Winter --- opdefines.h | 36 ++++++++++++++++++------------------ scheme.c | 18 ------------------ 2 files changed, 18 insertions(+), 36 deletions(-) diff --git a/opdefines.h b/opdefines.h index 7bdaefb..9cb723a 100644 --- a/opdefines.h +++ b/opdefines.h @@ -178,24 +178,24 @@ _OP_DEF(opexe_0, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) _OP_DEF(opexe_0, "interaction-environment", 0, 0, 0, OP_INT_ENV ) _OP_DEF(opexe_0, "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_0, "read", 0, 1, TST_INPORT, OP_READ ) + _OP_DEF(opexe_0, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) + _OP_DEF(opexe_0, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) + _OP_DEF(opexe_0, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) + _OP_DEF(opexe_0, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) + _OP_DEF(opexe_0, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDSEXPR ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDLIST ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDDOT ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDQUOTE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDQQUOTE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDQQUOTEVEC ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDUNQUOTE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDUQTSP ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDVEC ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_P0LIST ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_P1LIST ) + _OP_DEF(opexe_0, 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 ) diff --git a/scheme.c b/scheme.c index 48e0f3f..917f46b 100644 --- a/scheme.c +++ b/scheme.c @@ -438,7 +438,6 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_5(scheme *sc, enum scheme_opcodes op); static pointer opexe_6(scheme *sc, enum scheme_opcodes op); static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); static void assign_syntax(scheme *sc, char *name); @@ -4877,24 +4876,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_CURR_ENV): /* current-environment */ s_return(sc,sc->envir); - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} -static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { - pointer x; - - if(sc->nesting!=0) { - int n=sc->nesting; - sc->nesting=0; - sc->retcode=-1; - Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); - } - - switch (op) { /* ========== reading part ========== */ CASE(OP_READ): if(!is_pair(sc->args)) { -- cgit v1.2.3 From c183d8f4c6cdf6b48265f01e4c007895f2626fc5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 14:05:22 +0200 Subject: gpgscm: Merge 'opexe_6'. * tests/gpgscm/scheme.c (opexe_6): Merge into 'opexe_0'. * tests/gpgscm/opdefines.h: Adapt. -- Having separate functions to execute opcodes reduces our ability to thread the code and prevents the dispatch_table from being moved to rodata. Signed-off-by: Justus Winter --- opdefines.h | 12 ++++++------ scheme.c | 24 +++++------------------- 2 files changed, 11 insertions(+), 25 deletions(-) diff --git a/opdefines.h b/opdefines.h index 9cb723a..1a5076b 100644 --- a/opdefines.h +++ b/opdefines.h @@ -196,11 +196,11 @@ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_P0LIST ) _OP_DEF(opexe_0, 0, 0, 0, 0, OP_P1LIST ) _OP_DEF(opexe_0, 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 ) - _OP_DEF(opexe_6, "*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) + _OP_DEF(opexe_0, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) + _OP_DEF(opexe_0, "assq", 2, 2, TST_NONE, OP_ASSQ ) + _OP_DEF(opexe_0, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) + _OP_DEF(opexe_0, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) + _OP_DEF(opexe_0, "macro?", 1, 1, TST_NONE, OP_MACROP ) + _OP_DEF(opexe_0, "*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) #undef _OP_DEF diff --git a/scheme.c b/scheme.c index 917f46b..f90ac3f 100644 --- a/scheme.c +++ b/scheme.c @@ -438,7 +438,6 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_6(scheme *sc, enum scheme_opcodes op); static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); static void assign_syntax(scheme *sc, char *name); static int syntaxnum(pointer p); @@ -5158,27 +5157,14 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } } - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - - } - return sc->T; -} - -static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - long v; - - switch (op) { - CASE(OP_LIST_LENGTH): /* length */ /* a.k */ - v=list_length(sc,car(sc->args)); - if(v<0) { + CASE(OP_LIST_LENGTH): { /* length */ /* a.k */ + long l = list_length(sc, car(sc->args)); + if(l<0) { Error_1(sc,"length: not a list:",car(sc->args)); } gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, v)); - + s_return_enable_gc(sc, mk_integer(sc, l)); + } CASE(OP_ASSQ): /* assq */ /* a.k */ x = car(sc->args); for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { -- cgit v1.2.3 From 6d99d2f287aa40d8add81ce892026dfe05768fd4 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 14:11:58 +0200 Subject: gpgscm: Remove now obsolete dispatcher function from the opcodes. * tests/gpgscm/opdefines.h: Remove now obsolete dispatcher function from the opcodes. * tests/gpgscm/scheme-private.h (_OP_DEF): Adapt. * tests/gpgscm/scheme.c (dispatch_func): Remove type declaration. (op_code_info): Remove 'func'. (_OP_DEF): Adapt. (Eval_Cycle): Always call 'opexe_0'. Signed-off-by: Justus Winter --- opdefines.h | 376 +++++++++++++++++++++++++++---------------------------- scheme-private.h | 2 +- scheme.c | 7 +- 3 files changed, 191 insertions(+), 194 deletions(-) diff --git a/opdefines.h b/opdefines.h index 1a5076b..6c53e1f 100644 --- a/opdefines.h +++ b/opdefines.h @@ -1,206 +1,206 @@ - _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 ) +_OP_DEF("load", 1, 1, TST_STRING, OP_LOAD ) +_OP_DEF(0, 0, 0, 0, OP_T0LVL ) +_OP_DEF(0, 0, 0, 0, OP_T1LVL ) +_OP_DEF(0, 0, 0, 0, OP_READ_INTERNAL ) +_OP_DEF("gensym", 0, 0, 0, OP_GENSYM ) +_OP_DEF(0, 0, 0, 0, OP_VALUEPRINT ) +_OP_DEF(0, 0, 0, 0, OP_EVAL ) #if USE_TRACING - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL ) +_OP_DEF(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(0, 0, 0, 0, OP_E0ARGS ) +_OP_DEF(0, 0, 0, 0, OP_E1ARGS ) #if USE_HISTORY - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CALLSTACK_POP ) +_OP_DEF(0, 0, 0, 0, OP_CALLSTACK_POP ) #endif - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY_CODE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) +_OP_DEF(0, 0, 0, 0, OP_APPLY_CODE ) +_OP_DEF(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 ) +_OP_DEF(0, 0, 0, 0, OP_REAL_APPLY ) +_OP_DEF("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_0, 0, 0, 0, 0, OP_LET0REC ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1REC ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2REC ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_COND0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_COND1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DELAY ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_AND0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_AND1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_OR0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_OR1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_C0STREAM ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_C1STREAM ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_MACRO0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_MACRO1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CASE0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CASE1 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_CASE2 ) - _OP_DEF(opexe_0, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) - _OP_DEF(opexe_0, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) - _OP_DEF(opexe_0, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) +_OP_DEF(0, 0, 0, 0, OP_DOMACRO ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA1 ) +_OP_DEF("make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) +_OP_DEF(0, 0, 0, 0, OP_QUOTE ) +_OP_DEF(0, 0, 0, 0, OP_DEF0 ) +_OP_DEF(0, 0, 0, 0, OP_DEF1 ) +_OP_DEF("defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) +_OP_DEF(0, 0, 0, 0, OP_BEGIN ) +_OP_DEF(0, 0, 0, 0, OP_IF0 ) +_OP_DEF(0, 0, 0, 0, OP_IF1 ) +_OP_DEF(0, 0, 0, 0, OP_SET0 ) +_OP_DEF(0, 0, 0, 0, OP_SET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET0 ) +_OP_DEF(0, 0, 0, 0, OP_LET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET2 ) +_OP_DEF(0, 0, 0, 0, OP_LET0AST ) +_OP_DEF(0, 0, 0, 0, OP_LET1AST ) +_OP_DEF(0, 0, 0, 0, OP_LET2AST ) +_OP_DEF(0, 0, 0, 0, OP_LET0REC ) +_OP_DEF(0, 0, 0, 0, OP_LET1REC ) +_OP_DEF(0, 0, 0, 0, OP_LET2REC ) +_OP_DEF(0, 0, 0, 0, OP_COND0 ) +_OP_DEF(0, 0, 0, 0, OP_COND1 ) +_OP_DEF(0, 0, 0, 0, OP_DELAY ) +_OP_DEF(0, 0, 0, 0, OP_AND0 ) +_OP_DEF(0, 0, 0, 0, OP_AND1 ) +_OP_DEF(0, 0, 0, 0, OP_OR0 ) +_OP_DEF(0, 0, 0, 0, OP_OR1 ) +_OP_DEF(0, 0, 0, 0, OP_C0STREAM ) +_OP_DEF(0, 0, 0, 0, OP_C1STREAM ) +_OP_DEF(0, 0, 0, 0, OP_MACRO0 ) +_OP_DEF(0, 0, 0, 0, OP_MACRO1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE0 ) +_OP_DEF(0, 0, 0, 0, OP_CASE1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE2 ) +_OP_DEF("eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) +_OP_DEF("apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) +_OP_DEF("call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) #if USE_MATH - _OP_DEF(opexe_0, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) - _OP_DEF(opexe_0, "exp", 1, 1, TST_NUMBER, OP_EXP ) - _OP_DEF(opexe_0, "log", 1, 1, TST_NUMBER, OP_LOG ) - _OP_DEF(opexe_0, "sin", 1, 1, TST_NUMBER, OP_SIN ) - _OP_DEF(opexe_0, "cos", 1, 1, TST_NUMBER, OP_COS ) - _OP_DEF(opexe_0, "tan", 1, 1, TST_NUMBER, OP_TAN ) - _OP_DEF(opexe_0, "asin", 1, 1, TST_NUMBER, OP_ASIN ) - _OP_DEF(opexe_0, "acos", 1, 1, TST_NUMBER, OP_ACOS ) - _OP_DEF(opexe_0, "atan", 1, 2, TST_NUMBER, OP_ATAN ) - _OP_DEF(opexe_0, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) - _OP_DEF(opexe_0, "expt", 2, 2, TST_NUMBER, OP_EXPT ) - _OP_DEF(opexe_0, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) - _OP_DEF(opexe_0, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) - _OP_DEF(opexe_0, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) - _OP_DEF(opexe_0, "round", 1, 1, TST_NUMBER, OP_ROUND ) +_OP_DEF("inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) +_OP_DEF("exp", 1, 1, TST_NUMBER, OP_EXP ) +_OP_DEF("log", 1, 1, TST_NUMBER, OP_LOG ) +_OP_DEF("sin", 1, 1, TST_NUMBER, OP_SIN ) +_OP_DEF("cos", 1, 1, TST_NUMBER, OP_COS ) +_OP_DEF("tan", 1, 1, TST_NUMBER, OP_TAN ) +_OP_DEF("asin", 1, 1, TST_NUMBER, OP_ASIN ) +_OP_DEF("acos", 1, 1, TST_NUMBER, OP_ACOS ) +_OP_DEF("atan", 1, 2, TST_NUMBER, OP_ATAN ) +_OP_DEF("sqrt", 1, 1, TST_NUMBER, OP_SQRT ) +_OP_DEF("expt", 2, 2, TST_NUMBER, OP_EXPT ) +_OP_DEF("floor", 1, 1, TST_NUMBER, OP_FLOOR ) +_OP_DEF("ceiling", 1, 1, TST_NUMBER, OP_CEILING ) +_OP_DEF("truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) +_OP_DEF("round", 1, 1, TST_NUMBER, OP_ROUND ) #endif - _OP_DEF(opexe_0, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) - _OP_DEF(opexe_0, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) - _OP_DEF(opexe_0, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) - _OP_DEF(opexe_0, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) - _OP_DEF(opexe_0, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) - _OP_DEF(opexe_0, "remainder", 2, 2, TST_INTEGER, OP_REM ) - _OP_DEF(opexe_0, "modulo", 2, 2, TST_INTEGER, OP_MOD ) - _OP_DEF(opexe_0, "car", 1, 1, TST_PAIR, OP_CAR ) - _OP_DEF(opexe_0, "cdr", 1, 1, TST_PAIR, OP_CDR ) - _OP_DEF(opexe_0, "cons", 2, 2, TST_NONE, OP_CONS ) - _OP_DEF(opexe_0, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) - _OP_DEF(opexe_0, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) - _OP_DEF(opexe_0, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) - _OP_DEF(opexe_0, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) - _OP_DEF(opexe_0, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) - _OP_DEF(opexe_0, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) - _OP_DEF(opexe_0, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) - _OP_DEF(opexe_0, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) - _OP_DEF(opexe_0, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) - _OP_DEF(opexe_0, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) - _OP_DEF(opexe_0, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) - _OP_DEF(opexe_0, "string-length", 1, 1, TST_STRING, OP_STRLEN ) - _OP_DEF(opexe_0, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) - _OP_DEF(opexe_0, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) - _OP_DEF(opexe_0, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) - _OP_DEF(opexe_0, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) - _OP_DEF(opexe_0, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) - _OP_DEF(opexe_0, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) - _OP_DEF(opexe_0, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) - _OP_DEF(opexe_0, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) - _OP_DEF(opexe_0, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) - _OP_DEF(opexe_0, "not", 1, 1, TST_NONE, OP_NOT ) - _OP_DEF(opexe_0, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) - _OP_DEF(opexe_0, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) - _OP_DEF(opexe_0, "null?", 1, 1, TST_NONE, OP_NULLP ) - _OP_DEF(opexe_0, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) - _OP_DEF(opexe_0, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) - _OP_DEF(opexe_0, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) - _OP_DEF(opexe_0, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) - _OP_DEF(opexe_0, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) - _OP_DEF(opexe_0, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) - _OP_DEF(opexe_0, "number?", 1, 1, TST_ANY, OP_NUMBERP ) - _OP_DEF(opexe_0, "string?", 1, 1, TST_ANY, OP_STRINGP ) - _OP_DEF(opexe_0, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) - _OP_DEF(opexe_0, "real?", 1, 1, TST_ANY, OP_REALP ) - _OP_DEF(opexe_0, "char?", 1, 1, TST_ANY, OP_CHARP ) +_OP_DEF("+", 0, INF_ARG, TST_NUMBER, OP_ADD ) +_OP_DEF("-", 1, INF_ARG, TST_NUMBER, OP_SUB ) +_OP_DEF("*", 0, INF_ARG, TST_NUMBER, OP_MUL ) +_OP_DEF("/", 1, INF_ARG, TST_NUMBER, OP_DIV ) +_OP_DEF("quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) +_OP_DEF("remainder", 2, 2, TST_INTEGER, OP_REM ) +_OP_DEF("modulo", 2, 2, TST_INTEGER, OP_MOD ) +_OP_DEF("car", 1, 1, TST_PAIR, OP_CAR ) +_OP_DEF("cdr", 1, 1, TST_PAIR, OP_CDR ) +_OP_DEF("cons", 2, 2, TST_NONE, OP_CONS ) +_OP_DEF("set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) +_OP_DEF("set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) +_OP_DEF("char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) +_OP_DEF("integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) +_OP_DEF("char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) +_OP_DEF("char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) +_OP_DEF("symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) +_OP_DEF("atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) +_OP_DEF("string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) +_OP_DEF("string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) +_OP_DEF("make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) +_OP_DEF("string-length", 1, 1, TST_STRING, OP_STRLEN ) +_OP_DEF("string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) +_OP_DEF("string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) +_OP_DEF("string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) +_OP_DEF("substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) +_OP_DEF("vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) +_OP_DEF("make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) +_OP_DEF("vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) +_OP_DEF("vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) +_OP_DEF("vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) +_OP_DEF("not", 1, 1, TST_NONE, OP_NOT ) +_OP_DEF("boolean?", 1, 1, TST_NONE, OP_BOOLP ) +_OP_DEF("eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) +_OP_DEF("null?", 1, 1, TST_NONE, OP_NULLP ) +_OP_DEF("=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) +_OP_DEF("<", 2, INF_ARG, TST_NUMBER, OP_LESS ) +_OP_DEF(">", 2, INF_ARG, TST_NUMBER, OP_GRE ) +_OP_DEF("<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) +_OP_DEF(">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) +_OP_DEF("symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) +_OP_DEF("number?", 1, 1, TST_ANY, OP_NUMBERP ) +_OP_DEF("string?", 1, 1, TST_ANY, OP_STRINGP ) +_OP_DEF("integer?", 1, 1, TST_ANY, OP_INTEGERP ) +_OP_DEF("real?", 1, 1, TST_ANY, OP_REALP ) +_OP_DEF("char?", 1, 1, TST_ANY, OP_CHARP ) #if USE_CHAR_CLASSIFIERS - _OP_DEF(opexe_0, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) - _OP_DEF(opexe_0, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) - _OP_DEF(opexe_0, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) - _OP_DEF(opexe_0, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) - _OP_DEF(opexe_0, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) +_OP_DEF("char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) +_OP_DEF("char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) +_OP_DEF("char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) +_OP_DEF("char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) +_OP_DEF("char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) #endif - _OP_DEF(opexe_0, "port?", 1, 1, TST_ANY, OP_PORTP ) - _OP_DEF(opexe_0, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) - _OP_DEF(opexe_0, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) - _OP_DEF(opexe_0, "procedure?", 1, 1, TST_ANY, OP_PROCP ) - _OP_DEF(opexe_0, "pair?", 1, 1, TST_ANY, OP_PAIRP ) - _OP_DEF(opexe_0, "list?", 1, 1, TST_ANY, OP_LISTP ) - _OP_DEF(opexe_0, "environment?", 1, 1, TST_ANY, OP_ENVP ) - _OP_DEF(opexe_0, "vector?", 1, 1, TST_ANY, OP_VECTORP ) - _OP_DEF(opexe_0, "eq?", 2, 2, TST_ANY, OP_EQ ) - _OP_DEF(opexe_0, "eqv?", 2, 2, TST_ANY, OP_EQV ) - _OP_DEF(opexe_0, "force", 1, 1, TST_ANY, OP_FORCE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SAVE_FORCED ) - _OP_DEF(opexe_0, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) - _OP_DEF(opexe_0, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) - _OP_DEF(opexe_0, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) - _OP_DEF(opexe_0, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) - _OP_DEF(opexe_0, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_ERR1 ) - _OP_DEF(opexe_0, "reverse", 1, 1, TST_LIST, OP_REVERSE ) - _OP_DEF(opexe_0, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) - _OP_DEF(opexe_0, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) +_OP_DEF("port?", 1, 1, TST_ANY, OP_PORTP ) +_OP_DEF("input-port?", 1, 1, TST_ANY, OP_INPORTP ) +_OP_DEF("output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) +_OP_DEF("procedure?", 1, 1, TST_ANY, OP_PROCP ) +_OP_DEF("pair?", 1, 1, TST_ANY, OP_PAIRP ) +_OP_DEF("list?", 1, 1, TST_ANY, OP_LISTP ) +_OP_DEF("environment?", 1, 1, TST_ANY, OP_ENVP ) +_OP_DEF("vector?", 1, 1, TST_ANY, OP_VECTORP ) +_OP_DEF("eq?", 2, 2, TST_ANY, OP_EQ ) +_OP_DEF("eqv?", 2, 2, TST_ANY, OP_EQV ) +_OP_DEF("force", 1, 1, TST_ANY, OP_FORCE ) +_OP_DEF(0, 0, 0, 0, OP_SAVE_FORCED ) +_OP_DEF("write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) +_OP_DEF("write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) +_OP_DEF("display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) +_OP_DEF("newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) +_OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 ) +_OP_DEF(0, 0, 0, 0, OP_ERR1 ) +_OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE ) +_OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) +_OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND ) #if USE_PLIST - _OP_DEF(opexe_0, "set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) - _OP_DEF(opexe_0, "symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) +_OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) +_OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) #endif #if USE_TAGS - _OP_DEF(opexe_0, NULL, 0, 0, TST_NONE, OP_TAG_VALUE ) - _OP_DEF(opexe_0, "make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) - _OP_DEF(opexe_0, "get-tag", 1, 1, TST_ANY, OP_GET_TAG ) +_OP_DEF(NULL, 0, 0, TST_NONE, OP_TAG_VALUE ) +_OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) +_OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) #endif - _OP_DEF(opexe_0, "quit", 0, 1, TST_NUMBER, OP_QUIT ) - _OP_DEF(opexe_0, "gc", 0, 0, 0, OP_GC ) - _OP_DEF(opexe_0, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) - _OP_DEF(opexe_0, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) - _OP_DEF(opexe_0, "oblist", 0, 0, 0, OP_OBLIST ) - _OP_DEF(opexe_0, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) - _OP_DEF(opexe_0, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) - _OP_DEF(opexe_0, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) - _OP_DEF(opexe_0, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) - _OP_DEF(opexe_0, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) +_OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT ) +_OP_DEF("gc", 0, 0, 0, OP_GC ) +_OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) +_OP_DEF("new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) +_OP_DEF("oblist", 0, 0, 0, OP_OBLIST ) +_OP_DEF("current-input-port", 0, 0, 0, OP_CURR_INPORT ) +_OP_DEF("current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) +_OP_DEF("open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) +_OP_DEF("open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) +_OP_DEF("open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) #if USE_STRING_PORTS - _OP_DEF(opexe_0, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) - _OP_DEF(opexe_0, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) - _OP_DEF(opexe_0, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) - _OP_DEF(opexe_0, "get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) +_OP_DEF("open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) +_OP_DEF("open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) +_OP_DEF("open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) +_OP_DEF("get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) #endif - _OP_DEF(opexe_0, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) - _OP_DEF(opexe_0, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) - _OP_DEF(opexe_0, "interaction-environment", 0, 0, 0, OP_INT_ENV ) - _OP_DEF(opexe_0, "current-environment", 0, 0, 0, OP_CURR_ENV ) - _OP_DEF(opexe_0, "read", 0, 1, TST_INPORT, OP_READ ) - _OP_DEF(opexe_0, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) - _OP_DEF(opexe_0, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) - _OP_DEF(opexe_0, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) - _OP_DEF(opexe_0, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) - _OP_DEF(opexe_0, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDSEXPR ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDLIST ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDDOT ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDQUOTE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDQQUOTE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDQQUOTEVEC ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDUNQUOTE ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDUQTSP ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_RDVEC ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_P0LIST ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_P1LIST ) - _OP_DEF(opexe_0, 0, 0, 0, 0, OP_PVECFROM ) - _OP_DEF(opexe_0, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) - _OP_DEF(opexe_0, "assq", 2, 2, TST_NONE, OP_ASSQ ) - _OP_DEF(opexe_0, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) - _OP_DEF(opexe_0, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) - _OP_DEF(opexe_0, "macro?", 1, 1, TST_NONE, OP_MACROP ) - _OP_DEF(opexe_0, "*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) +_OP_DEF("close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) +_OP_DEF("close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) +_OP_DEF("interaction-environment", 0, 0, 0, OP_INT_ENV ) +_OP_DEF("current-environment", 0, 0, 0, OP_CURR_ENV ) +_OP_DEF("read", 0, 1, TST_INPORT, OP_READ ) +_OP_DEF("read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) +_OP_DEF("peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) +_OP_DEF("char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) +_OP_DEF("set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) +_OP_DEF("set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) +_OP_DEF(0, 0, 0, 0, OP_RDSEXPR ) +_OP_DEF(0, 0, 0, 0, OP_RDLIST ) +_OP_DEF(0, 0, 0, 0, OP_RDDOT ) +_OP_DEF(0, 0, 0, 0, OP_RDQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTEVEC ) +_OP_DEF(0, 0, 0, 0, OP_RDUNQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDUQTSP ) +_OP_DEF(0, 0, 0, 0, OP_RDVEC ) +_OP_DEF(0, 0, 0, 0, OP_P0LIST ) +_OP_DEF(0, 0, 0, 0, OP_P1LIST ) +_OP_DEF(0, 0, 0, 0, OP_PVECFROM ) +_OP_DEF("length", 1, 1, TST_LIST, OP_LIST_LENGTH ) +_OP_DEF("assq", 2, 2, TST_NONE, OP_ASSQ ) +_OP_DEF("get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) +_OP_DEF("closure?", 1, 1, TST_NONE, OP_CLOSUREP ) +_OP_DEF("macro?", 1, 1, TST_NONE, OP_MACROP ) +_OP_DEF("*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) #undef _OP_DEF diff --git a/scheme-private.h b/scheme-private.h index abe65e7..075dc70 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -200,7 +200,7 @@ const struct scheme_interface *vptr; /* operator code */ enum scheme_opcodes { -#define _OP_DEF(A,B,C,D,E,OP) OP, +#define _OP_DEF(A,B,C,D,OP) OP, #include "opdefines.h" OP_MAXDEFINED }; diff --git a/scheme.c b/scheme.c index f90ac3f..07f56ed 100644 --- a/scheme.c +++ b/scheme.c @@ -5213,8 +5213,6 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { return sc->T; /* NOTREACHED */ } -typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); - typedef int (*test_predicate)(pointer); static int is_any(pointer p) { @@ -5265,7 +5263,6 @@ static const struct { #define TST_NATURAL "\016" typedef struct { - dispatch_func func; const char *name; int min_arity; int max_arity; @@ -5275,7 +5272,7 @@ typedef struct { #define INF_ARG 0xffff static const op_code_info dispatch_table[]= { -#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, +#define _OP_DEF(A,B,C,D,OP) {A,B,C,D}, #include "opdefines.h" #undef _OP_DEF { 0 } @@ -5354,7 +5351,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { } } ok_to_freely_gc(sc); - if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { + if (opexe_0(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { return; } if(sc->no_memory) { -- cgit v1.2.3 From 49c22bd71892f47835d9e03f3bd3122a1f0b8faa Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 14:24:49 +0200 Subject: gpgscm: Use more threaded code. * tests/gpgscm/scheme.c (opexe_0): Use 's_thread_to' instead of 's_goto' wherever possible. Signed-off-by: Justus Winter --- scheme.c | 75 ++++++++++++++++++++++++++++++++-------------------------------- 1 file changed, 37 insertions(+), 38 deletions(-) diff --git a/scheme.c b/scheme.c index 07f56ed..3b6dfff 100644 --- a/scheme.c +++ b/scheme.c @@ -2963,8 +2963,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #if USE_THREADED_CODE /* Do not bounce back to Eval_Cycle but execute A by jumping directly - * to it. Only applicable if A is part of the same dispatch - * function. */ + * to it. */ #define s_thread_to(sc, a) \ BEGIN \ op = (int) (a); \ @@ -2972,7 +2971,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { END /* Define a label OP and emit a case statement for OP. For use in the - * dispatch functions. The slightly peculiar goto that is never + * dispatch function. The slightly peculiar goto that is never * executed avoids warnings about unused labels. */ #define CASE(OP) if (0) goto OP; OP: case OP @@ -3397,7 +3396,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { { sc->args=sc->NIL; sc->nesting = sc->nesting_stack[0]; - s_goto(sc,OP_QUIT); + s_thread_to(sc,OP_QUIT); } else { @@ -3434,7 +3433,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->tok = token(sc); if(sc->tok==TOK_EOF) { s_return(sc,sc->EOF_OBJ); } - s_goto(sc,OP_RDSEXPR); + s_thread_to(sc,OP_RDSEXPR); CASE(OP_GENSYM): s_return(sc, gensym(sc)); @@ -3449,7 +3448,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if(file_interactive(sc)) { sc->print_flag = 1; sc->args = sc->value; - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else { s_return(sc,sc->value); } @@ -3461,7 +3460,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_REAL_EVAL,sc->args,sc->code); sc->args=sc->code; putstr(sc,"\nEval: "); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } /* fall through */ CASE(OP_REAL_EVAL): @@ -3550,7 +3549,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->print_flag = 1; /* sc->args=cons(sc,sc->code,sc->args);*/ putstr(sc,"\nApply to: "); - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } /* fall through */ CASE(OP_REAL_APPLY): @@ -3856,7 +3855,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->code = cadar(sc->code); sc->args = sc->NIL; s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } else { /* end */ sc->args = reverse_in_place(sc, sc->NIL, sc->args); sc->code = car(sc->args); @@ -3870,7 +3869,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } sc->code = cdr(sc->code); sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); CASE(OP_COND0): /* cond */ if (!is_pair(sc->code)) { @@ -3879,7 +3878,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_COND1, sc->NIL, sc->code); sc->code = caar(sc->code); s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_COND1): /* cond */ if (is_true(sc->value)) { @@ -3894,9 +3893,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); gc_enable(sc); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } else { if ((sc->code = cdr(sc->code)) == sc->NIL) { s_return(sc,sc->NIL); @@ -3904,7 +3903,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_COND1, sc->NIL, sc->code); sc->code = caar(sc->code); s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } } @@ -3922,7 +3921,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_AND1): /* and */ if (is_false(sc->value)) { @@ -3934,7 +3933,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } CASE(OP_OR0): /* or */ @@ -3945,7 +3944,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_OR1): /* or */ if (is_true(sc->value)) { @@ -3957,13 +3956,13 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (cdr(sc->code) != sc->NIL) s_clear_flag(sc, TAIL_CONTEXT); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } CASE(OP_C0STREAM): /* cons-stream */ s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_C1STREAM): /* cons-stream */ sc->args = sc->value; /* save sc->value to register sc->args for gc */ @@ -3986,7 +3985,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"variable is not a symbol"); } s_save(sc,OP_MACRO1, sc->NIL, x); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_MACRO1): { /* macro */ pointer *sslot; @@ -4004,7 +4003,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); sc->code = car(sc->code); s_clear_flag(sc, TAIL_CONTEXT); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_CASE1): /* case */ for (x = sc->code; x != sc->NIL; x = cdr(x)) { @@ -4023,11 +4022,11 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (x != sc->NIL) { if (is_pair(caar(x))) { sc->code = cdar(x); - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } else {/* else */ s_save(sc,OP_CASE2, sc->NIL, cdar(x)); sc->code = caar(x); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } } else { s_return(sc,sc->NIL); @@ -4035,7 +4034,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_CASE2): /* case */ if (is_true(sc->value)) { - s_goto(sc,OP_BEGIN); + s_thread_to(sc,OP_BEGIN); } else { s_return(sc,sc->NIL); } @@ -4044,21 +4043,21 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->code = car(sc->args); sc->args = list_star(sc,cdr(sc->args)); /*sc->args = cadr(sc->args);*/ - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); CASE(OP_PEVAL): /* eval */ if(cdr(sc->args)!=sc->NIL) { sc->envir=cadr(sc->args); } sc->code = car(sc->args); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); CASE(OP_CONTINUATION): /* call-with-current-continuation */ sc->code = car(sc->args); gc_disable(sc, 2); sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); gc_enable(sc); - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); #if USE_MATH CASE(OP_INEX2EX): /* inexact->exact */ @@ -4637,7 +4636,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { /* Should change type to closure here */ s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); sc->args = sc->NIL; - s_goto(sc,OP_APPLY); + s_thread_to(sc,OP_APPLY); } else { s_return(sc,sc->code); } @@ -4662,7 +4661,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } else { sc->print_flag = 0; } - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); CASE(OP_NEWLINE): /* newline */ if(is_pair(sc->args)) { @@ -4692,11 +4691,11 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); sc->args = car(sc->args); sc->print_flag = 1; - s_goto(sc,OP_P0LIST); + s_thread_to(sc,OP_P0LIST); } else { putstr(sc, "\n"); if(sc->interactive_repl) { - s_goto(sc,OP_T0LVL); + s_thread_to(sc,OP_T0LVL); } else { return sc->NIL; } @@ -4879,19 +4878,19 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { /* ========== reading part ========== */ CASE(OP_READ): if(!is_pair(sc->args)) { - s_goto(sc,OP_READ_INTERNAL); + s_thread_to(sc,OP_READ_INTERNAL); } if(!is_inport(car(sc->args))) { Error_1(sc,"read: not an input port:",car(sc->args)); } if(car(sc->args)==sc->inport) { - s_goto(sc,OP_READ_INTERNAL); + s_thread_to(sc,OP_READ_INTERNAL); } x=sc->inport; sc->inport=car(sc->args); x=cons(sc,x,sc->NIL); s_save(sc,OP_SET_INPORT, x, sc->NIL); - s_goto(sc,OP_READ_INTERNAL); + s_thread_to(sc,OP_READ_INTERNAL); CASE(OP_READ_CHAR): /* read-char */ CASE(OP_PEEK_CHAR): /* peek-char */ { @@ -5000,7 +4999,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"undefined sharp expression"); } else { sc->code=cons(sc,slot_value_in_env(f),sc->NIL); - s_goto(sc,OP_EVAL); + s_thread_to(sc,OP_EVAL); } } case TOK_SHARP_CONST: @@ -5077,14 +5076,14 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_RDVEC): /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_goto(sc,OP_EVAL); Cannot be quoted*/ + s_thread_to(sc,OP_EVAL); Cannot be quoted*/ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); s_return(sc,x); Cannot be part of pairs*/ /*sc->code=mk_proc(sc,OP_VECTOR); sc->args=sc->value; - s_goto(sc,OP_APPLY);*/ + s_thread_to(sc,OP_APPLY);*/ sc->args=sc->value; - s_goto(sc,OP_VECTOR); + s_thread_to(sc,OP_VECTOR); /* ========== printing part ========== */ CASE(OP_P0LIST): -- cgit v1.2.3 From 5aeeb5af96dce901a8b21613e33baed8b9331692 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 16:32:36 +0200 Subject: gpgscm: Move dispatch table into rodata. * tests/gpgscm/opdefines.h: Use 0 instead of NULL. * tests/gpgscm/scheme.c (op_code_info): Use char arrays instead of pointers, make arity parameters smaller. (INF_ARG): Adapt. (_OP_DEF): Likewise. (dispatch_table): Likewise. (procname): Likewise. (Eval_cycle): Likewise. (scheme_init_custom_alloc): Likewise. Signed-off-by: Justus Winter --- opdefines.h | 2 +- scheme.c | 25 +++++++++++++------------ 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/opdefines.h b/opdefines.h index 6c53e1f..bee2b6d 100644 --- a/opdefines.h +++ b/opdefines.h @@ -154,7 +154,7 @@ _OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST _OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) #endif #if USE_TAGS -_OP_DEF(NULL, 0, 0, TST_NONE, OP_TAG_VALUE ) +_OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE ) _OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) _OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) #endif diff --git a/scheme.c b/scheme.c index 3b6dfff..7ba1cc2 100644 --- a/scheme.c +++ b/scheme.c @@ -5262,25 +5262,25 @@ static const struct { #define TST_NATURAL "\016" typedef struct { - const char *name; - int min_arity; - int max_arity; - const char *arg_tests_encoding; + char name[31]; /* strlen ("call-with-current-continuation") + 1 */ + unsigned char min_arity; + unsigned char max_arity; + char arg_tests_encoding[3]; } op_code_info; -#define INF_ARG 0xffff +#define INF_ARG 0xff static const op_code_info dispatch_table[]= { -#define _OP_DEF(A,B,C,D,OP) {A,B,C,D}, +#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}}, #include "opdefines.h" #undef _OP_DEF - { 0 } + {{0},0,0,{0}}, }; static const char *procname(pointer x) { int n=procnum(x); const char *name=dispatch_table[n].name; - if(name==0) { + if (name[0] == 0) { name="ILLEGAL!"; } return name; @@ -5291,7 +5291,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { sc->op = op; for (;;) { const op_code_info *pcd=dispatch_table+sc->op; - if (pcd->name!=0) { /* if built-in function, check arguments */ + if (pcd->name[0] != 0) { /* if built-in function, check arguments */ char msg[STRBUFFSIZE]; int ok=1; int n=list_length(sc,sc->args); @@ -5312,7 +5312,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { pcd->max_arity); } if(ok) { - if(pcd->arg_tests_encoding!=0) { + if (pcd->arg_tests_encoding[0] != 0) { int i=0; int j; const char *t=pcd->arg_tests_encoding; @@ -5326,7 +5326,8 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { if(!tests[j].fct(arg)) break; } - if(t[1]!=0) {/* last test is replicated as necessary */ + if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { + /* last test is replicated as necessary */ t++; } arglist=cdr(arglist); @@ -5620,7 +5621,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { assign_syntax(sc, "case"); for(i=0; i Date: Wed, 29 Mar 2017 17:09:01 +0200 Subject: gpgscm: Deduplicate code. * tests/gpgscm/scheme.c (oblist_add_by_name): Deduplicate. (new_slot_spec_in_env): Likewise. Fixes-commit: 6a3f857224eab108ae38e6259194b01b0ffdad8b Signed-off-by: Justus Winter --- scheme.c | 78 +++++++++++++++++++++++----------------------------------------- 1 file changed, 28 insertions(+), 50 deletions(-) diff --git a/scheme.c b/scheme.c index 7ba1cc2..655c246 100644 --- a/scheme.c +++ b/scheme.c @@ -1145,6 +1145,7 @@ pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { return (x); } + /* ========== oblist implementation ========== */ #ifndef USE_OBJECT_LIST @@ -1158,24 +1159,6 @@ static pointer oblist_initial_value(scheme *sc) return mk_vector(sc, 1009); } -/* Add a new symbol NAME at SLOT. SLOT must be obtained using - * oblist_find_by_name, and no insertion must be done between - * obtaining the SLOT and calling this function. Returns the new - * symbol. */ -static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) -{ -#define oblist_add_by_name_allocates 3 - pointer x; - - gc_disable(sc, gc_reservations (oblist_add_by_name)); - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - *slot = immutable_cons(sc, x, *slot); - gc_enable(sc); - return x; -} - /* Lookup the symbol NAME. Returns the symbol, or NIL if it does not * exist. In that case, SLOT points to the point where the new symbol * is to be inserted. */ @@ -1244,6 +1227,13 @@ oblist_find_by_name(scheme *sc, const char *name, pointer **slot) return sc->NIL; } +static pointer oblist_all_symbols(scheme *sc) +{ + return sc->oblist; +} + +#endif + /* Add a new symbol NAME at SLOT. SLOT must be obtained using * oblist_find_by_name, and no insertion must be done between * obtaining the SLOT and calling this function. Returns the new @@ -1253,18 +1243,16 @@ static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) #define oblist_add_by_name_allocates 3 pointer x; + gc_disable(sc, gc_reservations (oblist_add_by_name)); x = immutable_cons(sc, mk_string(sc, name), sc->NIL); typeflag(x) = T_SYMBOL; setimmutable(car(x)); *slot = immutable_cons(sc, x, *slot); + gc_enable(sc); return x; } -static pointer oblist_all_symbols(scheme *sc) -{ - return sc->oblist; -} -#endif + static pointer mk_port(scheme *sc, port *p) { pointer x = get_cell(sc, sc->NIL, sc->NIL); @@ -2643,6 +2631,7 @@ int eqv(pointer a, pointer b) { #define is_true(p) ((p) != sc->F) #define is_false(p) ((p) == sc->F) + /* ========== Environment implementation ========== */ #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) @@ -2705,21 +2694,6 @@ static void new_frame_in_env(scheme *sc, pointer old_env) setenvironment(sc->envir); } -/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using - * find_slot_spec_in_env, and no insertion must be done between - * obtaining SSLOT and the call to this function. */ -static INLINE void new_slot_spec_in_env(scheme *sc, - pointer variable, pointer value, - pointer *sslot) -{ -#define new_slot_spec_in_env_allocates 2 - pointer slot; - gc_disable(sc, gc_reservations (new_slot_spec_in_env)); - slot = immutable_cons(sc, variable, value); - *sslot = immutable_cons(sc, slot, *sslot); - gc_enable(sc); -} - /* Find the slot in ENV under the key HDL. If ALL is given, look in * all environments enclosing ENV. If the lookup fails, and SSLOT is * given, the position where the new slot has to be inserted is stored @@ -2766,18 +2740,6 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env) setenvironment(sc->envir); } -/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using - * find_slot_spec_in_env, and no insertion must be done between - * obtaining SSLOT and the call to this function. */ -static INLINE void new_slot_spec_in_env(scheme *sc, - pointer variable, pointer value, - pointer *sslot) -{ -#define new_slot_spec_in_env_allocates 2 - assert(is_symbol(variable)); - *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot); -} - /* Find the slot in ENV under the key HDL. If ALL is given, look in * all environments enclosing ENV. If the lookup fails, and SSLOT is * given, the position where the new slot has to be inserted is stored @@ -2816,6 +2778,21 @@ static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) return find_slot_spec_in_env(sc, env, hdl, all, NULL); } +/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using + * find_slot_spec_in_env, and no insertion must be done between + * obtaining SSLOT and the call to this function. */ +static INLINE void new_slot_spec_in_env(scheme *sc, + pointer variable, pointer value, + pointer *sslot) +{ +#define new_slot_spec_in_env_allocates 2 + pointer slot; + gc_disable(sc, gc_reservations (new_slot_spec_in_env)); + slot = immutable_cons(sc, variable, value); + *sslot = immutable_cons(sc, slot, *sslot); + gc_enable(sc); +} + static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) { #define new_slot_in_env_allocates new_slot_spec_in_env_allocates @@ -2838,6 +2815,7 @@ static INLINE pointer slot_value_in_env(pointer slot) return cdr(slot); } + /* ========== Evaluation Cycle ========== */ -- cgit v1.2.3 From be78c20cdd93ed295bfee1aef1e9d2e9253b779c Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 4 Apr 2017 12:02:54 +0200 Subject: gpgscm: Add and use opcode for reversing a list in place. * tests/gpgscm/lib.scm (string-split-pln): Use 'reverse!'. (string-rtrim): Likewise. * tests/gpgscm/opdefines.h (reverse!): New opcode. * tests/gpgscm/scheme.c (opexe_0): Handle new opcode. Signed-off-by: Justus Winter --- lib.scm | 8 ++++---- opdefines.h | 1 + scheme.c | 3 +++ 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/lib.scm b/lib.scm index 2cfe725..ed3d572 100644 --- a/lib.scm +++ b/lib.scm @@ -95,10 +95,10 @@ (let ((length (string-length haystack))) (define (split acc offset n) (if (>= offset length) - (reverse acc) + (reverse! acc) (let ((i (lookahead haystack offset))) (if (or (eq? i #f) (= 0 n)) - (reverse (cons (substring haystack offset length) acc)) + (reverse! (cons (substring haystack offset length) acc)) (split (cons (substring haystack offset i) acc) (+ i 1) (- n 1)))))) (split '() 0 n))) @@ -168,10 +168,10 @@ (define (string-rtrim predicate s) (if (string=? s "") "" - (let loop ((s' (reverse (string->list s)))) + (let loop ((s' (reverse! (string->list s)))) (if (predicate (car s')) (loop (cdr s')) - (list->string (reverse s')))))) + (list->string (reverse! s')))))) (assert (string=? "" (string-rtrim char-whitespace? ""))) (assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) diff --git a/opdefines.h b/opdefines.h index bee2b6d..dd32d1e 100644 --- a/opdefines.h +++ b/opdefines.h @@ -147,6 +147,7 @@ _OP_DEF("newline", 0, 1, TST_OUTPORT, _OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 ) _OP_DEF(0, 0, 0, 0, OP_ERR1 ) _OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE ) +_OP_DEF("reverse!", 1, 1, TST_LIST, OP_REVERSE_IN_PLACE ) _OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) _OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND ) #if USE_PLIST diff --git a/scheme.c b/scheme.c index 655c246..f3a99fd 100644 --- a/scheme.c +++ b/scheme.c @@ -4682,6 +4682,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_REVERSE): /* reverse */ s_return(sc,reverse(sc, sc->NIL, car(sc->args))); + CASE(OP_REVERSE_IN_PLACE): /* reverse! */ + s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args))); + CASE(OP_LIST_STAR): /* list* */ s_return(sc,list_star(sc,sc->args)); -- cgit v1.2.3 From d6c83fbb06abc99de696b3f9a0b1cb962fa05b26 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 18:05:33 +0200 Subject: gpgscm: Make tags mandatory. * tests/gpgscm/opdefines.h: Make tags mandatory. * tests/gpgscm/scheme.c: Likewise. * tests/gpgscm/scheme.h: Likewise. -- Tags provide a constant-time lookup mechanism for almost every object. This is useful for the interpreter itself, and the code for tags is tiny. Signed-off-by: Justus Winter --- opdefines.h | 2 -- scheme.c | 16 ++-------------- scheme.h | 6 ------ 3 files changed, 2 insertions(+), 22 deletions(-) diff --git a/opdefines.h b/opdefines.h index dd32d1e..61f7971 100644 --- a/opdefines.h +++ b/opdefines.h @@ -154,11 +154,9 @@ _OP_DEF("append", 0, INF_ARG, TST_NONE, _OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) _OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) #endif -#if USE_TAGS _OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE ) _OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) _OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) -#endif _OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT ) _OP_DEF("gc", 0, 0, 0, OP_GC ) _OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) diff --git a/scheme.c b/scheme.c index f3a99fd..fa089a0 100644 --- a/scheme.c +++ b/scheme.c @@ -671,8 +671,6 @@ copy_value(scheme *sc, pointer dst, pointer src) /* Tags are like property lists, but can be attached to arbitrary * values. */ -#if USE_TAGS - static pointer mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) { @@ -709,14 +707,6 @@ get_tag(scheme *sc, pointer v) return sc->NIL; } -#else - -#define mk_tagged_value(SC, X, A, B) (X) -#define has_tag(V) 0 -#define get_tag(SC, V) (SC)->NIL - -#endif - /* Low-level allocator. @@ -4718,7 +4708,6 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); #endif /* USE_PLIST */ -#if USE_TAGS CASE(OP_TAG_VALUE): { /* not exposed */ /* This tags sc->value with car(sc->args). Useful to tag * results of opcode evaluations. */ @@ -4738,7 +4727,6 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_GET_TAG): /* get-tag */ s_return(sc, get_tag(sc, car(sc->args))); -#endif /* USE_TAGS */ CASE(OP_QUIT): /* quit */ if(is_pair(sc->args)) { @@ -4927,12 +4915,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } else if (sc->tok == TOK_DOT) { Error_0(sc,"syntax error: illegal dot expression"); } else { -#if USE_TAGS && SHOW_ERROR_LINE +#if SHOW_ERROR_LINE pointer filename; pointer lineno; #endif sc->nesting_stack[sc->file_i]++; -#if USE_TAGS && SHOW_ERROR_LINE +#if SHOW_ERROR_LINE filename = sc->load_stack[sc->file_i].filename; lineno = sc->load_stack[sc->file_i].curr_line; diff --git a/scheme.h b/scheme.h index 8560f7d..d748186 100644 --- a/scheme.h +++ b/scheme.h @@ -44,7 +44,6 @@ extern "C" { # define USE_DL 0 # define USE_PLIST 0 # define USE_SMALL_INTEGERS 0 -# define USE_TAGS 0 # define USE_HISTORY 0 #endif @@ -78,11 +77,6 @@ extern "C" { # define USE_PLIST 0 #endif -/* If set, then every object can be tagged. */ -#ifndef USE_TAGS -# define USE_TAGS 1 -#endif - /* Keep a history of function calls. This enables a feature similar * to stack traces. */ #ifndef USE_HISTORY -- cgit v1.2.3 From 173531921d133a007d30c32cec00546749d8cfbf Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 29 Mar 2017 18:10:17 +0200 Subject: gpgscm: Improve syntax dispatch. * tests/gpgscm/scheme.c (assign_syntax): Add opcode parameter, store opcode in the tag. (syntaxnum): Add sc parameter, retrieve opcode from tag. (opexe_0): Adapt callsite. (scheme_init_custom_alloc): Likewise. Signed-off-by: Justus Winter --- scheme.c | 94 +++++++++++++++++++++++++--------------------------------------- 1 file changed, 36 insertions(+), 58 deletions(-) diff --git a/scheme.c b/scheme.c index fa089a0..934dd4e 100644 --- a/scheme.c +++ b/scheme.c @@ -439,8 +439,8 @@ static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); -static void assign_syntax(scheme *sc, char *name); -static int syntaxnum(pointer p); +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name); +static int syntaxnum(scheme *sc, pointer p); static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name); #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) @@ -3443,7 +3443,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } else if (is_pair(sc->code)) { if (is_syntax(x = car(sc->code))) { /* SYNTAX */ sc->code = cdr(sc->code); - s_goto(sc,syntaxnum(x)); + s_goto(sc, syntaxnum(sc, x)); } else {/* first, eval top element and eval arguments */ s_save(sc,OP_E0ARGS, sc->NIL, sc->code); /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ @@ -5332,15 +5332,28 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { /* ========== Initialization of internal keywords ========== */ -static void assign_syntax(scheme *sc, char *name) { - pointer x; +/* Symbols representing syntax are tagged with (OP . '()). */ +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) { + pointer x, y; pointer *slot; x = oblist_find_by_name(sc, name, &slot); assert (x == sc->NIL); - x = oblist_add_by_name(sc, name, slot); - typeflag(x) |= T_SYNTAX; + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL | T_SYNTAX; + setimmutable(car(x)); + y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL); + free_cell(sc, x); + setimmutable(get_tag(sc, y)); + *slot = immutable_cons(sc, y, *slot); +} + +/* Returns the opcode for the syntax represented by P. */ +static int syntaxnum(scheme *sc, pointer p) { + int op = ivalue_unchecked(car(get_tag(sc, p))); + assert (op < OP_MAXDEFINED); + return op; } static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) { @@ -5361,41 +5374,6 @@ static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { return y; } -/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ -static int syntaxnum(pointer p) { - const char *s=strvalue(car(p)); - switch(strlength(car(p))) { - case 2: - if(s[0]=='i') return OP_IF0; /* if */ - else return OP_OR0; /* or */ - case 3: - if(s[0]=='a') return OP_AND0; /* and */ - else return OP_LET0; /* let */ - case 4: - switch(s[3]) { - case 'e': return OP_CASE0; /* case */ - case 'd': return OP_COND0; /* cond */ - case '*': return OP_LET0AST; /* let* */ - default: return OP_SET0; /* set! */ - } - case 5: - switch(s[2]) { - case 'g': return OP_BEGIN; /* begin */ - case 'l': return OP_DELAY; /* delay */ - case 'c': return OP_MACRO0; /* macro */ - default: return OP_QUOTE; /* quote */ - } - case 6: - switch(s[2]) { - case 'm': return OP_LAMBDA; /* lambda */ - case 'f': return OP_DEF0; /* define */ - default: return OP_LET0REC; /* letrec */ - } - default: - return OP_C0STREAM; /* cons-stream */ - } -} - /* initialization of TinyScheme */ #if USE_INTERFACE INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { @@ -5572,22 +5550,22 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { x = mk_symbol(sc,"else"); new_slot_in_env(sc, x, sc->T); - assign_syntax(sc, "lambda"); - assign_syntax(sc, "quote"); - assign_syntax(sc, "define"); - assign_syntax(sc, "if"); - assign_syntax(sc, "begin"); - assign_syntax(sc, "set!"); - assign_syntax(sc, "let"); - assign_syntax(sc, "let*"); - assign_syntax(sc, "letrec"); - assign_syntax(sc, "cond"); - assign_syntax(sc, "delay"); - assign_syntax(sc, "and"); - assign_syntax(sc, "or"); - assign_syntax(sc, "cons-stream"); - assign_syntax(sc, "macro"); - assign_syntax(sc, "case"); + assign_syntax(sc, OP_LAMBDA, "lambda"); + assign_syntax(sc, OP_QUOTE, "quote"); + assign_syntax(sc, OP_DEF0, "define"); + assign_syntax(sc, OP_IF0, "if"); + assign_syntax(sc, OP_BEGIN, "begin"); + assign_syntax(sc, OP_SET0, "set!"); + assign_syntax(sc, OP_LET0, "let"); + assign_syntax(sc, OP_LET0AST, "let*"); + assign_syntax(sc, OP_LET0REC, "letrec"); + assign_syntax(sc, OP_COND0, "cond"); + assign_syntax(sc, OP_DELAY, "delay"); + assign_syntax(sc, OP_AND0, "and"); + assign_syntax(sc, OP_OR0, "or"); + assign_syntax(sc, OP_C0STREAM, "cons-stream"); + assign_syntax(sc, OP_MACRO0, "macro"); + assign_syntax(sc, OP_CASE0, "case"); for(i=0; i Date: Mon, 3 Apr 2017 11:25:49 +0200 Subject: gpgscm: Refactor checking for opcode arguments. * tests/gpgscm/scheme.c (op_code_info): Fix type, add forward declaration. (check_arguments): New function. (Eval_cycle): Use the new function. Signed-off-by: Justus Winter --- scheme.c | 130 ++++++++++++++++++++++++++++++++++----------------------------- 1 file changed, 70 insertions(+), 60 deletions(-) diff --git a/scheme.c b/scheme.c index 934dd4e..9ddd36d 100644 --- a/scheme.c +++ b/scheme.c @@ -438,6 +438,14 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); +struct op_code_info { + char name[31]; /* strlen ("call-with-current-continuation") + 1 */ + unsigned char min_arity; + unsigned char max_arity; + char arg_tests_encoding[3]; +}; +static const struct op_code_info dispatch_table[]; +static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size); static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name); static int syntaxnum(scheme *sc, pointer p); @@ -5230,16 +5238,9 @@ static const struct { #define TST_INTEGER "\015" #define TST_NATURAL "\016" -typedef struct { - char name[31]; /* strlen ("call-with-current-continuation") + 1 */ - unsigned char min_arity; - unsigned char max_arity; - char arg_tests_encoding[3]; -} op_code_info; - #define INF_ARG 0xff -static const op_code_info dispatch_table[]= { +static const struct op_code_info dispatch_table[]= { #define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}}, #include "opdefines.h" #undef _OP_DEF @@ -5255,64 +5256,73 @@ static const char *procname(pointer x) { return name; } +static int +check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size) +{ + int ok = 1; + int n = list_length(sc, sc->args); + + /* Check number of arguments */ + if (n < pcd->min_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at least", + pcd->min_arity); + } + if (ok && n>pcd->max_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at most", + pcd->max_arity); + } + if (ok) { + if (pcd->arg_tests_encoding[0] != 0) { + int i = 0; + int j; + const char *t = pcd->arg_tests_encoding; + pointer arglist = sc->args; + + do { + pointer arg = car(arglist); + j = (int)t[0]; + if (j == TST_LIST[0]) { + if (arg != sc->NIL && !is_pair(arg)) break; + } else { + if (!tests[j].fct(arg)) break; + } + + if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { + /* last test is replicated as necessary */ + t++; + } + arglist = cdr(arglist); + i++; + } while (i < n); + + if (i < n) { + ok = 0; + snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s", + pcd->name, + i + 1, + tests[j].kind, + type_to_string(type(car(arglist)))); + } + } + } + + return ok; +} + /* kernel of this interpreter */ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { sc->op = op; for (;;) { - const op_code_info *pcd=dispatch_table+sc->op; + const struct op_code_info *pcd=dispatch_table+sc->op; if (pcd->name[0] != 0) { /* if built-in function, check arguments */ char msg[STRBUFFSIZE]; - int ok=1; - int n=list_length(sc,sc->args); - - /* Check number of arguments */ - if(nmin_arity) { - ok=0; - snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at least", - pcd->min_arity); - } - if(ok && n>pcd->max_arity) { - ok=0; - snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at most", - pcd->max_arity); - } - if(ok) { - if (pcd->arg_tests_encoding[0] != 0) { - int i=0; - int j; - const char *t=pcd->arg_tests_encoding; - pointer arglist=sc->args; - do { - pointer arg=car(arglist); - j=(int)t[0]; - if(j==TST_LIST[0]) { - if(arg!=sc->NIL && !is_pair(arg)) break; - } else { - if(!tests[j].fct(arg)) break; - } - - if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { - /* last test is replicated as necessary */ - t++; - } - arglist=cdr(arglist); - i++; - } while(iname, - i+1, - tests[j].kind, - type_to_string(type(car(arglist)))); - } - } - } - if(!ok) { + if (! check_arguments (sc, pcd, msg, sizeof msg)) { if(_Error_1(sc,msg,0)==sc->NIL) { return; } -- cgit v1.2.3 From ef41f332cba624e9bca6100ebacd4fffe4e61679 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 5 Apr 2017 14:11:57 +0200 Subject: gpgscm: Mmap script files. * tests/gpgscm/main.c (load): Try to mmap the script. * tests/gpgscm/scheme.c (scheme_load_memory): New function, a generalization of 'scheme_load_string'. * tests/gpgscm/scheme.h (scheme_load_memory): New prototype. Signed-off-by: Justus Winter --- main.c | 41 ++++++++++++++++++++++++++++++++++++++++- scheme.c | 12 ++++++++---- scheme.h | 2 ++ 3 files changed, 50 insertions(+), 5 deletions(-) diff --git a/main.c b/main.c index 65929f0..79072a5 100644 --- a/main.c +++ b/main.c @@ -23,13 +23,20 @@ #include #include #include +#include #include #include #include #include #include +#include +#include #include +#if HAVE_MMAP +#include +#endif + #include "private.h" #include "scheme.h" #include "scheme-private.h" @@ -177,7 +184,39 @@ load (scheme *sc, char *file_name, } if (verbose > 1) fprintf (stderr, "Loading %s...\n", qualified_name); - scheme_load_named_file (sc, h, qualified_name); + +#if HAVE_MMAP + /* Always try to mmap the file. This allows the pages to be shared + * between processes. If anything fails, we fall back to using + * buffered streams. */ + if (1) + { + struct stat st; + void *map; + size_t len; + int fd = fileno (h); + + if (fd < 0) + goto fallback; + + if (fstat (fd, &st)) + goto fallback; + + len = (size_t) st.st_size; + if ((off_t) len != st.st_size) + goto fallback; /* Truncated. */ + + map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0); + if (map == MAP_FAILED) + goto fallback; + + scheme_load_memory (sc, map, len, qualified_name); + munmap (map, len); + } + else + fallback: +#endif + scheme_load_named_file (sc, h, qualified_name); fclose (h); if (sc->retcode && sc->nesting) diff --git a/scheme.c b/scheme.c index 9ddd36d..fd99207 100644 --- a/scheme.c +++ b/scheme.c @@ -5693,14 +5693,18 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { } void scheme_load_string(scheme *sc, const char *cmd) { + scheme_load_memory(sc, cmd, strlen(cmd), NULL); +} + +void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) { dump_stack_reset(sc); sc->envir = sc->global_env; sc->file_i=0; sc->load_stack[0].kind=port_input|port_string; - sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ - sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); - sc->load_stack[0].rep.string.curr=(char*)cmd; - port_init_location(sc, &sc->load_stack[0], NULL); + sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */ + sc->load_stack[0].rep.string.past_the_end = (char *) buf + len; + sc->load_stack[0].rep.string.curr = (char *) buf; + port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL); sc->loadport=mk_port(sc,sc->load_stack); sc->retcode=0; sc->interactive_repl=0; diff --git a/scheme.h b/scheme.h index d748186..6f917da 100644 --- a/scheme.h +++ b/scheme.h @@ -167,6 +167,8 @@ 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 void scheme_load_memory(scheme *sc, const char *buf, size_t len, + const char *filename); 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); -- cgit v1.2.3 From afb7060de5c55976d08e0692fbffd0cc108914a0 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 5 Apr 2017 16:56:46 +0200 Subject: gpgscm: Fix opcode dispatch. * tests/gpgscm/scheme.c (opexe_0): Consider 'op', not 'sc->op'. The former is the opcode we are currently executing. Signed-off-by: Justus Winter --- scheme.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index fd99207..933dc45 100644 --- a/scheme.c +++ b/scheme.c @@ -4884,7 +4884,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if(c==EOF) { s_return(sc,sc->EOF_OBJ); } - if(sc->op==OP_PEEK_CHAR) { + if(op==OP_PEEK_CHAR) { backchar(sc,c); } s_return(sc,mk_character(sc,c)); @@ -5183,7 +5183,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_VM_HISTORY): /* *vm-history* */ s_return(sc, history_flatten(sc)); default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op); Error_0(sc,sc->strbuff); } return sc->T; /* NOTREACHED */ -- cgit v1.2.3 From d9dd8135ec6e1a4b7a66bc385714b8c1beba3e96 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 11 Apr 2017 10:43:52 +0200 Subject: tests: Move common functionality. * tests/openpgp/defs.scm (with-home-directory, with-ephemeral-home-directory): Move... * tests/gpgscm/gnupg.scm: ... to this new file. * tests/gpgscm/main.c (main): Load the new file. Signed-off-by: Justus Winter --- gnupg.scm | 44 ++++++++++++++++++++++++++++++++++++++++++++ main.c | 2 ++ 2 files changed, 46 insertions(+) create mode 100644 gnupg.scm diff --git a/gnupg.scm b/gnupg.scm new file mode 100644 index 0000000..5fcf9fd --- /dev/null +++ b/gnupg.scm @@ -0,0 +1,44 @@ +;; Common definitions for executing gpg and related tools. +;; +;; Copyright (C) 2016, 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Evaluate a sequence of expressions with the given home directory. +(define-macro (with-home-directory gnupghome . expressions) + (let ((original-home-directory (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME"))) + (dynamic-wind + (lambda () (setenv "GNUPGHOME" ,gnupghome #t)) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))) + +;; Evaluate a sequence of expressions with an ephemeral home +;; directory. +(define-macro (with-ephemeral-home-directory setup-fn . expressions) + (let ((original-home-directory (gensym)) + (ephemeral-home-directory (gensym)) + (setup (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME")) + (,ephemeral-home-directory (mkdtemp)) + (,setup (delay (,setup-fn)))) + (finally (unlink-recursively ,ephemeral-home-directory) + (dynamic-wind + (lambda () + (setenv "GNUPGHOME" ,ephemeral-home-directory #t) + (with-working-directory ,ephemeral-home-directory (force ,setup))) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))) diff --git a/main.c b/main.c index 79072a5..5e04d97 100644 --- a/main.c +++ b/main.c @@ -314,6 +314,8 @@ main (int argc, char **argv) err = load (sc, "repl.scm", 0, 1); if (! err) err = load (sc, "tests.scm", 0, 1); + if (! err) + err = load (sc, "gnupg.scm", 0, 1); if (err) { fprintf (stderr, "Error initializing gpgscm: %s.\n", -- cgit v1.2.3 From b03bcee96fc4eb950c6ae38fd8b5af831b281f02 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 11 Apr 2017 11:50:54 +0200 Subject: tests: Fix distcheck. * tests/gpgscm/Makefile.am (EXTRA_DIST): Add 'gnupg.scm'. Fixes-commit: ccd2187212c12b84c86a10fd4417a16536243179 Signed-off-by: Justus Winter --- Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.am b/Makefile.am index 15fc883..dc999fb 100644 --- a/Makefile.am +++ b/Makefile.am @@ -26,6 +26,7 @@ EXTRA_DIST = \ repl.scm \ t-child.scm \ tests.scm \ + gnupg.scm \ time.scm AM_CPPFLAGS = -I$(top_srcdir)/common -- cgit v1.2.3 From e71c0d39d2fb896df85949a61811e3b19fd050d7 Mon Sep 17 00:00:00 2001 From: NIIBE Yutaka Date: Wed, 12 Apr 2017 12:05:53 +0900 Subject: gpgscm: Fix test program. * tests/gpgscm/t-child.c (main): Fix for setmode. Signed-off-by: NIIBE Yutaka --- t-child.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/t-child.c b/t-child.c index 547eb17..f4e3a04 100644 --- a/t-child.c +++ b/t-child.c @@ -33,9 +33,9 @@ main (int argc, char **argv) char buffer[4096]; memset (buffer, 'A', sizeof buffer); #if _WIN32 - if (! setmode (stdin, O_BINARY)) + if (! setmode (fileno (stdin), O_BINARY)) return 23; - if (! setmode (stdout, O_BINARY)) + if (! setmode (fileno (stdout), O_BINARY)) return 23; #endif -- cgit v1.2.3 From 8bda9387d5be9193fd0f484fd1272367a7422389 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 20 Apr 2017 15:04:52 +0200 Subject: gpgscm: Avoid fruitless garbage collection cycles. * tests/gpgscm/scheme-private.h (CELL_MINRECOVER): New macro. * tests/gpgscm/scheme.c (_get_cell): Move the heuristic to get more cells... (gc): ... here where every caller benefits from the optimization. Signed-off-by: Justus Winter --- scheme-private.h | 7 +++++++ scheme.c | 16 ++++++++-------- 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 075dc70..bc0269a 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -108,6 +108,13 @@ int tracing; #ifndef CELL_SEGSIZE #define CELL_SEGSIZE 5000 /* # of cells in one segment */ #endif + +/* If less than # of cells are recovered in a garbage collector run, + * allocate a new cell segment to avoid fruitless collection cycles in + * the near future. */ +#ifndef CELL_MINRECOVER +#define CELL_MINRECOVER (CELL_SEGSIZE >> 2) +#endif struct cell_segment *cell_segments; /* We use 4 registers. */ diff --git a/scheme.c b/scheme.c index 933dc45..11f6fcb 100644 --- a/scheme.c +++ b/scheme.c @@ -949,15 +949,10 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) { assert (gc_enabled (sc)); if (sc->free_cell == sc->NIL) { - const int min_to_be_recovered = CELL_SEGSIZE / 4; gc(sc,a, b); - if (sc->fcells < min_to_be_recovered - || sc->free_cell == sc->NIL) { - /* if only a few recovered, get more to avoid fruitless gc's */ - if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { - sc->no_memory=1; - return sc->sink; - } + if (sc->free_cell == sc->NIL) { + sc->no_memory=1; + return sc->sink; } } x = sc->free_cell; @@ -1746,6 +1741,11 @@ static void gc(scheme *sc, pointer a, pointer b) { snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); putstr(sc,msg); } + + /* if only a few recovered, get more to avoid fruitless gc's */ + if (sc->fcells < CELL_MINRECOVER + && alloc_cellseg(sc, 1) == 0) + sc->no_memory = 1; } static void finalize_cell(scheme *sc, pointer a) { -- cgit v1.2.3 From 763bd518b27d4e125fa3dce64417ae2aca2101d4 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 19 Apr 2017 16:09:44 +0200 Subject: gpgscm: Move 'trace' and 'stringify'. * tests/gpgscm/tests.scm (trace, stringify): Move... * tests/gpgscm/lib.scm: ... here. Signed-off-by: Justus Winter --- lib.scm | 12 ++++++++++++ tests.scm | 12 ------------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/lib.scm b/lib.scm index ed3d572..cafca8d 100644 --- a/lib.scm +++ b/lib.scm @@ -29,6 +29,18 @@ (assert #t) (assert (not #f)) +;; Trace displays and returns the given value. A debugging aid. +(define (trace x) + (display x) + (newline) + x) + +;; Stringification. +(define (stringify expression) + (let ((p (open-output-string))) + (write expression p) + (get-output-string p))) + (define (filter pred lst) (cond ((null? lst) '()) ((pred (car lst)) diff --git a/tests.scm b/tests.scm index 592b36f..4107889 100644 --- a/tests.scm +++ b/tests.scm @@ -17,18 +17,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see . -;; Trace displays and returns the given value. A debugging aid. -(define (trace x) - (display x) - (newline) - x) - -;; Stringification. -(define (stringify expression) - (let ((p (open-output-string))) - (write expression p) - (get-output-string p))) - ;; Reporting. (define (echo . msg) (for-each (lambda (x) (display x) (display " ")) msg) -- cgit v1.2.3 From b17f7efba0d25807eb184393afaa412fb8559787 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 22 Mar 2017 12:40:42 +0100 Subject: tests: Locate resources and scripts relative to top source dir. -- Locate every resource and every script used in the tests using a path relative to the top of the source tree. This is a purely mechanical change, mostly done using regular expressions, with a few manual fixups here and there. Signed-off-by: Justus Winter --- tests.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests.scm b/tests.scm index 4107889..e8cea85 100644 --- a/tests.scm +++ b/tests.scm @@ -189,7 +189,7 @@ (if (absolute-path? path) path (path-join (getcwd) path))) (define (in-srcdir . names) - (canonical-path (apply path-join (cons (getenv "srcdir") names)))) + (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names)))) ;; Try to find NAME in PATHS. Returns the full path name on success, ;; or raises an error. -- cgit v1.2.3 From aa843dbcd32c65eeac8c7c3cea4efb3ed7a94a0c Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 18 Apr 2017 12:27:49 +0200 Subject: gpgscm: Make test framework less functional. * tests/gpgscm/tests.scm (test-pool, tests): Previously, these methods updated objects by creating new updated copies of the object being manipulated. This made the code awkward without any benefit, therefore I change it to just update the object. Signed-off-by: Justus Winter --- tests.scm | 75 +++++++++++++++++++++++++++++---------------------------------- 1 file changed, 35 insertions(+), 40 deletions(-) diff --git a/tests.scm b/tests.scm index e8cea85..c098218 100644 --- a/tests.scm +++ b/tests.scm @@ -498,23 +498,22 @@ (define (new procs) (package (define (add test) - (new (cons test procs))) + (set! procs (cons test procs)) + (current-environment)) + (define (pid->test pid) + (let ((t (filter (lambda (x) (= pid x::pid)) procs))) + (if (null? t) #f (car t)))) (define (wait) (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) (if (null? unfinished) - (package) - (let* ((names (map (lambda (t) t::name) unfinished)) - (pids (map (lambda (t) t::pid) unfinished)) - (results - (map (lambda (pid retcode) (list pid retcode)) - pids - (wait-processes (map stringify names) pids #t)))) - (new - (map (lambda (t) - (if t::retcode - t - (t::set-retcode (cadr (assoc t::pid results))))) - procs)))))) + (current-environment) + (let ((names (map (lambda (t) t::name) unfinished)) + (pids (map (lambda (t) t::pid) unfinished))) + (for-each + (lambda (test retcode) (test:::set! 'retcode retcode)) + (map pid->test pids) + (wait-processes (map stringify names) pids #t))))) + (current-environment)) (define (passed) (filter (lambda (p) (= 0 p::retcode)) procs)) (define (skipped) @@ -568,14 +567,9 @@ (define (new name directory spawn pid retcode logfd) (package - (define (set-directory x) - (new name x spawn pid retcode logfd)) - (define (set-retcode x) - (new name directory spawn pid x logfd)) - (define (set-pid x) - (new name directory spawn x retcode logfd)) - (define (set-logfd x) - (new name directory spawn pid retcode x)) + (define (:set! key value) + (eval `(set! ,key ,value) (current-environment)) + (current-environment)) (define (open-log-file) (let ((filename (string-append (basename name) ".log"))) (catch '() (unlink filename)) @@ -584,24 +578,25 @@ (letfd ((log (open-log-file))) (with-working-directory directory (let* ((p (inbound-pipe)) - (pid (spawn args 0 (:write-end p) (:write-end p)))) + (pid' (spawn args 0 (:write-end p) (:write-end p)))) (close (:write-end p)) (splice (:read-end p) STDERR_FILENO log) (close (:read-end p)) - (let ((t' (set-retcode (wait-process name pid #t)))) - (t'::report) - t'))))) + (set! pid pid') + (set! retcode (wait-process name pid' #t))))) + (report) + (current-environment)) (define (run-sync-quiet . args) (with-working-directory directory - (set-retcode - (wait-process - name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t)))) + (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)) + (set! retcode (wait-process name pid #t))) + (current-environment)) (define (run-async . args) (let ((log (open-log-file))) (with-working-directory directory - (new name directory spawn - (spawn args CLOSED_FD log log) - retcode log)))) + (set! pid (spawn args CLOSED_FD log log))) + (set! logfd log)) + (current-environment)) (define (status) (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) (if (not t) "FAIL" (cadr t)))) @@ -620,10 +615,10 @@ (let ((results (pool::wait))) (for-each (lambda (t) (t::report)) (reverse results::procs)) (exit (results::report))) - (let* ((wd (mkdtemp-autoremove)) - (test (car tests')) - (test' (test::set-directory wd))) - (loop (pool::add (test'::run-async)) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add (test::run-async)) (cdr tests')))))) ;; Run the setup target to create an environment, then run all given @@ -633,10 +628,10 @@ (if (null? tests') (let ((results (pool::wait))) (exit (results::report))) - (let* ((wd (mkdtemp-autoremove)) - (test (car tests')) - (test' (test::set-directory wd))) - (loop (pool::add (test'::run-sync)) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add (test::run-sync)) (cdr tests')))))) ;; Helper to create environment caches from test functions. SETUP -- cgit v1.2.3 From a3e51fab6b30774959dc7d4d3409000fdbe1f7b3 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 20 Apr 2017 11:49:17 +0200 Subject: gpgscm: Make logging less verbose and more useful. * tests/gpgscm/tests.scm (call-with-io): When being verbose, include the pid in the output, and avoid duplicating the command arguments. Signed-off-by: Justus Winter --- tests.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/tests.scm b/tests.scm index c098218..b2dcc54 100644 --- a/tests.scm +++ b/tests.scm @@ -104,10 +104,11 @@ (es-fclose (:stdout h)) (es-fclose (:stderr h)) (if (> (*verbose*) 2) - (begin - (echo (stringify what) "returned:" result) - (echo (stringify what) "wrote to stdout:" out) - (echo (stringify what) "wrote to stderr:" err))) + (info "Child" (:pid h) "returned:" + `((command ,(stringify what)) + (status ,result) + (stdout ,out) + (stderr ,err)))) (list result out err)))) ;; Accessor function for the results of 'call-with-io'. ':stdout' and -- cgit v1.2.3 From 5dc43e579ef4340c668fa7e294f5a69fef9d622e Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 18 Apr 2017 18:51:06 +0200 Subject: gpgscm: Emit JUnit-style XML reports. * tests/gpgscm/Makefile.am (EXTRA_DIST): Add new file. * tests/gpgscm/lib.scm (string-translate): New function. * tests/gpgscm/main.c (main): Load new file. * tests/gpgscm/tests.scm (dirname): New function. (test-pool): Record execution times, emit XML report. (test): Record execution times, record log file name, emit XML report. (run-tests-parallel): Write XML report. (run-tests-sequential): Likewise. * tests/gpgscm/xml.scm: New file. * tests/gpgme/Makefile.am (CLEANFILES): Add 'report.xml'. * tests/gpgsm/Makefile.am: Likewise. * tests/migrations/Makefile.am: Likewise. * tests/openpgp/Makefile.am: Likewise. Signed-off-by: Justus Winter --- Makefile.am | 1 + lib.scm | 7 +++ main.c | 2 + tests.scm | 110 +++++++++++++++++++++++++++++++++++++++++----- xml.scm | 142 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 252 insertions(+), 10 deletions(-) create mode 100644 xml.scm diff --git a/Makefile.am b/Makefile.am index dc999fb..1bdd373 100644 --- a/Makefile.am +++ b/Makefile.am @@ -25,6 +25,7 @@ EXTRA_DIST = \ lib.scm \ repl.scm \ t-child.scm \ + xml.scm \ tests.scm \ gnupg.scm \ time.scm diff --git a/lib.scm b/lib.scm index cafca8d..258f692 100644 --- a/lib.scm +++ b/lib.scm @@ -199,6 +199,13 @@ (assert (string-contains? "Hallo" "llo")) (assert (not (string-contains? "Hallo" "olla"))) +;; Translate characters. +(define (string-translate s from to) + (list->string (map (lambda (c) + (let ((i (string-index from c))) + (if i (string-ref to i) c))) (string->list s)))) +(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar")) + ;; Read a word from port P. (define (read-word . p) (list->string diff --git a/main.c b/main.c index 5e04d97..e4b535e 100644 --- a/main.c +++ b/main.c @@ -312,6 +312,8 @@ main (int argc, char **argv) err = load (sc, "lib.scm", 0, 1); if (! err) err = load (sc, "repl.scm", 0, 1); + if (! err) + err = load (sc, "xml.scm", 0, 1); if (! err) err = load (sc, "tests.scm", 0, 1); if (! err) diff --git a/tests.scm b/tests.scm index b2dcc54..3118977 100644 --- a/tests.scm +++ b/tests.scm @@ -223,6 +223,10 @@ (substring path 0 (- (string-length path) (string-length suffix))) path))) +(define (dirname path) + (let ((i (string-rindex path #\/))) + (if i (substring path 0 i) "."))) + ;; Helper for (pipe). (define :read-end car) (define :write-end cadr) @@ -511,7 +515,9 @@ (let ((names (map (lambda (t) t::name) unfinished)) (pids (map (lambda (t) t::pid) unfinished))) (for-each - (lambda (test retcode) (test:::set! 'retcode retcode)) + (lambda (test retcode) + (test::set-end-time!) + (test:::set! 'retcode retcode)) (map pid->test pids) (wait-processes (map stringify names) pids #t))))) (current-environment)) @@ -539,7 +545,15 @@ (length skipped') "skipped.") (print-tests failed' "Failed tests:") (print-tests skipped' "Skipped tests:") - (length failed'))))))) + (length failed'))) + + (define (xml) + (xx::document + (xx::tag 'testsuites + `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") + ("xsi:noNamespaceSchemaLocation" + "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd")) + (map (lambda (t) (t::xml)) procs)))))))) (define (verbosity n) (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) @@ -549,6 +563,23 @@ ;; A single test. (define test + (begin + + ;; Private definitions. + + (define (isotime->junit t) + "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}" + "20170418T145809" + (string-append (substring t 0 4) + "-" + (substring t 4 6) + "-" + (substring t 6 11) + ":" + (substring t 11 13) + ":" + (substring t 13 15))) + (package (define (scm setup name path . args) ;; Start the process. @@ -568,14 +599,34 @@ (define (new name directory spawn pid retcode logfd) (package + + ;; XXX: OO glue. + (define self (current-environment)) (define (:set! key value) (eval `(set! ,key ,value) (current-environment)) (current-environment)) + + ;; The log is written here. + (define log-file-name "not set") + + ;; Record time stamps. + (define timestamp #f) + (define start-time 0) + (define end-time 0) + + (define (set-start-time!) + (set! timestamp (isotime->junit (get-isotime))) + (set! start-time (get-time))) + (define (set-end-time!) + (set! end-time (get-time))) + (define (open-log-file) - (let ((filename (string-append (basename name) ".log"))) - (catch '() (unlink filename)) - (open filename (logior O_RDWR O_BINARY O_CREAT) #o600))) + (set! log-file-name (string-append (basename name) ".log")) + (catch '() (unlink log-file-name)) + (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) + (define (run-sync . args) + (set-start-time!) (letfd ((log (open-log-file))) (with-working-directory directory (let* ((p (inbound-pipe)) @@ -588,25 +639,62 @@ (report) (current-environment)) (define (run-sync-quiet . args) + (set-start-time!) (with-working-directory directory - (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)) - (set! retcode (wait-process name pid #t))) + (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))) + (set! retcode (wait-process name pid #t)) + (set-end-time!) (current-environment)) (define (run-async . args) + (set-start-time!) (let ((log (open-log-file))) (with-working-directory directory (set! pid (spawn args CLOSED_FD log log))) (set! logfd log)) (current-environment)) (define (status) - (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) - (if (not t) "FAIL" (cadr t)))) + (let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))) + (if (not t) 'FAIL (cadr t)))) + (define (status-string) + (cadr (assoc (status) '((PASS "PASS") + (SKIP "SKIP") + (ERROR "ERROR") + (FAIL "FAIL"))))) (define (report) (unless (= logfd CLOSED_FD) (seek logfd 0 SEEK_SET) (splice logfd STDERR_FILENO) (close logfd)) - (echo (string-append (status) ":") name)))))) + (echo (string-append (status-string) ":") name)) + + (define (xml) + (xx::tag + 'testsuite + `((name ,name) + (time ,(- end-time start-time)) + (package ,(dirname name)) + (id 0) + (timestamp ,timestamp) + (hostname "unknown") + (tests 1) + (failures ,(if (eq? FAIL (status)) 1 0)) + (errors ,(if (eq? ERROR (status)) 1 0))) + (list + (xx::tag 'properties) + (xx::tag 'testcase + `((name ,(basename name)) + (classname ,(string-translate (dirname name) "/" ".")) + (time ,(- end-time start-time))) + `(,@(case (status) + ((PASS) '()) + ((SKIP) (list (xx::tag 'skipped))) + ((ERROR) (list + (xx::tag 'error '((message "Unknown error."))))) + (else + (list (xx::tag 'failure '((message "Unknown error.")))))))) + (xx::tag 'system-out '() + (list (xx::textnode (read-all (open-input-file log-file-name))))) + (xx::tag 'system-err '() (list (xx::textnode ""))))))))))) ;; Run the setup target to create an environment, then run all given ;; tests in parallel. @@ -615,6 +703,7 @@ (if (null? tests') (let ((results (pool::wait))) (for-each (lambda (t) (t::report)) (reverse results::procs)) + ((results::xml) (open-output-file "report.xml")) (exit (results::report))) (let ((wd (mkdtemp-autoremove)) (test (car tests'))) @@ -628,6 +717,7 @@ (let loop ((pool (test-pool::new '())) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) + ((results::xml) (open-output-file "report.xml")) (exit (results::report))) (let ((wd (mkdtemp-autoremove)) (test (car tests'))) diff --git a/xml.scm b/xml.scm new file mode 100644 index 0000000..771ec36 --- /dev/null +++ b/xml.scm @@ -0,0 +1,142 @@ +;; A tiny XML library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(define xx + (begin + + ;; Private declarations. + (define quote-text + '((#\< "<") + (#\> ">") + (#\& "&"))) + + (define quote-attribute-' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\' "'"))) + + (define quote-attribute-'' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))) + + (define (escape-string quotation string sink) + ;; This implementation is a bit awkward because iteration is so + ;; slow in TinySCHEME. We rely on string-index to skip to the + ;; next character we need to escape. We also avoid allocations + ;; wherever possible. + + ;; Given a list of integers or #f, return the sublist that + ;; starts with the lowest integer. + (define (min* x) + (let loop ((lowest x) (rest x)) + (if (null? rest) + lowest + (loop (if (or (null? lowest) (not (car lowest)) + (and (car rest) (> (car lowest) (car rest)))) rest lowest) + (cdr rest))))) + + (let ((i 0) (start 0) (len (string-length string)) + (indices (map (lambda (x) (string-index string (car x))) quotation)) + (next #f) (c #f)) + + ;; Set 'i' to the index of the next character that needs + ;; escaping, 'c' to the character that needs to be escaped, + ;; and update 'indices'. + (define (skip!) + (set! next (min* indices)) + (set! i (if (null? next) #f (car next))) + (if i + (begin + (set! c (string-ref string i)) + (set-car! next (string-index string c (+ 1 i)))) + (set! i (string-length string)))) + + (let loop () + (skip!) + (if (< i len) + (begin + (display (substring string start i) sink) + (display (cadr (assv c quotation)) sink) + (set! i (+ 1 i)) + (set! start i) + (loop)) + (display (substring string start len) sink))))) + + (let ((escape-string-s (lambda (quotation string) + (let ((sink (open-output-string))) + (escape-string quotation string sink) + (get-output-string sink))))) + (assert (equal? (escape-string-s quote-text "foo") "foo")) + (assert (equal? (escape-string-s quote-text "foo&") "foo&")) + (assert (equal? (escape-string-s quote-text "&foo") "&foo")) + (assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar")) + (assert (equal? (escape-string-s quote-text "foobar") "foo>bar"))) + + (define (escape quotation datum sink) + (cond + ((string? datum) (escape-string quotation datum sink)) + ((symbol? datum) (escape-string quotation (symbol->string datum) sink)) + ((number? datum) (display (number->string datum) sink)) + (else + (throw "Do not know how to encode" datum)))) + + (define (name->string name) + (cond + ((symbol? name) (symbol->string name)) + (else name))) + + (package + + (define (textnode string) + (lambda (sink) + (escape quote-text string sink))) + + (define (tag name . rest) + (let ((attributes (if (null? rest) '() (car rest))) + (children (if (> (length rest) 1) (cadr rest) '()))) + (lambda (sink) + (display "<" sink) + (display (name->string name) sink) + (unless (null? attributes) + (display " " sink) + (for-each (lambda (a) + (display (car a) sink) + (display "=\"" sink) + (escape quote-attribute-'' (cadr a) sink) + (display "\" " sink)) attributes)) + (if (null? children) + (display "/>\n" sink) + (begin + (display ">\n" sink) + (for-each (lambda (c) (c sink)) children) + (display "string name) sink) + (display ">\n" sink)))))) + + (define (document root . rest) + (let ((attributes (if (null? rest) '() (car rest)))) + (lambda (sink) + ;; xxx ignores attributes + (display "\n" sink) + (root sink) + (newline sink))))))) -- cgit v1.2.3 From 008894eff46724d60a24879d319b427606fcafd1 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 20 Apr 2017 15:09:13 +0200 Subject: gpgscm: Improve syntax checking. * tests/gpgscm/scheme.c (opexe_0): Make sure closure arguments are symbols. Signed-off-by: Justus Winter --- scheme.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index 11f6fcb..38f2870 100644 --- a/scheme.c +++ b/scheme.c @@ -3559,10 +3559,13 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { is_pair(x); x = cdr(x), y = cdr(y)) { if (y == sc->NIL) { Error_1(sc, "not enough arguments, missing:", x); - } else { + } else if (is_symbol(car(x))) { new_slot_in_env(sc, car(x), car(y)); - } + } else { + Error_1(sc, "syntax error in closure: not a symbol", car(x)); + } } + if (x == sc->NIL) { if (y != sc->NIL) { Error_0(sc, "too many arguments"); -- cgit v1.2.3 From b67d1a3f36f2b15fb75de613942668b71cad1bd7 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 20 Apr 2017 17:32:25 +0200 Subject: gpgscm: Fix test. * tests/gpgscm/t-child.scm: Use 'string-length' on the string. Signed-off-by: Justus Winter --- t-child.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/t-child.scm b/t-child.scm index 93208f4..fd1dcc3 100644 --- a/t-child.scm +++ b/t-child.scm @@ -107,12 +107,12 @@ (pipe:spawn `(,child stdout4096)) (pipe:spawn `(,child cat))) (tr:call-with-content (lambda (c) - (assert (= 4096 (length c)))))) + (assert (= 4096 (string-length c)))))) (tr:do (tr:pipe-do (pipe:spawn `(,child stdout8192)) (pipe:spawn `(,child cat))) (tr:call-with-content (lambda (c) - (assert (= 8192 (length c)))))) + (assert (= 8192 (string-length c)))))) (echo "All good.") -- cgit v1.2.3 From e8c896c7f9aabad6e1387f538accb54ac6b2b1cc Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 20 Apr 2017 17:38:43 +0200 Subject: gpgscm: Tweak error message display. * tests/gpgscm/init.scm (throw'): If the first argument to the error is a string, display it as such. Signed-off-by: Justus Winter --- init.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/init.scm b/init.scm index 87d3c88..af38620 100644 --- a/init.scm +++ b/init.scm @@ -613,8 +613,13 @@ (quit (cadr args))) (else (display message) - (if args (begin - (display ": ") + (when (and args (not (null? args))) + (display ": ") + (if (string? (car args)) + (begin (display (car args)) + (unless (null? (cdr args)) + (newline) + (write (cdr args)))) (write args))) (newline) (vm-history-print history) -- cgit v1.2.3 From 36e266a5cbb78560d32bc33f18f9041db1ff5080 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 20 Apr 2017 17:39:41 +0200 Subject: gpgscm: Refactor cell finalization. * tests/gpgscm/scheme.c (finalize_cell): Use switch, return whether the cell may be freed. (gc): Update callsite. Signed-off-by: Justus Winter --- scheme.c | 65 ++++++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 41 insertions(+), 24 deletions(-) diff --git a/scheme.c b/scheme.c index 38f2870..811c51f 100644 --- a/scheme.c +++ b/scheme.c @@ -402,7 +402,7 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b); static pointer reserve_cells(scheme *sc, int n); static pointer get_consecutive_cells(scheme *sc, int n); static pointer find_consecutive_cells(scheme *sc, int n); -static void finalize_cell(scheme *sc, pointer a); +static int finalize_cell(scheme *sc, pointer a); static int count_consecutive_cells(pointer x, int needed); static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); static pointer mk_number(scheme *sc, num n); @@ -1723,15 +1723,16 @@ static void gc(scheme *sc, pointer a, pointer b) { if (is_mark(p)) { clrmark(p); } else { - /* reclaim cell */ - if (typeflag(p) & T_FINALIZE) { - finalize_cell(sc, p); - } - ++sc->fcells; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; + /* reclaim cell */ + if ((typeflag(p) & T_FINALIZE) == 0 + || finalize_cell(sc, p)) { + /* Reclaim cell. */ + ++sc->fcells; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + } } } } @@ -1748,10 +1749,17 @@ static void gc(scheme *sc, pointer a, pointer b) { sc->no_memory = 1; } -static void finalize_cell(scheme *sc, pointer a) { - if(is_string(a)) { +/* Finalize A. Returns true if a can be added to the list of free + * cells. */ +static int +finalize_cell(scheme *sc, pointer a) +{ + switch (type(a)) { + case T_STRING: sc->free(strvalue(a)); - } else if(is_port(a)) { + break; + + case T_PORT: if(a->_object._port->kind&port_file && a->_object._port->rep.stdio.closeit) { port_close(sc,a,port_input|port_output); @@ -1759,19 +1767,28 @@ static void finalize_cell(scheme *sc, pointer a) { sc->free(a->_object._port->rep.string.start); } sc->free(a->_object._port); - } else if(is_foreign_object(a)) { + break; + + case T_FOREIGN_OBJECT: a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); - } else if (is_vector(a)) { - int i; - for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { - pointer p = a + i; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; - sc->fcells += 1; - } + break; + + case T_VECTOR: + do { + int i; + for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { + pointer p = a + i; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + sc->fcells += 1; + } + break; + } while (0); } + + return 1; /* Free cell. */ } #if SHOW_ERROR_LINE -- cgit v1.2.3 From 814783e753fa48982116a34dd73fb62105ed82d8 Mon Sep 17 00:00:00 2001 From: NIIBE Yutaka Date: Fri, 28 Apr 2017 10:06:33 +0900 Subject: Spelling fixes in docs and comments. -- In addition, fix trailing spaces in tests/inittests. GnuPG-bug-id: 3121 Reported-by: ka7 (klemens) Signed-off-by: NIIBE Yutaka --- tests.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests.scm b/tests.scm index 3118977..c6c887f 100644 --- a/tests.scm +++ b/tests.scm @@ -236,7 +236,7 @@ ;; (letfd ) ;; ;; Bind all variables given in and initialize each of them -;; to the given initial value, and close them after evaluting . +;; to the given initial value, and close them after evaluating . (define-macro (letfd bindings . body) (let bind ((bindings' bindings)) (if (null? bindings') @@ -305,7 +305,7 @@ ;; ;; Bind all variables given in , initialize each of them to ;; a string representing an unique path in the filesystem, and delete -;; them after evaluting . +;; them after evaluating . (define-macro (lettmp bindings . body) (let bind ((bindings' bindings)) (if (null? bindings') -- cgit v1.2.3 From df499c6ee5edf0a560138640141a3abef360b4f5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 5 Apr 2017 17:30:44 +0200 Subject: gpgscm: Merge opexe_0. * tests/gpgscm/scheme-private.h (struct scheme): Remove field 'op'. * tests/gpgscm/scheme.c (opexe_0): Inline into 'Eval_Cycle'. (_Error_1): Return the opcode to evaluate next. (Error_1): Do not return, but set the opcode and goto dispatch. (Error_0): Likewise. (s_goto): Likewise. (s_return): Likewise. (s_return_enable_gc): Likewise. (s_thread_to): Remove superfluous cast. (_s_return): Return the opcode to evaluate next. (scheme_init_custom_alloc): Adapt to removal of field 'op'. Signed-off-by: Justus Winter --- scheme-private.h | 1 - scheme.c | 86 +++++++++++++++++++++++++------------------------------- 2 files changed, 38 insertions(+), 49 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index bc0269a..0ba9a53 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -196,7 +196,6 @@ FILE *tmpfp; int tok; int print_flag; pointer value; -int op; unsigned int flags; void *ext_data; /* For the benefit of foreign functions */ diff --git a/scheme.c b/scheme.c index 811c51f..47051f2 100644 --- a/scheme.c +++ b/scheme.c @@ -437,7 +437,6 @@ static pointer reverse(scheme *sc, pointer term, pointer list); static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); -static pointer opexe_0(scheme *sc, enum scheme_opcodes op); struct op_code_info { char name[31]; /* strlen ("call-with-current-continuation") + 1 */ unsigned char min_arity; @@ -2834,7 +2833,8 @@ static INLINE pointer slot_value_in_env(pointer slot) /* ========== Evaluation Cycle ========== */ -static pointer _Error_1(scheme *sc, const char *s, pointer a) { +static enum scheme_opcodes +_Error_1(scheme *sc, const char *s, pointer a) { const char *str = s; pointer history; #if USE_ERROR_HOOK @@ -2892,8 +2892,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { sc->code = cons(sc, mk_string(sc, str), sc->code); setimmutable(car(sc->code)); sc->code = cons(sc, slot_value_in_env(x), sc->code); - sc->op = (int)OP_EVAL; - return sc->T; + return OP_EVAL; } #endif @@ -2904,11 +2903,10 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { } sc->args = cons(sc, mk_string(sc, str), sc->args); setimmutable(car(sc->args)); - sc->op = (int)OP_ERR0; - return sc->T; + return OP_ERR0; } -#define Error_1(sc,s, a) return _Error_1(sc,s,a) -#define Error_0(sc,s) return _Error_1(sc,s,0) +#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; } +#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; } /* Too small to turn into function */ # define BEGIN do { @@ -2949,9 +2947,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { /* Bounce back to Eval_Cycle and execute A. */ -#define s_goto(sc,a) BEGIN \ - sc->op = (int)(a); \ - return sc->T; END +#define s_goto(sc, a) { op = (a); goto dispatch; } #if USE_THREADED_CODE @@ -2959,7 +2955,7 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { * to it. */ #define s_thread_to(sc, a) \ BEGIN \ - op = (int) (a); \ + op = (a); \ goto a; \ END @@ -2975,11 +2971,11 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { /* Return to the previous frame on the dump stack, setting the current * value to A. */ -#define s_return(sc, a) return _s_return(sc, a, 0) +#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0)) /* Return to the previous frame on the dump stack, setting the current * value to A, and re-enable the garbage collector. */ -#define s_return_enable_gc(sc, a) return _s_return(sc, a, 1) +#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1)) static INLINE void dump_stack_reset(scheme *sc) { @@ -2996,18 +2992,20 @@ static void dump_stack_free(scheme *sc) sc->dump = sc->NIL; } -static pointer _s_return(scheme *sc, pointer a, int enable_gc) { +static enum scheme_opcodes +_s_return(scheme *sc, pointer a, int enable_gc) { pointer dump = sc->dump; pointer op; unsigned long v; + enum scheme_opcodes next_op; sc->value = (a); if (enable_gc) gc_enable(sc); if (dump == sc->NIL) - return sc->NIL; + return OP_QUIT; free_cons(sc, dump, &op, &dump); v = (unsigned long) ivalue_unchecked(op); - sc->op = (int) (v & S_OP_MASK); + next_op = (int) (v & S_OP_MASK); sc->flags = v & S_FLAG_MASK; #ifdef USE_SMALL_INTEGERS if (v < MAX_SMALL_INTEGER) { @@ -3019,7 +3017,7 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) { free_cons(sc, dump, &sc->args, &dump); free_cons(sc, dump, &sc->envir, &dump); free_cons(sc, dump, &sc->code, &sc->dump); - return sc->T; + return next_op; } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { @@ -3357,7 +3355,10 @@ int list_length(scheme *sc, pointer a) { #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) -static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { +/* kernel of this interpreter */ +static void +Eval_Cycle(scheme *sc, enum scheme_opcodes op) { + for (;;) { pointer x, y; pointer callsite; num v; @@ -3365,6 +3366,21 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { double dd; #endif int (*comp_func)(num, num) = NULL; + const struct op_code_info *pcd = &dispatch_table[op]; + + dispatch: + if (pcd->name[0] != 0) { /* if built-in function, check arguments */ + char msg[STRBUFFSIZE]; + if (! check_arguments (sc, pcd, msg, sizeof msg)) { + s_goto(sc, _Error_1(sc, msg, 0)); + } + } + + if(sc->no_memory) { + fprintf(stderr,"No memory!\n"); + exit(1); + } + ok_to_freely_gc(sc); switch (op) { CASE(OP_LOAD): /* load */ @@ -4693,7 +4709,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if(sc->interactive_repl) { s_thread_to(sc,OP_T0LVL); } else { - return sc->NIL; + return; } } @@ -4760,7 +4776,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if(is_pair(sc->args)) { sc->retcode=ivalue(car(sc->args)); } - return (sc->NIL); + return; CASE(OP_GC): /* gc */ gc(sc, sc->NIL, sc->NIL); @@ -5206,7 +5222,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op); Error_0(sc,sc->strbuff); } - return sc->T; /* NOTREACHED */ + } } typedef int (*test_predicate)(pointer); @@ -5335,31 +5351,6 @@ check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t m return ok; } -/* kernel of this interpreter */ -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { - sc->op = op; - for (;;) { - const struct op_code_info *pcd=dispatch_table+sc->op; - if (pcd->name[0] != 0) { /* if built-in function, check arguments */ - char msg[STRBUFFSIZE]; - if (! check_arguments (sc, pcd, msg, sizeof msg)) { - if(_Error_1(sc,msg,0)==sc->NIL) { - return; - } - pcd=dispatch_table+sc->op; - } - } - ok_to_freely_gc(sc); - if (opexe_0(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { - return; - } - if(sc->no_memory) { - fprintf(stderr,"No memory!\n"); - exit(1); - } - } -} - /* ========== Initialization of internal keywords ========== */ /* Symbols representing syntax are tagged with (OP . '()). */ @@ -5551,7 +5542,6 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { dump_stack_initialize(sc); sc->code = sc->NIL; sc->tracing=0; - sc->op = -1; sc->flags = 0; /* init sc->NIL */ -- cgit v1.2.3 From 272b0ad65ec4c6023d4b5a4fb2f003ada432b6e5 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 6 Apr 2017 11:52:36 +0200 Subject: gpgscm: Create and re-use frame objects. * tests/gpgscm/scheme-private.h (struct scheme): New field 'frame_freelist'. * tests/gpgscm/scheme.c (enum scheme_types): New type 'T_FRAME'. (type_to_string): Handle new type. (settype): New macro. (gc_disable): Make sure there is at least one frame in the free list. (mark): Handle frame objects. (finalize_cell): Likewise. (dump_stack_initialize): Initialize free list. (dump_stack_free): Simplify. (frame_length): New variable. (dump_stack_make_frame): New function. (frame_slots): Likewise. (frame_payload): New macro. (dump_stack_allocate_frame): New function. (dump_stack_deallocate_frame): Likewise. (dump_stack_preallocate_frame): Likewise. (_s_return): Unpack frame object and deallocate it. (s_save): Wrap state in an frame object. (dump_stack_mark): Mark the free list. -- TinySCHEME being a SECD-machine needs to push frames onto the dump stack. Previously, the dump stack was a list. This required four cells for the spine, as well as up to one additional cell to encode the current opcode. This was quite inefficient despite the fact that we recovered the spine as well as the integer cell. We introduce frame objects, which are a special variant of vectors of length four. Since the length is fixed, this frees up the length field of the vector object to store the unboxed opcode. A frame object now fits in two cells. Saving two or three cells is a mere byproduct, the performance gain comes from increased locality, unboxed opcode representation, and the ability to easily put the objects in a free list, keeping the garbage collector out of the continuous motion of the virtual machine. Signed-off-by: Justus Winter --- scheme-private.h | 1 + scheme.c | 141 ++++++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 114 insertions(+), 28 deletions(-) diff --git a/scheme-private.h b/scheme-private.h index 0ba9a53..7f92bda 100644 --- a/scheme-private.h +++ b/scheme-private.h @@ -122,6 +122,7 @@ pointer args; /* register for arguments of function */ pointer envir; /* stack register for current environment */ pointer code; /* register for current code */ pointer dump; /* stack register for next evaluation */ +pointer frame_freelist; #if USE_HISTORY struct history history; /* we keep track of the call history for diff --git a/scheme.c b/scheme.c index 47051f2..26bb5a5 100644 --- a/scheme.c +++ b/scheme.c @@ -139,7 +139,8 @@ enum scheme_types { T_NIL = 17 << 1 | 1, T_EOF_OBJ = 18 << 1 | 1, T_SINK = 19 << 1 | 1, - T_LAST_SYSTEM_TYPE = 19 << 1 | 1 + T_FRAME = 20 << 1 | 1, + T_LAST_SYSTEM_TYPE = 20 << 1 | 1 }; static const char * @@ -166,6 +167,7 @@ type_to_string (enum scheme_types typ) case T_NIL: return "nil"; case T_EOF_OBJ: return "eof object"; case T_SINK: return "sink"; + case T_FRAME: return "frame"; } assert (! "not reached"); } @@ -174,6 +176,7 @@ type_to_string (enum scheme_types typ) #define TYPE_BITS 6 #define ADJ (1 << TYPE_BITS) #define T_MASKTYPE (ADJ - 1) + /* 0000000000111111 */ #define T_TAGGED 1024 /* 0000010000000000 */ #define T_FINALIZE 2048 /* 0000100000000000 */ #define T_SYNTAX 4096 /* 0001000000000000 */ @@ -211,6 +214,7 @@ static const struct num num_one = { 1, {1} }; /* macros for cell operations */ #define typeflag(p) ((p)->_flag) #define type(p) (typeflag(p)&T_MASKTYPE) +#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ)) INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } #define strvalue(p) ((p)->_object._string._svalue) @@ -299,6 +303,9 @@ INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } #define setenvironment(p) typeflag(p) = T_ENVIRONMENT +INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); } +#define setframe(p) settype(p, T_FRAME) + #define is_atom(p) (typeflag(p)&T_ATOM) #define setatom(p) typeflag(p) |= T_ATOM #define clratom(p) typeflag(p) &= CLRATOM @@ -436,6 +443,7 @@ static pointer mk_continuation(scheme *sc, pointer d); static pointer reverse(scheme *sc, pointer term, pointer list); static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); +static void dump_stack_preallocate_frame(scheme *sc); static void dump_stack_mark(scheme *); struct op_code_info { char name[31]; /* strlen ("call-with-current-continuation") + 1 */ @@ -867,7 +875,8 @@ gc_reservation_failure(struct scheme *sc) "insufficient reservation\n") #else fprintf(stderr, - "insufficient reservation in line %d\n", + "insufficient %s reservation in line %d\n", + sc->frame_freelist == sc->NIL ? "frame" : "cell", sc->reserved_lineno); #endif abort(); @@ -893,7 +902,15 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno) sc->inhibit_gc += 1; } #define gc_disable(sc, reserve) \ - _gc_disable (sc, reserve, __LINE__) + do { \ + if (sc->frame_freelist == sc->NIL) { \ + if (gc_enabled(sc)) \ + dump_stack_preallocate_frame(sc); \ + else \ + gc_reservation_failure(sc); \ + } \ + _gc_disable (sc, reserve, __LINE__); \ + } while (0) /* Enable the garbage collector. */ #define gc_enable(sc) \ @@ -917,7 +934,12 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno) #else /* USE_GC_LOCKING */ -#define gc_disable(sc, reserve) (void) 0 +#define gc_reservation_failure(sc) (void) 0 +#define gc_disable(sc, reserve) \ + do { \ + if (sc->frame_freelist == sc->NIL) \ + dump_stack_preallocate_frame(sc); \ + } while (0) #define gc_enable(sc) (void) 0 #define gc_enabled(sc) 1 #define gc_consume(sc) (void) 0 @@ -1284,8 +1306,6 @@ INTERFACE pointer mk_character(scheme *sc, int c) { #if USE_SMALL_INTEGERS -/* s_save assumes that all opcodes can be expressed as a small - * integer. */ static const struct cell small_integers[] = { #define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}}, #include "small-integers.h" @@ -1599,6 +1619,9 @@ static pointer mk_sharp_const(scheme *sc, char *name) { /* ========== garbage collector ========== */ +const int frame_length; +static void dump_stack_deallocate_frame(scheme *sc, pointer frame); + /*-- * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, @@ -1611,9 +1634,10 @@ static void mark(pointer a) { p = a; E2: if (! is_mark(p)) setmark(p); - if(is_vector(p)) { + if (is_vector(p) || is_frame(p)) { int i; - for (i = 0; i < vector_length(p); i++) { + int len = is_vector(p) ? vector_length(p) : frame_length; + for (i = 0; i < len; i++) { mark(p->_object._vector._elements[i]); } } @@ -1783,8 +1807,12 @@ finalize_cell(scheme *sc, pointer a) sc->free_cell = p; sc->fcells += 1; } - break; } while (0); + break; + + case T_FRAME: + dump_stack_deallocate_frame(sc, a); + return 0; /* Do not free cell. */ } return 1; /* Free cell. */ @@ -2985,17 +3013,73 @@ static INLINE void dump_stack_reset(scheme *sc) static INLINE void dump_stack_initialize(scheme *sc) { dump_stack_reset(sc); + sc->frame_freelist = sc->NIL; } static void dump_stack_free(scheme *sc) { - sc->dump = sc->NIL; + dump_stack_initialize(sc); +} + +const int frame_length = 4; + +static pointer +dump_stack_make_frame(scheme *sc) +{ + pointer frame; + + frame = mk_vector(sc, frame_length); + if (! sc->no_memory) + setframe(frame); + + return frame; +} + +static INLINE pointer * +frame_slots(pointer frame) +{ + return &frame->_object._vector._elements[0]; +} + +#define frame_payload vector_length + +static pointer +dump_stack_allocate_frame(scheme *sc) +{ + pointer frame = sc->frame_freelist; + if (frame == sc->NIL) { + if (gc_enabled(sc)) + frame = dump_stack_make_frame(sc); + else + gc_reservation_failure(sc); + } else + sc->frame_freelist = *frame_slots(frame); + return frame; +} + +static void +dump_stack_deallocate_frame(scheme *sc, pointer frame) +{ + pointer *p = frame_slots(frame); + *p++ = sc->frame_freelist; + *p++ = sc->NIL; + *p++ = sc->NIL; + *p++ = sc->NIL; + sc->frame_freelist = frame; +} + +static void +dump_stack_preallocate_frame(scheme *sc) +{ + pointer frame = dump_stack_make_frame(sc); + if (! sc->no_memory) + dump_stack_deallocate_frame(sc, frame); } static enum scheme_opcodes _s_return(scheme *sc, pointer a, int enable_gc) { pointer dump = sc->dump; - pointer op; + pointer *p; unsigned long v; enum scheme_opcodes next_op; sc->value = (a); @@ -3003,37 +3087,38 @@ _s_return(scheme *sc, pointer a, int enable_gc) { gc_enable(sc); if (dump == sc->NIL) return OP_QUIT; - free_cons(sc, dump, &op, &dump); - v = (unsigned long) ivalue_unchecked(op); + v = frame_payload(dump); next_op = (int) (v & S_OP_MASK); sc->flags = v & S_FLAG_MASK; -#ifdef USE_SMALL_INTEGERS - if (v < MAX_SMALL_INTEGER) { - /* This is a small integer, we must not free it. */ - } else - /* Normal integer. Recover the cell. */ -#endif - free_cell(sc, op); - free_cons(sc, dump, &sc->args, &dump); - free_cons(sc, dump, &sc->envir, &dump); - free_cons(sc, dump, &sc->code, &sc->dump); + p = frame_slots(dump); + sc->args = *p++; + sc->envir = *p++; + sc->code = *p++; + sc->dump = *p++; + dump_stack_deallocate_frame(sc, dump); return next_op; } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { -#define s_save_allocates 5 +#define s_save_allocates 0 pointer dump; - unsigned long v = sc->flags | ((unsigned long) op); + pointer *p; gc_disable(sc, gc_reservations (s_save)); - dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); - dump = cons(sc, (args), dump); - sc->dump = cons(sc, mk_integer(sc, (long) v), dump); + dump = dump_stack_allocate_frame(sc); + frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op); + p = frame_slots(dump); + *p++ = args; + *p++ = sc->envir; + *p++ = code; + *p++ = sc->dump; + sc->dump = dump; gc_enable(sc); } static INLINE void dump_stack_mark(scheme *sc) { mark(sc->dump); + mark(sc->frame_freelist); } -- cgit v1.2.3 From 212a0febf8bbaf735ae2e65722f39a47a1c5b122 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 4 May 2017 15:12:49 +0200 Subject: tests: Support tests that are expected to fail. * tests/gpgscm/tests.scm (test-pool): Rework reporting. Filter using the computed test status instead of the return value. Also print the new categories 'failed expectedly' and 'passed unexpectedly'. (test): If a test ends with a bang (!), it is expected to fail. Adapt status, status-string, and xml accordingly. -- Allow tests to be marked as being expected to fail by appending a bang (!) to the tests name. If such a test fails, it will not be counted as failure, but will still be prominently displayed in the report. If it succeeds unexpectedly, this is counted as a failure. Fixes T3134. GnuPG-bug-id: 3134 Signed-off-by: Justus Winter --- tests.scm | 67 ++++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 27 deletions(-) diff --git a/tests.scm b/tests.scm index c6c887f..e5ec5c7 100644 --- a/tests.scm +++ b/tests.scm @@ -521,31 +521,29 @@ (map pid->test pids) (wait-processes (map stringify names) pids #t))))) (current-environment)) - (define (passed) - (filter (lambda (p) (= 0 p::retcode)) procs)) - (define (skipped) - (filter (lambda (p) (= 77 p::retcode)) procs)) - (define (hard-errored) - (filter (lambda (p) (= 99 p::retcode)) procs)) - (define (failed) - (filter (lambda (p) - (not (or (= 0 p::retcode) (= 77 p::retcode) - (= 99 p::retcode)))) - procs)) + (define (filter-tests status) + (filter (lambda (p) (eq? status (p::status))) procs)) (define (report) (define (print-tests tests message) (unless (null? tests) (apply echo (cons message (map (lambda (t) t::name) tests))))) - (let ((failed' (failed)) (skipped' (skipped))) + (let ((failed (filter-tests 'FAIL)) + (xfailed (filter-tests 'XFAIL)) + (xpassed (filter-tests 'XPASS)) + (skipped (filter-tests 'SKIP))) (echo (length procs) "tests run," - (length (passed)) "succeeded," - (length failed') "failed," - (length skipped') "skipped.") - (print-tests failed' "Failed tests:") - (print-tests skipped' "Skipped tests:") - (length failed'))) + (length (filter-tests 'PASS)) "succeeded," + (length failed) "failed," + (length xfailed) "failed expectedly," + (length xpassed) "succeeded unexpectedly," + (length skipped) "skipped.") + (print-tests failed "Failed tests:") + (print-tests xfailed "Expectedly failed tests:") + (print-tests xpassed "Unexpectedly passed tests:") + (print-tests skipped "Skipped tests:") + (+ (length failed) (length xpassed)))) (define (xml) (xx::document @@ -580,24 +578,34 @@ ":" (substring t 13 15))) + ;; If a tests name ends with a bang (!), it is expected to fail. + (define (expect-failure? name) + (string-suffix? name "!")) + ;; Strips the bang (if any). + (define (test-name name) + (if (expect-failure? name) + (substring name 0 (- (string-length name) 1)) + name)) + (package (define (scm setup name path . args) ;; Start the process. (define (spawn-scm args' in out err) (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) - ,(locate-test path) + ,(locate-test (test-name path)) ,@(if setup (force setup) '()) ,@args' ,@args) in out err)) - (new name #f spawn-scm #f #f CLOSED_FD)) + (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name))) (define (binary setup name path . args) ;; Start the process. (define (spawn-binary args' in out err) - (spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args) + (spawn-process-fd `(,(test-name path) + ,@(if setup (force setup) '()) ,@args' ,@args) in out err)) - (new name #f spawn-binary #f #f CLOSED_FD)) + (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name))) - (define (new name directory spawn pid retcode logfd) + (define (new name directory spawn pid retcode logfd expect-failure) (package ;; XXX: OO glue. @@ -653,13 +661,18 @@ (set! logfd log)) (current-environment)) (define (status) - (let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))) - (if (not t) 'FAIL (cadr t)))) + (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))) + (t (if (not t') 'FAIL (cadr t')))) + (if expect-failure + (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t)) + t))) (define (status-string) (cadr (assoc (status) '((PASS "PASS") (SKIP "SKIP") (ERROR "ERROR") - (FAIL "FAIL"))))) + (FAIL "FAIL") + (XPASS "XPASS") + (XFAIL "XFAIL"))))) (define (report) (unless (= logfd CLOSED_FD) (seek logfd 0 SEEK_SET) @@ -686,7 +699,7 @@ (classname ,(string-translate (dirname name) "/" ".")) (time ,(- end-time start-time))) `(,@(case (status) - ((PASS) '()) + ((PASS XFAIL) '()) ((SKIP) (list (xx::tag 'skipped))) ((ERROR) (list (xx::tag 'error '((message "Unknown error."))))) -- cgit v1.2.3 From dd48994b0c99a4099f49ccd437a08ddff39af8a2 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 11 May 2017 14:44:33 +0200 Subject: gpgscm: Make it possible to set the logfile name. * tests/gpgscm/tests.scm (test): Only set the default log filename when it has not been set before. Signed-off-by: Justus Winter --- tests.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests.scm b/tests.scm index e5ec5c7..490f95a 100644 --- a/tests.scm +++ b/tests.scm @@ -615,7 +615,7 @@ (current-environment)) ;; The log is written here. - (define log-file-name "not set") + (define log-file-name #f) ;; Record time stamps. (define timestamp #f) @@ -629,7 +629,8 @@ (set! end-time (get-time))) (define (open-log-file) - (set! log-file-name (string-append (basename name) ".log")) + (unless log-file-name + (set! log-file-name (string-append (basename name) ".log"))) (catch '() (unlink log-file-name)) (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) -- cgit v1.2.3 From 197404aae66c688d004337c0aefe153ef6b10f87 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 20 Mar 2017 10:21:06 +0100 Subject: tests: Move the makefile parser. * tests/gpgme/gpgme-defs.scm (parse-makefile, parse-makefile-expand): Move... * tests/gpgscm/makefile.scm: ... here. * tests/gpgscm/Makefile.am (EXTRA_DIST): Add new file. Signed-off-by: Justus Winter --- Makefile.am | 1 + makefile.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 77 insertions(+) create mode 100644 makefile.scm diff --git a/Makefile.am b/Makefile.am index 1bdd373..44d7b3f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -23,6 +23,7 @@ EXTRA_DIST = \ ffi.scm \ init.scm \ lib.scm \ + makefile.scm \ repl.scm \ t-child.scm \ xml.scm \ diff --git a/makefile.scm b/makefile.scm new file mode 100644 index 0000000..32fae3a --- /dev/null +++ b/makefile.scm @@ -0,0 +1,76 @@ +;; Support for parsing Makefiles +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(define (parse-makefile port key) + (define (is-continuation? tokens) + (string=? (last tokens) "\\")) + (define (valid-token? s) + (< 0 (string-length s))) + (define (drop-continuations tokens) + (let loop ((acc '()) (tks tokens)) + (if (null? tks) + (reverse acc) + (loop (if (string=? "\\" (car tks)) + acc + (cons (car tks) acc)) (cdr tks))))) + (let next ((acc '()) (found #f)) + (let ((line (read-line port))) + (if (eof-object? line) + acc + (let ((tokens (filter valid-token? + (string-splitp (string-trim char-whitespace? + line) + char-whitespace? -1)))) + (cond + ((or (null? tokens) + (string-prefix? (car tokens) "#") + (and (not found) (not (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))))) + (next acc found)) + ((not found) + (assert (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))) + (if (is-continuation? tokens) + (next (drop-continuations (cddr tokens)) #t) + (drop-continuations (cddr tokens)))) + (else + (assert found) + (if (is-continuation? tokens) + (next (append acc (drop-continuations tokens)) found) + (append acc (drop-continuations tokens)))))))))) + +(define (parse-makefile-expand filename expand key) + (define (variable? v) + (and (string-prefix? v "$(") (string-suffix? v ")"))) + + (let expand-all ((values (parse-makefile (open-input-file filename) key))) + (if (any variable? values) + (expand-all + (let expand-one ((acc '()) (v values)) + (cond + ((null? v) + acc) + ((variable? (car v)) + (let ((makefile (open-input-file filename)) + (key (substring (car v) 2 (- (string-length (car v)) 1)))) + (expand-one (append acc (expand filename makefile key)) + (cdr v)))) + (else + (expand-one (append acc (list (car v))) (cdr v)))))) + values))) -- cgit v1.2.3 From 4bc110e219b13d551c0c6c9987b7602e44715032 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 20 Mar 2017 10:30:08 +0100 Subject: tests: Make it possible to run all tests using our infrastructure. * Makefile.am (TESTS_ENVIRONMENT): New variable. (check-all): New phony target to run all tests. * tests/gpgme/gpgme-defs.scm (have-gpgme?): New function that tests whether the GPGME test suite is available instead of exiting the process. * tests/gpgscm/init.scm (export): New macro. * tests/gpgscm/tests.scm (run-tests): New function. (load-tests): Likewise. * tests/gpgme/run-tests.scm: Simplify and move the parsing of the list of tests to 'all-tests.scm'. * tests/gpgsm/run-tests.scm: Likewise. * tests/migrations/run-tests.scm: Likewise. * tests/openpgp/run-tests.scm: Likewise. * tests/gpgme/Makefile.am: To select the tests to run, use the variable 'TESTS'. This harmonizes the interface with the automake test suite. * tests/gpgsm/Makefile.am: Likewise. * tests/migrations/Makefile.am: Likewise. * tests/openpgp/Makefile.am: Likewise. * tests/openpgp/README: Likewise. * agent/all-tests.scm: New file. * common/all-tests.scm: Likewise. * g10/all-tests.scm: Likewise. * g13/all-tests.scm: Likewise. * tests/gpgme/all-tests.scm: Likewise. * tests/gpgsm/all-tests.scm: Likewise. * tests/migrations/all-tests.scm: Likewise. * tests/openpgp/all-tests.scm: Likewise. * tests/run-tests.scm: Likewise. -- This change allows us to run all tests in parallel and write one XML report capturing the results of every test. It also lays the foundation to parametrize test suites. Signed-off-by: Justus Winter --- init.scm | 5 +++++ tests.scm | 14 ++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/init.scm b/init.scm index af38620..3769ed0 100644 --- a/init.scm +++ b/init.scm @@ -701,6 +701,11 @@ ,@(cdr form) (current-environment)))) +(define-macro (export name . expressions) + `(define ,name + (begin + ,@expressions))) + ;;;;; I/O (define (input-output-port? p) diff --git a/tests.scm b/tests.scm index 490f95a..eee8ce5 100644 --- a/tests.scm +++ b/tests.scm @@ -226,6 +226,7 @@ (define (dirname path) (let ((i (string-rindex path #\/))) (if i (substring path 0 i) "."))) +(assert (string=? "foo/bar" (dirname "foo/bar/baz"))) ;; Helper for (pipe). (define :read-end car) @@ -739,6 +740,19 @@ (loop (pool::add (test::run-sync)) (cdr tests')))))) +;; Run tests either in sequence or in parallel, depending on the +;; number of tests and the command line flags. +(define (run-tests tests) + (if (and (flag "--parallel" *args*) + (> (length tests) 1)) + (run-tests-parallel tests) + (run-tests-sequential tests))) + +;; Load all tests from the given path. +(define (load-tests . path) + (load (apply in-srcdir `(,@path "all-tests.scm"))) + all-tests) + ;; Helper to create environment caches from test functions. SETUP ;; must be a test implementing the producer side cache protocol. ;; Returns a promise containing the arguments that must be passed to a -- cgit v1.2.3 From d2747ce24d445ae7ef3ec4ed0cca2f30aa833e7c Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Wed, 17 May 2017 16:10:37 +0200 Subject: gpgscm: Fix checking for opcode arguments. * tests/gpgscm/scheme.c (Eval_Cycle): Update 'pcd' after dispatching an instruction. Fixes-commit: 9c6407d17e0cb9f4a370b1b83e7816577ec7d29d Signed-off-by: Justus Winter --- scheme.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/scheme.c b/scheme.c index 26bb5a5..593bc74 100644 --- a/scheme.c +++ b/scheme.c @@ -3451,9 +3451,10 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { double dd; #endif int (*comp_func)(num, num) = NULL; - const struct op_code_info *pcd = &dispatch_table[op]; + const struct op_code_info *pcd; dispatch: + pcd = &dispatch_table[op]; if (pcd->name[0] != 0) { /* if built-in function, check arguments */ char msg[STRBUFFSIZE]; if (! check_arguments (sc, pcd, msg, sizeof msg)) { -- cgit v1.2.3 From f57405bea31bac1e3c8e4353aea9bb3cede1b90c Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Jun 2017 16:13:24 +0200 Subject: gpgscm: Improve error reporting. * tests/gpgscm/init.scm (throw'): Guard against 'args' being atomic. * tests/gpgscm/scheme.c (Eval_Cycle): Remove any superfluous colons in error messages. Signed-off-by: Justus Winter --- init.scm | 2 +- scheme.c | 50 ++++++++++++++++++++++++++------------------------ 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/init.scm b/init.scm index 3769ed0..b78a59e 100644 --- a/init.scm +++ b/init.scm @@ -615,7 +615,7 @@ (display message) (when (and args (not (null? args))) (display ": ") - (if (string? (car args)) + (if (and (pair? args) (string? (car args))) (begin (display (car args)) (unless (null? (cdr args)) (newline) diff --git a/scheme.c b/scheme.c index 593bc74..f5e52fc 100644 --- a/scheme.c +++ b/scheme.c @@ -3565,7 +3565,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { if (x != sc->NIL) { s_return(sc,slot_value_in_env(x)); } else { - Error_1(sc,"eval: unbound variable:", sc->code); + Error_1(sc, "eval: unbound variable", sc->code); } } else if (is_pair(sc->code)) { if (is_syntax(x = car(sc->code))) { /* SYNTAX */ @@ -3677,7 +3677,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { for (x = car(closure_code(sc->code)), y = sc->args; is_pair(x); x = cdr(x), y = cdr(y)) { if (y == sc->NIL) { - Error_1(sc, "not enough arguments, missing:", x); + Error_1(sc, "not enough arguments, missing", x); } else if (is_symbol(car(x))) { new_slot_in_env(sc, car(x), car(y)); } else { @@ -3692,7 +3692,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { } else if (is_symbol(x)) new_slot_in_env(sc, x, y); else { - Error_1(sc,"syntax error in closure: not a symbol:", x); + Error_1(sc, "syntax error in closure: not a symbol", x); } sc->code = cdr(closure_code(sc->code)); sc->args = sc->NIL; @@ -3805,7 +3805,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { set_slot_in_env(sc, y, sc->value); s_return(sc,sc->value); } else { - Error_1(sc,"set!: unbound variable:", sc->code); + Error_1(sc, "set!: unbound variable", sc->code); } @@ -3855,7 +3855,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { gc_enable(sc); - Error_1(sc, "Bad syntax of binding spec in let :", + Error_1(sc, "Bad syntax of binding spec in let", car(sc->code)); } s_save(sc,OP_LET1, sc->args, cdr(sc->code)); @@ -3881,9 +3881,9 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { if (is_symbol(car(sc->code))) { /* named let */ for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { if (!is_pair(x)) - Error_1(sc, "Bad syntax of binding in let :", x); + Error_1(sc, "Bad syntax of binding in let", x); if (!is_list(sc, car(x))) - Error_1(sc, "Bad syntax of binding in let :", car(x)); + Error_1(sc, "Bad syntax of binding in let", car(x)); gc_disable(sc, 1); sc->args = cons(sc, caar(x), sc->args); gc_enable(sc); @@ -3907,7 +3907,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_BEGIN); } if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { - Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code)); + Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code)); } s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); sc->code = cadaar(sc->code); @@ -3946,7 +3946,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { gc_enable(sc); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { - Error_1(sc, "Bad syntax of binding spec in letrec :", + Error_1(sc, "Bad syntax of binding spec in letrec", car(sc->code)); } s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); @@ -4165,7 +4165,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { } else if(modf(rvalue_unchecked(x),&dd)==0.0) { s_return(sc,mk_integer(sc,ivalue(x))); } else { - Error_1(sc,"inexact->exact: not integral:",x); + Error_1(sc, "inexact->exact: not integral", x); } CASE(OP_EXP): @@ -4425,7 +4425,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { } } if (pf < 0) { - Error_1(sc, "string->atom: bad base:", cadr(sc->args)); + Error_1(sc, "string->atom: bad base", cadr(sc->args)); } else if(*s=='#') /* no use of base! */ { s_return(sc, mk_sharp_const(sc, s+1)); } else { @@ -4466,7 +4466,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { } } if (pf < 0) { - Error_1(sc, "atom->string: bad base:", cadr(sc->args)); + Error_1(sc, "atom->string: bad base", cadr(sc->args)); } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { char *p; int len; @@ -4474,7 +4474,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { gc_disable(sc, 1); s_return_enable_gc(sc, mk_counted_string(sc, p, len)); } else { - Error_1(sc, "atom->string: not an atom:", x); + Error_1(sc, "atom->string: not an atom", x); } } @@ -4504,7 +4504,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { index=ivalue(cadr(sc->args)); if(index>=strlength(car(sc->args))) { - Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); + Error_1(sc, "string-ref: out of bounds", cadr(sc->args)); } gc_disable(sc, 1); @@ -4518,13 +4518,14 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { int c; if(is_immutable(car(sc->args))) { - Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); + Error_1(sc, "string-set!: unable to alter immutable string", + car(sc->args)); } str=strvalue(car(sc->args)); index=ivalue(cadr(sc->args)); if(index>=strlength(car(sc->args))) { - Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); + Error_1(sc, "string-set!: out of bounds", cadr(sc->args)); } c=charvalue(caddr(sc->args)); @@ -4563,13 +4564,13 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { index0=ivalue(cadr(sc->args)); if(index0>strlength(car(sc->args))) { - Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); + Error_1(sc, "substring: start out of bounds", cadr(sc->args)); } if(cddr(sc->args)!=sc->NIL) { index1=ivalue(caddr(sc->args)); if(index1>strlength(car(sc->args)) || index1args)); + Error_1(sc, "substring: end out of bounds", caddr(sc->args)); } } else { index1=strlength(car(sc->args)); @@ -4584,7 +4585,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { pointer vec; int len=list_length(sc,sc->args); if(len<0) { - Error_1(sc,"vector: not a proper list:",sc->args); + Error_1(sc, "vector: not a proper list", sc->args); } vec=mk_vector(sc,len); if(sc->no_memory) { s_return(sc, sc->sink); } @@ -4622,7 +4623,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { index=ivalue(cadr(sc->args)); if(index >= vector_length(car(sc->args))) { - Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); + Error_1(sc, "vector-ref: out of bounds", cadr(sc->args)); } s_return(sc,vector_elem(car(sc->args),index)); @@ -4632,12 +4633,13 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { int index; if(is_immutable(car(sc->args))) { - Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); + Error_1(sc, "vector-set!: unable to alter immutable vector", + car(sc->args)); } index=ivalue(cadr(sc->args)); if(index >= vector_length(car(sc->args))) { - Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); + Error_1(sc, "vector-set!: out of bounds", cadr(sc->args)); } set_vector_elem(car(sc->args),index,caddr(sc->args)); @@ -4980,7 +4982,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_READ_INTERNAL); } if(!is_inport(car(sc->args))) { - Error_1(sc,"read: not an input port:",car(sc->args)); + Error_1(sc, "read: not an input port", car(sc->args)); } if(car(sc->args)==sc->inport) { s_thread_to(sc,OP_READ_INTERNAL); @@ -5258,7 +5260,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { CASE(OP_LIST_LENGTH): { /* length */ /* a.k */ long l = list_length(sc, car(sc->args)); if(l<0) { - Error_1(sc,"length: not a list:",car(sc->args)); + Error_1(sc, "length: not a list", car(sc->args)); } gc_disable(sc, 1); s_return_enable_gc(sc, mk_integer(sc, l)); -- cgit v1.2.3 From f8934d091a274685c1b2a303ac2772adddd303c6 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Jun 2017 16:24:18 +0200 Subject: gpgscm: Improve error handling of foreign functions. * tests/gpgscm/ffi.scm (ffi-fail): Do not needlessly join the error message. Signed-off-by: Justus Winter --- ffi.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ffi.scm b/ffi.scm index 3f2e553..051c2c2 100644 --- a/ffi.scm +++ b/ffi.scm @@ -36,8 +36,7 @@ (define (ffi-fail name args message) (let ((args' (open-output-string))) (write (cons (string->symbol name) args) args') - (throw (string-append - (get-output-string args') ": " message)))) + (throw (get-output-string args') message))) ;; Pseudo-definitions for foreign functions. Evaluates to no code, ;; but serves as documentation. -- cgit v1.2.3 From b4628b4a23d7e8b55ef3f17d79ca86ae77cbc685 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Jun 2017 16:29:08 +0200 Subject: gpgscm: Improve option parsing. * tests/gpgscm/tests.scm (flag): Accept arguments of the form '--foo=bar'. Signed-off-by: Justus Winter --- tests.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/tests.scm b/tests.scm index eee8ce5..b66240d 100644 --- a/tests.scm +++ b/tests.scm @@ -766,7 +766,8 @@ ;; Command line flag handling. Returns the elements following KEY in ;; ARGUMENTS up to the next argument, or #f if KEY is not in -;; ARGUMENTS. +;; ARGUMENTS. If 'KEY=XYZ' is encountered, then the singleton list +;; containing 'XYZ' is returned. (define (flag key arguments) (cond ((null? arguments) @@ -777,6 +778,10 @@ (if (or (null? args) (string-prefix? (car args) "--")) (reverse acc) (loop (cons (car args) acc) (cdr args))))) + ((string-prefix? (car arguments) (string-append key "=")) + (list (substring (car arguments) + (+ (string-length key) 1) + (string-length (car arguments))))) ((string=? "--" (car arguments)) #f) (else @@ -784,6 +789,7 @@ (assert (equal? (flag "--xxx" '("--yyy")) #f)) (assert (equal? (flag "--xxx" '("--xxx")) '())) (assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy"))) +(assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo"))) (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz"))) (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz"))) (assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy"))) -- cgit v1.2.3 From 895ae4c6b1bd2fd9758d9c2835d9a3881e57a85a Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Jun 2017 16:31:25 +0200 Subject: gpgscm: Limit the number of parallel jobs. * ffi.c (do_wait_processes): Suppress the timeout error. * tests.scm (semaphore): New definition. (test-pool): Only run a bounded number of tests in parallel. (test::started?): New function. (run-tests-parallel): Do not report results, do not start the tests. (run-tests-sequential): Adapt. (run-tests): Parse the number of parallel jobs. -- This change limits the number of tests that are run in parallel. This way we do not overwhelm the operating systems' scheduler. As a side-effect, we also get more accurate runtime information, and it will be easy to implement timeouts on top of this. Use TESTFLAGS to limit the number of jobs: $ make check-all TESTFLAGS=--parallel=16 Signed-off-by: Justus Winter --- ffi.c | 2 ++ tests.scm | 106 +++++++++++++++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 93 insertions(+), 15 deletions(-) diff --git a/ffi.c b/ffi.c index 3af3328..4c03ba6 100644 --- a/ffi.c +++ b/ffi.c @@ -915,6 +915,8 @@ do_wait_processes (scheme *sc, pointer args) retcodes); if (err == GPG_ERR_GENERAL) err = 0; /* Let the return codes speak. */ + if (err == GPG_ERR_TIMEOUT) + err = 0; /* We may have got some results. */ for (i = 0; i < count; i++) retcodes_list = diff --git a/tests.scm b/tests.scm index b66240d..a6772d1 100644 --- a/tests.scm +++ b/tests.scm @@ -498,29 +498,98 @@ ;; The main test framework. ;; +(define semaphore + (package + (define (new n) + (package + (define (acquire!?) + (if (> n 0) + (begin + (set! n (- n 1)) + #t) + #f)) + (define (release!) + (set! n (+ n 1))))))) + ;; A pool of tests. (define test-pool (package - (define (new procs) + (define (new n) (package + ;; A semaphore to restrict the number of spawned processes. + (define sem (semaphore::new n)) + + ;; A list of enqueued, but not yet run tests. + (define enqueued '()) + + ;; A list of running or finished processes. + (define procs '()) + (define (add test) - (set! procs (cons test procs)) + (if (test::started?) + (set! procs (cons test procs)) + (if (sem::acquire!?) + (add (test::run-async)) + (set! enqueued (cons test enqueued)))) (current-environment)) + + ;; Pop the last of the enqueued tests off the fifo queue. + (define (pop-test!) + (let ((i (length enqueued))) + (assert (> i 0)) + (cond + ((= i 1) + (let ((test (car enqueued))) + (set! enqueued '()) + test)) + (else + (let* ((tail (list-tail enqueued (- i 2))) + (test (cadr tail))) + (set-cdr! tail '()) + (assert (= (length enqueued) (- i 1))) + test))))) + (define (pid->test pid) (let ((t (filter (lambda (x) (= pid x::pid)) procs))) (if (null? t) #f (car t)))) (define (wait) + (if (null? enqueued) + ;; If no tests are enqueued, we can just block until all + ;; of them finished. + (wait' #t) + ;; Otherwise, we must not block, but give some tests the + ;; chance to finish so that we can start new ones. + (begin + (wait' #f) + (usleep (/ 1000000 10)) + (wait)))) + (define (wait' hang) (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) (if (null? unfinished) (current-environment) (let ((names (map (lambda (t) t::name) unfinished)) - (pids (map (lambda (t) t::pid) unfinished))) + (pids (map (lambda (t) t::pid) unfinished)) + (any #f)) (for-each (lambda (test retcode) - (test::set-end-time!) - (test:::set! 'retcode retcode)) + (unless (< retcode 0) + (test::set-end-time!) + (test:::set! 'retcode retcode) + (test::report) + (sem::release!) + (set! any #t))) (map pid->test pids) - (wait-processes (map stringify names) pids #t))))) + (wait-processes (map stringify names) pids hang)) + + ;; If some processes finished, try to start new ones. + (let loop () + (cond + ((not any) #f) + ((pair? enqueued) + (if (sem::acquire!?) + (let ((test (pop-test!))) + (add (test::run-async)) + (loop))))))))) (current-environment)) (define (filter-tests status) (filter (lambda (p) (eq? status (p::status))) procs)) @@ -629,6 +698,10 @@ (define (set-end-time!) (set! end-time (get-time))) + ;; Has the test been started yet? + (define (started?) + (number? pid)) + (define (open-log-file) (unless log-file-name (set! log-file-name (string-append (basename name) ".log"))) @@ -713,23 +786,22 @@ ;; Run the setup target to create an environment, then run all given ;; tests in parallel. -(define (run-tests-parallel tests) - (let loop ((pool (test-pool::new '())) (tests' tests)) +(define (run-tests-parallel tests n) + (let loop ((pool (test-pool::new n)) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) - (for-each (lambda (t) (t::report)) (reverse results::procs)) ((results::xml) (open-output-file "report.xml")) (exit (results::report))) (let ((wd (mkdtemp-autoremove)) (test (car tests'))) (test:::set! 'directory wd) - (loop (pool::add (test::run-async)) + (loop (pool::add test) (cdr tests')))))) ;; Run the setup target to create an environment, then run all given ;; tests in sequence. (define (run-tests-sequential tests) - (let loop ((pool (test-pool::new '())) (tests' tests)) + (let loop ((pool (test-pool::new 1)) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) ((results::xml) (open-output-file "report.xml")) @@ -743,10 +815,14 @@ ;; Run tests either in sequence or in parallel, depending on the ;; number of tests and the command line flags. (define (run-tests tests) - (if (and (flag "--parallel" *args*) - (> (length tests) 1)) - (run-tests-parallel tests) - (run-tests-sequential tests))) + (let ((parallel (flag "--parallel" *args*)) + (default-parallel-jobs 32)) + (if (and parallel (> (length tests) 1)) + (run-tests-parallel tests (if (and (pair? parallel) + (string->number (car parallel))) + (string->number (car parallel)) + default-parallel-jobs)) + (run-tests-sequential tests)))) ;; Load all tests from the given path. (define (load-tests . path) -- cgit v1.2.3 From ba3164673676468472ae37f32c3964d231e8a8f8 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 11 Jul 2017 16:07:39 +0200 Subject: gpgscm: Make it impossible to catch '*interpreter-exit*'. * tests/gpgscm/init.scm (throw'): Make it impossible to catch '*interpreter-exit*'. This fixes 'exit' (and with it 'fail') inside 'catch' statements. Signed-off-by: Justus Winter --- init.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/init.scm b/init.scm index b78a59e..66bec0f 100644 --- a/init.scm +++ b/init.scm @@ -605,12 +605,12 @@ ;; This is used by the vm to throw exceptions. (define (throw' message args history) (cond - ((more-handlers?) - ((pop-handler) message args history)) ((and args (list? args) (= 2 (length args)) (equal? *interpreter-exit* (car args))) (*run-atexit-handlers*) (quit (cadr args))) + ((more-handlers?) + ((pop-handler) message args history)) (else (display message) (when (and args (not (null? args))) -- cgit v1.2.3 From 8377569cae0764fd44701d67626b4c96f0bd8804 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 13 Jul 2017 16:29:25 +0200 Subject: gpgscm: Make loading of modules less verbose. * tests/gpgscm/main.c (load): Increase logging threshold. Signed-off-by: Justus Winter --- main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.c b/main.c index e4b535e..4dae365 100644 --- a/main.c +++ b/main.c @@ -182,7 +182,7 @@ load (scheme *sc, char *file_name, "of the Scheme library.\n"); goto leave; } - if (verbose > 1) + if (verbose > 2) fprintf (stderr, "Loading %s...\n", qualified_name); #if HAVE_MMAP -- cgit v1.2.3 From c67386dcd95dd6a451b861e178503b29a7b13502 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 14 Jul 2017 12:55:01 +0200 Subject: gpgscm: Fail early if the test setup fails. * tests/gpgscm/tests.scm (make-environment-cache): Check status code of setup script. Signed-off-by: Justus Winter --- tests.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests.scm b/tests.scm index a6772d1..06084de 100644 --- a/tests.scm +++ b/tests.scm @@ -838,6 +838,8 @@ (let ((tarball (make-temporary-file "environment-cache"))) (atexit (lambda () (remove-temporary-file tarball))) (setup::run-sync '--create-tarball tarball) + (if (not (equal? 'PASS (setup::status))) + (fail "Setup failed.")) `(--unpack-tarball ,tarball))))) ;; Command line flag handling. Returns the elements following KEY in -- cgit v1.2.3 From a4dbace8c1d771bed5783aadf87a8075454e5a35 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 14 Jul 2017 12:57:41 +0200 Subject: gpgscm: Library improvements. * tests/gpgscm/repl.scm (prompt-yes-no?): New function. * tests/gpgscm/tests.scm (pathsep-split): Likewise. (pathsep-join): Likewise. (with-path): Use the new function. Signed-off-by: Justus Winter --- repl.scm | 12 ++++++++++++ tests.scm | 12 +++++++++++- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/repl.scm b/repl.scm index 84454dc..833ec0d 100644 --- a/repl.scm +++ b/repl.scm @@ -55,3 +55,15 @@ (define (interactive-repl . environment) (repl (lambda (p) (prompt-append-prefix "gpgscm " p)) (if (null? environment) (interaction-environment) (car environment)))) + +;; Ask a yes/no question. +(define (prompt-yes-no? question default) + (let ((answer (prompt (string-append question "? [" + (if default "Y/n" "y/N") "] ")))) + (cond + ((= 0 (string-length answer)) + default) + ((or (equal? "y" answer) (equal? "Y" answer)) + #t) + (else + #f)))) diff --git a/tests.scm b/tests.scm index 06084de..40ba7e3 100644 --- a/tests.scm +++ b/tests.scm @@ -192,6 +192,16 @@ (define (in-srcdir . names) (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names)))) +;; Split a list of paths. +(define (pathsep-split s) + (string-split s *pathsep*)) + +;; Join a list of paths. +(define (pathsep-join paths) + (foldr (lambda (a b) (string-append a (string *pathsep*) b)) + (car paths) + (cdr paths))) + ;; Try to find NAME in PATHS. Returns the full path name on success, ;; or raises an error. (define (path-expand name paths) @@ -209,7 +219,7 @@ ;; (load (with-path "library.scm")) (define (with-path name) (catch name - (path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*)))) + (path-expand name (pathsep-split (getenv "GPGSCM_PATH"))))) (define (basename path) (let ((i (string-index path #\/))) -- cgit v1.2.3 From c4230af0e62d7c8812eaedf4e6451a6288ff5769 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 18 Jul 2017 16:15:45 +0200 Subject: gpgscm,w32: Fix testing for absolute paths. * tests/gpgscm/main.c (path_absolute_p): New function. (load): Use new function. Signed-off-by: Justus Winter --- main.c | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/main.c b/main.c index 4dae365..5540ac3 100644 --- a/main.c +++ b/main.c @@ -124,6 +124,19 @@ my_strusage( int level ) } + +static int +path_absolute_p (const char *p) +{ +#if _WIN32 + return ((strlen (p) > 2 && p[1] == ':' && (p[2] == '\\' || p[2] == '/')) + || p[0] == '\\' || p[0] == '/'); +#else + return p[0] == '/'; +#endif +} + + /* Load the Scheme program from FILE_NAME. If FILE_NAME is not an absolute path, and LOOKUP_IN_PATH is given, then it is qualified with the values in scmpath until the file is found. */ @@ -139,9 +152,9 @@ load (scheme *sc, char *file_name, FILE *h = NULL; use_path = - lookup_in_path && ! (file_name[0] == '/' || scmpath_len == 0); + lookup_in_path && ! (path_absolute_p (file_name) || scmpath_len == 0); - if (file_name[0] == '/' || lookup_in_cwd || scmpath_len == 0) + if (path_absolute_p (file_name) || lookup_in_cwd || scmpath_len == 0) { h = fopen (file_name, "r"); if (! h) -- cgit v1.2.3 From d230224c38dd4b31348f7a1ad24be9e27935dc80 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 7 Aug 2017 11:15:56 +0200 Subject: tests: Do not run all tests unless in maintainer mode. * configure.ac: Leak the maintainer mode flag into 'config.h'. * tests/gpgscm/ffi.c: Pass it into the scheme environment. * tests/openpgp/all-tests.scm: Only run tests against non-default configurations (keyring, extended-key-format) in maintainer mode. -- Werner is concerned that the tests do take up too much time and asked me to reduce the runtime of the tests for normal users. Signed-off-by: Justus Winter --- ffi.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ffi.c b/ffi.c index 4c03ba6..4c2148a 100644 --- a/ffi.c +++ b/ffi.c @@ -1442,6 +1442,14 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, #endif ); + ffi_define (sc, "*maintainer-mode*", +#if MAINTAINER_MODE + sc->T +#else + sc->F +#endif + ); + ffi_define (sc, "*stdin*", sc->vptr->mk_port_from_file (sc, stdin, port_input)); -- cgit v1.2.3 From c2fbc80c643db372f16aed100393cd2d4de46979 Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Tue, 8 Aug 2017 13:47:00 +0200 Subject: gpgscm: Make the test summary stand out * tests/gpgscm/tests.scm (test-pool): Add delimiter lines. -- This is to make those summaries a bit more simlar to those from automake. Signed-off-by: Werner Koch --- tests.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests.scm b/tests.scm index 40ba7e3..5141002 100644 --- a/tests.scm +++ b/tests.scm @@ -613,6 +613,7 @@ (xfailed (filter-tests 'XFAIL)) (xpassed (filter-tests 'XPASS)) (skipped (filter-tests 'SKIP))) + (echo "===================") (echo (length procs) "tests run," (length (filter-tests 'PASS)) "succeeded," (length failed) "failed," @@ -623,6 +624,7 @@ (print-tests xfailed "Expectedly failed tests:") (print-tests xpassed "Unexpectedly passed tests:") (print-tests skipped "Skipped tests:") + (echo "===================") (+ (length failed) (length xpassed)))) (define (xml) -- cgit v1.2.3 From 3aa37d802ac10a38414a8cfe120de92a76968836 Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Tue, 8 Aug 2017 17:28:25 +0200 Subject: build: New configure option --enable-all-tests. * configure.ac: New option --enable-all-tests. * tests/gpgscm/ffi.c (ffi_init): New gloabl var *run-all-tests*. * tests/openpgp/all-tests.scm (all-tests): Use that var instead of *maintainer-mode*. * Makefile.am (AM_DISTCHECK_CONFIGURE_FLAGS): Add --enable-all-tests. -- It is better to have a separate option to run all tests than to put this on top of --enable-maintainer-mode. This way we can also make sure to run all tests during "make distcheck". Signed-off-by: Werner Koch --- ffi.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ffi.c b/ffi.c index 4c2148a..dde5b52 100644 --- a/ffi.c +++ b/ffi.c @@ -1450,6 +1450,14 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, #endif ); + ffi_define (sc, "*run-all-tests*", +#if RUN_ALL_TESTS + sc->T +#else + sc->F +#endif + ); + ffi_define (sc, "*stdin*", sc->vptr->mk_port_from_file (sc, stdin, port_input)); -- cgit v1.2.3 From dda5fb3474a81047e5bd52a194640fb44e1d60ab Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 21 Aug 2017 14:49:29 +0200 Subject: gpgscm: Fix -Wimplicit-fallthrough warnings. * tests/gpgscm/scheme.c (CASE): Rearrange so that the case statement is at the front. (Eval_Cycle): Improve fallthrough annotations. Signed-off-by: Justus Winter --- scheme.c | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/scheme.c b/scheme.c index f5e52fc..4384841 100644 --- a/scheme.c +++ b/scheme.c @@ -2990,7 +2990,7 @@ _Error_1(scheme *sc, const char *s, pointer a) { /* Define a label OP and emit a case statement for OP. For use in the * dispatch function. The slightly peculiar goto that is never * executed avoids warnings about unused labels. */ -#define CASE(OP) if (0) goto OP; OP: case OP +#define CASE(OP) case OP: if (0) goto OP; OP #else /* USE_THREADED_CODE */ #define s_thread_to(sc, a) s_goto(sc, a) @@ -3727,7 +3727,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_APPLY); } } - + /* Fallthrough. */ #else CASE(OP_LAMBDA): /* lambda */ sc->value = sc->code; @@ -4655,9 +4655,13 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { CASE(OP_NULLP): /* null? */ s_retbool(car(sc->args) == sc->NIL); CASE(OP_NUMEQ): /* = */ + /* Fallthrough. */ CASE(OP_LESS): /* < */ + /* Fallthrough. */ CASE(OP_GRE): /* > */ + /* Fallthrough. */ CASE(OP_LEQ): /* <= */ + /* Fallthrough. */ CASE(OP_GEQ): /* >= */ switch(op) { case OP_NUMEQ: comp_func=num_eq; break; @@ -4746,7 +4750,9 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->value); CASE(OP_WRITE): /* write */ + /* Fallthrough. */ CASE(OP_DISPLAY): /* display */ + /* Fallthrough. */ CASE(OP_WRITE_CHAR): /* write-char */ if(is_pair(cdr(sc->args))) { if(cadr(sc->args)!=sc->outport) { @@ -4894,7 +4900,9 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { s_return(sc,sc->outport); CASE(OP_OPEN_INFILE): /* open-input-file */ + /* Fallthrough. */ CASE(OP_OPEN_OUTFILE): /* open-output-file */ + /* Fallthrough. */ CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ { int prop=0; pointer p; @@ -4914,6 +4922,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { #if USE_STRING_PORTS CASE(OP_OPEN_INSTRING): /* open-input-string */ + /* Fallthrough. */ CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ { int prop=0; pointer p; @@ -4994,6 +5003,7 @@ Eval_Cycle(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_READ_INTERNAL); CASE(OP_READ_CHAR): /* read-char */ + /* Fallthrough. */ CASE(OP_PEEK_CHAR): /* peek-char */ { int c; if(is_pair(sc->args)) { -- cgit v1.2.3 From 09984557106ba52ff8889effd811282dca389a99 Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Thu, 5 Oct 2017 17:27:09 +0200 Subject: gpgscm: Move files to a gpgscm subdirectory. -- Note that we used git filter-branch --subdirectory-filter tests/gpgscm in gnupg master to filter out the gpgscm part. This commit merely moves these files to a subdirectory which will be used in libgpg-error for gpgscm. Signed-off-by: Werner Koch --- LICENSE.TinySCHEME | 31 - Makefile.am | 64 - Manual.txt | 444 ---- ffi-private.h | 148 -- ffi.c | 1470 ----------- ffi.h | 30 - ffi.scm | 51 - gnupg.scm | 44 - gpgscm/LICENSE.TinySCHEME | 31 + gpgscm/Makefile.am | 64 + gpgscm/Manual.txt | 444 ++++ gpgscm/ffi-private.h | 148 ++ gpgscm/ffi.c | 1470 +++++++++++ gpgscm/ffi.h | 30 + gpgscm/ffi.scm | 51 + gpgscm/gnupg.scm | 44 + gpgscm/init.scm | 823 +++++++ gpgscm/lib.scm | 307 +++ gpgscm/main.c | 359 +++ gpgscm/makefile.scm | 76 + gpgscm/opdefines.h | 205 ++ gpgscm/private.h | 26 + gpgscm/repl.scm | 69 + gpgscm/scheme-config.h | 32 + gpgscm/scheme-private.h | 274 +++ gpgscm/scheme.c | 6028 +++++++++++++++++++++++++++++++++++++++++++++ gpgscm/scheme.h | 290 +++ gpgscm/small-integers.h | 847 +++++++ gpgscm/t-child.c | 74 + gpgscm/t-child.scm | 118 + gpgscm/tests.scm | 886 +++++++ gpgscm/time.scm | 42 + gpgscm/xml.scm | 142 ++ init.scm | 823 ------- lib.scm | 307 --- main.c | 359 --- makefile.scm | 76 - opdefines.h | 205 -- private.h | 26 - repl.scm | 69 - scheme-config.h | 32 - scheme-private.h | 274 --- scheme.c | 6028 --------------------------------------------- scheme.h | 290 --- small-integers.h | 847 ------- t-child.c | 74 - t-child.scm | 118 - tests.scm | 886 ------- time.scm | 42 - xml.scm | 142 -- 50 files changed, 12880 insertions(+), 12880 deletions(-) delete mode 100644 LICENSE.TinySCHEME delete mode 100644 Makefile.am delete mode 100644 Manual.txt delete mode 100644 ffi-private.h delete mode 100644 ffi.c delete mode 100644 ffi.h delete mode 100644 ffi.scm delete mode 100644 gnupg.scm create mode 100644 gpgscm/LICENSE.TinySCHEME create mode 100644 gpgscm/Makefile.am create mode 100644 gpgscm/Manual.txt create mode 100644 gpgscm/ffi-private.h create mode 100644 gpgscm/ffi.c create mode 100644 gpgscm/ffi.h create mode 100644 gpgscm/ffi.scm create mode 100644 gpgscm/gnupg.scm create mode 100644 gpgscm/init.scm create mode 100644 gpgscm/lib.scm create mode 100644 gpgscm/main.c create mode 100644 gpgscm/makefile.scm create mode 100644 gpgscm/opdefines.h create mode 100644 gpgscm/private.h create mode 100644 gpgscm/repl.scm create mode 100644 gpgscm/scheme-config.h create mode 100644 gpgscm/scheme-private.h create mode 100644 gpgscm/scheme.c create mode 100644 gpgscm/scheme.h create mode 100644 gpgscm/small-integers.h create mode 100644 gpgscm/t-child.c create mode 100644 gpgscm/t-child.scm create mode 100644 gpgscm/tests.scm create mode 100644 gpgscm/time.scm create mode 100644 gpgscm/xml.scm delete mode 100644 init.scm delete mode 100644 lib.scm delete mode 100644 main.c delete mode 100644 makefile.scm delete mode 100644 opdefines.h delete mode 100644 private.h delete mode 100644 repl.scm delete mode 100644 scheme-config.h delete mode 100644 scheme-private.h delete mode 100644 scheme.c delete mode 100644 scheme.h delete mode 100644 small-integers.h delete mode 100644 t-child.c delete mode 100644 t-child.scm delete mode 100644 tests.scm delete mode 100644 time.scm delete mode 100644 xml.scm diff --git a/LICENSE.TinySCHEME b/LICENSE.TinySCHEME deleted file mode 100644 index 23a7e85..0000000 --- a/LICENSE.TinySCHEME +++ /dev/null @@ -1,31 +0,0 @@ - LICENSE TERMS - -Copyright (c) 2000, Dimitrios Souflis -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -Redistributions in binary form must reproduce the above copyright -notice, this list of conditions and the following disclaimer in the -documentation and/or other materials provided with the distribution. - -Neither the name of Dimitrios Souflis nor the names of the -contributors may be used to endorse or promote products derived from -this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR -CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile.am b/Makefile.am deleted file mode 100644 index 44d7b3f..0000000 --- a/Makefile.am +++ /dev/null @@ -1,64 +0,0 @@ -# TinyScheme-based test driver. -# -# Copyright (C) 2016 g10 Code GmbH -# -# This file is part of GnuPG. -# -# GnuPG is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# GnuPG is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, see . - -EXTRA_DIST = \ - LICENSE.TinySCHEME \ - Manual.txt \ - ffi.scm \ - init.scm \ - lib.scm \ - makefile.scm \ - repl.scm \ - t-child.scm \ - xml.scm \ - tests.scm \ - gnupg.scm \ - time.scm - -AM_CPPFLAGS = -I$(top_srcdir)/common -include $(top_srcdir)/am/cmacros.am - -AM_CFLAGS = - -CLEANFILES = - -bin_PROGRAMS = gpgscm -noinst_PROGRAMS = t-child - -common_libs = ../$(libcommon) -commonpth_libs = ../$(libcommonpth) - -gpgscm_CFLAGS = -imacros scheme-config.h \ - $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) -gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ - scheme-config.h scheme.c scheme.h scheme-private.h \ - opdefines.h small-integers.h -gpgscm_LDADD = $(LDADD) $(common_libs) \ - $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \ - $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) - -t_child_SOURCES = t-child.c - -# Make sure that all libs are build before we use them. This is -# important for things like make -j2. -$(PROGRAMS): $(common_libs) - -check-local: gpgscm$(EXEEXT) t-child$(EXEEXT) - EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \ - ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm diff --git a/Manual.txt b/Manual.txt deleted file mode 100644 index b146926..0000000 --- a/Manual.txt +++ /dev/null @@ -1,444 +0,0 @@ - - - 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? ) (defined? ) - Checks whether the given symbol is defined in the current (or given) - environment. - - Symbols - (gensym) - Returns a new interned symbol each time. Will probably move to the - library when string->symbol is implemented. - - Directives - (gc) - Performs garbage collection immediately. - - (gc-verbose) (gc-verbose ) - The argument (defaulting to #t) controls whether GC produces - visible outcome. - - (quit) (quit ) - Stops the interpreter and sets the 'retcode' internal field (defaults - to 0). When standalone, 'retcode' is returned as exit code to the OS. - - (tracing ) - 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>=?. - (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>=?. - (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 ) - 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 ) - Returns the expanded form of the macro call denoted by the argument - - (define-with-return ( ...) ) - Like plain 'define', but makes the continuation available as 'return' - inside the procedure. Handy for imperative programs. - - (new-segment ) - Allocates more memory segments. - - defined? - See "Environments" - - (get-closure-code ) - Gets the code as scheme data. - - (make-closure ) - Makes a new closure in the given environment. - - Obsolete procedures - (print-width ) - - 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_. 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 [ ...] - followed by - -1 [ ...] - -c [ ...] - 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 - ... ) - - "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 :: and - transforms it in the following manner (T is the transformation function): - - T(::) = (*colon-hook* 'T() ) - - where is a symbol not containing any double-colons. - - As the definition is recursive, qualifiers can be nested. - The user can define his own *colon-hook*, to handle qualified names. - By default, "init.scm" defines *colon-hook* as EVAL. Consequently, - the qualifier must denote a Scheme environment, such as one returned - by (interaction-environment). "Init.scm" defines a new syntantic form, - PACKAGE, as a simple example. It is used like this: - - (define toto - (package - (define foo 1) - (define bar +))) - - foo ==> Error, "foo" undefined - (eval 'foo) ==> Error, "foo" undefined - (eval 'foo toto) ==> 1 - toto::foo ==> 1 - ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 - (toto::bar 2 toto::foo) ==> 3 - (eval (bar 2 foo) toto) ==> 3 - - If the user installs another package infrastructure, he must define - a new 'package' procedure or macro to retain compatibility with supplied - code. - - Note: Older versions used ':' as a qualifier. Unfortunately, the use - of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially - precludes its use as a real qualifier. diff --git a/ffi-private.h b/ffi-private.h deleted file mode 100644 index 037da56..0000000 --- a/ffi-private.h +++ /dev/null @@ -1,148 +0,0 @@ -/* FFI interface for TinySCHEME. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#ifndef GPGSCM_FFI_PRIVATE_H -#define GPGSCM_FFI_PRIVATE_H - -#include -#include "scheme.h" -#include "scheme-private.h" - -#define FFI_PROLOG() \ - unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1; \ - int err GPGRT_ATTR_UNUSED = 0 \ - -int ffi_bool_value (scheme *sc, pointer p); - -#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X) -#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X) -#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X) -#define CONVERSION_list(SC, X) (X) -#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X)) -#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \ - ? (SC)->vptr->string_value \ - : (SC)->vptr->symname) (X)) - -#define IS_A_number(SC, X) (SC)->vptr->is_number (X) -#define IS_A_string(SC, X) (SC)->vptr->is_string (X) -#define IS_A_character(SC, X) (SC)->vptr->is_character (X) -#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X) -#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T) -#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ - || (SC)->vptr->is_symbol (X)) - -#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS) \ - do { \ - if ((ARGS) == (SC)->NIL) \ - return (SC)->vptr->mk_string ((SC), \ - "too few arguments: want " \ - #TARGET "("#WANT"/"#CTYPE")\n"); \ - if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \ - char ffi_error_message[256]; \ - snprintf (ffi_error_message, sizeof ffi_error_message, \ - "argument %d must be: " #WANT "\n", ffi_arg_index); \ - return (SC)->vptr->mk_string ((SC), ffi_error_message); \ - } \ - TARGET = CONVERSION_##WANT (SC, pair_car (ARGS)); \ - ARGS = pair_cdr (ARGS); \ - ffi_arg_index += 1; \ - } while (0) - -#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS) \ - do { \ - if ((ARGS) != (SC)->NIL) \ - return (SC)->vptr->mk_string ((SC), "too many arguments"); \ - } while (0) - -#define FFI_RETURN_ERR(SC, ERR) \ - return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1) - -#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err) - -#define FFI_RETURN_POINTER(SC, X) \ - return _cons ((SC), mk_integer ((SC), err), \ - _cons ((SC), (X), (SC)->NIL, 1), 1) -#define FFI_RETURN_INT(SC, X) \ - FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X))) -#define FFI_RETURN_STRING(SC, X) \ - FFI_RETURN_POINTER ((SC), mk_string ((SC), (X))) - -char *ffi_schemify_name (const char *s, int macro); - -void ffi_scheme_eval (scheme *sc, const char *format, ...) - GPGRT_ATTR_PRINTF (2, 3); -pointer ffi_sprintf (scheme *sc, const char *format, ...) - GPGRT_ATTR_PRINTF (2, 3); - -#define ffi_define_function_name(SC, NAME, F) \ - do { \ - char *_fname = ffi_schemify_name ("__" #F, 0); \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), _fname), \ - mk_foreign_func ((SC), (do_##F))); \ - ffi_scheme_eval ((SC), \ - "(define (%s . a) (ffi-apply \"%s\" %s a))", \ - (NAME), (NAME), _fname); \ - free (_fname); \ - } while (0) - -#define ffi_define_function(SC, F) \ - do { \ - char *_name = ffi_schemify_name (#F, 0); \ - ffi_define_function_name ((SC), _name, F); \ - free (_name); \ - } while (0) - -#define ffi_define_constant(SC, C) \ - do { \ - char *_name = ffi_schemify_name (#C, 1); \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), _name), \ - mk_integer ((SC), (C))); \ - free (_name); \ - } while (0) - -#define ffi_define(SC, SYM, EXP) \ - scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP) - -#define ffi_define_variable_pointer(SC, C, P) \ - do { \ - char *_name = ffi_schemify_name (#C, 0); \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), _name), \ - (P)); \ - free (_name); \ - } while (0) - -#define ffi_define_variable_integer(SC, C) \ - ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C)) - -#define ffi_define_variable_string(SC, C) \ - ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: "")) - -gpg_error_t ffi_list2argv (scheme *sc, pointer list, - char ***argv, size_t *len); -gpg_error_t ffi_list2intv (scheme *sc, pointer list, - int **intv, size_t *len); - -#endif /* GPGSCM_FFI_PRIVATE_H */ diff --git a/ffi.c b/ffi.c deleted file mode 100644 index dde5b52..0000000 --- a/ffi.c +++ /dev/null @@ -1,1470 +0,0 @@ -/* FFI interface for TinySCHEME. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#if HAVE_LIBREADLINE -#define GNUPG_LIBREADLINE_H_INCLUDED -#include -#include -#endif - -#include "../../common/util.h" -#include "../../common/exechelp.h" -#include "../../common/sysutils.h" - -#include "private.h" -#include "ffi.h" -#include "ffi-private.h" - -/* For use in nice error messages. */ -static const char * -ordinal_suffix (int n) -{ - switch (n) - { - case 1: return "st"; - case 2: return "nd"; - case 3: return "rd"; - default: return "th"; - } - assert (! "reached"); -} - - - -int -ffi_bool_value (scheme *sc, pointer p) -{ - return ! (p == sc->F); -} - - - -static pointer -do_logand (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v, acc = ~0; - while (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - acc &= v; - } - FFI_RETURN_INT (sc, acc); -} - -static pointer -do_logior (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v, acc = 0; - while (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - acc |= v; - } - FFI_RETURN_INT (sc, acc); -} - -static pointer -do_logxor (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v, acc = 0; - while (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - acc ^= v; - } - FFI_RETURN_INT (sc, acc); -} - -static pointer -do_lognot (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v; - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, ~v); -} - -/* User interface. */ - -static pointer -do_flush_stdio (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - fflush (stdout); - fflush (stderr); - FFI_RETURN (sc); -} - - -int use_libreadline; - -/* Read a string, and return a pointer to it. Returns NULL on EOF. */ -char * -rl_gets (const char *prompt) -{ - static char *line = NULL; - char *p; - xfree (line); - -#if HAVE_LIBREADLINE - { - line = readline (prompt); - if (line && *line) - add_history (line); - } -#else - { - size_t max_size = 0xff; - printf ("%s", prompt); - fflush (stdout); - line = xtrymalloc (max_size); - if (line != NULL) - fgets (line, max_size, stdin); - } -#endif - - /* Strip trailing whitespace. */ - if (line && strlen (line) > 0) - for (p = &line[strlen (line) - 1]; isspace (*p); p--) - *p = 0; - - return line; -} - -static pointer -do_prompt (scheme *sc, pointer args) -{ - FFI_PROLOG (); - const char *prompt; - const char *line; - FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - line = rl_gets (prompt); - if (! line) - FFI_RETURN_POINTER (sc, sc->EOF_OBJ); - - FFI_RETURN_STRING (sc, line); -} - -static pointer -do_sleep (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int seconds; - FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - sleep (seconds); - FFI_RETURN (sc); -} - -static pointer -do_usleep (scheme *sc, pointer args) -{ - FFI_PROLOG (); - useconds_t microseconds; - FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - usleep (microseconds); - FFI_RETURN (sc); -} - -static pointer -do_chdir (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, path, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (chdir (name)) - FFI_RETURN_ERR (sc, errno); - FFI_RETURN (sc); -} - -static pointer -do_strerror (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int error; - FFI_ARG_OR_RETURN (sc, int, error, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_STRING (sc, gpg_strerror (error)); -} - -static pointer -do_getenv (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - char *value; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - value = getenv (name); - FFI_RETURN_STRING (sc, value ? value : ""); -} - -static pointer -do_setenv (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - char *value; - int overwrite; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARG_OR_RETURN (sc, char *, value, string, args); - FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (gnupg_setenv (name, value, overwrite)) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_exit (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int retcode; - FFI_ARG_OR_RETURN (sc, int, retcode, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - exit (retcode); -} - -/* XXX: use gnupgs variant b/c mode as string */ -static pointer -do_open (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int fd; - char *pathname; - int flags; - mode_t mode = 0; - FFI_ARG_OR_RETURN (sc, char *, pathname, path, args); - FFI_ARG_OR_RETURN (sc, int, flags, number, args); - if (args != sc->NIL) - FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - fd = open (pathname, flags, mode); - if (fd == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN_INT (sc, fd); -} - -static pointer -do_fdopen (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FILE *stream; - int fd; - char *mode; - int kind; - FFI_ARG_OR_RETURN (sc, int, fd, number, args); - FFI_ARG_OR_RETURN (sc, char *, mode, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - stream = fdopen (fd, mode); - if (stream == NULL) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - - if (setvbuf (stream, NULL, _IONBF, 0) != 0) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - - kind = 0; - if (strchr (mode, 'r')) - kind |= port_input; - if (strchr (mode, 'w')) - kind |= port_output; - - FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind)); -} - -static pointer -do_close (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int fd; - FFI_ARG_OR_RETURN (sc, int, fd, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); -} - -static pointer -do_seek (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int fd; - off_t offset; - int whence; - FFI_ARG_OR_RETURN (sc, int, fd, number, args); - FFI_ARG_OR_RETURN (sc, off_t, offset, number, args); - FFI_ARG_OR_RETURN (sc, int, whence, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1 - ? gpg_error_from_syserror () : 0); -} - -static pointer -do_get_temp_path (scheme *sc, pointer args) -{ - FFI_PROLOG (); -#ifdef HAVE_W32_SYSTEM - char buffer[MAX_PATH+1]; -#endif - FFI_ARGS_DONE_OR_RETURN (sc, args); - -#ifdef HAVE_W32_SYSTEM - if (GetTempPath (MAX_PATH+1, buffer) == 0) - FFI_RETURN_STRING (sc, "/temp"); - FFI_RETURN_STRING (sc, buffer); -#else - FFI_RETURN_STRING (sc, "/tmp"); -#endif -} - -static pointer -do_mkdtemp (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *template; -#ifdef PATH_MAX - char buffer[PATH_MAX]; -#else - char buffer[1024]; -#endif - char *name; - FFI_ARG_OR_RETURN (sc, char *, template, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - if (strlen (template) > sizeof buffer - 1) - FFI_RETURN_ERR (sc, EINVAL); - strncpy (buffer, template, sizeof buffer); - - name = gnupg_mkdtemp (buffer); - if (name == NULL) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN_STRING (sc, name); -} - -static pointer -do_unlink (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (unlink (name) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static gpg_error_t -unlink_recursively (const char *name) -{ - gpg_error_t err = 0; - struct stat st; - - if (stat (name, &st) == -1) - return gpg_error_from_syserror (); - - if (S_ISDIR (st.st_mode)) - { - DIR *dir; - struct dirent *dent; - - dir = opendir (name); - if (dir == NULL) - return gpg_error_from_syserror (); - - while ((dent = readdir (dir))) - { - char *child; - - if (strcmp (dent->d_name, ".") == 0 - || strcmp (dent->d_name, "..") == 0) - continue; - - child = xtryasprintf ("%s/%s", name, dent->d_name); - if (child == NULL) - { - err = gpg_error_from_syserror (); - goto leave; - } - - err = unlink_recursively (child); - xfree (child); - if (err == gpg_error_from_errno (ENOENT)) - err = 0; - if (err) - goto leave; - } - - leave: - closedir (dir); - if (! err) - rmdir (name); - return err; - } - else - if (unlink (name) == -1) - return gpg_error_from_syserror (); - return 0; -} - -static pointer -do_unlink_recursively (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = unlink_recursively (name); - FFI_RETURN (sc); -} - -static pointer -do_rename (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *old; - char *new; - FFI_ARG_OR_RETURN (sc, char *, old, string, args); - FFI_ARG_OR_RETURN (sc, char *, new, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (rename (old, new) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_getcwd (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer result; - char *cwd; - FFI_ARGS_DONE_OR_RETURN (sc, args); - cwd = gnupg_getcwd (); - if (cwd == NULL) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - result = sc->vptr->mk_string (sc, cwd); - xfree (cwd); - FFI_RETURN_POINTER (sc, result); -} - -static pointer -do_mkdir (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - char *mode; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARG_OR_RETURN (sc, char *, mode, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (gnupg_mkdir (name, mode) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_rmdir (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (rmdir (name) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_get_isotime (scheme *sc, pointer args) -{ - FFI_PROLOG (); - gnupg_isotime_t timebuf; - FFI_ARGS_DONE_OR_RETURN (sc, args); - gnupg_get_isotime (timebuf); - FFI_RETURN_STRING (sc, timebuf); -} - -static pointer -do_get_time (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, gnupg_get_time ()); -} - -static pointer -do_getpid (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, getpid ()); -} - -static pointer -do_srandom (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int seed; - FFI_ARG_OR_RETURN (sc, int, seed, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - srand (seed); - FFI_RETURN (sc); -} - -static int -random_scaled (int scale) -{ - int v; -#ifdef HAVE_RAND - v = rand (); -#else - v = random (); -#endif - -#ifndef RAND_MAX /* for SunOS */ -#define RAND_MAX 32767 -#endif - - return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1); -} - -static pointer -do_random (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int scale; - FFI_ARG_OR_RETURN (sc, int, scale, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, random_scaled (scale)); -} - -static pointer -do_make_random_string (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int size; - pointer chunk; - char *p; - FFI_ARG_OR_RETURN (sc, int, size, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (size < 0) - return ffi_sprintf (sc, "size must be positive"); - - chunk = sc->vptr->mk_counted_string (sc, NULL, size); - if (sc->no_memory) - FFI_RETURN_ERR (sc, ENOMEM); - - for (p = sc->vptr->string_value (chunk); size; p++, size--) - *p = (char) random_scaled (256); - FFI_RETURN_POINTER (sc, chunk); -} - - - -/* estream functions. */ - -struct es_object_box -{ - estream_t stream; - int closed; -}; - -static void -es_object_finalize (scheme *sc, void *data) -{ - struct es_object_box *box = data; - (void) sc; - - if (! box->closed) - es_fclose (box->stream); - xfree (box); -} - -static void -es_object_to_string (scheme *sc, char *out, size_t size, void *data) -{ - struct es_object_box *box = data; - (void) sc; - - snprintf (out, size, "#estream %p", box->stream); -} - -static struct foreign_object_vtable es_object_vtable = - { - es_object_finalize, - es_object_to_string, - }; - -static pointer -es_wrap (scheme *sc, estream_t stream) -{ - struct es_object_box *box = xmalloc (sizeof *box); - if (box == NULL) - return sc->NIL; - - box->stream = stream; - box->closed = 0; - return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box); -} - -static struct es_object_box * -es_unwrap (scheme *sc, pointer object) -{ - (void) sc; - - if (! is_foreign_object (object)) - return NULL; - - if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable) - return NULL; - - return sc->vptr->get_foreign_object_data (object); -} - -#define CONVERSION_estream(SC, X) es_unwrap (SC, X) -#define IS_A_estream(SC, X) es_unwrap (SC, X) - -static pointer -do_es_fclose (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = es_fclose (box->stream); - if (! err) - box->closed = 1; - FFI_RETURN (sc); -} - -static pointer -do_es_read (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - size_t bytes_to_read; - - pointer result; - void *buffer; - size_t bytes_read; - - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - buffer = xtrymalloc (bytes_to_read); - if (buffer == NULL) - FFI_RETURN_ERR (sc, ENOMEM); - - err = es_read (box->stream, buffer, bytes_to_read, &bytes_read); - if (err) - FFI_RETURN_ERR (sc, err); - - result = sc->vptr->mk_counted_string (sc, buffer, bytes_read); - xfree (buffer); - FFI_RETURN_POINTER (sc, result); -} - -static pointer -do_es_feof (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F); -} - -static pointer -do_es_write (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - const char *buffer; - size_t bytes_to_write, bytes_written; - - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - /* XXX how to get the length of the string buffer? scheme strings - may contain \0. */ - FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - bytes_to_write = strlen (buffer); - while (bytes_to_write > 0) - { - err = es_write (box->stream, buffer, bytes_to_write, &bytes_written); - if (err) - break; - bytes_to_write -= bytes_written; - buffer += bytes_written; - } - - FFI_RETURN (sc); -} - - - -/* Process handling. */ - -static pointer -do_spawn_process (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer arguments; - char **argv; - size_t len; - unsigned int flags; - - estream_t infp; - estream_t outfp; - estream_t errfp; - pid_t pid; - - FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); - FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - err = ffi_list2argv (sc, arguments, &argv, &len); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%luth element of first argument is " - "neither string nor symbol", - (unsigned long) len); - if (err) - FFI_RETURN_ERR (sc, err); - - if (verbose > 1) - { - char **p; - fprintf (stderr, "Executing:"); - for (p = argv; *p; p++) - fprintf (stderr, " '%s'", *p); - fprintf (stderr, "\n"); - } - - err = gnupg_spawn_process (argv[0], (const char **) &argv[1], - NULL, - NULL, - flags, - &infp, &outfp, &errfp, &pid); - xfree (argv); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) -#define IMS(A, B) \ - _cons (sc, es_wrap (sc, (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMS (infp, - IMS (outfp, - IMS (errfp, - IMC (pid, sc->NIL))))); -#undef IMS -#undef IMC -} - -static pointer -do_spawn_process_fd (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer arguments; - char **argv; - size_t len; - int infd, outfd, errfd; - - pid_t pid; - - FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); - FFI_ARG_OR_RETURN (sc, int, infd, number, args); - FFI_ARG_OR_RETURN (sc, int, outfd, number, args); - FFI_ARG_OR_RETURN (sc, int, errfd, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - err = ffi_list2argv (sc, arguments, &argv, &len); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%luth element of first argument is " - "neither string nor symbol", - (unsigned long) len); - if (err) - FFI_RETURN_ERR (sc, err); - - if (verbose > 1) - { - char **p; - fprintf (stderr, "Executing:"); - for (p = argv; *p; p++) - fprintf (stderr, " '%s'", *p); - fprintf (stderr, "\n"); - } - - err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1], - infd, outfd, errfd, &pid); - xfree (argv); - FFI_RETURN_INT (sc, pid); -} - -static pointer -do_wait_process (scheme *sc, pointer args) -{ - FFI_PROLOG (); - const char *name; - pid_t pid; - int hang; - - int retcode; - - FFI_ARG_OR_RETURN (sc, const char *, name, string, args); - FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args); - FFI_ARG_OR_RETURN (sc, int, hang, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_wait_process (name, pid, hang, &retcode); - if (err == GPG_ERR_GENERAL) - err = 0; /* Let the return code speak for itself. */ - - FFI_RETURN_INT (sc, retcode); -} - - -static pointer -do_wait_processes (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer list_names; - char **names; - pointer list_pids; - size_t i, count; - pid_t *pids; - int hang; - int *retcodes; - pointer retcodes_list = sc->NIL; - - FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args); - FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args); - FFI_ARG_OR_RETURN (sc, int, hang, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - if (sc->vptr->list_length (sc, list_names) - != sc->vptr->list_length (sc, list_pids)) - return - sc->vptr->mk_string (sc, "length of first two arguments must match"); - - err = ffi_list2argv (sc, list_names, &names, &count); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%lu%s element of first argument is " - "neither string nor symbol", - (unsigned long) count, - ordinal_suffix ((int) count)); - if (err) - FFI_RETURN_ERR (sc, err); - - err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%lu%s element of second argument is " - "not a number", - (unsigned long) count, - ordinal_suffix ((int) count)); - if (err) - FFI_RETURN_ERR (sc, err); - - retcodes = xtrycalloc (sizeof *retcodes, count); - if (retcodes == NULL) - { - xfree (names); - xfree (pids); - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - } - - err = gnupg_wait_processes ((const char **) names, pids, count, hang, - retcodes); - if (err == GPG_ERR_GENERAL) - err = 0; /* Let the return codes speak. */ - if (err == GPG_ERR_TIMEOUT) - err = 0; /* We may have got some results. */ - - for (i = 0; i < count; i++) - retcodes_list = - (sc->vptr->cons) (sc, - sc->vptr->mk_integer (sc, - (long) retcodes[count-1-i]), - retcodes_list); - - xfree (names); - xfree (pids); - xfree (retcodes); - FFI_RETURN_POINTER (sc, retcodes_list); -} - - -static pointer -do_pipe (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int filedes[2]; - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_create_pipe (filedes); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMC (filedes[0], - IMC (filedes[1], sc->NIL))); -#undef IMC -} - -static pointer -do_inbound_pipe (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int filedes[2]; - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_create_inbound_pipe (filedes, NULL, 0); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMC (filedes[0], - IMC (filedes[1], sc->NIL))); -#undef IMC -} - -static pointer -do_outbound_pipe (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int filedes[2]; - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_create_outbound_pipe (filedes, NULL, 0); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMC (filedes[0], - IMC (filedes[1], sc->NIL))); -#undef IMC -} - - - -/* Test helper functions. */ -static pointer -do_file_equal (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer result = sc->F; - char *a_name, *b_name; - int binary; - const char *mode; - FILE *a_stream = NULL, *b_stream = NULL; - struct stat a_stat, b_stat; -#define BUFFER_SIZE 1024 - char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE]; -#undef BUFFER_SIZE - size_t chunk; - - FFI_ARG_OR_RETURN (sc, char *, a_name, string, args); - FFI_ARG_OR_RETURN (sc, char *, b_name, string, args); - FFI_ARG_OR_RETURN (sc, int, binary, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - mode = binary ? "rb" : "r"; - a_stream = fopen (a_name, mode); - if (a_stream == NULL) - goto errout; - - b_stream = fopen (b_name, mode); - if (b_stream == NULL) - goto errout; - - if (fstat (fileno (a_stream), &a_stat) < 0) - goto errout; - - if (fstat (fileno (b_stream), &b_stat) < 0) - goto errout; - - if (binary && a_stat.st_size != b_stat.st_size) - { - if (verbose) - fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n", - a_name, b_name, (unsigned long) a_stat.st_size, - (unsigned long) b_stat.st_size); - - goto out; - } - - while (! feof (a_stream)) - { - chunk = sizeof a_buf; - - chunk = fread (a_buf, 1, chunk, a_stream); - if (chunk == 0 && ferror (a_stream)) - goto errout; /* some error */ - - if (fread (b_buf, 1, chunk, b_stream) < chunk) - { - if (feof (b_stream)) - goto out; /* short read */ - goto errout; /* some error */ - } - - if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0) - goto out; - } - - fread (b_buf, 1, 1, b_stream); - if (! feof (b_stream)) - goto out; /* b is longer */ - - /* They match. */ - result = sc->T; - - out: - if (a_stream) - fclose (a_stream); - if (b_stream) - fclose (b_stream); - FFI_RETURN_POINTER (sc, result); - errout: - err = gpg_error_from_syserror (); - goto out; -} - -static pointer -do_splice (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int source; - char buffer[1024]; - ssize_t bytes_read; - pointer sinks, sink; - FFI_ARG_OR_RETURN (sc, int, source, number, args); - sinks = args; - if (sinks == sc->NIL) - return ffi_sprintf (sc, "need at least one sink"); - for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++) - if (! sc->vptr->is_number (pair_car (sink))) - return ffi_sprintf (sc, "%d%s argument is not a number", - ffi_arg_index, ordinal_suffix (ffi_arg_index)); - - while (1) - { - bytes_read = read (source, buffer, sizeof buffer); - if (bytes_read == 0) - break; - if (bytes_read < 0) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - - for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink)) - { - int fd = sc->vptr->ivalue (pair_car (sink)); - char *p = buffer; - ssize_t left = bytes_read; - - while (left) - { - ssize_t written = write (fd, p, left); - if (written < 0) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - assert (written <= left); - left -= written; - p += written; - } - } - } - FFI_RETURN (sc); -} - -static pointer -do_string_index (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *haystack; - char needle; - ssize_t offset = 0; - char *position; - FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); - FFI_ARG_OR_RETURN (sc, char, needle, character, args); - if (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); - if (offset < 0) - return ffi_sprintf (sc, "offset must be positive"); - if (offset > strlen (haystack)) - return ffi_sprintf (sc, "offset exceeds haystack"); - } - FFI_ARGS_DONE_OR_RETURN (sc, args); - - position = strchr (haystack+offset, needle); - if (position) - FFI_RETURN_INT (sc, position - haystack); - else - FFI_RETURN_POINTER (sc, sc->F); -} - -static pointer -do_string_rindex (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *haystack; - char needle; - ssize_t offset = 0; - char *position; - FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); - FFI_ARG_OR_RETURN (sc, char, needle, character, args); - if (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); - if (offset < 0) - return ffi_sprintf (sc, "offset must be positive"); - if (offset > strlen (haystack)) - return ffi_sprintf (sc, "offset exceeds haystack"); - } - FFI_ARGS_DONE_OR_RETURN (sc, args); - - position = strrchr (haystack+offset, needle); - if (position) - FFI_RETURN_INT (sc, position - haystack); - else - FFI_RETURN_POINTER (sc, sc->F); -} - -static pointer -do_string_contains (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *haystack; - char *needle; - FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); - FFI_ARG_OR_RETURN (sc, char *, needle, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); -} - - - -static pointer -do_get_verbose (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, verbose); -} - -static pointer -do_set_verbose (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int new_verbosity, old; - FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - old = verbose; - verbose = new_verbosity; - - FFI_RETURN_INT (sc, old); -} - - -gpg_error_t -ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) -{ - int i; - - *len = sc->vptr->list_length (sc, list); - *argv = xtrycalloc (*len + 1, sizeof **argv); - if (*argv == NULL) - return gpg_error_from_syserror (); - - for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) - { - if (sc->vptr->is_string (sc->vptr->pair_car (list))) - (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list)); - else if (sc->vptr->is_symbol (sc->vptr->pair_car (list))) - (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list)); - else - { - xfree (*argv); - *argv = NULL; - *len = i; - return gpg_error (GPG_ERR_INV_VALUE); - } - } - (*argv)[i] = NULL; - return 0; -} - -gpg_error_t -ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) -{ - int i; - - *len = sc->vptr->list_length (sc, list); - *intv = xtrycalloc (*len, sizeof **intv); - if (*intv == NULL) - return gpg_error_from_syserror (); - - for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) - { - if (sc->vptr->is_number (sc->vptr->pair_car (list))) - (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list)); - else - { - xfree (*intv); - *intv = NULL; - *len = i; - return gpg_error (GPG_ERR_INV_VALUE); - } - } - - return 0; -} - - -char * -ffi_schemify_name (const char *s, int macro) -{ - /* Fixme: We should use xtrystrdup and return NULL. However, this - * requires a lot more changes. Simply returning S as done - * originally is not an option. */ - char *n = xstrdup (s), *p; - /* if (n == NULL) */ - /* return s; */ - - for (p = n; *p; p++) - { - *p = (char) tolower (*p); - /* We convert _ to - in identifiers. We allow, however, for - function names to start with a leading _. The functions in - this namespace are not yet finalized and might change or - vanish without warning. Use them with care. */ - if (! macro - && p != n - && *p == '_') - *p = '-'; - } - return n; -} - -pointer -ffi_sprintf (scheme *sc, const char *format, ...) -{ - pointer result; - va_list listp; - char *expression; - int size, written; - - va_start (listp, format); - size = vsnprintf (NULL, 0, format, listp); - va_end (listp); - - expression = xtrymalloc (size + 1); - if (expression == NULL) - return NULL; - - va_start (listp, format); - written = vsnprintf (expression, size + 1, format, listp); - va_end (listp); - - assert (size == written); - - result = sc->vptr->mk_string (sc, expression); - xfree (expression); - return result; -} - -void -ffi_scheme_eval (scheme *sc, const char *format, ...) -{ - va_list listp; - char *expression; - int size, written; - - va_start (listp, format); - size = vsnprintf (NULL, 0, format, listp); - va_end (listp); - - expression = xtrymalloc (size + 1); - if (expression == NULL) - return; - - va_start (listp, format); - written = vsnprintf (expression, size + 1, format, listp); - va_end (listp); - - assert (size == written); - - sc->vptr->load_string (sc, expression); - xfree (expression); -} - -gpg_error_t -ffi_init (scheme *sc, const char *argv0, const char *scriptname, - int argc, const char **argv) -{ - int i; - pointer args = sc->NIL; - - /* bitwise arithmetic */ - ffi_define_function (sc, logand); - ffi_define_function (sc, logior); - ffi_define_function (sc, logxor); - ffi_define_function (sc, lognot); - - /* libc. */ - ffi_define_constant (sc, O_RDONLY); - ffi_define_constant (sc, O_WRONLY); - ffi_define_constant (sc, O_RDWR); - ffi_define_constant (sc, O_CREAT); - ffi_define_constant (sc, O_APPEND); -#ifndef O_BINARY -# define O_BINARY 0 -#endif -#ifndef O_TEXT -# define O_TEXT 0 -#endif - ffi_define_constant (sc, O_BINARY); - ffi_define_constant (sc, O_TEXT); - ffi_define_constant (sc, STDIN_FILENO); - ffi_define_constant (sc, STDOUT_FILENO); - ffi_define_constant (sc, STDERR_FILENO); - ffi_define_constant (sc, SEEK_SET); - ffi_define_constant (sc, SEEK_CUR); - ffi_define_constant (sc, SEEK_END); - - ffi_define_function (sc, sleep); - ffi_define_function (sc, usleep); - ffi_define_function (sc, chdir); - ffi_define_function (sc, strerror); - ffi_define_function (sc, getenv); - ffi_define_function (sc, setenv); - ffi_define_function_name (sc, "_exit", exit); - ffi_define_function (sc, open); - ffi_define_function (sc, fdopen); - ffi_define_function (sc, close); - ffi_define_function (sc, seek); - ffi_define_function (sc, get_temp_path); - ffi_define_function_name (sc, "_mkdtemp", mkdtemp); - ffi_define_function (sc, unlink); - ffi_define_function (sc, unlink_recursively); - ffi_define_function (sc, rename); - ffi_define_function (sc, getcwd); - ffi_define_function (sc, mkdir); - ffi_define_function (sc, rmdir); - ffi_define_function (sc, get_isotime); - ffi_define_function (sc, get_time); - ffi_define_function (sc, getpid); - - /* Random numbers. */ - ffi_define_function (sc, srandom); - ffi_define_function (sc, random); - ffi_define_function (sc, make_random_string); - - /* Process management. */ - ffi_define_function (sc, spawn_process); - ffi_define_function (sc, spawn_process_fd); - ffi_define_function (sc, wait_process); - ffi_define_function (sc, wait_processes); - ffi_define_function (sc, pipe); - ffi_define_function (sc, inbound_pipe); - ffi_define_function (sc, outbound_pipe); - - /* estream functions. */ - ffi_define_function_name (sc, "es-fclose", es_fclose); - ffi_define_function_name (sc, "es-read", es_read); - ffi_define_function_name (sc, "es-feof", es_feof); - ffi_define_function_name (sc, "es-write", es_write); - - /* Test helper functions. */ - ffi_define_function (sc, file_equal); - ffi_define_function (sc, splice); - ffi_define_function (sc, string_index); - ffi_define_function (sc, string_rindex); - ffi_define_function_name (sc, "string-contains?", string_contains); - - /* User interface. */ - ffi_define_function (sc, flush_stdio); - ffi_define_function (sc, prompt); - - /* Configuration. */ - ffi_define_function_name (sc, "*verbose*", get_verbose); - ffi_define_function_name (sc, "*set-verbose!*", set_verbose); - - ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); - ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname)); - for (i = argc - 1; i >= 0; i--) - { - pointer value = sc->vptr->mk_string (sc, argv[i]); - args = (sc->vptr->cons) (sc, value, args); - } - ffi_define (sc, "*args*", args); - -#if _WIN32 - ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';')); -#else - ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); -#endif - - ffi_define (sc, "*win32*", -#if _WIN32 - sc->T -#else - sc->F -#endif - ); - - ffi_define (sc, "*maintainer-mode*", -#if MAINTAINER_MODE - sc->T -#else - sc->F -#endif - ); - - ffi_define (sc, "*run-all-tests*", -#if RUN_ALL_TESTS - sc->T -#else - sc->F -#endif - ); - - - ffi_define (sc, "*stdin*", - sc->vptr->mk_port_from_file (sc, stdin, port_input)); - ffi_define (sc, "*stdout*", - sc->vptr->mk_port_from_file (sc, stdout, port_output)); - ffi_define (sc, "*stderr*", - sc->vptr->mk_port_from_file (sc, stderr, port_output)); - - return 0; -} diff --git a/ffi.h b/ffi.h deleted file mode 100644 index eba6282..0000000 --- a/ffi.h +++ /dev/null @@ -1,30 +0,0 @@ -/* FFI interface for TinySCHEME. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#ifndef GPGSCM_FFI_H -#define GPGSCM_FFI_H - -#include -#include "scheme.h" - -gpg_error_t ffi_init (scheme *sc, const char *argv0, const char *scriptname, - int argc, const char **argv); - -#endif /* GPGSCM_FFI_H */ diff --git a/ffi.scm b/ffi.scm deleted file mode 100644 index 051c2c2..0000000 --- a/ffi.scm +++ /dev/null @@ -1,51 +0,0 @@ -;; FFI interface for TinySCHEME. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Foreign function wrapper. Expects F to return a list with the -;; first element being the `error_t' value returned by the foreign -;; function. The error is thrown, or the cdr of the result is -;; returned. -(define (ffi-apply name f args) - (let ((result (apply f args))) - (cond - ((string? result) - (ffi-fail name args result)) - ((not (= (car result) 0)) - (ffi-fail name args (strerror (car result)))) - ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) - ((= (car result) 0) '()) - (else - (throw (list "Result violates FFI calling convention: " result)))))) - -(define (ffi-fail name args message) - (let ((args' (open-output-string))) - (write (cons (string->symbol name) args) args') - (throw (get-output-string args') message))) - -;; Pseudo-definitions for foreign functions. Evaluates to no code, -;; but serves as documentation. -(macro (ffi-define form)) - -;; Runtime support. - -;; Low-level mechanism to terminate the process. -(ffi-define (_exit status)) - -;; Get the current time in seconds since the epoch. -(ffi-define (get-time)) diff --git a/gnupg.scm b/gnupg.scm deleted file mode 100644 index 5fcf9fd..0000000 --- a/gnupg.scm +++ /dev/null @@ -1,44 +0,0 @@ -;; Common definitions for executing gpg and related tools. -;; -;; Copyright (C) 2016, 2017 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Evaluate a sequence of expressions with the given home directory. -(define-macro (with-home-directory gnupghome . expressions) - (let ((original-home-directory (gensym))) - `(let ((,original-home-directory (getenv "GNUPGHOME"))) - (dynamic-wind - (lambda () (setenv "GNUPGHOME" ,gnupghome #t)) - (lambda () ,@expressions) - (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))) - -;; Evaluate a sequence of expressions with an ephemeral home -;; directory. -(define-macro (with-ephemeral-home-directory setup-fn . expressions) - (let ((original-home-directory (gensym)) - (ephemeral-home-directory (gensym)) - (setup (gensym))) - `(let ((,original-home-directory (getenv "GNUPGHOME")) - (,ephemeral-home-directory (mkdtemp)) - (,setup (delay (,setup-fn)))) - (finally (unlink-recursively ,ephemeral-home-directory) - (dynamic-wind - (lambda () - (setenv "GNUPGHOME" ,ephemeral-home-directory #t) - (with-working-directory ,ephemeral-home-directory (force ,setup))) - (lambda () ,@expressions) - (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))) diff --git a/gpgscm/LICENSE.TinySCHEME b/gpgscm/LICENSE.TinySCHEME new file mode 100644 index 0000000..23a7e85 --- /dev/null +++ b/gpgscm/LICENSE.TinySCHEME @@ -0,0 +1,31 @@ + LICENSE TERMS + +Copyright (c) 2000, Dimitrios Souflis +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of Dimitrios Souflis nor the names of the +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/gpgscm/Makefile.am b/gpgscm/Makefile.am new file mode 100644 index 0000000..44d7b3f --- /dev/null +++ b/gpgscm/Makefile.am @@ -0,0 +1,64 @@ +# TinyScheme-based test driver. +# +# Copyright (C) 2016 g10 Code GmbH +# +# This file is part of GnuPG. +# +# GnuPG is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# GnuPG is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . + +EXTRA_DIST = \ + LICENSE.TinySCHEME \ + Manual.txt \ + ffi.scm \ + init.scm \ + lib.scm \ + makefile.scm \ + repl.scm \ + t-child.scm \ + xml.scm \ + tests.scm \ + gnupg.scm \ + time.scm + +AM_CPPFLAGS = -I$(top_srcdir)/common +include $(top_srcdir)/am/cmacros.am + +AM_CFLAGS = + +CLEANFILES = + +bin_PROGRAMS = gpgscm +noinst_PROGRAMS = t-child + +common_libs = ../$(libcommon) +commonpth_libs = ../$(libcommonpth) + +gpgscm_CFLAGS = -imacros scheme-config.h \ + $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) +gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ + scheme-config.h scheme.c scheme.h scheme-private.h \ + opdefines.h small-integers.h +gpgscm_LDADD = $(LDADD) $(common_libs) \ + $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \ + $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) + +t_child_SOURCES = t-child.c + +# Make sure that all libs are build before we use them. This is +# important for things like make -j2. +$(PROGRAMS): $(common_libs) + +check-local: gpgscm$(EXEEXT) t-child$(EXEEXT) + EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \ + ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm diff --git a/gpgscm/Manual.txt b/gpgscm/Manual.txt new file mode 100644 index 0000000..b146926 --- /dev/null +++ b/gpgscm/Manual.txt @@ -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? ) (defined? ) + Checks whether the given symbol is defined in the current (or given) + environment. + + Symbols + (gensym) + Returns a new interned symbol each time. Will probably move to the + library when string->symbol is implemented. + + Directives + (gc) + Performs garbage collection immediately. + + (gc-verbose) (gc-verbose ) + The argument (defaulting to #t) controls whether GC produces + visible outcome. + + (quit) (quit ) + Stops the interpreter and sets the 'retcode' internal field (defaults + to 0). When standalone, 'retcode' is returned as exit code to the OS. + + (tracing ) + 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>=?. + (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>=?. + (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 ) + 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 ) + Returns the expanded form of the macro call denoted by the argument + + (define-with-return ( ...) ) + Like plain 'define', but makes the continuation available as 'return' + inside the procedure. Handy for imperative programs. + + (new-segment ) + Allocates more memory segments. + + defined? + See "Environments" + + (get-closure-code ) + Gets the code as scheme data. + + (make-closure ) + Makes a new closure in the given environment. + + Obsolete procedures + (print-width ) + + 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_. 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 [ ...] + followed by + -1 [ ...] + -c [ ...] + 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 + ... ) + + "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 :: and + transforms it in the following manner (T is the transformation function): + + T(::) = (*colon-hook* 'T() ) + + where is a symbol not containing any double-colons. + + As the definition is recursive, qualifiers can be nested. + The user can define his own *colon-hook*, to handle qualified names. + By default, "init.scm" defines *colon-hook* as EVAL. Consequently, + the qualifier must denote a Scheme environment, such as one returned + by (interaction-environment). "Init.scm" defines a new syntantic form, + PACKAGE, as a simple example. It is used like this: + + (define toto + (package + (define foo 1) + (define bar +))) + + foo ==> Error, "foo" undefined + (eval 'foo) ==> Error, "foo" undefined + (eval 'foo toto) ==> 1 + toto::foo ==> 1 + ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 + (toto::bar 2 toto::foo) ==> 3 + (eval (bar 2 foo) toto) ==> 3 + + If the user installs another package infrastructure, he must define + a new 'package' procedure or macro to retain compatibility with supplied + code. + + Note: Older versions used ':' as a qualifier. Unfortunately, the use + of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially + precludes its use as a real qualifier. diff --git a/gpgscm/ffi-private.h b/gpgscm/ffi-private.h new file mode 100644 index 0000000..037da56 --- /dev/null +++ b/gpgscm/ffi-private.h @@ -0,0 +1,148 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef GPGSCM_FFI_PRIVATE_H +#define GPGSCM_FFI_PRIVATE_H + +#include +#include "scheme.h" +#include "scheme-private.h" + +#define FFI_PROLOG() \ + unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1; \ + int err GPGRT_ATTR_UNUSED = 0 \ + +int ffi_bool_value (scheme *sc, pointer p); + +#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X) +#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X) +#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X) +#define CONVERSION_list(SC, X) (X) +#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X)) +#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \ + ? (SC)->vptr->string_value \ + : (SC)->vptr->symname) (X)) + +#define IS_A_number(SC, X) (SC)->vptr->is_number (X) +#define IS_A_string(SC, X) (SC)->vptr->is_string (X) +#define IS_A_character(SC, X) (SC)->vptr->is_character (X) +#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X) +#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T) +#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ + || (SC)->vptr->is_symbol (X)) + +#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS) \ + do { \ + if ((ARGS) == (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), \ + "too few arguments: want " \ + #TARGET "("#WANT"/"#CTYPE")\n"); \ + if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \ + char ffi_error_message[256]; \ + snprintf (ffi_error_message, sizeof ffi_error_message, \ + "argument %d must be: " #WANT "\n", ffi_arg_index); \ + return (SC)->vptr->mk_string ((SC), ffi_error_message); \ + } \ + TARGET = CONVERSION_##WANT (SC, pair_car (ARGS)); \ + ARGS = pair_cdr (ARGS); \ + ffi_arg_index += 1; \ + } while (0) + +#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS) \ + do { \ + if ((ARGS) != (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), "too many arguments"); \ + } while (0) + +#define FFI_RETURN_ERR(SC, ERR) \ + return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1) + +#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err) + +#define FFI_RETURN_POINTER(SC, X) \ + return _cons ((SC), mk_integer ((SC), err), \ + _cons ((SC), (X), (SC)->NIL, 1), 1) +#define FFI_RETURN_INT(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X))) +#define FFI_RETURN_STRING(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_string ((SC), (X))) + +char *ffi_schemify_name (const char *s, int macro); + +void ffi_scheme_eval (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); +pointer ffi_sprintf (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); + +#define ffi_define_function_name(SC, NAME, F) \ + do { \ + char *_fname = ffi_schemify_name ("__" #F, 0); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _fname), \ + mk_foreign_func ((SC), (do_##F))); \ + ffi_scheme_eval ((SC), \ + "(define (%s . a) (ffi-apply \"%s\" %s a))", \ + (NAME), (NAME), _fname); \ + free (_fname); \ + } while (0) + +#define ffi_define_function(SC, F) \ + do { \ + char *_name = ffi_schemify_name (#F, 0); \ + ffi_define_function_name ((SC), _name, F); \ + free (_name); \ + } while (0) + +#define ffi_define_constant(SC, C) \ + do { \ + char *_name = ffi_schemify_name (#C, 1); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + mk_integer ((SC), (C))); \ + free (_name); \ + } while (0) + +#define ffi_define(SC, SYM, EXP) \ + scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP) + +#define ffi_define_variable_pointer(SC, C, P) \ + do { \ + char *_name = ffi_schemify_name (#C, 0); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + (P)); \ + free (_name); \ + } while (0) + +#define ffi_define_variable_integer(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C)) + +#define ffi_define_variable_string(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: "")) + +gpg_error_t ffi_list2argv (scheme *sc, pointer list, + char ***argv, size_t *len); +gpg_error_t ffi_list2intv (scheme *sc, pointer list, + int **intv, size_t *len); + +#endif /* GPGSCM_FFI_PRIVATE_H */ diff --git a/gpgscm/ffi.c b/gpgscm/ffi.c new file mode 100644 index 0000000..dde5b52 --- /dev/null +++ b/gpgscm/ffi.c @@ -0,0 +1,1470 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#if HAVE_LIBREADLINE +#define GNUPG_LIBREADLINE_H_INCLUDED +#include +#include +#endif + +#include "../../common/util.h" +#include "../../common/exechelp.h" +#include "../../common/sysutils.h" + +#include "private.h" +#include "ffi.h" +#include "ffi-private.h" + +/* For use in nice error messages. */ +static const char * +ordinal_suffix (int n) +{ + switch (n) + { + case 1: return "st"; + case 2: return "nd"; + case 3: return "rd"; + default: return "th"; + } + assert (! "reached"); +} + + + +int +ffi_bool_value (scheme *sc, pointer p) +{ + return ! (p == sc->F); +} + + + +static pointer +do_logand (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = ~0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc &= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logior (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc |= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logxor (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc ^= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_lognot (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v; + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, ~v); +} + +/* User interface. */ + +static pointer +do_flush_stdio (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + fflush (stdout); + fflush (stderr); + FFI_RETURN (sc); +} + + +int use_libreadline; + +/* Read a string, and return a pointer to it. Returns NULL on EOF. */ +char * +rl_gets (const char *prompt) +{ + static char *line = NULL; + char *p; + xfree (line); + +#if HAVE_LIBREADLINE + { + line = readline (prompt); + if (line && *line) + add_history (line); + } +#else + { + size_t max_size = 0xff; + printf ("%s", prompt); + fflush (stdout); + line = xtrymalloc (max_size); + if (line != NULL) + fgets (line, max_size, stdin); + } +#endif + + /* Strip trailing whitespace. */ + if (line && strlen (line) > 0) + for (p = &line[strlen (line) - 1]; isspace (*p); p--) + *p = 0; + + return line; +} + +static pointer +do_prompt (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *prompt; + const char *line; + FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + line = rl_gets (prompt); + if (! line) + FFI_RETURN_POINTER (sc, sc->EOF_OBJ); + + FFI_RETURN_STRING (sc, line); +} + +static pointer +do_sleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int seconds; + FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + sleep (seconds); + FFI_RETURN (sc); +} + +static pointer +do_usleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + useconds_t microseconds; + FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + usleep (microseconds); + FFI_RETURN (sc); +} + +static pointer +do_chdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, path, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (chdir (name)) + FFI_RETURN_ERR (sc, errno); + FFI_RETURN (sc); +} + +static pointer +do_strerror (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int error; + FFI_ARG_OR_RETURN (sc, int, error, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_STRING (sc, gpg_strerror (error)); +} + +static pointer +do_getenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *value; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + value = getenv (name); + FFI_RETURN_STRING (sc, value ? value : ""); +} + +static pointer +do_setenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *value; + int overwrite; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, value, string, args); + FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (gnupg_setenv (name, value, overwrite)) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_exit (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int retcode; + FFI_ARG_OR_RETURN (sc, int, retcode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + exit (retcode); +} + +/* XXX: use gnupgs variant b/c mode as string */ +static pointer +do_open (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + char *pathname; + int flags; + mode_t mode = 0; + FFI_ARG_OR_RETURN (sc, char *, pathname, path, args); + FFI_ARG_OR_RETURN (sc, int, flags, number, args); + if (args != sc->NIL) + FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + fd = open (pathname, flags, mode); + if (fd == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_INT (sc, fd); +} + +static pointer +do_fdopen (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FILE *stream; + int fd; + char *mode; + int kind; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + stream = fdopen (fd, mode); + if (stream == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + if (setvbuf (stream, NULL, _IONBF, 0) != 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + kind = 0; + if (strchr (mode, 'r')) + kind |= port_input; + if (strchr (mode, 'w')) + kind |= port_output; + + FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind)); +} + +static pointer +do_close (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); +} + +static pointer +do_seek (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + off_t offset; + int whence; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARG_OR_RETURN (sc, off_t, offset, number, args); + FFI_ARG_OR_RETURN (sc, int, whence, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1 + ? gpg_error_from_syserror () : 0); +} + +static pointer +do_get_temp_path (scheme *sc, pointer args) +{ + FFI_PROLOG (); +#ifdef HAVE_W32_SYSTEM + char buffer[MAX_PATH+1]; +#endif + FFI_ARGS_DONE_OR_RETURN (sc, args); + +#ifdef HAVE_W32_SYSTEM + if (GetTempPath (MAX_PATH+1, buffer) == 0) + FFI_RETURN_STRING (sc, "/temp"); + FFI_RETURN_STRING (sc, buffer); +#else + FFI_RETURN_STRING (sc, "/tmp"); +#endif +} + +static pointer +do_mkdtemp (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *template; +#ifdef PATH_MAX + char buffer[PATH_MAX]; +#else + char buffer[1024]; +#endif + char *name; + FFI_ARG_OR_RETURN (sc, char *, template, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (strlen (template) > sizeof buffer - 1) + FFI_RETURN_ERR (sc, EINVAL); + strncpy (buffer, template, sizeof buffer); + + name = gnupg_mkdtemp (buffer); + if (name == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_STRING (sc, name); +} + +static pointer +do_unlink (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (unlink (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static gpg_error_t +unlink_recursively (const char *name) +{ + gpg_error_t err = 0; + struct stat st; + + if (stat (name, &st) == -1) + return gpg_error_from_syserror (); + + if (S_ISDIR (st.st_mode)) + { + DIR *dir; + struct dirent *dent; + + dir = opendir (name); + if (dir == NULL) + return gpg_error_from_syserror (); + + while ((dent = readdir (dir))) + { + char *child; + + if (strcmp (dent->d_name, ".") == 0 + || strcmp (dent->d_name, "..") == 0) + continue; + + child = xtryasprintf ("%s/%s", name, dent->d_name); + if (child == NULL) + { + err = gpg_error_from_syserror (); + goto leave; + } + + err = unlink_recursively (child); + xfree (child); + if (err == gpg_error_from_errno (ENOENT)) + err = 0; + if (err) + goto leave; + } + + leave: + closedir (dir); + if (! err) + rmdir (name); + return err; + } + else + if (unlink (name) == -1) + return gpg_error_from_syserror (); + return 0; +} + +static pointer +do_unlink_recursively (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = unlink_recursively (name); + FFI_RETURN (sc); +} + +static pointer +do_rename (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *old; + char *new; + FFI_ARG_OR_RETURN (sc, char *, old, string, args); + FFI_ARG_OR_RETURN (sc, char *, new, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rename (old, new) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_getcwd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result; + char *cwd; + FFI_ARGS_DONE_OR_RETURN (sc, args); + cwd = gnupg_getcwd (); + if (cwd == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + result = sc->vptr->mk_string (sc, cwd); + xfree (cwd); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_mkdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *mode; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (gnupg_mkdir (name, mode) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_rmdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rmdir (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_get_isotime (scheme *sc, pointer args) +{ + FFI_PROLOG (); + gnupg_isotime_t timebuf; + FFI_ARGS_DONE_OR_RETURN (sc, args); + gnupg_get_isotime (timebuf); + FFI_RETURN_STRING (sc, timebuf); +} + +static pointer +do_get_time (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, gnupg_get_time ()); +} + +static pointer +do_getpid (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, getpid ()); +} + +static pointer +do_srandom (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int seed; + FFI_ARG_OR_RETURN (sc, int, seed, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + srand (seed); + FFI_RETURN (sc); +} + +static int +random_scaled (int scale) +{ + int v; +#ifdef HAVE_RAND + v = rand (); +#else + v = random (); +#endif + +#ifndef RAND_MAX /* for SunOS */ +#define RAND_MAX 32767 +#endif + + return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1); +} + +static pointer +do_random (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int scale; + FFI_ARG_OR_RETURN (sc, int, scale, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, random_scaled (scale)); +} + +static pointer +do_make_random_string (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int size; + pointer chunk; + char *p; + FFI_ARG_OR_RETURN (sc, int, size, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (size < 0) + return ffi_sprintf (sc, "size must be positive"); + + chunk = sc->vptr->mk_counted_string (sc, NULL, size); + if (sc->no_memory) + FFI_RETURN_ERR (sc, ENOMEM); + + for (p = sc->vptr->string_value (chunk); size; p++, size--) + *p = (char) random_scaled (256); + FFI_RETURN_POINTER (sc, chunk); +} + + + +/* estream functions. */ + +struct es_object_box +{ + estream_t stream; + int closed; +}; + +static void +es_object_finalize (scheme *sc, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + if (! box->closed) + es_fclose (box->stream); + xfree (box); +} + +static void +es_object_to_string (scheme *sc, char *out, size_t size, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + snprintf (out, size, "#estream %p", box->stream); +} + +static struct foreign_object_vtable es_object_vtable = + { + es_object_finalize, + es_object_to_string, + }; + +static pointer +es_wrap (scheme *sc, estream_t stream) +{ + struct es_object_box *box = xmalloc (sizeof *box); + if (box == NULL) + return sc->NIL; + + box->stream = stream; + box->closed = 0; + return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box); +} + +static struct es_object_box * +es_unwrap (scheme *sc, pointer object) +{ + (void) sc; + + if (! is_foreign_object (object)) + return NULL; + + if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable) + return NULL; + + return sc->vptr->get_foreign_object_data (object); +} + +#define CONVERSION_estream(SC, X) es_unwrap (SC, X) +#define IS_A_estream(SC, X) es_unwrap (SC, X) + +static pointer +do_es_fclose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = es_fclose (box->stream); + if (! err) + box->closed = 1; + FFI_RETURN (sc); +} + +static pointer +do_es_read (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + size_t bytes_to_read; + + pointer result; + void *buffer; + size_t bytes_read; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + buffer = xtrymalloc (bytes_to_read); + if (buffer == NULL) + FFI_RETURN_ERR (sc, ENOMEM); + + err = es_read (box->stream, buffer, bytes_to_read, &bytes_read); + if (err) + FFI_RETURN_ERR (sc, err); + + result = sc->vptr->mk_counted_string (sc, buffer, bytes_read); + xfree (buffer); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_es_feof (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F); +} + +static pointer +do_es_write (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + const char *buffer; + size_t bytes_to_write, bytes_written; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + /* XXX how to get the length of the string buffer? scheme strings + may contain \0. */ + FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + bytes_to_write = strlen (buffer); + while (bytes_to_write > 0) + { + err = es_write (box->stream, buffer, bytes_to_write, &bytes_written); + if (err) + break; + bytes_to_write -= bytes_written; + buffer += bytes_written; + } + + FFI_RETURN (sc); +} + + + +/* Process handling. */ + +static pointer +do_spawn_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + unsigned int flags; + + estream_t infp; + estream_t outfp; + estream_t errfp; + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process (argv[0], (const char **) &argv[1], + NULL, + NULL, + flags, + &infp, &outfp, &errfp, &pid); + xfree (argv); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) +#define IMS(A, B) \ + _cons (sc, es_wrap (sc, (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMS (infp, + IMS (outfp, + IMS (errfp, + IMC (pid, sc->NIL))))); +#undef IMS +#undef IMC +} + +static pointer +do_spawn_process_fd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + int infd, outfd, errfd; + + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, int, infd, number, args); + FFI_ARG_OR_RETURN (sc, int, outfd, number, args); + FFI_ARG_OR_RETURN (sc, int, errfd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1], + infd, outfd, errfd, &pid); + xfree (argv); + FFI_RETURN_INT (sc, pid); +} + +static pointer +do_wait_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *name; + pid_t pid; + int hang; + + int retcode; + + FFI_ARG_OR_RETURN (sc, const char *, name, string, args); + FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_wait_process (name, pid, hang, &retcode); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return code speak for itself. */ + + FFI_RETURN_INT (sc, retcode); +} + + +static pointer +do_wait_processes (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer list_names; + char **names; + pointer list_pids; + size_t i, count; + pid_t *pids; + int hang; + int *retcodes; + pointer retcodes_list = sc->NIL; + + FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args); + FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (sc->vptr->list_length (sc, list_names) + != sc->vptr->list_length (sc, list_pids)) + return + sc->vptr->mk_string (sc, "length of first two arguments must match"); + + err = ffi_list2argv (sc, list_names, &names, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%lu%s element of first argument is " + "neither string nor symbol", + (unsigned long) count, + ordinal_suffix ((int) count)); + if (err) + FFI_RETURN_ERR (sc, err); + + err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%lu%s element of second argument is " + "not a number", + (unsigned long) count, + ordinal_suffix ((int) count)); + if (err) + FFI_RETURN_ERR (sc, err); + + retcodes = xtrycalloc (sizeof *retcodes, count); + if (retcodes == NULL) + { + xfree (names); + xfree (pids); + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + } + + err = gnupg_wait_processes ((const char **) names, pids, count, hang, + retcodes); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return codes speak. */ + if (err == GPG_ERR_TIMEOUT) + err = 0; /* We may have got some results. */ + + for (i = 0; i < count; i++) + retcodes_list = + (sc->vptr->cons) (sc, + sc->vptr->mk_integer (sc, + (long) retcodes[count-1-i]), + retcodes_list); + + xfree (names); + xfree (pids); + xfree (retcodes); + FFI_RETURN_POINTER (sc, retcodes_list); +} + + +static pointer +do_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_pipe (filedes); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_inbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_inbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_outbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_outbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + + + +/* Test helper functions. */ +static pointer +do_file_equal (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result = sc->F; + char *a_name, *b_name; + int binary; + const char *mode; + FILE *a_stream = NULL, *b_stream = NULL; + struct stat a_stat, b_stat; +#define BUFFER_SIZE 1024 + char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE]; +#undef BUFFER_SIZE + size_t chunk; + + FFI_ARG_OR_RETURN (sc, char *, a_name, string, args); + FFI_ARG_OR_RETURN (sc, char *, b_name, string, args); + FFI_ARG_OR_RETURN (sc, int, binary, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + mode = binary ? "rb" : "r"; + a_stream = fopen (a_name, mode); + if (a_stream == NULL) + goto errout; + + b_stream = fopen (b_name, mode); + if (b_stream == NULL) + goto errout; + + if (fstat (fileno (a_stream), &a_stat) < 0) + goto errout; + + if (fstat (fileno (b_stream), &b_stat) < 0) + goto errout; + + if (binary && a_stat.st_size != b_stat.st_size) + { + if (verbose) + fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n", + a_name, b_name, (unsigned long) a_stat.st_size, + (unsigned long) b_stat.st_size); + + goto out; + } + + while (! feof (a_stream)) + { + chunk = sizeof a_buf; + + chunk = fread (a_buf, 1, chunk, a_stream); + if (chunk == 0 && ferror (a_stream)) + goto errout; /* some error */ + + if (fread (b_buf, 1, chunk, b_stream) < chunk) + { + if (feof (b_stream)) + goto out; /* short read */ + goto errout; /* some error */ + } + + if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0) + goto out; + } + + fread (b_buf, 1, 1, b_stream); + if (! feof (b_stream)) + goto out; /* b is longer */ + + /* They match. */ + result = sc->T; + + out: + if (a_stream) + fclose (a_stream); + if (b_stream) + fclose (b_stream); + FFI_RETURN_POINTER (sc, result); + errout: + err = gpg_error_from_syserror (); + goto out; +} + +static pointer +do_splice (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int source; + char buffer[1024]; + ssize_t bytes_read; + pointer sinks, sink; + FFI_ARG_OR_RETURN (sc, int, source, number, args); + sinks = args; + if (sinks == sc->NIL) + return ffi_sprintf (sc, "need at least one sink"); + for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++) + if (! sc->vptr->is_number (pair_car (sink))) + return ffi_sprintf (sc, "%d%s argument is not a number", + ffi_arg_index, ordinal_suffix (ffi_arg_index)); + + while (1) + { + bytes_read = read (source, buffer, sizeof buffer); + if (bytes_read == 0) + break; + if (bytes_read < 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink)) + { + int fd = sc->vptr->ivalue (pair_car (sink)); + char *p = buffer; + ssize_t left = bytes_read; + + while (left) + { + ssize_t written = write (fd, p, left); + if (written < 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + assert (written <= left); + left -= written; + p += written; + } + } + } + FFI_RETURN (sc); +} + +static pointer +do_string_index (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_rindex (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strrchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_contains (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char *needle; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char *, needle, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); +} + + + +static pointer +do_get_verbose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, verbose); +} + +static pointer +do_set_verbose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int new_verbosity, old; + FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + old = verbose; + verbose = new_verbosity; + + FFI_RETURN_INT (sc, old); +} + + +gpg_error_t +ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *argv = xtrycalloc (*len + 1, sizeof **argv); + if (*argv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_string (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list)); + else if (sc->vptr->is_symbol (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list)); + else + { + xfree (*argv); + *argv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + (*argv)[i] = NULL; + return 0; +} + +gpg_error_t +ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *intv = xtrycalloc (*len, sizeof **intv); + if (*intv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_number (sc->vptr->pair_car (list))) + (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list)); + else + { + xfree (*intv); + *intv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + + return 0; +} + + +char * +ffi_schemify_name (const char *s, int macro) +{ + /* Fixme: We should use xtrystrdup and return NULL. However, this + * requires a lot more changes. Simply returning S as done + * originally is not an option. */ + char *n = xstrdup (s), *p; + /* if (n == NULL) */ + /* return s; */ + + for (p = n; *p; p++) + { + *p = (char) tolower (*p); + /* We convert _ to - in identifiers. We allow, however, for + function names to start with a leading _. The functions in + this namespace are not yet finalized and might change or + vanish without warning. Use them with care. */ + if (! macro + && p != n + && *p == '_') + *p = '-'; + } + return n; +} + +pointer +ffi_sprintf (scheme *sc, const char *format, ...) +{ + pointer result; + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return NULL; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + result = sc->vptr->mk_string (sc, expression); + xfree (expression); + return result; +} + +void +ffi_scheme_eval (scheme *sc, const char *format, ...) +{ + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + sc->vptr->load_string (sc, expression); + xfree (expression); +} + +gpg_error_t +ffi_init (scheme *sc, const char *argv0, const char *scriptname, + int argc, const char **argv) +{ + int i; + pointer args = sc->NIL; + + /* bitwise arithmetic */ + ffi_define_function (sc, logand); + ffi_define_function (sc, logior); + ffi_define_function (sc, logxor); + ffi_define_function (sc, lognot); + + /* libc. */ + ffi_define_constant (sc, O_RDONLY); + ffi_define_constant (sc, O_WRONLY); + ffi_define_constant (sc, O_RDWR); + ffi_define_constant (sc, O_CREAT); + ffi_define_constant (sc, O_APPEND); +#ifndef O_BINARY +# define O_BINARY 0 +#endif +#ifndef O_TEXT +# define O_TEXT 0 +#endif + ffi_define_constant (sc, O_BINARY); + ffi_define_constant (sc, O_TEXT); + ffi_define_constant (sc, STDIN_FILENO); + ffi_define_constant (sc, STDOUT_FILENO); + ffi_define_constant (sc, STDERR_FILENO); + ffi_define_constant (sc, SEEK_SET); + ffi_define_constant (sc, SEEK_CUR); + ffi_define_constant (sc, SEEK_END); + + ffi_define_function (sc, sleep); + ffi_define_function (sc, usleep); + ffi_define_function (sc, chdir); + ffi_define_function (sc, strerror); + ffi_define_function (sc, getenv); + ffi_define_function (sc, setenv); + ffi_define_function_name (sc, "_exit", exit); + ffi_define_function (sc, open); + ffi_define_function (sc, fdopen); + ffi_define_function (sc, close); + ffi_define_function (sc, seek); + ffi_define_function (sc, get_temp_path); + ffi_define_function_name (sc, "_mkdtemp", mkdtemp); + ffi_define_function (sc, unlink); + ffi_define_function (sc, unlink_recursively); + ffi_define_function (sc, rename); + ffi_define_function (sc, getcwd); + ffi_define_function (sc, mkdir); + ffi_define_function (sc, rmdir); + ffi_define_function (sc, get_isotime); + ffi_define_function (sc, get_time); + ffi_define_function (sc, getpid); + + /* Random numbers. */ + ffi_define_function (sc, srandom); + ffi_define_function (sc, random); + ffi_define_function (sc, make_random_string); + + /* Process management. */ + ffi_define_function (sc, spawn_process); + ffi_define_function (sc, spawn_process_fd); + ffi_define_function (sc, wait_process); + ffi_define_function (sc, wait_processes); + ffi_define_function (sc, pipe); + ffi_define_function (sc, inbound_pipe); + ffi_define_function (sc, outbound_pipe); + + /* estream functions. */ + ffi_define_function_name (sc, "es-fclose", es_fclose); + ffi_define_function_name (sc, "es-read", es_read); + ffi_define_function_name (sc, "es-feof", es_feof); + ffi_define_function_name (sc, "es-write", es_write); + + /* Test helper functions. */ + ffi_define_function (sc, file_equal); + ffi_define_function (sc, splice); + ffi_define_function (sc, string_index); + ffi_define_function (sc, string_rindex); + ffi_define_function_name (sc, "string-contains?", string_contains); + + /* User interface. */ + ffi_define_function (sc, flush_stdio); + ffi_define_function (sc, prompt); + + /* Configuration. */ + ffi_define_function_name (sc, "*verbose*", get_verbose); + ffi_define_function_name (sc, "*set-verbose!*", set_verbose); + + ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); + ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname)); + for (i = argc - 1; i >= 0; i--) + { + pointer value = sc->vptr->mk_string (sc, argv[i]); + args = (sc->vptr->cons) (sc, value, args); + } + ffi_define (sc, "*args*", args); + +#if _WIN32 + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';')); +#else + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); +#endif + + ffi_define (sc, "*win32*", +#if _WIN32 + sc->T +#else + sc->F +#endif + ); + + ffi_define (sc, "*maintainer-mode*", +#if MAINTAINER_MODE + sc->T +#else + sc->F +#endif + ); + + ffi_define (sc, "*run-all-tests*", +#if RUN_ALL_TESTS + sc->T +#else + sc->F +#endif + ); + + + ffi_define (sc, "*stdin*", + sc->vptr->mk_port_from_file (sc, stdin, port_input)); + ffi_define (sc, "*stdout*", + sc->vptr->mk_port_from_file (sc, stdout, port_output)); + ffi_define (sc, "*stderr*", + sc->vptr->mk_port_from_file (sc, stderr, port_output)); + + return 0; +} diff --git a/gpgscm/ffi.h b/gpgscm/ffi.h new file mode 100644 index 0000000..eba6282 --- /dev/null +++ b/gpgscm/ffi.h @@ -0,0 +1,30 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef GPGSCM_FFI_H +#define GPGSCM_FFI_H + +#include +#include "scheme.h" + +gpg_error_t ffi_init (scheme *sc, const char *argv0, const char *scriptname, + int argc, const char **argv); + +#endif /* GPGSCM_FFI_H */ diff --git a/gpgscm/ffi.scm b/gpgscm/ffi.scm new file mode 100644 index 0000000..051c2c2 --- /dev/null +++ b/gpgscm/ffi.scm @@ -0,0 +1,51 @@ +;; FFI interface for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Foreign function wrapper. Expects F to return a list with the +;; first element being the `error_t' value returned by the foreign +;; function. The error is thrown, or the cdr of the result is +;; returned. +(define (ffi-apply name f args) + (let ((result (apply f args))) + (cond + ((string? result) + (ffi-fail name args result)) + ((not (= (car result) 0)) + (ffi-fail name args (strerror (car result)))) + ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) + ((= (car result) 0) '()) + (else + (throw (list "Result violates FFI calling convention: " result)))))) + +(define (ffi-fail name args message) + (let ((args' (open-output-string))) + (write (cons (string->symbol name) args) args') + (throw (get-output-string args') message))) + +;; Pseudo-definitions for foreign functions. Evaluates to no code, +;; but serves as documentation. +(macro (ffi-define form)) + +;; Runtime support. + +;; Low-level mechanism to terminate the process. +(ffi-define (_exit status)) + +;; Get the current time in seconds since the epoch. +(ffi-define (get-time)) diff --git a/gpgscm/gnupg.scm b/gpgscm/gnupg.scm new file mode 100644 index 0000000..5fcf9fd --- /dev/null +++ b/gpgscm/gnupg.scm @@ -0,0 +1,44 @@ +;; Common definitions for executing gpg and related tools. +;; +;; Copyright (C) 2016, 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Evaluate a sequence of expressions with the given home directory. +(define-macro (with-home-directory gnupghome . expressions) + (let ((original-home-directory (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME"))) + (dynamic-wind + (lambda () (setenv "GNUPGHOME" ,gnupghome #t)) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))) + +;; Evaluate a sequence of expressions with an ephemeral home +;; directory. +(define-macro (with-ephemeral-home-directory setup-fn . expressions) + (let ((original-home-directory (gensym)) + (ephemeral-home-directory (gensym)) + (setup (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME")) + (,ephemeral-home-directory (mkdtemp)) + (,setup (delay (,setup-fn)))) + (finally (unlink-recursively ,ephemeral-home-directory) + (dynamic-wind + (lambda () + (setenv "GNUPGHOME" ,ephemeral-home-directory #t) + (with-working-directory ,ephemeral-home-directory (force ,setup))) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))) diff --git a/gpgscm/init.scm b/gpgscm/init.scm new file mode 100644 index 0000000..66bec0f --- /dev/null +++ b/gpgscm/init.scm @@ -0,0 +1,823 @@ +; 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-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-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))))) + +;; Print the given history. +(define (vm-history-print history) + (let loop ((n 0) (skip 0) (frames history)) + (cond + ((null? frames) + #t) + ((> skip 0) + (loop 0 (- skip 1) (cdr frames))) + (else + (let ((f (car frames))) + (display n) + (display ": ") + (let ((tag (get-tag f))) + (when (and (pair? tag) (string? (car tag)) (number? (cdr tag))) + (display (basename (car tag))) + (display ":") + (display (+ 1 (cdr tag))) + (display ": "))) + (write f)) + (newline) + (loop (+ n 1) skip (cdr frames)))))) + +;;;; 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. Within the recovery expression +; the thrown exception is bound to *error*. Errors can be rethrown +; using (rethrow *error*). +; +; Finalization can be expressed using "finally": +; +; (finally (finalize-something called-purely-for side-effects) +; (whether-or-not something goes-wrong) +; (with-these calls)) +; +; The final expression is executed purely for its side-effects, +; both when the function exits successfully, and when an exception +; is thrown. +; +; 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*)) + +;; This throws an exception. +(define (throw message . args) + (throw' message args (cdr (*vm-history*)))) + +;; This is used by the vm to throw exceptions. +(define (throw' message args history) + (cond + ((and args (list? args) (= 2 (length args)) + (equal? *interpreter-exit* (car args))) + (*run-atexit-handlers*) + (quit (cadr args))) + ((more-handlers?) + ((pop-handler) message args history)) + (else + (display message) + (when (and args (not (null? args))) + (display ": ") + (if (and (pair? args) (string? (car args))) + (begin (display (car args)) + (unless (null? (cdr args)) + (newline) + (write (cdr args)))) + (write args))) + (newline) + (vm-history-print history) + (quit 1)))) + +;; Convenience function to rethrow the error. +(define (rethrow e) + (apply throw' e)) + +(macro (catch form) + (let ((label (gensym))) + `(call/cc (lambda (**exit**) + (push-handler (lambda *error* (**exit** ,(cadr form)))) + (let ((,label (begin ,@(cddr form)))) + (pop-handler) + ,label))))) + +(define-macro (finally final-expression . expressions) + (let ((result (gensym))) + `(let ((,result (catch (begin ,final-expression (rethrow *error*)) + ,@expressions))) + ,final-expression + ,result))) + +;; Make the vm use throw'. +(define *error-hook* throw') + + + +;; High-level mechanism to terminate the process is to throw an error +;; of the form (*interpreter-exit* status). This gives automatic +;; resource management a chance to clean up. +(define *interpreter-exit* (gensym)) + +;; Terminate the process returning STATUS to the parent. +(define (exit status) + (throw "interpreter exit" *interpreter-exit* status)) + +;; A list of functions run at interpreter shutdown. +(define *atexit-handlers* (list)) + +;; Execute all these functions. +(define (*run-atexit-handlers*) + (unless (null? *atexit-handlers*) + (let ((proc (car *atexit-handlers*))) + ;; Drop proc from the list so that it will not get + ;; executed again even if it raises an exception. + (set! *atexit-handlers* (cdr *atexit-handlers*)) + (proc) + (*run-atexit-handlers*)))) + +;; Register a function to be run at interpreter shutdown. +(define (atexit proc) + (set! *atexit-handlers* (cons proc *atexit-handlers*))) + + + +;;;;; 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) + +(macro (package form) + `(apply (lambda () + ,@(cdr form) + (current-environment)))) + +(define-macro (export name . expressions) + `(define ,name + (begin + ,@expressions))) + +;;;;; 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) diff --git a/gpgscm/lib.scm b/gpgscm/lib.scm new file mode 100644 index 0000000..258f692 --- /dev/null +++ b/gpgscm/lib.scm @@ -0,0 +1,307 @@ +;; Additional library functions for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(macro (assert form) + (let ((tag (get-tag form))) + `(if (not ,(cadr form)) + (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag))) + `(string-append ,(car tag) ":" + ,(number->string (+ 1 (cdr tag))) + ": Assertion failed: ") + "Assertion failed: ") + (quote ,(cadr form)))))) +(assert #t) +(assert (not #f)) + +;; Trace displays and returns the given value. A debugging aid. +(define (trace x) + (display x) + (newline) + x) + +;; Stringification. +(define (stringify expression) + (let ((p (open-output-string))) + (write expression p) + (get-output-string p))) + +(define (filter pred lst) + (cond ((null? lst) '()) + ((pred (car lst)) + (cons (car lst) (filter pred (cdr lst)))) + (else (filter pred (cdr lst))))) + +(define (any p l) + (cond ((null? l) #f) + ((p (car l)) #t) + (else (any p (cdr l))))) + +(define (all p l) + (cond ((null? l) #t) + ((not (p (car l))) #f) + (else (all p (cdr l))))) + +;; Return the first element of a list. +(define first car) + +;; Return the last element of a list. +(define (last lst) + (if (null? (cdr lst)) + (car lst) + (last (cdr lst)))) + +;; Compute the powerset of a list. +(define (powerset set) + (if (null? set) + '(()) + (let ((rst (powerset (cdr set)))) + (append (map (lambda (x) (cons (car set) x)) + rst) + rst)))) + +;; Is PREFIX a prefix of S? +(define (string-prefix? s prefix) + (and (>= (string-length s) (string-length prefix)) + (string=? prefix (substring s 0 (string-length prefix))))) +(assert (string-prefix? "Scheme" "Sch")) + +;; Is SUFFIX a suffix of S? +(define (string-suffix? s suffix) + (and (>= (string-length s) (string-length suffix)) + (string=? suffix (substring s (- (string-length s) + (string-length suffix)) + (string-length s))))) +(assert (string-suffix? "Scheme" "eme")) + +;; Locate the first occurrence of needle in haystack starting at offset. +(ffi-define (string-index haystack needle [offset])) +(assert (= 2 (string-index "Hallo" #\l))) +(assert (= 3 (string-index "Hallo" #\l 3))) +(assert (equal? #f (string-index "Hallo" #\.))) + +;; Locate the last occurrence of needle in haystack starting at offset. +(ffi-define (string-rindex haystack needle [offset])) +(assert (= 3 (string-rindex "Hallo" #\l))) +(assert (equal? #f (string-rindex "Hallo" #\a 2))) +(assert (equal? #f (string-rindex "Hallo" #\.))) + +;; Split HAYSTACK at each character that makes PREDICATE true at most +;; N times. +(define (string-split-pln haystack predicate lookahead n) + (let ((length (string-length haystack))) + (define (split acc offset n) + (if (>= offset length) + (reverse! acc) + (let ((i (lookahead haystack offset))) + (if (or (eq? i #f) (= 0 n)) + (reverse! (cons (substring haystack offset length) acc)) + (split (cons (substring haystack offset i) acc) + (+ i 1) (- n 1)))))) + (split '() 0 n))) + +(define (string-indexp haystack offset predicate) + (cond + ((= (string-length haystack) offset) + #f) + ((predicate (string-ref haystack offset)) + offset) + (else + (string-indexp haystack (+ 1 offset) predicate)))) + +;; Split HAYSTACK at each character that makes PREDICATE true at most +;; N times. +(define (string-splitp haystack predicate n) + (string-split-pln haystack predicate + (lambda (haystack offset) + (string-indexp haystack offset predicate)) + n)) +(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1))) +(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1))) +(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1))) + +;; Split haystack at delimiter at most n times. +(define (string-splitn haystack delimiter n) + (string-split-pln haystack + (lambda (c) (char=? c delimiter)) + (lambda (haystack offset) + (string-index haystack delimiter offset)) + n)) +(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1)))) + +;; Split haystack at delimiter. +(define (string-split haystack delimiter) + (string-splitn haystack delimiter -1)) +(assert (= 3 (length (string-split "foo:bar:baz" #\:)))) +(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:)))) +(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:)))) +(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:)))) + +;; Split haystack at newlines. +(define (string-split-newlines haystack) + (if *win32* + (map (lambda (line) (if (string-suffix? line "\r") + (substring line 0 (- (string-length line) 1)) + line)) + (string-split haystack #\newline)) + (string-split haystack #\newline))) + +;; Trim the prefix of S containing only characters that make PREDICATE +;; true. +(define (string-ltrim predicate s) + (if (string=? s "") + "" + (let loop ((s' (string->list s))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string s'))))) +(assert (string=? "" (string-ltrim char-whitespace? ""))) +(assert (string=? "foo" (string-ltrim char-whitespace? " foo"))) + +;; Trim the suffix of S containing only characters that make PREDICATE +;; true. +(define (string-rtrim predicate s) + (if (string=? s "") + "" + (let loop ((s' (reverse! (string->list s)))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string (reverse! s')))))) +(assert (string=? "" (string-rtrim char-whitespace? ""))) +(assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) + +;; Trim both the prefix and suffix of S containing only characters +;; that make PREDICATE true. +(define (string-trim predicate s) + (string-ltrim predicate (string-rtrim predicate s))) +(assert (string=? "" (string-trim char-whitespace? ""))) +(assert (string=? "foo" (string-trim char-whitespace? " foo "))) + +;; Check if needle is contained in haystack. +(ffi-define (string-contains? haystack needle)) +(assert (string-contains? "Hallo" "llo")) +(assert (not (string-contains? "Hallo" "olla"))) + +;; Translate characters. +(define (string-translate s from to) + (list->string (map (lambda (c) + (let ((i (string-index from c))) + (if i (string-ref to i) c))) (string->list s)))) +(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar")) + +;; Read a word from port P. +(define (read-word . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char-alphabetic? c) + (apply read-char p) + (cons c (f))) + (else + (apply read-char p) + '())))))) + +(define (list->string-reversed lst) + (let* ((len (length lst)) + (str (make-string len))) + (let loop ((i (- len 1)) + (l lst)) + (if (< i 0) + (begin + (assert (null? l)) + str) + (begin + (string-set! str i (car l)) + (loop (- i 1) (cdr l))))))) + +;; Read a line from port P. +(define (read-line . p) + (let loop ((acc '())) + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) + (if (null? acc) + c ;; #eof + (list->string-reversed acc))) + ((char=? c #\newline) + (apply read-char p) + (list->string-reversed acc)) + (else + (apply read-char p) + (loop (cons c acc))))))) + +;; Read everything from port P. +(define (read-all . p) + (let loop ((acc (open-output-string))) + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) (get-output-string acc)) + (else + (write-char (apply read-char p) acc) + (loop acc)))))) + +;; +;; Windows support. +;; + +;; Like call-with-input-file but opens the file in 'binary' mode. +(define (call-with-binary-input-file filename proc) + (letfd ((fd (open filename (logior O_RDONLY O_BINARY)))) + (proc (fdopen fd "rb")))) + +;; Like call-with-output-file but opens the file in 'binary' mode. +(define (call-with-binary-output-file filename proc) + (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (proc (fdopen fd "wb")))) + +;; +;; Libc functions. +;; + +;; Change the read/write offset. +(ffi-define (seek fd offset whence)) + +;; Constants for WHENCE. +(ffi-define SEEK_SET) +(ffi-define SEEK_CUR) +(ffi-define SEEK_END) + +;; Get our process id. +(ffi-define (getpid)) + +;; Copy data from file descriptor SOURCE to every file descriptor in +;; SINKS. +(ffi-define (splice source . sinks)) + +;; +;; Random numbers. +;; + +;; Seed the random number generator. +(ffi-define (srandom seed)) + +;; Get a pseudo-random number between 0 (inclusive) and SCALE +;; (exclusive). +(ffi-define (random scale)) + +;; Create a string of the given SIZE containing pseudo-random data. +(ffi-define (make-random-string size)) diff --git a/gpgscm/main.c b/gpgscm/main.c new file mode 100644 index 0000000..5540ac3 --- /dev/null +++ b/gpgscm/main.c @@ -0,0 +1,359 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#if HAVE_MMAP +#include +#endif + +#include "private.h" +#include "scheme.h" +#include "scheme-private.h" +#include "ffi.h" +#include "../common/i18n.h" +#include "../../common/argparse.h" +#include "../../common/init.h" +#include "../../common/logging.h" +#include "../../common/strlist.h" +#include "../../common/sysutils.h" +#include "../../common/util.h" + +/* The TinyScheme banner. Unfortunately, it isn't in the header + file. */ +#define ts_banner "TinyScheme 1.41" + +int verbose; + + + +/* Constants to identify the commands and options. */ +enum cmd_and_opt_values + { + aNull = 0, + oVerbose = 'v', + }; + +/* The list of commands and options. */ +static ARGPARSE_OPTS opts[] = + { + ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")), + ARGPARSE_end (), + }; + +char *scmpath = ""; +size_t scmpath_len = 0; + +/* Command line parsing. */ +static void +parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) +{ + int no_more_options = 0; + + while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts)) + { + switch (pargs->r_opt) + { + case oVerbose: + verbose++; + break; + + default: + pargs->err = 2; + break; + } + } +} + +/* Print usage information and provide strings for help. */ +static const char * +my_strusage( int level ) +{ + const char *p; + + switch (level) + { + case 11: p = "gpgscm (@GNUPG@)"; + break; + case 13: p = VERSION; break; + case 17: p = PRINTABLE_OS_NAME; break; + case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break; + + case 1: + case 40: + p = _("Usage: gpgscm [options] [file] (-h for help)"); + break; + case 41: + p = _("Syntax: gpgscm [options] [file]\n" + "Execute the given Scheme program, or spawn interactive shell.\n"); + break; + + default: p = NULL; break; + } + return p; +} + + + +static int +path_absolute_p (const char *p) +{ +#if _WIN32 + return ((strlen (p) > 2 && p[1] == ':' && (p[2] == '\\' || p[2] == '/')) + || p[0] == '\\' || p[0] == '/'); +#else + return p[0] == '/'; +#endif +} + + +/* Load the Scheme program from FILE_NAME. If FILE_NAME is not an + absolute path, and LOOKUP_IN_PATH is given, then it is qualified + with the values in scmpath until the file is found. */ +static gpg_error_t +load (scheme *sc, char *file_name, + int lookup_in_cwd, int lookup_in_path) +{ + gpg_error_t err = 0; + size_t n; + const char *directory; + char *qualified_name = file_name; + int use_path; + FILE *h = NULL; + + use_path = + lookup_in_path && ! (path_absolute_p (file_name) || scmpath_len == 0); + + if (path_absolute_p (file_name) || lookup_in_cwd || scmpath_len == 0) + { + h = fopen (file_name, "r"); + if (! h) + err = gpg_error_from_syserror (); + } + + if (h == NULL && use_path) + for (directory = scmpath, n = scmpath_len; n; + directory += strlen (directory) + 1, n--) + { + if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0) + return gpg_error_from_syserror (); + + h = fopen (qualified_name, "r"); + if (h) + { + err = 0; + break; + } + + if (n > 1) + { + free (qualified_name); + continue; /* Try again! */ + } + + err = gpg_error_from_syserror (); + } + + if (h == NULL) + { + /* Failed and no more elements in scmpath to try. */ + fprintf (stderr, "Could not read %s: %s.\n", + qualified_name, gpg_strerror (err)); + if (lookup_in_path) + fprintf (stderr, + "Consider using GPGSCM_PATH to specify the location " + "of the Scheme library.\n"); + goto leave; + } + if (verbose > 2) + fprintf (stderr, "Loading %s...\n", qualified_name); + +#if HAVE_MMAP + /* Always try to mmap the file. This allows the pages to be shared + * between processes. If anything fails, we fall back to using + * buffered streams. */ + if (1) + { + struct stat st; + void *map; + size_t len; + int fd = fileno (h); + + if (fd < 0) + goto fallback; + + if (fstat (fd, &st)) + goto fallback; + + len = (size_t) st.st_size; + if ((off_t) len != st.st_size) + goto fallback; /* Truncated. */ + + map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0); + if (map == MAP_FAILED) + goto fallback; + + scheme_load_memory (sc, map, len, qualified_name); + munmap (map, len); + } + else + fallback: +#endif + scheme_load_named_file (sc, h, qualified_name); + fclose (h); + + if (sc->retcode && sc->nesting) + { + fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); + err = gpg_error (GPG_ERR_GENERAL); + } + + leave: + if (file_name != qualified_name) + free (qualified_name); + return err; +} + + + +int +main (int argc, char **argv) +{ + int retcode; + gpg_error_t err; + char *argv0; + ARGPARSE_ARGS pargs; + scheme *sc; + char *p; +#if _WIN32 + char pathsep = ';'; +#else + char pathsep = ':'; +#endif + char *script = NULL; + + /* Save argv[0] so that we can re-exec. */ + argv0 = argv[0]; + + /* Parse path. */ + if (getenv ("GPGSCM_PATH")) + scmpath = getenv ("GPGSCM_PATH"); + + p = scmpath = strdup (scmpath); + if (p == NULL) + return 2; + + if (*p) + scmpath_len++; + for (; *p; p++) + if (*p == pathsep) + *p = 0, scmpath_len++; + + set_strusage (my_strusage); + log_set_prefix ("gpgscm", GPGRT_LOG_WITH_PREFIX); + + /* Make sure that our subsystems are ready. */ + i18n_init (); + init_common_subsystems (&argc, &argv); + + if (!gcry_check_version (NEED_LIBGCRYPT_VERSION)) + { + fputs ("libgcrypt version mismatch\n", stderr); + exit (2); + } + + /* Parse the command line. */ + pargs.argc = &argc; + pargs.argv = &argv; + pargs.flags = 0; + parse_arguments (&pargs, opts); + + if (log_get_errorcount (0)) + exit (2); + + sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free); + if (! sc) { + fprintf (stderr, "Could not initialize TinyScheme!\n"); + return 2; + } + scheme_set_input_port_file (sc, stdin); + scheme_set_output_port_file (sc, stderr); + + if (argc) + { + script = argv[0]; + argc--, argv++; + } + + err = load (sc, "init.scm", 0, 1); + if (! err) + err = load (sc, "ffi.scm", 0, 1); + if (! err) + err = ffi_init (sc, argv0, script ? script : "interactive", + argc, (const char **) argv); + if (! err) + err = load (sc, "lib.scm", 0, 1); + if (! err) + err = load (sc, "repl.scm", 0, 1); + if (! err) + err = load (sc, "xml.scm", 0, 1); + if (! err) + err = load (sc, "tests.scm", 0, 1); + if (! err) + err = load (sc, "gnupg.scm", 0, 1); + if (err) + { + fprintf (stderr, "Error initializing gpgscm: %s.\n", + gpg_strerror (err)); + exit (2); + } + + if (script == NULL) + { + /* Interactive shell. */ + fprintf (stderr, "gpgscm/"ts_banner".\n"); + scheme_load_string (sc, "(interactive-repl)"); + } + else + { + err = load (sc, script, 1, 1); + if (err) + log_fatal ("%s: %s", script, gpg_strerror (err)); + } + + retcode = sc->retcode; + scheme_load_string (sc, "(*run-atexit-handlers*)"); + scheme_deinit (sc); + xfree (sc); + return retcode; +} diff --git a/gpgscm/makefile.scm b/gpgscm/makefile.scm new file mode 100644 index 0000000..32fae3a --- /dev/null +++ b/gpgscm/makefile.scm @@ -0,0 +1,76 @@ +;; Support for parsing Makefiles +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(define (parse-makefile port key) + (define (is-continuation? tokens) + (string=? (last tokens) "\\")) + (define (valid-token? s) + (< 0 (string-length s))) + (define (drop-continuations tokens) + (let loop ((acc '()) (tks tokens)) + (if (null? tks) + (reverse acc) + (loop (if (string=? "\\" (car tks)) + acc + (cons (car tks) acc)) (cdr tks))))) + (let next ((acc '()) (found #f)) + (let ((line (read-line port))) + (if (eof-object? line) + acc + (let ((tokens (filter valid-token? + (string-splitp (string-trim char-whitespace? + line) + char-whitespace? -1)))) + (cond + ((or (null? tokens) + (string-prefix? (car tokens) "#") + (and (not found) (not (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))))) + (next acc found)) + ((not found) + (assert (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))) + (if (is-continuation? tokens) + (next (drop-continuations (cddr tokens)) #t) + (drop-continuations (cddr tokens)))) + (else + (assert found) + (if (is-continuation? tokens) + (next (append acc (drop-continuations tokens)) found) + (append acc (drop-continuations tokens)))))))))) + +(define (parse-makefile-expand filename expand key) + (define (variable? v) + (and (string-prefix? v "$(") (string-suffix? v ")"))) + + (let expand-all ((values (parse-makefile (open-input-file filename) key))) + (if (any variable? values) + (expand-all + (let expand-one ((acc '()) (v values)) + (cond + ((null? v) + acc) + ((variable? (car v)) + (let ((makefile (open-input-file filename)) + (key (substring (car v) 2 (- (string-length (car v)) 1)))) + (expand-one (append acc (expand filename makefile key)) + (cdr v)))) + (else + (expand-one (append acc (list (car v))) (cdr v)))))) + values))) diff --git a/gpgscm/opdefines.h b/gpgscm/opdefines.h new file mode 100644 index 0000000..61f7971 --- /dev/null +++ b/gpgscm/opdefines.h @@ -0,0 +1,205 @@ +_OP_DEF("load", 1, 1, TST_STRING, OP_LOAD ) +_OP_DEF(0, 0, 0, 0, OP_T0LVL ) +_OP_DEF(0, 0, 0, 0, OP_T1LVL ) +_OP_DEF(0, 0, 0, 0, OP_READ_INTERNAL ) +_OP_DEF("gensym", 0, 0, 0, OP_GENSYM ) +_OP_DEF(0, 0, 0, 0, OP_VALUEPRINT ) +_OP_DEF(0, 0, 0, 0, OP_EVAL ) +#if USE_TRACING +_OP_DEF(0, 0, 0, 0, OP_REAL_EVAL ) +#endif +_OP_DEF(0, 0, 0, 0, OP_E0ARGS ) +_OP_DEF(0, 0, 0, 0, OP_E1ARGS ) +#if USE_HISTORY +_OP_DEF(0, 0, 0, 0, OP_CALLSTACK_POP ) +#endif +_OP_DEF(0, 0, 0, 0, OP_APPLY_CODE ) +_OP_DEF(0, 0, 0, 0, OP_APPLY ) +#if USE_TRACING +_OP_DEF(0, 0, 0, 0, OP_REAL_APPLY ) +_OP_DEF("tracing", 1, 1, TST_NATURAL, OP_TRACING ) +#endif +_OP_DEF(0, 0, 0, 0, OP_DOMACRO ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA1 ) +_OP_DEF("make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) +_OP_DEF(0, 0, 0, 0, OP_QUOTE ) +_OP_DEF(0, 0, 0, 0, OP_DEF0 ) +_OP_DEF(0, 0, 0, 0, OP_DEF1 ) +_OP_DEF("defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) +_OP_DEF(0, 0, 0, 0, OP_BEGIN ) +_OP_DEF(0, 0, 0, 0, OP_IF0 ) +_OP_DEF(0, 0, 0, 0, OP_IF1 ) +_OP_DEF(0, 0, 0, 0, OP_SET0 ) +_OP_DEF(0, 0, 0, 0, OP_SET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET0 ) +_OP_DEF(0, 0, 0, 0, OP_LET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET2 ) +_OP_DEF(0, 0, 0, 0, OP_LET0AST ) +_OP_DEF(0, 0, 0, 0, OP_LET1AST ) +_OP_DEF(0, 0, 0, 0, OP_LET2AST ) +_OP_DEF(0, 0, 0, 0, OP_LET0REC ) +_OP_DEF(0, 0, 0, 0, OP_LET1REC ) +_OP_DEF(0, 0, 0, 0, OP_LET2REC ) +_OP_DEF(0, 0, 0, 0, OP_COND0 ) +_OP_DEF(0, 0, 0, 0, OP_COND1 ) +_OP_DEF(0, 0, 0, 0, OP_DELAY ) +_OP_DEF(0, 0, 0, 0, OP_AND0 ) +_OP_DEF(0, 0, 0, 0, OP_AND1 ) +_OP_DEF(0, 0, 0, 0, OP_OR0 ) +_OP_DEF(0, 0, 0, 0, OP_OR1 ) +_OP_DEF(0, 0, 0, 0, OP_C0STREAM ) +_OP_DEF(0, 0, 0, 0, OP_C1STREAM ) +_OP_DEF(0, 0, 0, 0, OP_MACRO0 ) +_OP_DEF(0, 0, 0, 0, OP_MACRO1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE0 ) +_OP_DEF(0, 0, 0, 0, OP_CASE1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE2 ) +_OP_DEF("eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) +_OP_DEF("apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) +_OP_DEF("call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) +#if USE_MATH +_OP_DEF("inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) +_OP_DEF("exp", 1, 1, TST_NUMBER, OP_EXP ) +_OP_DEF("log", 1, 1, TST_NUMBER, OP_LOG ) +_OP_DEF("sin", 1, 1, TST_NUMBER, OP_SIN ) +_OP_DEF("cos", 1, 1, TST_NUMBER, OP_COS ) +_OP_DEF("tan", 1, 1, TST_NUMBER, OP_TAN ) +_OP_DEF("asin", 1, 1, TST_NUMBER, OP_ASIN ) +_OP_DEF("acos", 1, 1, TST_NUMBER, OP_ACOS ) +_OP_DEF("atan", 1, 2, TST_NUMBER, OP_ATAN ) +_OP_DEF("sqrt", 1, 1, TST_NUMBER, OP_SQRT ) +_OP_DEF("expt", 2, 2, TST_NUMBER, OP_EXPT ) +_OP_DEF("floor", 1, 1, TST_NUMBER, OP_FLOOR ) +_OP_DEF("ceiling", 1, 1, TST_NUMBER, OP_CEILING ) +_OP_DEF("truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) +_OP_DEF("round", 1, 1, TST_NUMBER, OP_ROUND ) +#endif +_OP_DEF("+", 0, INF_ARG, TST_NUMBER, OP_ADD ) +_OP_DEF("-", 1, INF_ARG, TST_NUMBER, OP_SUB ) +_OP_DEF("*", 0, INF_ARG, TST_NUMBER, OP_MUL ) +_OP_DEF("/", 1, INF_ARG, TST_NUMBER, OP_DIV ) +_OP_DEF("quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) +_OP_DEF("remainder", 2, 2, TST_INTEGER, OP_REM ) +_OP_DEF("modulo", 2, 2, TST_INTEGER, OP_MOD ) +_OP_DEF("car", 1, 1, TST_PAIR, OP_CAR ) +_OP_DEF("cdr", 1, 1, TST_PAIR, OP_CDR ) +_OP_DEF("cons", 2, 2, TST_NONE, OP_CONS ) +_OP_DEF("set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) +_OP_DEF("set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) +_OP_DEF("char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) +_OP_DEF("integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) +_OP_DEF("char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) +_OP_DEF("char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) +_OP_DEF("symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) +_OP_DEF("atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) +_OP_DEF("string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) +_OP_DEF("string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) +_OP_DEF("make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) +_OP_DEF("string-length", 1, 1, TST_STRING, OP_STRLEN ) +_OP_DEF("string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) +_OP_DEF("string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) +_OP_DEF("string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) +_OP_DEF("substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) +_OP_DEF("vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) +_OP_DEF("make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) +_OP_DEF("vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) +_OP_DEF("vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) +_OP_DEF("vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) +_OP_DEF("not", 1, 1, TST_NONE, OP_NOT ) +_OP_DEF("boolean?", 1, 1, TST_NONE, OP_BOOLP ) +_OP_DEF("eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) +_OP_DEF("null?", 1, 1, TST_NONE, OP_NULLP ) +_OP_DEF("=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) +_OP_DEF("<", 2, INF_ARG, TST_NUMBER, OP_LESS ) +_OP_DEF(">", 2, INF_ARG, TST_NUMBER, OP_GRE ) +_OP_DEF("<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) +_OP_DEF(">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) +_OP_DEF("symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) +_OP_DEF("number?", 1, 1, TST_ANY, OP_NUMBERP ) +_OP_DEF("string?", 1, 1, TST_ANY, OP_STRINGP ) +_OP_DEF("integer?", 1, 1, TST_ANY, OP_INTEGERP ) +_OP_DEF("real?", 1, 1, TST_ANY, OP_REALP ) +_OP_DEF("char?", 1, 1, TST_ANY, OP_CHARP ) +#if USE_CHAR_CLASSIFIERS +_OP_DEF("char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) +_OP_DEF("char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) +_OP_DEF("char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) +_OP_DEF("char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) +_OP_DEF("char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) +#endif +_OP_DEF("port?", 1, 1, TST_ANY, OP_PORTP ) +_OP_DEF("input-port?", 1, 1, TST_ANY, OP_INPORTP ) +_OP_DEF("output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) +_OP_DEF("procedure?", 1, 1, TST_ANY, OP_PROCP ) +_OP_DEF("pair?", 1, 1, TST_ANY, OP_PAIRP ) +_OP_DEF("list?", 1, 1, TST_ANY, OP_LISTP ) +_OP_DEF("environment?", 1, 1, TST_ANY, OP_ENVP ) +_OP_DEF("vector?", 1, 1, TST_ANY, OP_VECTORP ) +_OP_DEF("eq?", 2, 2, TST_ANY, OP_EQ ) +_OP_DEF("eqv?", 2, 2, TST_ANY, OP_EQV ) +_OP_DEF("force", 1, 1, TST_ANY, OP_FORCE ) +_OP_DEF(0, 0, 0, 0, OP_SAVE_FORCED ) +_OP_DEF("write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) +_OP_DEF("write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) +_OP_DEF("display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) +_OP_DEF("newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) +_OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 ) +_OP_DEF(0, 0, 0, 0, OP_ERR1 ) +_OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE ) +_OP_DEF("reverse!", 1, 1, TST_LIST, OP_REVERSE_IN_PLACE ) +_OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) +_OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND ) +#if USE_PLIST +_OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) +_OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) +#endif +_OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE ) +_OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) +_OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) +_OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT ) +_OP_DEF("gc", 0, 0, 0, OP_GC ) +_OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) +_OP_DEF("new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) +_OP_DEF("oblist", 0, 0, 0, OP_OBLIST ) +_OP_DEF("current-input-port", 0, 0, 0, OP_CURR_INPORT ) +_OP_DEF("current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) +_OP_DEF("open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) +_OP_DEF("open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) +_OP_DEF("open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) +#if USE_STRING_PORTS +_OP_DEF("open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) +_OP_DEF("open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) +_OP_DEF("open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) +_OP_DEF("get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) +#endif +_OP_DEF("close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) +_OP_DEF("close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) +_OP_DEF("interaction-environment", 0, 0, 0, OP_INT_ENV ) +_OP_DEF("current-environment", 0, 0, 0, OP_CURR_ENV ) +_OP_DEF("read", 0, 1, TST_INPORT, OP_READ ) +_OP_DEF("read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) +_OP_DEF("peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) +_OP_DEF("char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) +_OP_DEF("set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) +_OP_DEF("set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) +_OP_DEF(0, 0, 0, 0, OP_RDSEXPR ) +_OP_DEF(0, 0, 0, 0, OP_RDLIST ) +_OP_DEF(0, 0, 0, 0, OP_RDDOT ) +_OP_DEF(0, 0, 0, 0, OP_RDQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTEVEC ) +_OP_DEF(0, 0, 0, 0, OP_RDUNQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDUQTSP ) +_OP_DEF(0, 0, 0, 0, OP_RDVEC ) +_OP_DEF(0, 0, 0, 0, OP_P0LIST ) +_OP_DEF(0, 0, 0, 0, OP_P1LIST ) +_OP_DEF(0, 0, 0, 0, OP_PVECFROM ) +_OP_DEF("length", 1, 1, TST_LIST, OP_LIST_LENGTH ) +_OP_DEF("assq", 2, 2, TST_NONE, OP_ASSQ ) +_OP_DEF("get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) +_OP_DEF("closure?", 1, 1, TST_NONE, OP_CLOSUREP ) +_OP_DEF("macro?", 1, 1, TST_NONE, OP_MACROP ) +_OP_DEF("*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) + +#undef _OP_DEF diff --git a/gpgscm/private.h b/gpgscm/private.h new file mode 100644 index 0000000..6e330e0 --- /dev/null +++ b/gpgscm/private.h @@ -0,0 +1,26 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef __GPGSCM_PRIVATE_H__ +#define __GPGSCM_PRIVATE_H__ + +extern int verbose; + +#endif /* __GPGSCM_PRIVATE_H__ */ diff --git a/gpgscm/repl.scm b/gpgscm/repl.scm new file mode 100644 index 0000000..833ec0d --- /dev/null +++ b/gpgscm/repl.scm @@ -0,0 +1,69 @@ +;; A read-evaluate-print-loop for gpgscm. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Interactive repl using 'prompt' function. P must be a function +;; that given the current entered prefix returns the prompt to +;; display. +(define (repl p environment) + (call/cc + (lambda (exit) + (let loop ((prefix "")) + (let ((line (prompt (p prefix)))) + (if (and (not (eof-object? line)) (= 0 (string-length line))) + (exit (loop prefix))) + (if (not (eof-object? line)) + (let* ((next (string-append prefix line)) + (c (catch (begin (echo "Parse error:" *error*) + (loop prefix)) + (read (open-input-string next))))) + (if (not (eof-object? c)) + (begin + (catch (begin + (display (car *error*)) + (when (and (cadr *error*) + (not (null? (cadr *error*)))) + (display ": ") + (write (cadr *error*))) + (newline) + (vm-history-print (caddr *error*))) + (echo " ===>" (eval c environment))) + (exit (loop "")))) + (exit (loop next))))))))) + +(define (prompt-append-prefix prompt prefix) + (string-append prompt (if (> (string-length prefix) 0) + (string-append prefix "...") + "> "))) + +;; Default repl run by main.c. +(define (interactive-repl . environment) + (repl (lambda (p) (prompt-append-prefix "gpgscm " p)) + (if (null? environment) (interaction-environment) (car environment)))) + +;; Ask a yes/no question. +(define (prompt-yes-no? question default) + (let ((answer (prompt (string-append question "? [" + (if default "Y/n" "y/N") "] ")))) + (cond + ((= 0 (string-length answer)) + default) + ((or (equal? "y" answer) (equal? "Y" answer)) + #t) + (else + #f)))) diff --git a/gpgscm/scheme-config.h b/gpgscm/scheme-config.h new file mode 100644 index 0000000..15ca969 --- /dev/null +++ b/gpgscm/scheme-config.h @@ -0,0 +1,32 @@ +/* TinyScheme configuration. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#define STANDALONE 0 +#define USE_MATH 0 +#define USE_CHAR_CLASSIFIERS 1 +#define USE_ASCII_NAMES 1 +#define USE_STRING_PORTS 1 +#define USE_ERROR_HOOK 1 +#define USE_TRACING 1 +#define USE_COLON_HOOK 1 +#define USE_DL 0 +#define USE_PLIST 0 +#define USE_INTERFACE 1 +#define SHOW_ERROR_LINE 1 diff --git a/gpgscm/scheme-private.h b/gpgscm/scheme-private.h new file mode 100644 index 0000000..7f92bda --- /dev/null +++ b/gpgscm/scheme-private.h @@ -0,0 +1,274 @@ +/* scheme-private.h */ + +#ifndef _SCHEME_PRIVATE_H +#define _SCHEME_PRIVATE_H + +#include +#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; + } stdio; + struct { + char *start; + char *past_the_end; + char *curr; + } string; + } rep; +#if SHOW_ERROR_LINE + pointer curr_line; + pointer filename; +#endif +} port; + +/* cell structure */ +struct cell { + uintptr_t _flag; + union { + num _number; + struct { + char *_svalue; + int _length; + } _string; + port *_port; + foreign_func _ff; + struct { + struct cell *_car; + struct cell *_cdr; + } _cons; + struct { + size_t _length; + pointer _elements[0]; + } _vector; + struct { + char *_data; + const foreign_object_vtable *_vtable; + } _foreign_object; + } _object; +}; + +#if USE_HISTORY +/* The history is a two-dimensional ring buffer. A donut-shaped data + * structure. This data structure is inspired by MIT/GNU Scheme. */ +struct history { + /* Number of calls to store. Must be a power of two. */ + size_t N; + + /* Number of tail-calls to store in each call frame. Must be a + * power of two. */ + size_t M; + + /* Masks for fast index calculations. */ + size_t mask_N; + size_t mask_M; + + /* A vector of size N containing calls. */ + pointer callstack; + + /* A vector of size N containing vectors of size M containing tail + * calls. */ + pointer tailstacks; + + /* Our current position. */ + size_t n; + size_t *m; +}; +#endif + +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 + +/* If less than # of cells are recovered in a garbage collector run, + * allocate a new cell segment to avoid fruitless collection cycles in + * the near future. */ +#ifndef CELL_MINRECOVER +#define CELL_MINRECOVER (CELL_SEGSIZE >> 2) +#endif +struct cell_segment *cell_segments; + +/* 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 */ +pointer frame_freelist; + +#if USE_HISTORY +struct history history; /* we keep track of the call history for + * error messages */ +#endif + +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* */ +#if USE_COMPILE_HOOK +pointer COMPILE_HOOK; /* *compile-hook* */ +#endif + +pointer free_cell; /* pointer to top of free cells */ +long fcells; /* # of free cells */ +size_t inhibit_gc; /* nesting of gc_disable */ +size_t reserved_cells; /* # of reserved cells */ +#ifndef NDEBUG +int reserved_lineno; /* location of last reservation */ +#endif + +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; +size_t strbuff_size; +FILE *tmpfp; +int tok; +int print_flag; +pointer value; +unsigned int flags; + +void *ext_data; /* For the benefit of foreign functions */ +long gensym_cnt; + +const struct scheme_interface *vptr; +}; + +/* operator code */ +enum scheme_opcodes { +#define _OP_DEF(A,B,C,D,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); + +int is_foreign_object(pointer p); +const foreign_object_vtable *get_foreign_object_vtable(pointer p); +void *get_foreign_object_data(pointer p); + +#ifdef __cplusplus +} +#endif + +#endif + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/gpgscm/scheme.c b/gpgscm/scheme.c new file mode 100644 index 0000000..4384841 --- /dev/null +++ b/gpgscm/scheme.c @@ -0,0 +1,6028 @@ +/* T I N Y S C H E M E 1 . 4 1 + * Dimitrios Souflis (dsouflis@acm.org) + * Based on MiniScheme (original credits follow) + * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) + * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp + * (MINISCM) This version has been modified by R.C. Secrist. + * (MINISCM) + * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. + * (MINISCM) + * (MINISCM) This is a revised and modified version by Akira KIDA. + * (MINISCM) current version is 0.85k4 (15 May 1994) + * + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#define _SCHEME_SOURCE +#include "scheme-private.h" +#ifndef WIN32 +# include +#endif +#ifdef WIN32 +#define snprintf _snprintf +#endif +#if USE_DL +# include "dynload.h" +#endif +#if USE_MATH +# include +#endif + +#include +#include +#include +#include +#include + +#if USE_STRCASECMP +#include +# ifndef __APPLE__ +# define stricmp strcasecmp +# endif +#endif + +/* Used for documentation purposes, to signal functions in 'interface' */ +#define INTERFACE + +#define TOK_EOF (-1) +#define TOK_LPAREN 0 +#define TOK_RPAREN 1 +#define TOK_DOT 2 +#define TOK_ATOM 3 +#define TOK_QUOTE 4 +#define TOK_COMMENT 5 +#define TOK_DQUOTE 6 +#define TOK_BQUOTE 7 +#define TOK_COMMA 8 +#define TOK_ATMARK 9 +#define TOK_SHARP 10 +#define TOK_SHARP_CONST 11 +#define TOK_VEC 12 + +#define BACKQUOTE '`' +#define DELIMITERS "()\";\f\t\v\n\r " + +/* + * Basic memory allocation units + */ + +#define banner "TinyScheme 1.41" + +#include +#include +#include + +#ifdef __APPLE__ +static int stricmp(const char *s1, const char *s2) +{ + unsigned char c1, c2; + do { + c1 = tolower(*s1); + c2 = tolower(*s2); + if (c1 < c2) + return -1; + else if (c1 > c2) + return 1; + s1++, s2++; + } while (c1 != 0); + return 0; +} +#endif /* __APPLE__ */ + +#if USE_STRLWR && !defined(HAVE_STRLWR) +static const char *strlwr(char *s) { + const char *p=s; + while(*s) { + *s=tolower(*s); + s++; + } + return p; +} +#endif + +#ifndef prompt +# define prompt "ts> " +#endif + +#ifndef InitFile +# define InitFile "init.scm" +#endif + +#ifndef FIRST_CELLSEGS +# define FIRST_CELLSEGS 3 +#endif + + + +/* All types have the LSB set. The garbage collector takes advantage + * of that to identify types. */ +enum scheme_types { + T_STRING = 1 << 1 | 1, + T_NUMBER = 2 << 1 | 1, + T_SYMBOL = 3 << 1 | 1, + T_PROC = 4 << 1 | 1, + T_PAIR = 5 << 1 | 1, + T_CLOSURE = 6 << 1 | 1, + T_CONTINUATION = 7 << 1 | 1, + T_FOREIGN = 8 << 1 | 1, + T_CHARACTER = 9 << 1 | 1, + T_PORT = 10 << 1 | 1, + T_VECTOR = 11 << 1 | 1, + T_MACRO = 12 << 1 | 1, + T_PROMISE = 13 << 1 | 1, + T_ENVIRONMENT = 14 << 1 | 1, + T_FOREIGN_OBJECT = 15 << 1 | 1, + T_BOOLEAN = 16 << 1 | 1, + T_NIL = 17 << 1 | 1, + T_EOF_OBJ = 18 << 1 | 1, + T_SINK = 19 << 1 | 1, + T_FRAME = 20 << 1 | 1, + T_LAST_SYSTEM_TYPE = 20 << 1 | 1 +}; + +static const char * +type_to_string (enum scheme_types typ) +{ + switch (typ) + { + case T_STRING: return "string"; + case T_NUMBER: return "number"; + case T_SYMBOL: return "symbol"; + case T_PROC: return "proc"; + case T_PAIR: return "pair"; + case T_CLOSURE: return "closure"; + case T_CONTINUATION: return "continuation"; + case T_FOREIGN: return "foreign"; + case T_CHARACTER: return "character"; + case T_PORT: return "port"; + case T_VECTOR: return "vector"; + case T_MACRO: return "macro"; + case T_PROMISE: return "promise"; + case T_ENVIRONMENT: return "environment"; + case T_FOREIGN_OBJECT: return "foreign object"; + case T_BOOLEAN: return "boolean"; + case T_NIL: return "nil"; + case T_EOF_OBJ: return "eof object"; + case T_SINK: return "sink"; + case T_FRAME: return "frame"; + } + assert (! "not reached"); +} + +/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ +#define TYPE_BITS 6 +#define ADJ (1 << TYPE_BITS) +#define T_MASKTYPE (ADJ - 1) + /* 0000000000111111 */ +#define T_TAGGED 1024 /* 0000010000000000 */ +#define T_FINALIZE 2048 /* 0000100000000000 */ +#define T_SYNTAX 4096 /* 0001000000000000 */ +#define T_IMMUTABLE 8192 /* 0010000000000000 */ +#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ +#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ +#define MARK 32768 /* 1000000000000000 */ +#define UNMARK 32767 /* 0111111111111111 */ + + +static num num_add(num a, num b); +static num num_mul(num a, num b); +static num num_div(num a, num b); +static num num_intdiv(num a, num b); +static num num_sub(num a, num b); +static num num_rem(num a, num b); +static num num_mod(num a, num b); +static int num_eq(num a, num b); +static int num_gt(num a, num b); +static int num_ge(num a, num b); +static int num_lt(num a, num b); +static int num_le(num a, num b); + +#if USE_MATH +static double round_per_R5RS(double x); +#endif +static int is_zero_double(double x); +static INLINE int num_is_integer(pointer p) { + return ((p)->_object._number.is_fixnum); +} + +static const struct num num_zero = { 1, {0} }; +static const struct num num_one = { 1, {1} }; + +/* macros for cell operations */ +#define typeflag(p) ((p)->_flag) +#define type(p) (typeflag(p)&T_MASKTYPE) +#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ)) + +INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } +#define strvalue(p) ((p)->_object._string._svalue) +#define strlength(p) ((p)->_object._string._length) + +INTERFACE static int is_list(scheme *sc, pointer p); +INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } +/* Given a vector, return it's length. */ +#define vector_length(v) (v)->_object._vector._length +/* Given a vector length, compute the amount of cells required to + * represent it. */ +#define vector_size(len) (1 + ((len) - 1 + 2) / 3) +INTERFACE static void fill_vector(pointer vec, pointer obj); +INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem); +INTERFACE static pointer vector_elem(pointer vec, int ielem); +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); +INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } +INTERFACE INLINE int is_integer(pointer p) { + if (!is_number(p)) + return 0; + if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) + return 1; + return 0; +} + +INTERFACE INLINE int is_real(pointer p) { + return is_number(p) && (!(p)->_object._number.is_fixnum); +} + +INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } +INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } +INLINE num nvalue(pointer p) { return ((p)->_object._number); } +INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } +INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } +#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) +#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) +#define set_num_integer(p) (p)->_object._number.is_fixnum=1; +#define set_num_real(p) (p)->_object._number.is_fixnum=0; +INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } + +INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } +INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } +INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } + +INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } +#define car(p) ((p)->_object._cons._car) +#define cdr(p) ((p)->_object._cons._cdr) +INTERFACE pointer pair_car(pointer p) { return car(p); } +INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } +INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } +INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } + +INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } +INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } +#if USE_PLIST +SCHEME_EXPORT INLINE int hasprop(pointer p) { return (is_symbol(p)); } +#define symprop(p) cdr(p) +#endif + +INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } +INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } +INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } +INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } +#define procnum(p) ivalue_unchecked(p) +static const char *procname(pointer x); + +INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } +INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } +INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } +INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } + +INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } +#define cont_dump(p) cdr(p) + +INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); } +INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) { + return p->_object._foreign_object._vtable; +} +INTERFACE void *get_foreign_object_data(pointer p) { + return p->_object._foreign_object._data; +} + +/* To do: promise should be forced ONCE only */ +INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } + +INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } +#define setenvironment(p) typeflag(p) = T_ENVIRONMENT + +INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); } +#define setframe(p) settype(p, T_FRAME) + +#define is_atom(p) (typeflag(p)&T_ATOM) +#define setatom(p) typeflag(p) |= T_ATOM +#define clratom(p) typeflag(p) &= CLRATOM + +#define is_mark(p) (typeflag(p)&MARK) +#define setmark(p) typeflag(p) |= MARK +#define clrmark(p) typeflag(p) &= UNMARK + +INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } +/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ +INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } + +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define cdar(p) cdr(car(p)) +#define cddr(p) cdr(cdr(p)) +#define cadar(p) car(cdr(car(p))) +#define caddr(p) car(cdr(cdr(p))) +#define cdaar(p) cdr(car(car(p))) +#define cadaar(p) car(cdr(car(car(p)))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define cddddr(p) cdr(cdr(cdr(cdr(p)))) + +#if USE_HISTORY +static pointer history_flatten(scheme *sc); +static void history_mark(scheme *sc); +#else +# define history_mark(SC) (void) 0 +# define history_flatten(SC) (SC)->NIL +#endif + +#if USE_CHAR_CLASSIFIERS +static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } +static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } +static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } +static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } +static INLINE int Cislower(int c) { return isascii(c) && islower(c); } +#endif + +#if USE_ASCII_NAMES +static const char charnames[32][3]={ + "nul", + "soh", + "stx", + "etx", + "eot", + "enq", + "ack", + "bel", + "bs", + "ht", + "lf", + "vt", + "ff", + "cr", + "so", + "si", + "dle", + "dc1", + "dc2", + "dc3", + "dc4", + "nak", + "syn", + "etb", + "can", + "em", + "sub", + "esc", + "fs", + "gs", + "rs", + "us" +}; + +static int is_ascii_name(const char *name, int *pc) { + int i; + for(i=0; i<32; i++) { + if (strncasecmp(name, charnames[i], 3) == 0) { + *pc=i; + return 1; + } + } + if (strcasecmp(name, "del") == 0) { + *pc=127; + return 1; + } + return 0; +} + +#endif + +static int file_push(scheme *sc, pointer fname); +static void file_pop(scheme *sc); +static int file_interactive(scheme *sc); +static INLINE int is_one_of(char *s, int c); +static int alloc_cellseg(scheme *sc, int n); +static long binary_decode(const char *s); +static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); +static pointer _get_cell(scheme *sc, pointer a, pointer b); +static pointer reserve_cells(scheme *sc, int n); +static pointer get_consecutive_cells(scheme *sc, int n); +static pointer find_consecutive_cells(scheme *sc, int n); +static int finalize_cell(scheme *sc, pointer a); +static int count_consecutive_cells(pointer x, int needed); +static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); +static pointer mk_number(scheme *sc, num n); +static char *store_string(scheme *sc, int len, const char *str, char fill); +static pointer mk_vector(scheme *sc, int len); +static pointer mk_atom(scheme *sc, char *q); +static pointer mk_sharp_const(scheme *sc, char *name); +static pointer mk_port(scheme *sc, port *p); +static pointer port_from_filename(scheme *sc, const char *fn, int prop); +static pointer port_from_file(scheme *sc, FILE *, int prop); +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); +static port *port_rep_from_file(scheme *sc, FILE *, int prop); +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static void port_close(scheme *sc, pointer p, int flag); +static void mark(pointer a); +static void gc(scheme *sc, pointer a, pointer b); +static int basic_inchar(port *pt); +static int inchar(scheme *sc); +static void backchar(scheme *sc, int c); +static char *readstr_upto(scheme *sc, char *delim); +static pointer readstrexp(scheme *sc); +static INLINE int skipspace(scheme *sc); +static int token(scheme *sc); +static void printslashstring(scheme *sc, char *s, int len); +static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); +static void printatom(scheme *sc, pointer l, int f); +static pointer mk_proc(scheme *sc, enum scheme_opcodes op); +static pointer mk_closure(scheme *sc, pointer c, pointer e); +static pointer mk_continuation(scheme *sc, pointer d); +static pointer reverse(scheme *sc, pointer term, pointer list); +static pointer reverse_in_place(scheme *sc, pointer term, pointer list); +static pointer revappend(scheme *sc, pointer a, pointer b); +static void dump_stack_preallocate_frame(scheme *sc); +static void dump_stack_mark(scheme *); +struct op_code_info { + char name[31]; /* strlen ("call-with-current-continuation") + 1 */ + unsigned char min_arity; + unsigned char max_arity; + char arg_tests_encoding[3]; +}; +static const struct op_code_info dispatch_table[]; +static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size); +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name); +static int syntaxnum(scheme *sc, pointer p); +static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name); + +#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) +#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) + +static num num_add(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue+b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)+num_rvalue(b); + } + return ret; +} + +static num num_mul(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue*b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)*num_rvalue(b); + } + return ret; +} + +static num num_div(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_intdiv(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_sub(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue-b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)-num_rvalue(b); + } + return ret; +} + +static num num_rem(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* remainder should have same sign as second operand */ + if (res > 0) { + if (e1 < 0) { + res -= labs(e2); + } + } else if (res < 0) { + if (e1 > 0) { + res += labs(e2); + } + } + ret.value.ivalue=res; + return ret; +} + +static num num_mod(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* modulo should have same sign as second operand */ + if (res * e2 < 0) { + res += e2; + } + ret.value.ivalue=res; + return ret; +} + +static int num_eq(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue==b.value.ivalue; + } else { + ret=num_rvalue(a)==num_rvalue(b); + } + return ret; +} + + +static int num_gt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue>b.value.ivalue; + } else { + ret=num_rvalue(a)>num_rvalue(b); + } + return ret; +} + +static int num_ge(num a, num b) { + return !num_lt(a,b); +} + +static int num_lt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivaluedce) { + return ce; + } else if(dfl-DBL_MIN; +} + +static long binary_decode(const char *s) { + long x=0; + + while(*s!=0 && (*s=='1' || *s=='0')) { + x<<=1; + x+=*s-'0'; + s++; + } + + return x; +} + + + +/* + * Copying values. + * + * Occasionally, we need to copy a value from one location in the + * storage to another. Scheme objects are fine. Some primitive + * objects, however, require finalization, usually to free resources. + * + * For these values, we either make a copy or acquire a reference. + */ + +/* + * Copy SRC to DST. + * + * Copies the representation of SRC to DST. This makes SRC + * indistinguishable from DST from the perspective of a Scheme + * expression modulo the fact that they reside at a different location + * in the store. + * + * Conditions: + * + * - SRC must not be a vector. + * - Caller must ensure that any resources associated with the + * value currently stored in DST is accounted for. + */ +static void +copy_value(scheme *sc, pointer dst, pointer src) +{ + memcpy(dst, src, sizeof *src); + + /* We may need to make a copy or acquire a reference. */ + if (typeflag(dst) & T_FINALIZE) + switch (type(dst)) { + case T_STRING: + strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0); + break; + case T_PORT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_FOREIGN_OBJECT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_VECTOR: + assert (!"vectors cannot be copied"); + } +} + + + +/* Tags are like property lists, but can be attached to arbitrary + * values. */ + +static pointer +mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) +{ + pointer r, t; + + assert(! is_vector(v)); + + r = get_consecutive_cells(sc, 2); + if (r == sc->sink) + return sc->sink; + + copy_value(sc, r, v); + typeflag(r) |= T_TAGGED; + + t = r + 1; + typeflag(t) = T_PAIR; + car(t) = tag_car; + cdr(t) = tag_cdr; + + return r; +} + +static INLINE int +has_tag(pointer v) +{ + return !! (typeflag(v) & T_TAGGED); +} + +static INLINE pointer +get_tag(scheme *sc, pointer v) +{ + if (has_tag(v)) + return v + 1; + return sc->NIL; +} + + + +/* Low-level allocator. + * + * Memory is allocated in segments. Every segment holds a fixed + * number of cells. Segments are linked into a list, sorted in + * reverse address order (i.e. those with a higher address first). + * This is used in the garbage collector to build the freelist in + * address order. + */ + +struct cell_segment +{ + struct cell_segment *next; + void *alloc; + pointer cells; + size_t cells_len; +}; + +/* Allocate a new cell segment but do not make it available yet. */ +static int +_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment) +{ + int adj = ADJ; + void *cp; + + if (adj < sizeof(struct cell)) + adj = sizeof(struct cell); + + /* The segment header is conveniently allocated with the cells. */ + cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj); + if (cp == NULL) + return 1; + + *segment = cp; + (*segment)->next = NULL; + (*segment)->alloc = cp; + cp = (void *) ((uintptr_t) cp + sizeof **segment); + + /* adjust in TYPE_BITS-bit boundary */ + if (((uintptr_t) cp) % adj != 0) + cp = (void *) (adj * ((uintptr_t) cp / adj + 1)); + + (*segment)->cells = cp; + (*segment)->cells_len = len; + return 0; +} + +/* Deallocate a cell segment. Returns the next cell segment. + * Convenient for deallocation in a loop. */ +static struct cell_segment * +_dealloc_cellseg(scheme *sc, struct cell_segment *segment) +{ + + struct cell_segment *next; + + if (segment == NULL) + return NULL; + + next = segment->next; + sc->free(segment->alloc); + return next; +} + +/* allocate new cell segment */ +static int alloc_cellseg(scheme *sc, int n) { + pointer last; + pointer p; + int k; + + for (k = 0; k < n; k++) { + struct cell_segment *new, **s; + if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) { + return k; + } + /* insert new segment in reverse address order */ + for (s = &sc->cell_segments; + *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc; + s = &(*s)->next) { + /* walk */ + } + new->next = *s; + *s = new; + + sc->fcells += new->cells_len; + last = new->cells + new->cells_len - 1; + for (p = new->cells; p <= last; p++) { + typeflag(p) = 0; + cdr(p) = p + 1; + car(p) = sc->NIL; + } + /* insert new cells in address order on free list */ + if (sc->free_cell == sc->NIL || p < sc->free_cell) { + cdr(last) = sc->free_cell; + sc->free_cell = new->cells; + } else { + p = sc->free_cell; + while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p)) + p = cdr(p); + cdr(last) = cdr(p); + cdr(p) = new->cells; + } + } + return n; +} + + + +/* Controlling the garbage collector. + * + * Every time a cell is allocated, the interpreter may run out of free + * cells and do a garbage collection. This is problematic because it + * might garbage collect objects that have been allocated, but are not + * yet made available to the interpreter. + * + * Previously, we would plug such newly allocated cells into the list + * of newly allocated objects rooted at car(sc->sink), but that + * requires allocating yet another cell increasing pressure on the + * memory management system. + * + * A faster alternative is to preallocate the cells needed for an + * operation and make sure the garbage collection is not run until all + * allocated objects are plugged in. This can be done with gc_disable + * and gc_enable. + */ + +/* The garbage collector is enabled if the inhibit counter is + * zero. */ +#define GC_ENABLED 0 + +/* For now we provide a way to disable this optimization for + * benchmarking and because it produces slightly smaller code. */ +#ifndef USE_GC_LOCKING +# define USE_GC_LOCKING 1 +#endif + +/* To facilitate nested calls to gc_disable, functions that allocate + * more than one cell may define a macro, e.g. foo_allocates. This + * macro can be used to compute the amount of preallocation at the + * call site with the help of this macro. */ +#define gc_reservations(fn) fn ## _allocates + +#if USE_GC_LOCKING + +/* Report a shortage in reserved cells, and terminate the program. */ +static void +gc_reservation_failure(struct scheme *sc) +{ +#ifdef NDEBUG + fprintf(stderr, + "insufficient reservation\n") +#else + fprintf(stderr, + "insufficient %s reservation in line %d\n", + sc->frame_freelist == sc->NIL ? "frame" : "cell", + sc->reserved_lineno); +#endif + abort(); +} + +/* Disable the garbage collection and reserve the given number of + * cells. gc_disable may be nested, but the enclosing reservation + * must include the reservations of all nested calls. Note: You must + * re-enable the gc before calling Error_X. */ +static void +_gc_disable(struct scheme *sc, size_t reserve, int lineno) +{ + if (sc->inhibit_gc == 0) { + reserve_cells(sc, (reserve)); + sc->reserved_cells = (reserve); +#ifdef NDEBUG + (void) lineno; +#else + sc->reserved_lineno = lineno; +#endif + } else if (sc->reserved_cells < (reserve)) + gc_reservation_failure (sc); + sc->inhibit_gc += 1; +} +#define gc_disable(sc, reserve) \ + do { \ + if (sc->frame_freelist == sc->NIL) { \ + if (gc_enabled(sc)) \ + dump_stack_preallocate_frame(sc); \ + else \ + gc_reservation_failure(sc); \ + } \ + _gc_disable (sc, reserve, __LINE__); \ + } while (0) + +/* Enable the garbage collector. */ +#define gc_enable(sc) \ + do { \ + assert(sc->inhibit_gc); \ + sc->inhibit_gc -= 1; \ + } while (0) + +/* Test whether the garbage collector is enabled. */ +#define gc_enabled(sc) \ + (sc->inhibit_gc == GC_ENABLED) + +/* Consume a reserved cell. */ +#define gc_consume(sc) \ + do { \ + assert(! gc_enabled (sc)); \ + if (sc->reserved_cells == 0) \ + gc_reservation_failure (sc); \ + sc->reserved_cells -= 1; \ + } while (0) + +#else /* USE_GC_LOCKING */ + +#define gc_reservation_failure(sc) (void) 0 +#define gc_disable(sc, reserve) \ + do { \ + if (sc->frame_freelist == sc->NIL) \ + dump_stack_preallocate_frame(sc); \ + } while (0) +#define gc_enable(sc) (void) 0 +#define gc_enabled(sc) 1 +#define gc_consume(sc) (void) 0 + +#endif /* USE_GC_LOCKING */ + +static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { + if (! gc_enabled (sc) || sc->free_cell != sc->NIL) { + pointer x = sc->free_cell; + if (! gc_enabled (sc)) + gc_consume (sc); + sc->free_cell = cdr(x); + --sc->fcells; + return (x); + } + assert (gc_enabled (sc)); + return _get_cell (sc, a, b); +} + + +/* get new cell. parameter a, b is marked by gc. */ +static pointer _get_cell(scheme *sc, pointer a, pointer b) { + pointer x; + + if(sc->no_memory) { + return sc->sink; + } + + assert (gc_enabled (sc)); + if (sc->free_cell == sc->NIL) { + gc(sc,a, b); + if (sc->free_cell == sc->NIL) { + sc->no_memory=1; + return sc->sink; + } + } + x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); +} + +/* make sure that there is a given number of cells free */ +static pointer reserve_cells(scheme *sc, int n) { + if(sc->no_memory) { + return sc->NIL; + } + + /* Are there enough cells available? */ + if (sc->fcells < n) { + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + if (sc->fcells < n) { + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) { + sc->no_memory=1; + return sc->NIL; + } + } + if (sc->fcells < n) { + /* If all fail, report failure */ + sc->no_memory=1; + return sc->NIL; + } + } + return (sc->T); +} + +static pointer get_consecutive_cells(scheme *sc, int n) { + pointer x; + + if(sc->no_memory) { return sc->sink; } + + /* Are there any cells available? */ + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) + { + sc->no_memory=1; + return sc->sink; + } + + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If all fail, report failure */ + sc->no_memory=1; + return sc->sink; +} + +static int count_consecutive_cells(pointer x, int needed) { + int n=1; + while(cdr(x)==x+1) { + x=cdr(x); + n++; + if(n>needed) return n; + } + return n; +} + +static pointer find_consecutive_cells(scheme *sc, int n) { + pointer *pp; + int cnt; + + pp=&sc->free_cell; + while(*pp!=sc->NIL) { + cnt=count_consecutive_cells(*pp,n); + if(cnt>=n) { + pointer x=*pp; + *pp=cdr(*pp+n-1); + sc->fcells -= n; + return x; + } + pp=&cdr(*pp+cnt-1); + } + return sc->NIL; +} + +/* Free a cell. This is dangerous. Only free cells that are not + * referenced. */ +static INLINE void +free_cell(scheme *sc, pointer a) +{ + cdr(a) = sc->free_cell; + sc->free_cell = a; + sc->fcells += 1; +} + +/* Free a cell and retrieve its content. This is dangerous. Only + * free cells that are not referenced. */ +static INLINE void +free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr) +{ + *r_car = car(a); + *r_cdr = cdr(a); + free_cell(sc, a); +} + +/* To retain recent allocs before interpreter knows about them - + Tehom */ + +static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) +{ + pointer holder = get_cell_x(sc, recent, extra); + typeflag(holder) = T_PAIR | T_IMMUTABLE; + car(holder) = recent; + cdr(holder) = car(sc->sink); + car(sc->sink) = holder; +} + +static INLINE void ok_to_freely_gc(scheme *sc) +{ + pointer a = car(sc->sink), next; + car(sc->sink) = sc->NIL; + while (a != sc->NIL) + { + next = cdr(a); + free_cell(sc, a); + a = next; + } +} + +static pointer get_cell(scheme *sc, pointer a, pointer b) +{ + pointer cell = get_cell_x(sc, a, b); + /* For right now, include "a" and "b" in "cell" so that gc doesn't + think they are garbage. */ + /* Tentatively record it as a pair so gc understands it. */ + typeflag(cell) = T_PAIR; + car(cell) = a; + cdr(cell) = b; + if (gc_enabled (sc)) + push_recent_alloc(sc, cell, sc->NIL); + return cell; +} + +static pointer get_vector_object(scheme *sc, int len, pointer init) +{ + pointer cells = get_consecutive_cells(sc, vector_size(len)); + int i; + int alloc_len = 1 + 3 * (vector_size(len) - 1); + if(sc->no_memory) { return sc->sink; } + /* Record it as a vector so that gc understands it. */ + typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE); + vector_length(cells) = len; + fill_vector(cells,init); + + /* Initialize the unused slots at the end. */ + assert (alloc_len - len < 3); + for (i = len; i < alloc_len; i++) + cells->_object._vector._elements[i] = sc->NIL; + + if (gc_enabled (sc)) + push_recent_alloc(sc, cells, sc->NIL); + return cells; +} + +/* Medium level cell allocation */ + +/* get new cons cell */ +pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { + pointer x = get_cell(sc,a, b); + + typeflag(x) = T_PAIR; + if(immutable) { + setimmutable(x); + } + car(x) = a; + cdr(x) = b; + return (x); +} + + +/* ========== oblist implementation ========== */ + +#ifndef USE_OBJECT_LIST + +static int hash_fn(const char *key, int table_size); + +static pointer oblist_initial_value(scheme *sc) +{ + /* There are about 768 symbols used after loading the + * interpreter. */ + return mk_vector(sc, 1009); +} + +/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not + * exist. In that case, SLOT points to the point where the new symbol + * is to be inserted. */ +static INLINE pointer +oblist_find_by_name(scheme *sc, const char *name, pointer **slot) +{ + int location; + pointer x; + char *s; + int d; + + location = hash_fn(name, vector_length(sc->oblist)); + for (*slot = vector_elem_slot(sc->oblist, location), x = **slot; + x != sc->NIL; *slot = &cdr(x), x = **slot) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + d = stricmp(name, s); + if (d == 0) + return car(x); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + return sc->NIL; +} + +static pointer oblist_all_symbols(scheme *sc) +{ + int i; + pointer x; + pointer ob_list = sc->NIL; + + for (i = 0; i < vector_length(sc->oblist); i++) { + for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { + ob_list = cons(sc, x, ob_list); + } + } + return ob_list; +} + +#else + +static pointer oblist_initial_value(scheme *sc) +{ + return sc->NIL; +} + +/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not + * exist. In that case, SLOT points to the point where the new symbol + * is to be inserted. */ +static INLINE pointer +oblist_find_by_name(scheme *sc, const char *name, pointer **slot) +{ + pointer x; + char *s; + int d; + + for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + d = stricmp(name, s); + if (d == 0) + return car(x); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + return sc->NIL; +} + +static pointer oblist_all_symbols(scheme *sc) +{ + return sc->oblist; +} + +#endif + +/* Add a new symbol NAME at SLOT. SLOT must be obtained using + * oblist_find_by_name, and no insertion must be done between + * obtaining the SLOT and calling this function. Returns the new + * symbol. */ +static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) +{ +#define oblist_add_by_name_allocates 3 + pointer x; + + gc_disable(sc, gc_reservations (oblist_add_by_name)); + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + *slot = immutable_cons(sc, x, *slot); + gc_enable(sc); + return x; +} + + + +static pointer mk_port(scheme *sc, port *p) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = T_PORT|T_ATOM|T_FINALIZE; + x->_object._port=p; + return (x); +} + +pointer mk_foreign_func(scheme *sc, foreign_func f) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN | T_ATOM); + x->_object._ff=f; + return (x); +} + +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE); + x->_object._foreign_object._vtable=vtable; + x->_object._foreign_object._data = data; + return (x); +} + +INTERFACE pointer mk_character(scheme *sc, int c) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_CHARACTER | T_ATOM); + ivalue_unchecked(x)= c; + set_num_integer(x); + return (x); +} + + + +#if USE_SMALL_INTEGERS + +static const struct cell small_integers[] = { +#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}}, +#include "small-integers.h" +#undef DEFINE_INTEGER + {0} +}; + +#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1) + +static INLINE pointer +mk_small_integer(scheme *sc, long n) +{ +#define mk_small_integer_allocates 0 + (void) sc; + assert(0 <= n && n < MAX_SMALL_INTEGER); + return (pointer) &small_integers[n]; +} +#else + +#define mk_small_integer_allocates 1 +#define mk_small_integer mk_integer + +#endif + +/* get number atom (integer) */ +INTERFACE pointer mk_integer(scheme *sc, long n) { + pointer x; + +#if USE_SMALL_INTEGERS + if (0 <= n && n < MAX_SMALL_INTEGER) + return mk_small_integer(sc, n); +#endif + + x = get_cell(sc,sc->NIL, sc->NIL); + typeflag(x) = (T_NUMBER | T_ATOM); + ivalue_unchecked(x)= n; + set_num_integer(x); + return (x); +} + + + +INTERFACE pointer mk_real(scheme *sc, double n) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + rvalue_unchecked(x)= n; + set_num_real(x); + return (x); +} + +static pointer mk_number(scheme *sc, num n) { + if(n.is_fixnum) { + return mk_integer(sc,n.value.ivalue); + } else { + return mk_real(sc,n.value.rvalue); + } +} + +/* allocate name to string area */ +static char *store_string(scheme *sc, int len_str, const char *str, char fill) { + char *q; + + q=(char*)sc->malloc(len_str+1); + if(q==0) { + sc->no_memory=1; + return sc->strbuff; + } + if(str!=0) { + memcpy (q, str, len_str); + q[len_str]=0; + } else { + memset(q, fill, len_str); + q[len_str]=0; + } + return (q); +} + +/* get new string */ +INTERFACE pointer mk_string(scheme *sc, const char *str) { + return mk_counted_string(sc,str,strlen(str)); +} + +INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); + strvalue(x) = store_string(sc,len,str,0); + strlength(x) = len; + return (x); +} + +INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); + strvalue(x) = store_string(sc,len,0,fill); + strlength(x) = len; + return (x); +} + +INTERFACE static pointer mk_vector(scheme *sc, int len) +{ return get_vector_object(sc,len,sc->NIL); } + +INTERFACE static void fill_vector(pointer vec, pointer obj) { + size_t i; + assert (is_vector (vec)); + for(i = 0; i < vector_length(vec); i++) { + vec->_object._vector._elements[i] = obj; + } +} + +INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) { + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + return &vec->_object._vector._elements[ielem]; +} + +INTERFACE static pointer vector_elem(pointer vec, int ielem) { + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + return vec->_object._vector._elements[ielem]; +} + +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + vec->_object._vector._elements[ielem] = a; + return a; +} + +/* get new symbol */ +INTERFACE pointer mk_symbol(scheme *sc, const char *name) { +#define mk_symbol_allocates oblist_add_by_name_allocates + pointer x; + pointer *slot; + + /* first check oblist */ + x = oblist_find_by_name(sc, name, &slot); + if (x != sc->NIL) { + return (x); + } else { + x = oblist_add_by_name(sc, name, slot); + return (x); + } +} + +INTERFACE pointer gensym(scheme *sc) { + pointer x; + pointer *slot; + char name[40]; + + for(; sc->gensym_cntgensym_cnt++) { + snprintf(name,40,"gensym-%ld",sc->gensym_cnt); + + /* first check oblist */ + x = oblist_find_by_name(sc, name, &slot); + + if (x != sc->NIL) { + continue; + } else { + x = oblist_add_by_name(sc, name, slot); + return (x); + } + } + + return sc->NIL; +} + +/* double the size of the string buffer */ +static int expand_strbuff(scheme *sc) { + size_t new_size = sc->strbuff_size * 2; + char *new_buffer = sc->malloc(new_size); + if (new_buffer == 0) { + sc->no_memory = 1; + return 1; + } + memcpy(new_buffer, sc->strbuff, sc->strbuff_size); + sc->free(sc->strbuff); + sc->strbuff = new_buffer; + sc->strbuff_size = new_size; + return 0; +} + +/* make symbol or number atom from string */ +static pointer mk_atom(scheme *sc, char *q) { + char c, *p; + int has_dec_point=0; + int has_fp_exp = 0; + +#if USE_COLON_HOOK + char *next; + next = p = q; + while ((next = strstr(next, "::")) != 0) { + /* Keep looking for the last occurrence. */ + p = next; + next = next + 2; + } + + if (p != q) { + *p=0; + return cons(sc, sc->COLON_HOOK, + cons(sc, + cons(sc, + sc->QUOTE, + cons(sc, mk_symbol(sc, strlwr(p + 2)), + sc->NIL)), + cons(sc, mk_atom(sc, q), sc->NIL))); + } +#endif + + p = q; + c = *p++; + if ((c == '+') || (c == '-')) { + c = *p++; + if (c == '.') { + has_dec_point=1; + c = *p++; + } + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (c == '.') { + has_dec_point=1; + c = *p++; + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + + for ( ; (c = *p) != 0; ++p) { + if (!isdigit(c)) { + if(c=='.') { + if(!has_dec_point) { + has_dec_point=1; + continue; + } + } + else if ((c == 'e') || (c == 'E')) { + if(!has_fp_exp) { + has_dec_point = 1; /* decimal point illegal + from now on */ + p++; + if ((*p == '-') || (*p == '+') || isdigit(*p)) { + continue; + } + } + } + return (mk_symbol(sc, strlwr(q))); + } + } + if(has_dec_point) { + return mk_real(sc,atof(q)); + } + return (mk_integer(sc, atol(q))); +} + +/* make constant */ +static pointer mk_sharp_const(scheme *sc, char *name) { + long x; + char tmp[STRBUFFSIZE]; + + if (!strcmp(name, "t")) + return (sc->T); + else if (!strcmp(name, "f")) + return (sc->F); + else if (*name == 'o') {/* #o (octal) */ + snprintf(tmp, STRBUFFSIZE, "0%s", name+1); + sscanf(tmp, "%lo", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'd') { /* #d (decimal) */ + sscanf(name+1, "%ld", (long int *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'x') { /* #x (hex) */ + snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); + sscanf(tmp, "%lx", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'b') { /* #b (binary) */ + x = binary_decode(name+1); + return (mk_integer(sc, x)); + } else if (*name == '\\') { /* #\w (character) */ + int c=0; + if(stricmp(name+1,"space")==0) { + c=' '; + } else if(stricmp(name+1,"newline")==0) { + c='\n'; + } else if(stricmp(name+1,"return")==0) { + c='\r'; + } else if(stricmp(name+1,"tab")==0) { + c='\t'; + } else if(name[1]=='x' && name[2]!=0) { + int c1=0; + if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { + c=c1; + } else { + return sc->NIL; + } +#if USE_ASCII_NAMES + } else if(is_ascii_name(name+1,&c)) { + /* nothing */ +#endif + } else if(name[2]==0) { + c=name[1]; + } else { + return sc->NIL; + } + return mk_character(sc,c); + } else + return (sc->NIL); +} + +/* ========== garbage collector ========== */ + +const int frame_length; +static void dump_stack_deallocate_frame(scheme *sc, pointer frame); + +/*-- + * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, + * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, + * for marking. + */ +static void mark(pointer a) { + pointer t, q, p; + + t = (pointer) 0; + p = a; +E2: if (! is_mark(p)) + setmark(p); + if (is_vector(p) || is_frame(p)) { + int i; + int len = is_vector(p) ? vector_length(p) : frame_length; + for (i = 0; i < len; i++) { + mark(p->_object._vector._elements[i]); + } + } +#if SHOW_ERROR_LINE + else if (is_port(p)) { + port *pt = p->_object._port; + mark(pt->curr_line); + mark(pt->filename); + } +#endif + /* Mark tag if p has one. */ + if (has_tag(p)) + mark(p + 1); + if (is_atom(p)) + goto E6; + /* E4: down car */ + q = car(p); + if (q && !is_mark(q)) { + setatom(p); /* a note that we have moved car */ + car(p) = t; + t = p; + p = q; + goto E2; + } +E5: q = cdr(p); /* down cdr */ + if (q && !is_mark(q)) { + cdr(p) = t; + t = p; + p = q; + goto E2; + } +E6: /* up. Undo the link switching from steps E4 and E5. */ + if (!t) + return; + q = t; + if (is_atom(q)) { + clratom(q); + t = car(q); + car(q) = p; + p = q; + goto E5; + } else { + t = cdr(q); + cdr(q) = p; + p = q; + goto E6; + } +} + +/* garbage collection. parameter a, b is marked. */ +static void gc(scheme *sc, pointer a, pointer b) { + pointer p; + struct cell_segment *s; + int i; + + assert (gc_enabled (sc)); + + if(sc->gc_verbose) { + putstr(sc, "gc..."); + } + + /* mark system globals */ + mark(sc->oblist); + mark(sc->global_env); + + /* mark current registers */ + mark(sc->args); + mark(sc->envir); + mark(sc->code); + history_mark(sc); + dump_stack_mark(sc); + mark(sc->value); + mark(sc->inport); + mark(sc->save_inport); + mark(sc->outport); + mark(sc->loadport); + for (i = 0; i <= sc->file_i; i++) { + mark(sc->load_stack[i].filename); + mark(sc->load_stack[i].curr_line); + } + + /* Mark recent objects the interpreter doesn't know about yet. */ + mark(car(sc->sink)); + /* Mark any older stuff above nested C calls */ + mark(sc->c_nest); + + /* mark variables a, b */ + mark(a); + mark(b); + + /* garbage collect */ + clrmark(sc->NIL); + sc->fcells = 0; + sc->free_cell = sc->NIL; + /* free-list is kept sorted by address so as to maintain consecutive + ranges, if possible, for use with vectors. Here we scan the cells + (which are also kept sorted by address) downwards to build the + free-list in sorted order. + */ + for (s = sc->cell_segments; s; s = s->next) { + p = s->cells + s->cells_len; + while (--p >= s->cells) { + if ((typeflag(p) & 1) == 0) + /* All types have the LSB set. This is not a typeflag. */ + continue; + if (is_mark(p)) { + clrmark(p); + } else { + /* reclaim cell */ + if ((typeflag(p) & T_FINALIZE) == 0 + || finalize_cell(sc, p)) { + /* Reclaim cell. */ + ++sc->fcells; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + } + } + } + } + + if (sc->gc_verbose) { + char msg[80]; + snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); + putstr(sc,msg); + } + + /* if only a few recovered, get more to avoid fruitless gc's */ + if (sc->fcells < CELL_MINRECOVER + && alloc_cellseg(sc, 1) == 0) + sc->no_memory = 1; +} + +/* Finalize A. Returns true if a can be added to the list of free + * cells. */ +static int +finalize_cell(scheme *sc, pointer a) +{ + switch (type(a)) { + case T_STRING: + sc->free(strvalue(a)); + break; + + case T_PORT: + if(a->_object._port->kind&port_file + && a->_object._port->rep.stdio.closeit) { + port_close(sc,a,port_input|port_output); + } else if (a->_object._port->kind & port_srfi6) { + sc->free(a->_object._port->rep.string.start); + } + sc->free(a->_object._port); + break; + + case T_FOREIGN_OBJECT: + a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); + break; + + case T_VECTOR: + do { + int i; + for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { + pointer p = a + i; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + sc->fcells += 1; + } + } while (0); + break; + + case T_FRAME: + dump_stack_deallocate_frame(sc, a); + return 0; /* Do not free cell. */ + } + + return 1; /* Free cell. */ +} + +#if SHOW_ERROR_LINE +static void +port_clear_location (scheme *sc, port *p) +{ + p->curr_line = sc->NIL; + p->filename = sc->NIL; +} + +static void +port_increment_current_line (scheme *sc, port *p, long delta) +{ + if (delta == 0) + return; + + p->curr_line = + mk_integer(sc, ivalue_unchecked(p->curr_line) + delta); +} + +static void +port_init_location (scheme *sc, port *p, pointer name) +{ + p->curr_line = mk_integer(sc, 0); + p->filename = name ? name : mk_string(sc, ""); +} + +#else + +static void +port_clear_location (scheme *sc, port *p) +{ +} + +static void +port_increment_current_line (scheme *sc, port *p, long delta) +{ +} + +static void +port_init_location (scheme *sc, port *p, pointer name) +{ +} + +#endif + +/* ========== Routines for Reading ========== */ + +static int file_push(scheme *sc, pointer fname) { + FILE *fin = NULL; + + if (sc->file_i == MAXFIL-1) + return 0; + fin = fopen(string_value(fname), "r"); + if(fin!=0) { + sc->file_i++; + sc->load_stack[sc->file_i].kind=port_file|port_input; + sc->load_stack[sc->file_i].rep.stdio.file=fin; + sc->load_stack[sc->file_i].rep.stdio.closeit=1; + sc->nesting_stack[sc->file_i]=0; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + port_init_location(sc, &sc->load_stack[sc->file_i], fname); + } + return fin!=0; +} + +static void file_pop(scheme *sc) { + if(sc->file_i != 0) { + sc->nesting=sc->nesting_stack[sc->file_i]; + port_close(sc,sc->loadport,port_input); + port_clear_location(sc, &sc->load_stack[sc->file_i]); + sc->file_i--; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + } +} + +static int file_interactive(scheme *sc) { + return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin + && sc->inport->_object._port->kind&port_file; +} + +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { + FILE *f; + char *rw; + port *pt; + if(prop==(port_input|port_output)) { + rw="a+"; + } else if(prop==port_output) { + rw="w"; + } else { + rw="r"; + } + f=fopen(fn,rw); + if(f==0) { + return 0; + } + pt=port_rep_from_file(sc,f,prop); + pt->rep.stdio.closeit=1; + port_init_location(sc, pt, mk_string(sc, fn)); + return pt; +} + +static pointer port_from_filename(scheme *sc, const char *fn, int prop) { + port *pt; + pt=port_rep_from_filename(sc,fn,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_file(scheme *sc, FILE *f, int prop) +{ + port *pt; + + pt = (port *)sc->malloc(sizeof *pt); + if (pt == NULL) { + return NULL; + } + pt->kind = port_file | prop; + pt->rep.stdio.file = f; + pt->rep.stdio.closeit = 0; + port_init_location(sc, pt, NULL); + return pt; +} + +static pointer port_from_file(scheme *sc, FILE *f, int prop) { + port *pt; + pt=port_rep_from_file(sc,f,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + pt->kind=port_string|prop; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=past_the_end; + port_init_location(sc, pt, NULL); + return pt; +} + +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=port_rep_from_string(sc,start,past_the_end,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +#define BLOCK_SIZE 256 + +static port *port_rep_from_scratch(scheme *sc) { + port *pt; + char *start; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + start=sc->malloc(BLOCK_SIZE); + if(start==0) { + return 0; + } + memset(start,' ',BLOCK_SIZE-1); + start[BLOCK_SIZE-1]='\0'; + pt->kind=port_string|port_output|port_srfi6; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=start+BLOCK_SIZE-1; + port_init_location(sc, pt, NULL); + return pt; +} + +static pointer port_from_scratch(scheme *sc) { + port *pt; + pt=port_rep_from_scratch(sc); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static void port_close(scheme *sc, pointer p, int flag) { + port *pt=p->_object._port; + pt->kind&=~flag; + if((pt->kind & (port_input|port_output))==0) { + /* Cleanup is here so (close-*-port) functions could work too */ + port_clear_location(sc, pt); + if(pt->kind&port_file) { + fclose(pt->rep.stdio.file); + } + pt->kind=port_free; + } +} + +/* get new character from input file */ +static int inchar(scheme *sc) { + int c; + port *pt; + + pt = sc->inport->_object._port; + if(pt->kind & port_saw_EOF) + { return EOF; } + c = basic_inchar(pt); + if(c == EOF && sc->inport == sc->loadport) { + /* Instead, set port_saw_EOF */ + pt->kind |= port_saw_EOF; + + /* file_pop(sc); */ + return EOF; + /* NOTREACHED */ + } + return c; +} + +static int basic_inchar(port *pt) { + if(pt->kind & port_file) { + return fgetc(pt->rep.stdio.file); + } else { + if(*pt->rep.string.curr == 0 || + pt->rep.string.curr == pt->rep.string.past_the_end) { + return EOF; + } else { + return *pt->rep.string.curr++; + } + } +} + +/* back character to input buffer */ +static void backchar(scheme *sc, int c) { + port *pt; + if(c==EOF) return; + pt=sc->inport->_object._port; + if(pt->kind&port_file) { + ungetc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.start) { + --pt->rep.string.curr; + } + } +} + +static int realloc_port_string(scheme *sc, port *p) +{ + char *start=p->rep.string.start; + size_t old_size = p->rep.string.past_the_end - start; + size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; + char *str=sc->malloc(new_size); + if(str) { + memset(str,' ',new_size-1); + str[new_size-1]='\0'; + memcpy(str, start, old_size); + p->rep.string.start=str; + p->rep.string.past_the_end=str+new_size-1; + p->rep.string.curr-=start-str; + sc->free(start); + return 1; + } else { + return 0; + } +} + +INTERFACE void putstr(scheme *sc, const char *s) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputs(s,pt->rep.stdio.file); + } else { + for(;*s;s++) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s; + } + } + } +} + +static void putchars(scheme *sc, const char *s, int len) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fwrite(s,1,len,pt->rep.stdio.file); + } else { + for(;len;len--) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s++; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s++; + } + } + } +} + +INTERFACE void putcharacter(scheme *sc, int c) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=c; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=c; + } + } +} + +/* read characters up to delimiter, but cater to character constants */ +static char *readstr_upto(scheme *sc, char *delim) { + char *p = sc->strbuff; + + while ((p - sc->strbuff < sc->strbuff_size) && + !is_one_of(delim, (*p++ = inchar(sc)))); + + if(p == sc->strbuff+2 && p[-2] == '\\') { + *p=0; + } else { + backchar(sc,p[-1]); + *--p = '\0'; + } + return sc->strbuff; +} + +/* read string expression "xxx...xxx" */ +static pointer readstrexp(scheme *sc) { + char *p = sc->strbuff; + int c; + int c1=0; + enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; + + for (;;) { + c=inchar(sc); + if(c == EOF) { + return sc->F; + } + if(p-sc->strbuff > (sc->strbuff_size)-1) { + ptrdiff_t offset = p - sc->strbuff; + if (expand_strbuff(sc) != 0) { + return sc->F; + } + p = sc->strbuff + offset; + } + switch(state) { + case st_ok: + switch(c) { + case '\\': + state=st_bsl; + break; + case '"': + *p=0; + return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); + default: + *p++=c; + break; + } + break; + case st_bsl: + switch(c) { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + state=st_oct1; + c1=c-'0'; + break; + case 'x': + case 'X': + state=st_x1; + c1=0; + break; + case 'n': + *p++='\n'; + state=st_ok; + break; + case 't': + *p++='\t'; + state=st_ok; + break; + case 'r': + *p++='\r'; + state=st_ok; + break; + case '"': + *p++='"'; + state=st_ok; + break; + default: + *p++=c; + state=st_ok; + break; + } + break; + case st_x1: + case st_x2: + c=toupper(c); + if(c>='0' && c<='F') { + if(c<='9') { + c1=(c1<<4)+c-'0'; + } else { + c1=(c1<<4)+c-'A'+10; + } + if(state==st_x1) { + state=st_x2; + } else { + *p++=c1; + state=st_ok; + } + } else { + return sc->F; + } + break; + case st_oct1: + case st_oct2: + if (c < '0' || c > '7') + { + *p++=c1; + backchar(sc, c); + state=st_ok; + } + else + { + if (state==st_oct2 && c1 >= 32) + return sc->F; + + c1=(c1<<3)+(c-'0'); + + if (state == st_oct1) + state=st_oct2; + else + { + *p++=c1; + state=st_ok; + } + } + break; + + } + } +} + +/* check c is in chars */ +static INLINE int is_one_of(char *s, int c) { + if(c==EOF) return 1; + while (*s) + if (*s++ == c) + return (1); + return (0); +} + +/* skip white characters */ +static INLINE int skipspace(scheme *sc) { + int c = 0, curr_line = 0; + + do { + c=inchar(sc); +#if SHOW_ERROR_LINE + if(c=='\n') + curr_line++; +#endif + } while (isspace(c)); + + /* record it */ + port_increment_current_line(sc, &sc->load_stack[sc->file_i], curr_line); + + if(c!=EOF) { + backchar(sc,c); + return 1; + } + else + { return EOF; } +} + +/* get token */ +static int token(scheme *sc) { + int c; + c = skipspace(sc); + if(c == EOF) { return (TOK_EOF); } + switch (c=inchar(sc)) { + case EOF: + return (TOK_EOF); + case '(': + return (TOK_LPAREN); + case ')': + return (TOK_RPAREN); + case '.': + c=inchar(sc); + if(is_one_of(" \n\t",c)) { + return (TOK_DOT); + } else { + backchar(sc,c); + backchar(sc,'.'); + return TOK_ATOM; + } + case '\'': + return (TOK_QUOTE); + case ';': + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + + if(c == '\n') + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + case '"': + return (TOK_DQUOTE); + case BACKQUOTE: + return (TOK_BQUOTE); + case ',': + if ((c=inchar(sc)) == '@') { + return (TOK_ATMARK); + } else { + backchar(sc,c); + return (TOK_COMMA); + } + case '#': + c=inchar(sc); + if (c == '(') { + return (TOK_VEC); + } else if(c == '!') { + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + + if(c == '\n') + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + } else { + backchar(sc,c); + if(is_one_of(" tfodxb\\",c)) { + return TOK_SHARP_CONST; + } else { + return (TOK_SHARP); + } + } + default: + backchar(sc,c); + return (TOK_ATOM); + } +} + +/* ========== Routines for Printing ========== */ +#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) + +static void printslashstring(scheme *sc, char *p, int len) { + int i; + unsigned char *s=(unsigned char*)p; + putcharacter(sc,'"'); + for ( i=0; iNIL) { + p = "()"; + } else if (l == sc->T) { + p = "#t"; + } else if (l == sc->F) { + p = "#f"; + } else if (l == sc->EOF_OBJ) { + p = "#"; + } else if (is_port(l)) { + p = "#"; + } else if (is_number(l)) { + p = sc->strbuff; + if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { + if(num_is_integer(l)) { + snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); + } else { + snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); + /* r5rs says there must be a '.' (unless 'e'?) */ + f = strcspn(p, ".e"); + if (p[f] == 0) { + p[f] = '.'; /* not found, so add '.0' at the end */ + p[f+1] = '0'; + p[f+2] = 0; + } + } + } else { + long v = ivalue(l); + if (f == 16) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lx", v); + else + snprintf(p, STRBUFFSIZE, "-%lx", -v); + } else if (f == 8) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lo", v); + else + snprintf(p, STRBUFFSIZE, "-%lo", -v); + } else if (f == 2) { + unsigned long b = (v < 0) ? -v : v; + p = &p[STRBUFFSIZE-1]; + *p = 0; + do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); + if (v < 0) *--p = '-'; + } + } + } else if (is_string(l)) { + if (!f) { + *pp = strvalue(l); + *plen = strlength(l); + return; + } else { /* Hack, uses the fact that printing is needed */ + *pp=sc->strbuff; + *plen=0; + printslashstring(sc, strvalue(l), strlength(l)); + return; + } + } else if (is_character(l)) { + int c=charvalue(l); + p = sc->strbuff; + if (!f) { + p[0]=c; + p[1]=0; + } else { + switch(c) { + case ' ': + p = "#\\space"; + break; + case '\n': + p = "#\\newline"; + break; + case '\r': + p = "#\\return"; + break; + case '\t': + p = "#\\tab"; + break; + default: +#if USE_ASCII_NAMES + if(c==127) { + p = "#\\del"; + break; + } else if(c<32) { + snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]); + break; + } +#else + if(c<32) { + snprintf(p,STRBUFFSIZE,"#\\x%x",c); + break; + } +#endif + snprintf(p,STRBUFFSIZE,"#\\%c",c); + break; + } + } + } else if (is_symbol(l)) { + p = symname(l); + } else if (is_proc(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); + } else if (is_macro(l)) { + p = "#"; + } else if (is_closure(l)) { + p = "#"; + } else if (is_promise(l)) { + p = "#"; + } else if (is_foreign(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#", procnum(l)); + } else if (is_continuation(l)) { + p = "#"; + } else if (is_foreign_object(l)) { + p = sc->strbuff; + l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data); + } else { + p = "#"; + } + *pp=p; + *plen=strlen(p); +} +/* ========== Routines for Evaluation Cycle ========== */ + +/* make closure. c is code. e is environment */ +static pointer mk_closure(scheme *sc, pointer c, pointer e) { + pointer x = get_cell(sc, c, e); + + typeflag(x) = T_CLOSURE; + car(x) = c; + cdr(x) = e; + return (x); +} + +/* make continuation. */ +static pointer mk_continuation(scheme *sc, pointer d) { + pointer x = get_cell(sc, sc->NIL, d); + + typeflag(x) = T_CONTINUATION; + cont_dump(x) = d; + return (x); +} + +static pointer list_star(scheme *sc, pointer d) { + pointer p, q; + if(cdr(d)==sc->NIL) { + return car(d); + } + p=cons(sc,car(d),cdr(d)); + q=p; + while(cdr(cdr(p))!=sc->NIL) { + d=cons(sc,car(p),cdr(p)); + if(cdr(cdr(p))!=sc->NIL) { + p=cdr(d); + } + } + cdr(p)=car(cdr(p)); + return q; +} + +/* reverse list -- produce new list */ +static pointer reverse(scheme *sc, pointer term, pointer list) { +/* a must be checked by gc */ + pointer a = list, p = term; + + for ( ; is_pair(a); a = cdr(a)) { + p = cons(sc, car(a), p); + } + return (p); +} + +/* reverse list --- in-place */ +static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { + pointer p = list, result = term, q; + + while (p != sc->NIL) { + q = cdr(p); + cdr(p) = result; + result = p; + p = q; + } + return (result); +} + +/* append list -- produce new list (in reverse order) */ +static pointer revappend(scheme *sc, pointer a, pointer b) { + pointer result = a; + pointer p = b; + + while (is_pair(p)) { + result = cons(sc, car(p), result); + p = cdr(p); + } + + if (p == sc->NIL) { + return result; + } + + return sc->F; /* signal an error */ +} + +/* equivalence of atoms */ +int eqv(pointer a, pointer b) { + if (is_string(a)) { + if (is_string(b)) + return (strvalue(a) == strvalue(b)); + else + return (0); + } else if (is_number(a)) { + if (is_number(b)) { + if (num_is_integer(a) == num_is_integer(b)) + return num_eq(nvalue(a),nvalue(b)); + } + return (0); + } else if (is_character(a)) { + if (is_character(b)) + return charvalue(a)==charvalue(b); + else + return (0); + } else if (is_port(a)) { + if (is_port(b)) + return a==b; + else + return (0); + } else if (is_proc(a)) { + if (is_proc(b)) + return procnum(a)==procnum(b); + else + return (0); + } else { + return (a == b); + } +} + +/* true or false value macro */ +/* () is #t in R5RS */ +#define is_true(p) ((p) != sc->F) +#define is_false(p) ((p) == sc->F) + + +/* ========== Environment implementation ========== */ + +#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) + +static int hash_fn(const char *key, int table_size) +{ + unsigned int hashed = 0; + const char *c; + int bits_per_int = sizeof(unsigned int)*8; + + for (c = key; *c; c++) { + /* letters have about 5 bits in them */ + hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); + hashed ^= *c; + } + return hashed % table_size; +} +#endif + +/* Compares A and B. Returns an integer less than, equal to, or + * greater than zero if A is stored at a memory location that is + * numerical less than, equal to, or greater than that of B. */ +static int +pointercmp(pointer a, pointer b) +{ + uintptr_t a_n = (uintptr_t) a; + uintptr_t b_n = (uintptr_t) b; + + if (a_n < b_n) + return -1; + if (a_n > b_n) + return 1; + return 0; +} + +#ifndef USE_ALIST_ENV + +/* + * In this implementation, each frame of the environment may be + * a hash table: a vector of alists hashed by variable name. + * In practice, we use a vector only for the initial frame; + * subsequent frames are too small and transient for the lookup + * speed to out-weigh the cost of making a new vector. + */ + +static void new_frame_in_env(scheme *sc, pointer old_env) +{ + pointer new_frame; + + /* The interaction-environment has about 480 variables in it. */ + if (old_env == sc->NIL) { + new_frame = mk_vector(sc, 751); + } else { + new_frame = sc->NIL; + } + + gc_disable(sc, 1); + sc->envir = immutable_cons(sc, new_frame, old_env); + gc_enable(sc); + setenvironment(sc->envir); +} + +/* Find the slot in ENV under the key HDL. If ALL is given, look in + * all environments enclosing ENV. If the lookup fails, and SSLOT is + * given, the position where the new slot has to be inserted is stored + * at SSLOT. */ +static pointer +find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) +{ + pointer x,y; + int location; + pointer *sl; + int d; + assert(is_symbol(hdl)); + + for (x = env; x != sc->NIL; x = cdr(x)) { + if (is_vector(car(x))) { + location = hash_fn(symname(hdl), vector_length(car(x))); + sl = vector_elem_slot(car(x), location); + } else { + sl = &car(x); + } + for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) { + d = pointercmp(caar(y), hdl); + if (d == 0) + return car(y); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + + if (x == env && sslot) + *sslot = sl; /* Insert here. */ + + if (!all) + return sc->NIL; /* Miss, and stop looking. */ + } + + return sc->NIL; /* Not found in any environment. */ +} + +#else /* USE_ALIST_ENV */ + +static INLINE void new_frame_in_env(scheme *sc, pointer old_env) +{ + sc->envir = immutable_cons(sc, sc->NIL, old_env); + setenvironment(sc->envir); +} + +/* Find the slot in ENV under the key HDL. If ALL is given, look in + * all environments enclosing ENV. If the lookup fails, and SSLOT is + * given, the position where the new slot has to be inserted is stored + * at SSLOT. */ +static pointer +find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) +{ + pointer x,y; + pointer *sl; + int d; + assert(is_symbol(hdl)); + + for (x = env; x != sc->NIL; x = cdr(x)) { + for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) { + d = pointercmp(caar(y), hdl); + if (d == 0) + return car(y); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + + if (x == env && sslot) + *sslot = sl; /* Insert here. */ + + if (!all) + return sc->NIL; /* Miss, and stop looking. */ + } + + return sc->NIL; /* Not found in any environment. */ +} + +#endif /* USE_ALIST_ENV else */ + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + return find_slot_spec_in_env(sc, env, hdl, all, NULL); +} + +/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using + * find_slot_spec_in_env, and no insertion must be done between + * obtaining SSLOT and the call to this function. */ +static INLINE void new_slot_spec_in_env(scheme *sc, + pointer variable, pointer value, + pointer *sslot) +{ +#define new_slot_spec_in_env_allocates 2 + pointer slot; + gc_disable(sc, gc_reservations (new_slot_spec_in_env)); + slot = immutable_cons(sc, variable, value); + *sslot = immutable_cons(sc, slot, *sslot); + gc_enable(sc); +} + +static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) +{ +#define new_slot_in_env_allocates new_slot_spec_in_env_allocates + pointer slot; + pointer *sslot; + assert(is_symbol(variable)); + slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot); + assert(slot == sc->NIL); + new_slot_spec_in_env(sc, variable, value, sslot); +} + +static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) +{ + (void)sc; + cdr(slot) = value; +} + +static INLINE pointer slot_value_in_env(pointer slot) +{ + return cdr(slot); +} + + +/* ========== Evaluation Cycle ========== */ + + +static enum scheme_opcodes +_Error_1(scheme *sc, const char *s, pointer a) { + const char *str = s; + pointer history; +#if USE_ERROR_HOOK + pointer x; + pointer hdl=sc->ERROR_HOOK; +#endif + +#if SHOW_ERROR_LINE + char sbuf[STRBUFFSIZE]; +#endif + + history = history_flatten(sc); + +#if SHOW_ERROR_LINE + /* make sure error is not in REPL */ + if (((sc->load_stack[sc->file_i].kind & port_file) == 0 + || sc->load_stack[sc->file_i].rep.stdio.file != stdin)) { + pointer tag; + const char *fname; + int ln; + + if (history != sc->NIL && has_tag(car(history)) + && (tag = get_tag(sc, car(history))) + && is_string(car(tag)) && is_integer(cdr(tag))) { + fname = string_value(car(tag)); + ln = ivalue_unchecked(cdr(tag)); + } else { + fname = string_value(sc->load_stack[sc->file_i].filename); + ln = ivalue_unchecked(sc->load_stack[sc->file_i].curr_line); + } + + /* should never happen */ + if(!fname) fname = ""; + + /* we started from 0 */ + ln++; + snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s); + + str = (const char*)sbuf; + } +#endif + +#if USE_ERROR_HOOK + x=find_slot_in_env(sc,sc->envir,hdl,1); + if (x != sc->NIL) { + sc->code = cons(sc, cons(sc, sc->QUOTE, + cons(sc, history, sc->NIL)), + sc->NIL); + if(a!=0) { + sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)), + sc->code); + } else { + sc->code = cons(sc, sc->F, sc->code); + } + sc->code = cons(sc, mk_string(sc, str), sc->code); + setimmutable(car(sc->code)); + sc->code = cons(sc, slot_value_in_env(x), sc->code); + return OP_EVAL; + } +#endif + + if(a!=0) { + sc->args = cons(sc, (a), sc->NIL); + } else { + sc->args = sc->NIL; + } + sc->args = cons(sc, mk_string(sc, str), sc->args); + setimmutable(car(sc->args)); + return OP_ERR0; +} +#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; } +#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; } + +/* Too small to turn into function */ +# define BEGIN do { +# define END } while (0) + + + +/* Flags. The interpreter has a flags field. When the interpreter + * pushes a frame to the dump stack, it is encoded with the opcode. + * Therefore, we do not use the least significant byte. */ + +/* Masks used to encode and decode opcode and flags. */ +#define S_OP_MASK 0x000000ff +#define S_FLAG_MASK 0xffffff00 + +/* Set if the interpreter evaluates an expression in a tail context + * (see R5RS, section 3.5). If a function, procedure, or continuation + * is invoked while this flag is set, the call is recorded as tail + * call in the history buffer. */ +#define S_FLAG_TAIL_CONTEXT 0x00000100 + +/* Set flag F. */ +#define s_set_flag(sc, f) \ + BEGIN \ + (sc)->flags |= S_FLAG_ ## f; \ + END + +/* Clear flag F. */ +#define s_clear_flag(sc, f) \ + BEGIN \ + (sc)->flags &= ~ S_FLAG_ ## f; \ + END + +/* Check if flag F is set. */ +#define s_get_flag(sc, f) \ + !!((sc)->flags & S_FLAG_ ## f) + + + +/* Bounce back to Eval_Cycle and execute A. */ +#define s_goto(sc, a) { op = (a); goto dispatch; } + +#if USE_THREADED_CODE + +/* Do not bounce back to Eval_Cycle but execute A by jumping directly + * to it. */ +#define s_thread_to(sc, a) \ + BEGIN \ + op = (a); \ + goto a; \ + END + +/* Define a label OP and emit a case statement for OP. For use in the + * dispatch function. The slightly peculiar goto that is never + * executed avoids warnings about unused labels. */ +#define CASE(OP) case OP: if (0) goto OP; OP + +#else /* USE_THREADED_CODE */ +#define s_thread_to(sc, a) s_goto(sc, a) +#define CASE(OP) case OP +#endif /* USE_THREADED_CODE */ + +/* Return to the previous frame on the dump stack, setting the current + * value to A. */ +#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0)) + +/* Return to the previous frame on the dump stack, setting the current + * value to A, and re-enable the garbage collector. */ +#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1)) + +static INLINE void dump_stack_reset(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + dump_stack_reset(sc); + sc->frame_freelist = sc->NIL; +} + +static void dump_stack_free(scheme *sc) +{ + dump_stack_initialize(sc); +} + +const int frame_length = 4; + +static pointer +dump_stack_make_frame(scheme *sc) +{ + pointer frame; + + frame = mk_vector(sc, frame_length); + if (! sc->no_memory) + setframe(frame); + + return frame; +} + +static INLINE pointer * +frame_slots(pointer frame) +{ + return &frame->_object._vector._elements[0]; +} + +#define frame_payload vector_length + +static pointer +dump_stack_allocate_frame(scheme *sc) +{ + pointer frame = sc->frame_freelist; + if (frame == sc->NIL) { + if (gc_enabled(sc)) + frame = dump_stack_make_frame(sc); + else + gc_reservation_failure(sc); + } else + sc->frame_freelist = *frame_slots(frame); + return frame; +} + +static void +dump_stack_deallocate_frame(scheme *sc, pointer frame) +{ + pointer *p = frame_slots(frame); + *p++ = sc->frame_freelist; + *p++ = sc->NIL; + *p++ = sc->NIL; + *p++ = sc->NIL; + sc->frame_freelist = frame; +} + +static void +dump_stack_preallocate_frame(scheme *sc) +{ + pointer frame = dump_stack_make_frame(sc); + if (! sc->no_memory) + dump_stack_deallocate_frame(sc, frame); +} + +static enum scheme_opcodes +_s_return(scheme *sc, pointer a, int enable_gc) { + pointer dump = sc->dump; + pointer *p; + unsigned long v; + enum scheme_opcodes next_op; + sc->value = (a); + if (enable_gc) + gc_enable(sc); + if (dump == sc->NIL) + return OP_QUIT; + v = frame_payload(dump); + next_op = (int) (v & S_OP_MASK); + sc->flags = v & S_FLAG_MASK; + p = frame_slots(dump); + sc->args = *p++; + sc->envir = *p++; + sc->code = *p++; + sc->dump = *p++; + dump_stack_deallocate_frame(sc, dump); + return next_op; +} + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { +#define s_save_allocates 0 + pointer dump; + pointer *p; + gc_disable(sc, gc_reservations (s_save)); + dump = dump_stack_allocate_frame(sc); + frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op); + p = frame_slots(dump); + *p++ = args; + *p++ = sc->envir; + *p++ = code; + *p++ = sc->dump; + sc->dump = dump; + gc_enable(sc); +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + mark(sc->dump); + mark(sc->frame_freelist); +} + + + +#if USE_HISTORY + +static void +history_free(scheme *sc) +{ + sc->free(sc->history.m); + sc->history.tailstacks = sc->NIL; + sc->history.callstack = sc->NIL; +} + +static pointer +history_init(scheme *sc, size_t N, size_t M) +{ + size_t i; + struct history *h = &sc->history; + + h->N = N; + h->mask_N = N - 1; + h->n = N - 1; + assert ((N & h->mask_N) == 0); + + h->M = M; + h->mask_M = M - 1; + assert ((M & h->mask_M) == 0); + + h->callstack = mk_vector(sc, N); + if (h->callstack == sc->sink) + goto fail; + + h->tailstacks = mk_vector(sc, N); + for (i = 0; i < N; i++) { + pointer tailstack = mk_vector(sc, M); + if (tailstack == sc->sink) + goto fail; + set_vector_elem(h->tailstacks, i, tailstack); + } + + h->m = sc->malloc(N * sizeof *h->m); + if (h->m == NULL) + goto fail; + + for (i = 0; i < N; i++) + h->m[i] = 0; + + return sc->T; + +fail: + history_free(sc); + return sc->F; +} + +static void +history_mark(scheme *sc) +{ + struct history *h = &sc->history; + mark(h->callstack); + mark(h->tailstacks); +} + +#define add_mod(a, b, mask) (((a) + (b)) & (mask)) +#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask) + +static INLINE void +tailstack_clear(scheme *sc, pointer v) +{ + assert(is_vector(v)); + /* XXX optimize */ + fill_vector(v, sc->NIL); +} + +static pointer +callstack_pop(scheme *sc) +{ + struct history *h = &sc->history; + size_t n = h->n; + pointer item; + + if (h->callstack == sc->NIL) + return sc->NIL; + + item = vector_elem(h->callstack, n); + /* Clear our frame so that it can be gc'ed and we don't run into it + * when walking the history. */ + set_vector_elem(h->callstack, n, sc->NIL); + tailstack_clear(sc, vector_elem(h->tailstacks, n)); + + /* Exit from the frame. */ + h->n = sub_mod(h->n, 1, h->mask_N); + + return item; +} + +static void +callstack_push(scheme *sc, pointer item) +{ + struct history *h = &sc->history; + size_t n = h->n; + + if (h->callstack == sc->NIL) + return; + + /* Enter a new frame. */ + n = h->n = add_mod(n, 1, h->mask_N); + + /* Initialize tail stack. */ + tailstack_clear(sc, vector_elem(h->tailstacks, n)); + h->m[n] = h->mask_M; + + set_vector_elem(h->callstack, n, item); +} + +static void +tailstack_push(scheme *sc, pointer item) +{ + struct history *h = &sc->history; + size_t n = h->n; + size_t m = h->m[n]; + + if (h->callstack == sc->NIL) + return; + + /* Enter a new tail frame. */ + m = h->m[n] = add_mod(m, 1, h->mask_M); + set_vector_elem(vector_elem(h->tailstacks, n), m, item); +} + +static pointer +tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n, + pointer acc) +{ + struct history *h = &sc->history; + pointer frame; + + assert(i <= h->M); + assert(n < h->M); + + if (acc == sc->sink) + return sc->sink; + + if (i == 0) { + /* We reached the end, but we did not see a unused frame. Signal + this using '... . */ + return cons(sc, mk_symbol(sc, "..."), acc); + } + + frame = vector_elem(tailstack, n); + if (frame == sc->NIL) { + /* A unused frame. We reached the end of the history. */ + return acc; + } + + /* Add us. */ + acc = cons(sc, frame, acc); + + return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M), + acc); +} + +static pointer +callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc) +{ + struct history *h = &sc->history; + pointer frame; + + assert(i <= h->N); + assert(n < h->N); + + if (acc == sc->sink) + return sc->sink; + + if (i == 0) { + /* We reached the end, but we did not see a unused frame. Signal + this using '... . */ + return cons(sc, mk_symbol(sc, "..."), acc); + } + + frame = vector_elem(h->callstack, n); + if (frame == sc->NIL) { + /* A unused frame. We reached the end of the history. */ + return acc; + } + + /* First, emit the tail calls. */ + acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n], + acc); + + /* Then us. */ + acc = cons(sc, frame, acc); + + return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc); +} + +static pointer +history_flatten(scheme *sc) +{ + struct history *h = &sc->history; + pointer history; + + if (h->callstack == sc->NIL) + return sc->NIL; + + history = callstack_flatten(sc, h->N, h->n, sc->NIL); + if (history == sc->sink) + return sc->sink; + + return reverse_in_place(sc, sc->NIL, history); +} + +#undef add_mod +#undef sub_mod + +#else /* USE_HISTORY */ + +#define history_init(SC, A, B) (void) 0 +#define history_free(SC) (void) 0 +#define callstack_pop(SC) (void) 0 +#define callstack_push(SC, X) (void) 0 +#define tailstack_push(SC, X) (void) 0 + +#endif /* USE_HISTORY */ + + + +#if USE_PLIST +static pointer +get_property(scheme *sc, pointer obj, pointer key) +{ + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + return cdar(x); + + return sc->NIL; +} + +static pointer +set_property(scheme *sc, pointer obj, pointer key, pointer value) +{ +#define set_property_allocates 2 + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + cdar(x) = value; + else { + gc_disable(sc, gc_reservations(set_property)); + symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); + gc_enable(sc); + } + + return sc->T; +} +#endif + + + +static int is_list(scheme *sc, pointer a) +{ return list_length(sc,a) >= 0; } + +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +int list_length(scheme *sc, pointer a) { + int i=0; + pointer slow, fast; + + slow = fast = a; + while (1) + { + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + fast = cdr(fast); + ++i; + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + ++i; + fast = cdr(fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr(slow); + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + + + +#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) + +/* kernel of this interpreter */ +static void +Eval_Cycle(scheme *sc, enum scheme_opcodes op) { + for (;;) { + pointer x, y; + pointer callsite; + num v; +#if USE_MATH + double dd; +#endif + int (*comp_func)(num, num) = NULL; + const struct op_code_info *pcd; + + dispatch: + pcd = &dispatch_table[op]; + if (pcd->name[0] != 0) { /* if built-in function, check arguments */ + char msg[STRBUFFSIZE]; + if (! check_arguments (sc, pcd, msg, sizeof msg)) { + s_goto(sc, _Error_1(sc, msg, 0)); + } + } + + if(sc->no_memory) { + fprintf(stderr,"No memory!\n"); + exit(1); + } + ok_to_freely_gc(sc); + + switch (op) { + CASE(OP_LOAD): /* load */ + if(file_interactive(sc)) { + fprintf(sc->outport->_object._port->rep.stdio.file, + "Loading %s\n", strvalue(car(sc->args))); + } + if (!file_push(sc, car(sc->args))) { + Error_1(sc,"unable to open", car(sc->args)); + } + else + { + sc->args = mk_integer(sc,sc->file_i); + s_thread_to(sc,OP_T0LVL); + } + + CASE(OP_T0LVL): /* top level */ + /* If we reached the end of file, this loop is done. */ + if(sc->loadport->_object._port->kind & port_saw_EOF) + { + if(sc->file_i == 0) + { + sc->args=sc->NIL; + sc->nesting = sc->nesting_stack[0]; + s_thread_to(sc,OP_QUIT); + } + else + { + file_pop(sc); + s_return(sc,sc->value); + } + /* NOTREACHED */ + } + + /* If interactive, be nice to user. */ + if(file_interactive(sc)) + { + sc->envir = sc->global_env; + dump_stack_reset(sc); + putstr(sc,"\n"); + putstr(sc,prompt); + } + + /* Set up another iteration of REPL */ + sc->nesting=0; + sc->save_inport=sc->inport; + sc->inport = sc->loadport; + s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); + s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); + s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); + s_thread_to(sc,OP_READ_INTERNAL); + + CASE(OP_T1LVL): /* top level */ + sc->code = sc->value; + sc->inport=sc->save_inport; + s_thread_to(sc,OP_EVAL); + + CASE(OP_READ_INTERNAL): /* internal read */ + sc->tok = token(sc); + if(sc->tok==TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + s_thread_to(sc,OP_RDSEXPR); + + CASE(OP_GENSYM): + s_return(sc, gensym(sc)); + + CASE(OP_VALUEPRINT): /* print evaluation result */ + /* OP_VALUEPRINT is always pushed, because when changing from + non-interactive to interactive mode, it needs to be + already on the stack */ + if(sc->tracing) { + putstr(sc,"\nGives: "); + } + if(file_interactive(sc)) { + sc->print_flag = 1; + sc->args = sc->value; + s_thread_to(sc,OP_P0LIST); + } else { + s_return(sc,sc->value); + } + + CASE(OP_EVAL): /* main part of evaluation */ +#if USE_TRACING + if(sc->tracing) { + /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ + s_save(sc,OP_REAL_EVAL,sc->args,sc->code); + sc->args=sc->code; + putstr(sc,"\nEval: "); + s_thread_to(sc,OP_P0LIST); + } + /* fall through */ + CASE(OP_REAL_EVAL): +#endif + if (is_symbol(sc->code)) { /* symbol */ + x=find_slot_in_env(sc,sc->envir,sc->code,1); + if (x != sc->NIL) { + s_return(sc,slot_value_in_env(x)); + } else { + Error_1(sc, "eval: unbound variable", sc->code); + } + } else if (is_pair(sc->code)) { + if (is_syntax(x = car(sc->code))) { /* SYNTAX */ + sc->code = cdr(sc->code); + s_goto(sc, syntaxnum(sc, x)); + } else {/* first, eval top element and eval arguments */ + s_save(sc,OP_E0ARGS, sc->NIL, sc->code); + /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ + sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } + } else { + s_return(sc,sc->code); + } + + CASE(OP_E0ARGS): /* eval arguments */ + if (is_macro(sc->value)) { /* macro expansion */ + gc_disable(sc, 1 + gc_reservations (s_save)); + s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); + sc->args = cons(sc,sc->code, sc->NIL); + gc_enable(sc); + sc->code = sc->value; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_APPLY); + } else { + gc_disable(sc, 1); + sc->args = cons(sc, sc->code, sc->NIL); + gc_enable(sc); + sc->code = cdr(sc->code); + s_thread_to(sc,OP_E1ARGS); + } + + CASE(OP_E1ARGS): /* eval arguments */ + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); + sc->code = car(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + s_thread_to(sc,OP_APPLY_CODE); + } + +#if USE_TRACING + CASE(OP_TRACING): { + int tr=sc->tracing; + sc->tracing=ivalue(car(sc->args)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, tr)); + } +#endif + +#if USE_HISTORY + CASE(OP_CALLSTACK_POP): /* pop the call stack */ + callstack_pop(sc); + s_return(sc, sc->value); +#endif + + CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)', + * record in the history as invoked from + * 'car(args)' */ + free_cons(sc, sc->args, &callsite, &sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + /* Fallthrough. */ + + CASE(OP_APPLY): /* apply 'code' to 'args' */ +#if USE_TRACING + if(sc->tracing) { + s_save(sc,OP_REAL_APPLY,sc->args,sc->code); + sc->print_flag = 1; + /* sc->args=cons(sc,sc->code,sc->args);*/ + putstr(sc,"\nApply to: "); + s_thread_to(sc,OP_P0LIST); + } + /* fall through */ + CASE(OP_REAL_APPLY): +#endif +#if USE_HISTORY + if (op != OP_APPLY_CODE) + callsite = sc->code; + if (s_get_flag(sc, TAIL_CONTEXT)) { + /* We are evaluating a tail call. */ + tailstack_push(sc, callsite); + } else { + callstack_push(sc, callsite); + s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL); + } +#endif + + if (is_proc(sc->code)) { + s_goto(sc,procnum(sc->code)); /* PROCEDURE */ + } else if (is_foreign(sc->code)) + { + /* Keep nested calls from GC'ing the arglist */ + push_recent_alloc(sc,sc->args,sc->NIL); + x=sc->code->_object._ff(sc,sc->args); + s_return(sc,x); + } else if (is_closure(sc->code) || is_macro(sc->code) + || is_promise(sc->code)) { /* CLOSURE */ + /* Should not accept promise */ + /* make environment */ + new_frame_in_env(sc, closure_env(sc->code)); + for (x = car(closure_code(sc->code)), y = sc->args; + is_pair(x); x = cdr(x), y = cdr(y)) { + if (y == sc->NIL) { + Error_1(sc, "not enough arguments, missing", x); + } else if (is_symbol(car(x))) { + new_slot_in_env(sc, car(x), car(y)); + } else { + Error_1(sc, "syntax error in closure: not a symbol", car(x)); + } + } + + if (x == sc->NIL) { + if (y != sc->NIL) { + Error_0(sc, "too many arguments"); + } + } else if (is_symbol(x)) + new_slot_in_env(sc, x, y); + else { + Error_1(sc, "syntax error in closure: not a symbol", x); + } + sc->code = cdr(closure_code(sc->code)); + sc->args = sc->NIL; + s_set_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_BEGIN); + } else if (is_continuation(sc->code)) { /* CONTINUATION */ + sc->dump = cont_dump(sc->code); + s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); + } else { + Error_1(sc,"illegal function",sc->code); + } + + CASE(OP_DOMACRO): /* do macro */ + sc->code = sc->value; + s_thread_to(sc,OP_EVAL); + +#if USE_COMPILE_HOOK + CASE(OP_LAMBDA): /* lambda */ + /* If the hook is defined, apply it to sc->code, otherwise + set sc->value fall through */ + { + pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); + if(f==sc->NIL) { + sc->value = sc->code; + /* Fallthru */ + } else { + gc_disable(sc, 1 + gc_reservations (s_save)); + s_save(sc,OP_LAMBDA1,sc->args,sc->code); + sc->args=cons(sc,sc->code,sc->NIL); + gc_enable(sc); + sc->code=slot_value_in_env(f); + s_thread_to(sc,OP_APPLY); + } + } + /* Fallthrough. */ +#else + CASE(OP_LAMBDA): /* lambda */ + sc->value = sc->code; + /* Fallthrough. */ +#endif + + CASE(OP_LAMBDA1): + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); + + + CASE(OP_MKCLOSURE): /* make-closure */ + x=car(sc->args); + if(car(x)==sc->LAMBDA) { + x=cdr(x); + } + if(cdr(sc->args)==sc->NIL) { + y=sc->envir; + } else { + y=cadr(sc->args); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, x, y)); + + CASE(OP_QUOTE): /* quote */ + s_return(sc,car(sc->code)); + + CASE(OP_DEF0): /* define */ + if(is_immutable(car(sc->code))) + Error_1(sc,"define: unable to alter immutable", car(sc->code)); + + if (is_pair(car(sc->code))) { + x = caar(sc->code); + gc_disable(sc, 2); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_DEF1, sc->NIL, x); + s_thread_to(sc,OP_EVAL); + + CASE(OP_DEF1): { /* define */ + pointer *sslot; + x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_spec_in_env(sc, sc->code, sc->value, sslot); + } + s_return(sc,sc->code); + } + + CASE(OP_DEFP): /* defined? */ + x=sc->envir; + if(cdr(sc->args)!=sc->NIL) { + x=cadr(sc->args); + } + s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); + + CASE(OP_SET0): /* set! */ + if(is_immutable(car(sc->code))) + Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); + s_save(sc,OP_SET1, sc->NIL, car(sc->code)); + sc->code = cadr(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_SET1): /* set! */ + y=find_slot_in_env(sc,sc->envir,sc->code,1); + if (y != sc->NIL) { + set_slot_in_env(sc, y, sc->value); + s_return(sc,sc->value); + } else { + Error_1(sc, "set!: unbound variable", sc->code); + } + + + CASE(OP_BEGIN): /* begin */ + { + int last; + + if (!is_pair(sc->code)) { + s_return(sc,sc->code); + } + + last = cdr(sc->code) == sc->NIL; + if (!last) { + s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); + } + sc->code = car(sc->code); + if (! last) + /* This is not the end of the list. This is not a tail + * position. */ + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } + + CASE(OP_IF0): /* if */ + s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_IF1): /* if */ + if (is_true(sc->value)) + sc->code = car(sc->code); + else + sc->code = cadr(sc->code); /* (if #f 1) ==> () because + * car(sc->NIL) = sc->NIL */ + s_thread_to(sc,OP_EVAL); + + CASE(OP_LET0): /* let */ + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); + s_thread_to(sc,OP_LET1); + + CASE(OP_LET1): /* let (calculate parameters) */ + gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0)); + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + gc_enable(sc); + Error_1(sc, "Bad syntax of binding spec in let", + car(sc->code)); + } + s_save(sc,OP_LET1, sc->args, cdr(sc->code)); + gc_enable(sc); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + gc_enable(sc); + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_thread_to(sc,OP_LET2); + } + + CASE(OP_LET2): /* let */ + new_frame_in_env(sc, sc->envir); + for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; + y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + if (is_symbol(car(sc->code))) { /* named let */ + for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { + if (!is_pair(x)) + Error_1(sc, "Bad syntax of binding in let", x); + if (!is_list(sc, car(x))) + Error_1(sc, "Bad syntax of binding in let", car(x)); + gc_disable(sc, 1); + sc->args = cons(sc, caar(x), sc->args); + gc_enable(sc); + } + gc_disable(sc, 2 + gc_reservations (new_slot_in_env)); + x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); + new_slot_in_env(sc, car(sc->code), x); + gc_enable(sc); + sc->code = cddr(sc->code); + sc->args = sc->NIL; + } else { + sc->code = cdr(sc->code); + sc->args = sc->NIL; + } + s_thread_to(sc,OP_BEGIN); + + CASE(OP_LET0AST): /* let* */ + if (car(sc->code) == sc->NIL) { + new_frame_in_env(sc, sc->envir); + sc->code = cdr(sc->code); + s_thread_to(sc,OP_BEGIN); + } + if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code)); + } + s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); + sc->code = cadaar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_LET1AST): /* let* (make new frame) */ + new_frame_in_env(sc, sc->envir); + s_thread_to(sc,OP_LET2AST); + + CASE(OP_LET2AST): /* let* (calculate parameters) */ + new_slot_in_env(sc, caar(sc->code), sc->value); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_LET2AST, sc->args, sc->code); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + sc->code = sc->args; + sc->args = sc->NIL; + s_thread_to(sc,OP_BEGIN); + } + + CASE(OP_LET0REC): /* letrec */ + new_frame_in_env(sc, sc->envir); + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = car(sc->code); + s_thread_to(sc,OP_LET1REC); + + CASE(OP_LET1REC): /* letrec (calculate parameters) */ + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in letrec", + car(sc->code)); + } + s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_thread_to(sc,OP_LET2REC); + } + + CASE(OP_LET2REC): /* letrec */ + for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + sc->code = cdr(sc->code); + sc->args = sc->NIL; + s_thread_to(sc,OP_BEGIN); + + CASE(OP_COND0): /* cond */ + if (!is_pair(sc->code)) { + Error_0(sc,"syntax error in cond"); + } + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_COND1): /* cond */ + if (is_true(sc->value)) { + if ((sc->code = cdar(sc->code)) == sc->NIL) { + s_return(sc,sc->value); + } + if(!sc->code || car(sc->code)==sc->FEED_TO) { + if(!is_pair(cdr(sc->code))) { + Error_0(sc,"syntax error in cond"); + } + gc_disable(sc, 4); + x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); + sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); + gc_enable(sc); + s_thread_to(sc,OP_EVAL); + } + s_thread_to(sc,OP_BEGIN); + } else { + if ((sc->code = cdr(sc->code)) == sc->NIL) { + s_return(sc,sc->NIL); + } else { + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } + } + + CASE(OP_DELAY): /* delay */ + gc_disable(sc, 2); + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return_enable_gc(sc,x); + + CASE(OP_AND0): /* and */ + if (sc->code == sc->NIL) { + s_return(sc,sc->T); + } + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_AND1): /* and */ + if (is_false(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + } + + CASE(OP_OR0): /* or */ + if (sc->code == sc->NIL) { + s_return(sc,sc->F); + } + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_OR1): /* or */ + if (is_true(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + } + + CASE(OP_C0STREAM): /* cons-stream */ + s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_C1STREAM): /* cons-stream */ + sc->args = sc->value; /* save sc->value to register sc->args for gc */ + gc_disable(sc, 3); + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return_enable_gc(sc, cons(sc, sc->args, x)); + + CASE(OP_MACRO0): /* macro */ + if (is_pair(car(sc->code))) { + x = caar(sc->code); + gc_disable(sc, 2); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_MACRO1, sc->NIL, x); + s_thread_to(sc,OP_EVAL); + + CASE(OP_MACRO1): { /* macro */ + pointer *sslot; + typeflag(sc->value) = T_MACRO; + x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_spec_in_env(sc, sc->code, sc->value, sslot); + } + s_return(sc,sc->code); + } + + CASE(OP_CASE0): /* case */ + s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_CASE1): /* case */ + for (x = sc->code; x != sc->NIL; x = cdr(x)) { + if (!is_pair(y = caar(x))) { + break; + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (eqv(car(y), sc->value)) { + break; + } + } + if (y != sc->NIL) { + break; + } + } + if (x != sc->NIL) { + if (is_pair(caar(x))) { + sc->code = cdar(x); + s_thread_to(sc,OP_BEGIN); + } else {/* else */ + s_save(sc,OP_CASE2, sc->NIL, cdar(x)); + sc->code = caar(x); + s_thread_to(sc,OP_EVAL); + } + } else { + s_return(sc,sc->NIL); + } + + CASE(OP_CASE2): /* case */ + if (is_true(sc->value)) { + s_thread_to(sc,OP_BEGIN); + } else { + s_return(sc,sc->NIL); + } + + CASE(OP_PAPPLY): /* apply */ + sc->code = car(sc->args); + sc->args = list_star(sc,cdr(sc->args)); + /*sc->args = cadr(sc->args);*/ + s_thread_to(sc,OP_APPLY); + + CASE(OP_PEVAL): /* eval */ + if(cdr(sc->args)!=sc->NIL) { + sc->envir=cadr(sc->args); + } + sc->code = car(sc->args); + s_thread_to(sc,OP_EVAL); + + CASE(OP_CONTINUATION): /* call-with-current-continuation */ + sc->code = car(sc->args); + gc_disable(sc, 2); + sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); + gc_enable(sc); + s_thread_to(sc,OP_APPLY); + +#if USE_MATH + CASE(OP_INEX2EX): /* inexact->exact */ + x=car(sc->args); + if(num_is_integer(x)) { + s_return(sc,x); + } else if(modf(rvalue_unchecked(x),&dd)==0.0) { + s_return(sc,mk_integer(sc,ivalue(x))); + } else { + Error_1(sc, "inexact->exact: not integral", x); + } + + CASE(OP_EXP): + x=car(sc->args); + s_return(sc, mk_real(sc, exp(rvalue(x)))); + + CASE(OP_LOG): + x=car(sc->args); + s_return(sc, mk_real(sc, log(rvalue(x)))); + + CASE(OP_SIN): + x=car(sc->args); + s_return(sc, mk_real(sc, sin(rvalue(x)))); + + CASE(OP_COS): + x=car(sc->args); + s_return(sc, mk_real(sc, cos(rvalue(x)))); + + CASE(OP_TAN): + x=car(sc->args); + s_return(sc, mk_real(sc, tan(rvalue(x)))); + + CASE(OP_ASIN): + x=car(sc->args); + s_return(sc, mk_real(sc, asin(rvalue(x)))); + + CASE(OP_ACOS): + x=car(sc->args); + s_return(sc, mk_real(sc, acos(rvalue(x)))); + + CASE(OP_ATAN): + x=car(sc->args); + if(cdr(sc->args)==sc->NIL) { + s_return(sc, mk_real(sc, atan(rvalue(x)))); + } else { + pointer y=cadr(sc->args); + s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); + } + + CASE(OP_SQRT): + x=car(sc->args); + s_return(sc, mk_real(sc, sqrt(rvalue(x)))); + + CASE(OP_EXPT): { + double result; + int real_result=1; + pointer y=cadr(sc->args); + x=car(sc->args); + if (num_is_integer(x) && num_is_integer(y)) + real_result=0; + /* This 'if' is an R5RS compatibility fix. */ + /* NOTE: Remove this 'if' fix for R6RS. */ + if (rvalue(x) == 0 && rvalue(y) < 0) { + result = 0.0; + } else { + result = pow(rvalue(x),rvalue(y)); + } + /* Before returning integer result make sure we can. */ + /* If the test fails, result is too big for integer. */ + if (!real_result) + { + long result_as_long = (long)result; + if (result != (double)result_as_long) + real_result = 1; + } + if (real_result) { + s_return(sc, mk_real(sc, result)); + } else { + s_return(sc, mk_integer(sc, result)); + } + } + + CASE(OP_FLOOR): + x=car(sc->args); + s_return(sc, mk_real(sc, floor(rvalue(x)))); + + CASE(OP_CEILING): + x=car(sc->args); + s_return(sc, mk_real(sc, ceil(rvalue(x)))); + + CASE(OP_TRUNCATE ): { + double rvalue_of_x ; + x=car(sc->args); + rvalue_of_x = rvalue(x) ; + if (rvalue_of_x > 0) { + s_return(sc, mk_real(sc, floor(rvalue_of_x))); + } else { + s_return(sc, mk_real(sc, ceil(rvalue_of_x))); + } + } + + CASE(OP_ROUND): + x=car(sc->args); + if (num_is_integer(x)) + s_return(sc, x); + s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); +#endif + + CASE(OP_ADD): /* + */ + v=num_zero; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_add(v,nvalue(car(x))); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_MUL): /* * */ + v=num_one; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_mul(v,nvalue(car(x))); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_SUB): /* - */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_zero; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + v=num_sub(v,nvalue(car(x))); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_DIV): /* / */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (!is_zero_double(rvalue(car(x)))) + v=num_div(v,nvalue(car(x))); + else { + Error_0(sc,"/: division by zero"); + } + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_INTDIV): /* quotient */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (ivalue(car(x)) != 0) + v=num_intdiv(v,nvalue(car(x))); + else { + Error_0(sc,"quotient: division by zero"); + } + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_REM): /* remainder */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_rem(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"remainder: division by zero"); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_MOD): /* modulo */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_mod(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"modulo: division by zero"); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_CAR): /* car */ + s_return(sc,caar(sc->args)); + + CASE(OP_CDR): /* cdr */ + s_return(sc,cdar(sc->args)); + + CASE(OP_CONS): /* cons */ + cdr(sc->args) = cadr(sc->args); + s_return(sc,sc->args); + + CASE(OP_SETCAR): /* set-car! */ + if(!is_immutable(car(sc->args))) { + caar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-car!: unable to alter immutable pair"); + } + + CASE(OP_SETCDR): /* set-cdr! */ + if(!is_immutable(car(sc->args))) { + cdar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-cdr!: unable to alter immutable pair"); + } + + CASE(OP_CHAR2INT): { /* char->integer */ + char c; + c=(char)ivalue(car(sc->args)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c)); + } + + CASE(OP_INT2CHAR): { /* integer->char */ + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); + } + + CASE(OP_CHARUPCASE): { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=toupper(c); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); + } + + CASE(OP_CHARDNCASE): { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=tolower(c); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); + } + + CASE(OP_STR2SYM): /* string->symbol */ + gc_disable(sc, gc_reservations (mk_symbol)); + s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args)))); + + CASE(OP_STR2ATOM): /* string->atom */ { + char *s=strvalue(car(sc->args)); + long pf = 0; + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "string->atom: bad base", cadr(sc->args)); + } else if(*s=='#') /* no use of base! */ { + s_return(sc, mk_sharp_const(sc, s+1)); + } else { + if (pf == 0 || pf == 10) { + s_return(sc, mk_atom(sc, s)); + } + else { + char *ep; + long iv = strtol(s,&ep,(int )pf); + if (*ep == 0) { + s_return(sc, mk_integer(sc, iv)); + } + else { + s_return(sc, sc->F); + } + } + } + } + + CASE(OP_SYM2STR): /* symbol->string */ + gc_disable(sc, 1); + x=mk_string(sc,symname(car(sc->args))); + setimmutable(x); + s_return_enable_gc(sc, x); + + CASE(OP_ATOM2STR): /* atom->string */ { + long pf = 0; + x=car(sc->args); + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "atom->string: bad base", cadr(sc->args)); + } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { + char *p; + int len; + atom2str(sc,x,(int )pf,&p,&len); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_counted_string(sc, p, len)); + } else { + Error_1(sc, "atom->string: not an atom", x); + } + } + + CASE(OP_MKSTRING): { /* make-string */ + int fill=' '; + int len; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=charvalue(cadr(sc->args)); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill)); + } + + CASE(OP_STRLEN): /* string-length */ + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args)))); + + CASE(OP_STRREF): { /* string-ref */ + char *str; + int index; + + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + + if(index>=strlength(car(sc->args))) { + Error_1(sc, "string-ref: out of bounds", cadr(sc->args)); + } + + gc_disable(sc, 1); + s_return_enable_gc(sc, + mk_character(sc, ((unsigned char*) str)[index])); + } + + CASE(OP_STRSET): { /* string-set! */ + char *str; + int index; + int c; + + if(is_immutable(car(sc->args))) { + Error_1(sc, "string-set!: unable to alter immutable string", + car(sc->args)); + } + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + if(index>=strlength(car(sc->args))) { + Error_1(sc, "string-set!: out of bounds", cadr(sc->args)); + } + + c=charvalue(caddr(sc->args)); + + str[index]=(char)c; + s_return(sc,car(sc->args)); + } + + CASE(OP_STRAPPEND): { /* string-append */ + /* in 1.29 string-append was in Scheme in init.scm but was too slow */ + int len = 0; + pointer newstr; + char *pos; + + /* compute needed length for new string */ + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + len += strlength(car(x)); + } + gc_disable(sc, 1); + newstr = mk_empty_string(sc, len, ' '); + /* store the contents of the argument strings into the new string */ + for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; + pos += strlength(car(x)), x = cdr(x)) { + memcpy(pos, strvalue(car(x)), strlength(car(x))); + } + s_return_enable_gc(sc, newstr); + } + + CASE(OP_SUBSTR): { /* substring */ + char *str; + int index0; + int index1; + + str=strvalue(car(sc->args)); + + index0=ivalue(cadr(sc->args)); + + if(index0>strlength(car(sc->args))) { + Error_1(sc, "substring: start out of bounds", cadr(sc->args)); + } + + if(cddr(sc->args)!=sc->NIL) { + index1=ivalue(caddr(sc->args)); + if(index1>strlength(car(sc->args)) || index1args)); + } + } else { + index1=strlength(car(sc->args)); + } + + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0)); + } + + CASE(OP_VECTOR): { /* vector */ + int i; + pointer vec; + int len=list_length(sc,sc->args); + if(len<0) { + Error_1(sc, "vector: not a proper list", sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { + set_vector_elem(vec,i,car(x)); + } + s_return(sc,vec); + } + + CASE(OP_MKVECTOR): { /* make-vector */ + pointer fill=sc->NIL; + int len; + pointer vec; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=cadr(sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + if(fill!=sc->NIL) { + fill_vector(vec,fill); + } + s_return(sc,vec); + } + + CASE(OP_VECLEN): /* vector-length */ + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args)))); + + CASE(OP_VECREF): { /* vector-ref */ + int index; + + index=ivalue(cadr(sc->args)); + + if(index >= vector_length(car(sc->args))) { + Error_1(sc, "vector-ref: out of bounds", cadr(sc->args)); + } + + s_return(sc,vector_elem(car(sc->args),index)); + } + + CASE(OP_VECSET): { /* vector-set! */ + int index; + + if(is_immutable(car(sc->args))) { + Error_1(sc, "vector-set!: unable to alter immutable vector", + car(sc->args)); + } + + index=ivalue(cadr(sc->args)); + if(index >= vector_length(car(sc->args))) { + Error_1(sc, "vector-set!: out of bounds", cadr(sc->args)); + } + + set_vector_elem(car(sc->args),index,caddr(sc->args)); + s_return(sc,car(sc->args)); + } + + CASE(OP_NOT): /* not */ + s_retbool(is_false(car(sc->args))); + CASE(OP_BOOLP): /* boolean? */ + s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); + CASE(OP_EOFOBJP): /* boolean? */ + s_retbool(car(sc->args) == sc->EOF_OBJ); + CASE(OP_NULLP): /* null? */ + s_retbool(car(sc->args) == sc->NIL); + CASE(OP_NUMEQ): /* = */ + /* Fallthrough. */ + CASE(OP_LESS): /* < */ + /* Fallthrough. */ + CASE(OP_GRE): /* > */ + /* Fallthrough. */ + CASE(OP_LEQ): /* <= */ + /* Fallthrough. */ + CASE(OP_GEQ): /* >= */ + switch(op) { + case OP_NUMEQ: comp_func=num_eq; break; + case OP_LESS: comp_func=num_lt; break; + case OP_GRE: comp_func=num_gt; break; + case OP_LEQ: comp_func=num_le; break; + case OP_GEQ: comp_func=num_ge; break; + default: assert (! "reached"); + } + x=sc->args; + v=nvalue(car(x)); + x=cdr(x); + + for (; x != sc->NIL; x = cdr(x)) { + if(!comp_func(v,nvalue(car(x)))) { + s_retbool(0); + } + v=nvalue(car(x)); + } + s_retbool(1); + CASE(OP_SYMBOLP): /* symbol? */ + s_retbool(is_symbol(car(sc->args))); + CASE(OP_NUMBERP): /* number? */ + s_retbool(is_number(car(sc->args))); + CASE(OP_STRINGP): /* string? */ + s_retbool(is_string(car(sc->args))); + CASE(OP_INTEGERP): /* integer? */ + s_retbool(is_integer(car(sc->args))); + CASE(OP_REALP): /* real? */ + s_retbool(is_number(car(sc->args))); /* All numbers are real */ + CASE(OP_CHARP): /* char? */ + s_retbool(is_character(car(sc->args))); +#if USE_CHAR_CLASSIFIERS + CASE(OP_CHARAP): /* char-alphabetic? */ + s_retbool(Cisalpha(ivalue(car(sc->args)))); + CASE(OP_CHARNP): /* char-numeric? */ + s_retbool(Cisdigit(ivalue(car(sc->args)))); + CASE(OP_CHARWP): /* char-whitespace? */ + s_retbool(Cisspace(ivalue(car(sc->args)))); + CASE(OP_CHARUP): /* char-upper-case? */ + s_retbool(Cisupper(ivalue(car(sc->args)))); + CASE(OP_CHARLP): /* char-lower-case? */ + s_retbool(Cislower(ivalue(car(sc->args)))); +#endif + CASE(OP_PORTP): /* port? */ + s_retbool(is_port(car(sc->args))); + CASE(OP_INPORTP): /* input-port? */ + s_retbool(is_inport(car(sc->args))); + CASE(OP_OUTPORTP): /* output-port? */ + s_retbool(is_outport(car(sc->args))); + CASE(OP_PROCP): /* procedure? */ + /*-- + * continuation should be procedure by the example + * (call-with-current-continuation procedure?) ==> #t + * in R^3 report sec. 6.9 + */ + s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) + || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); + CASE(OP_PAIRP): /* pair? */ + s_retbool(is_pair(car(sc->args))); + CASE(OP_LISTP): /* list? */ + s_retbool(list_length(sc,car(sc->args)) >= 0); + + CASE(OP_ENVP): /* environment? */ + s_retbool(is_environment(car(sc->args))); + CASE(OP_VECTORP): /* vector? */ + s_retbool(is_vector(car(sc->args))); + CASE(OP_EQ): /* eq? */ + s_retbool(car(sc->args) == cadr(sc->args)); + CASE(OP_EQV): /* eqv? */ + s_retbool(eqv(car(sc->args), cadr(sc->args))); + + CASE(OP_FORCE): /* force */ + sc->code = car(sc->args); + if (is_promise(sc->code)) { + /* Should change type to closure here */ + s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); + sc->args = sc->NIL; + s_thread_to(sc,OP_APPLY); + } else { + s_return(sc,sc->code); + } + + CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */ + copy_value(sc, sc->code, sc->value); + s_return(sc,sc->value); + + CASE(OP_WRITE): /* write */ + /* Fallthrough. */ + CASE(OP_DISPLAY): /* display */ + /* Fallthrough. */ + CASE(OP_WRITE_CHAR): /* write-char */ + if(is_pair(cdr(sc->args))) { + if(cadr(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=cadr(sc->args); + } + } + sc->args = car(sc->args); + if(op==OP_WRITE) { + sc->print_flag = 1; + } else { + sc->print_flag = 0; + } + s_thread_to(sc,OP_P0LIST); + + CASE(OP_NEWLINE): /* newline */ + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=car(sc->args); + } + } + putstr(sc, "\n"); + s_return(sc,sc->T); + + CASE(OP_ERR0): /* error */ + sc->retcode=-1; + if (!is_string(car(sc->args))) { + sc->args=cons(sc,mk_string(sc," -- "),sc->args); + setimmutable(car(sc->args)); + } + putstr(sc, "Error: "); + putstr(sc, strvalue(car(sc->args))); + sc->args = cdr(sc->args); + s_thread_to(sc,OP_ERR1); + + CASE(OP_ERR1): /* error */ + putstr(sc, " "); + if (sc->args != sc->NIL) { + s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + sc->print_flag = 1; + s_thread_to(sc,OP_P0LIST); + } else { + putstr(sc, "\n"); + if(sc->interactive_repl) { + s_thread_to(sc,OP_T0LVL); + } else { + return; + } + } + + CASE(OP_REVERSE): /* reverse */ + s_return(sc,reverse(sc, sc->NIL, car(sc->args))); + + CASE(OP_REVERSE_IN_PLACE): /* reverse! */ + s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args))); + + CASE(OP_LIST_STAR): /* list* */ + s_return(sc,list_star(sc,sc->args)); + + CASE(OP_APPEND): /* append */ + x = sc->NIL; + y = sc->args; + if (y == x) { + s_return(sc, x); + } + + /* cdr() in the while condition is not a typo. If car() */ + /* is used (append '() 'a) will return the wrong result.*/ + while (cdr(y) != sc->NIL) { + x = revappend(sc, x, car(y)); + y = cdr(y); + if (x == sc->F) { + Error_0(sc, "non-list argument to append"); + } + } + + s_return(sc, reverse_in_place(sc, car(y), x)); + +#if USE_PLIST + CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */ + gc_disable(sc, gc_reservations(set_property)); + s_return_enable_gc(sc, + set_property(sc, car(sc->args), + cadr(sc->args), caddr(sc->args))); + + CASE(OP_SYMBOL_PROPERTY): /* symbol-property */ + s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); +#endif /* USE_PLIST */ + + CASE(OP_TAG_VALUE): { /* not exposed */ + /* This tags sc->value with car(sc->args). Useful to tag + * results of opcode evaluations. */ + pointer a, b, c; + free_cons(sc, sc->args, &a, &b); + free_cons(sc, b, &b, &c); + assert(c == sc->NIL); + s_return(sc, mk_tagged_value(sc, sc->value, a, b)); + } + + CASE(OP_MK_TAGGED): /* make-tagged-value */ + if (is_vector(car(sc->args))) + Error_0(sc, "cannot tag vector"); + s_return(sc, mk_tagged_value(sc, car(sc->args), + car(cadr(sc->args)), + cdr(cadr(sc->args)))); + + CASE(OP_GET_TAG): /* get-tag */ + s_return(sc, get_tag(sc, car(sc->args))); + + CASE(OP_QUIT): /* quit */ + if(is_pair(sc->args)) { + sc->retcode=ivalue(car(sc->args)); + } + return; + + CASE(OP_GC): /* gc */ + gc(sc, sc->NIL, sc->NIL); + s_return(sc,sc->T); + + CASE(OP_GCVERB): /* gc-verbose */ + { int was = sc->gc_verbose; + + sc->gc_verbose = (car(sc->args) != sc->F); + s_retbool(was); + } + + CASE(OP_NEWSEGMENT): /* new-segment */ + if (!is_pair(sc->args) || !is_number(car(sc->args))) { + Error_0(sc,"new-segment: argument must be a number"); + } + alloc_cellseg(sc, (int) ivalue(car(sc->args))); + s_return(sc,sc->T); + + CASE(OP_OBLIST): /* oblist */ + s_return(sc, oblist_all_symbols(sc)); + + CASE(OP_CURR_INPORT): /* current-input-port */ + s_return(sc,sc->inport); + + CASE(OP_CURR_OUTPORT): /* current-output-port */ + s_return(sc,sc->outport); + + CASE(OP_OPEN_INFILE): /* open-input-file */ + /* Fallthrough. */ + CASE(OP_OPEN_OUTFILE): /* open-output-file */ + /* Fallthrough. */ + CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INFILE: prop=port_input; break; + case OP_OPEN_OUTFILE: prop=port_output; break; + case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; + default: assert (! "reached"); + } + p=port_from_filename(sc,strvalue(car(sc->args)),prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + break; + } + +#if USE_STRING_PORTS + CASE(OP_OPEN_INSTRING): /* open-input-string */ + /* Fallthrough. */ + CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INSTRING: prop=port_input; break; + case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; + default: assert (! "reached"); + } + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + } + CASE(OP_OPEN_OUTSTRING): /* open-output-string */ { + pointer p; + if(car(sc->args)==sc->NIL) { + p=port_from_scratch(sc); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } else { + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), + port_output); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } + s_return(sc,p); + } + CASE(OP_GET_OUTSTRING): /* get-output-string */ { + port *p; + + if ((p=car(sc->args)->_object._port)->kind&port_string) { + gc_disable(sc, 1); + s_return_enable_gc( + sc, + mk_counted_string(sc, + p->rep.string.start, + p->rep.string.curr - p->rep.string.start)); + } + s_return(sc,sc->F); + } +#endif + + CASE(OP_CLOSE_INPORT): /* close-input-port */ + port_close(sc,car(sc->args),port_input); + s_return(sc,sc->T); + + CASE(OP_CLOSE_OUTPORT): /* close-output-port */ + port_close(sc,car(sc->args),port_output); + s_return(sc,sc->T); + + CASE(OP_INT_ENV): /* interaction-environment */ + s_return(sc,sc->global_env); + + CASE(OP_CURR_ENV): /* current-environment */ + s_return(sc,sc->envir); + + + /* ========== reading part ========== */ + CASE(OP_READ): + if(!is_pair(sc->args)) { + s_thread_to(sc,OP_READ_INTERNAL); + } + if(!is_inport(car(sc->args))) { + Error_1(sc, "read: not an input port", car(sc->args)); + } + if(car(sc->args)==sc->inport) { + s_thread_to(sc,OP_READ_INTERNAL); + } + x=sc->inport; + sc->inport=car(sc->args); + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + s_thread_to(sc,OP_READ_INTERNAL); + + CASE(OP_READ_CHAR): /* read-char */ + /* Fallthrough. */ + CASE(OP_PEEK_CHAR): /* peek-char */ { + int c; + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->inport) { + x=sc->inport; + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + sc->inport=car(sc->args); + } + } + c=inchar(sc); + if(c==EOF) { + s_return(sc,sc->EOF_OBJ); + } + if(op==OP_PEEK_CHAR) { + backchar(sc,c); + } + s_return(sc,mk_character(sc,c)); + } + + CASE(OP_CHAR_READY): /* char-ready? */ { + pointer p=sc->inport; + int res; + if(is_pair(sc->args)) { + p=car(sc->args); + } + res=p->_object._port->kind&port_string; + s_retbool(res); + } + + CASE(OP_SET_INPORT): /* set-input-port */ + sc->inport=car(sc->args); + s_return(sc,sc->value); + + CASE(OP_SET_OUTPORT): /* set-output-port */ + sc->outport=car(sc->args); + s_return(sc,sc->value); + + CASE(OP_RDSEXPR): + switch (sc->tok) { + case TOK_EOF: + s_return(sc,sc->EOF_OBJ); + /* NOTREACHED */ + case TOK_VEC: + s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); + /* fall through */ + case TOK_LPAREN: + sc->tok = token(sc); + if (sc->tok == TOK_RPAREN) { + s_return(sc,sc->NIL); + } else if (sc->tok == TOK_DOT) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { +#if SHOW_ERROR_LINE + pointer filename; + pointer lineno; +#endif + sc->nesting_stack[sc->file_i]++; +#if SHOW_ERROR_LINE + filename = sc->load_stack[sc->file_i].filename; + lineno = sc->load_stack[sc->file_i].curr_line; + + s_save(sc, OP_TAG_VALUE, + cons(sc, filename, cons(sc, lineno, sc->NIL)), + sc->NIL); +#endif + s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); + s_thread_to(sc,OP_RDSEXPR); + } + case TOK_QUOTE: + s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + case TOK_BQUOTE: + sc->tok = token(sc); + if(sc->tok==TOK_VEC) { + s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); + sc->tok=TOK_LPAREN; + s_thread_to(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); + } + s_thread_to(sc,OP_RDSEXPR); + case TOK_COMMA: + s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + case TOK_ATMARK: + s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + case TOK_ATOM: + s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); + case TOK_DQUOTE: + x=readstrexp(sc); + if(x==sc->F) { + Error_0(sc,"Error reading string"); + } + setimmutable(x); + s_return(sc,x); + case TOK_SHARP: { + pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); + if(f==sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + sc->code=cons(sc,slot_value_in_env(f),sc->NIL); + s_thread_to(sc,OP_EVAL); + } + } + case TOK_SHARP_CONST: + if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + s_return(sc,x); + } + default: + Error_0(sc,"syntax error: illegal token"); + } + break; + + CASE(OP_RDLIST): { + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); + sc->tok = token(sc); + if (sc->tok == TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + else if (sc->tok == TOK_RPAREN) { + int c = inchar(sc); + if (c != '\n') + backchar(sc,c); + else + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); + } else if (sc->tok == TOK_DOT) { + s_save(sc,OP_RDDOT, sc->args, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDLIST, sc->args, sc->NIL);; + s_thread_to(sc,OP_RDSEXPR); + } + } + + CASE(OP_RDDOT): + if (token(sc) != TOK_RPAREN) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->value, sc->args)); + } + + CASE(OP_RDQUOTE): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QUOTE, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDQQUOTE): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QQUOTE, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDQQUOTEVEC): + gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol)); + s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"), + cons(sc, mk_symbol(sc,"vector"), + cons(sc,cons(sc, sc->QQUOTE, + cons(sc,sc->value,sc->NIL)), + sc->NIL)))); + + CASE(OP_RDUNQUOTE): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTE, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDUQTSP): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDVEC): + /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_thread_to(sc,OP_EVAL); Cannot be quoted*/ + /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_return(sc,x); Cannot be part of pairs*/ + /*sc->code=mk_proc(sc,OP_VECTOR); + sc->args=sc->value; + s_thread_to(sc,OP_APPLY);*/ + sc->args=sc->value; + s_thread_to(sc,OP_VECTOR); + + /* ========== printing part ========== */ + CASE(OP_P0LIST): + if(is_vector(sc->args)) { + putstr(sc,"#("); + sc->args=cons(sc,sc->args,mk_integer(sc,0)); + s_thread_to(sc,OP_PVECFROM); + } else if(is_environment(sc->args)) { + putstr(sc,"#"); + s_return(sc,sc->T); + } else if (!is_pair(sc->args)) { + printatom(sc, sc->args, sc->print_flag); + s_return(sc,sc->T); + } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "'"); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "`"); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, ","); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { + putstr(sc, ",@"); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else { + putstr(sc, "("); + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + s_thread_to(sc,OP_P0LIST); + } + + CASE(OP_P1LIST): + if (is_pair(sc->args)) { + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + putstr(sc, " "); + sc->args = car(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if(is_vector(sc->args)) { + s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); + putstr(sc, " . "); + s_thread_to(sc,OP_P0LIST); + } else { + if (sc->args != sc->NIL) { + putstr(sc, " . "); + printatom(sc, sc->args, sc->print_flag); + } + putstr(sc, ")"); + s_return(sc,sc->T); + } + CASE(OP_PVECFROM): { + int i=ivalue_unchecked(cdr(sc->args)); + pointer vec=car(sc->args); + int len = vector_length(vec); + if(i==len) { + putstr(sc,")"); + s_return(sc,sc->T); + } else { + pointer elem=vector_elem(vec,i); + cdr(sc->args) = mk_integer(sc, i + 1); + s_save(sc,OP_PVECFROM, sc->args, sc->NIL); + sc->args=elem; + if (i > 0) + putstr(sc," "); + s_thread_to(sc,OP_P0LIST); + } + } + + CASE(OP_LIST_LENGTH): { /* length */ /* a.k */ + long l = list_length(sc, car(sc->args)); + if(l<0) { + Error_1(sc, "length: not a list", car(sc->args)); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, l)); + } + CASE(OP_ASSQ): /* assq */ /* a.k */ + x = car(sc->args); + for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { + if (!is_pair(car(y))) { + Error_0(sc,"unable to handle non pair element"); + } + if (x == caar(y)) + break; + } + if (is_pair(y)) { + s_return(sc,car(y)); + } else { + s_return(sc,sc->F); + } + + + CASE(OP_GET_CLOSURE): /* get-closure-code */ /* a.k */ + sc->args = car(sc->args); + if (sc->args == sc->NIL) { + s_return(sc,sc->F); + } else if (is_closure(sc->args)) { + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); + } else if (is_macro(sc->args)) { + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); + } else { + s_return(sc,sc->F); + } + CASE(OP_CLOSUREP): /* closure? */ + /* + * Note, macro object is also a closure. + * Therefore, (closure? <#MACRO>) ==> #t + */ + s_retbool(is_closure(car(sc->args))); + CASE(OP_MACROP): /* macro? */ + s_retbool(is_macro(car(sc->args))); + CASE(OP_VM_HISTORY): /* *vm-history* */ + s_return(sc, history_flatten(sc)); + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op); + Error_0(sc,sc->strbuff); + } + } +} + +typedef int (*test_predicate)(pointer); + +static int is_any(pointer p) { + (void)p; + return 1; +} + +static int is_nonneg(pointer p) { + return ivalue(p)>=0 && is_integer(p); +} + +/* Correspond carefully with following defines! */ +static const struct { + test_predicate fct; + const char *kind; +} tests[]={ + {0,0}, /* unused */ + {is_any, 0}, + {is_string, "string"}, + {is_symbol, "symbol"}, + {is_port, "port"}, + {is_inport,"input port"}, + {is_outport,"output port"}, + {is_environment, "environment"}, + {is_pair, "pair"}, + {0, "pair or '()"}, + {is_character, "character"}, + {is_vector, "vector"}, + {is_number, "number"}, + {is_integer, "integer"}, + {is_nonneg, "non-negative integer"} +}; + +#define TST_NONE 0 +#define TST_ANY "\001" +#define TST_STRING "\002" +#define TST_SYMBOL "\003" +#define TST_PORT "\004" +#define TST_INPORT "\005" +#define TST_OUTPORT "\006" +#define TST_ENVIRONMENT "\007" +#define TST_PAIR "\010" +#define TST_LIST "\011" +#define TST_CHAR "\012" +#define TST_VECTOR "\013" +#define TST_NUMBER "\014" +#define TST_INTEGER "\015" +#define TST_NATURAL "\016" + +#define INF_ARG 0xff + +static const struct op_code_info dispatch_table[]= { +#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}}, +#include "opdefines.h" +#undef _OP_DEF + {{0},0,0,{0}}, +}; + +static const char *procname(pointer x) { + int n=procnum(x); + const char *name=dispatch_table[n].name; + if (name[0] == 0) { + name="ILLEGAL!"; + } + return name; +} + +static int +check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size) +{ + int ok = 1; + int n = list_length(sc, sc->args); + + /* Check number of arguments */ + if (n < pcd->min_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at least", + pcd->min_arity); + } + if (ok && n>pcd->max_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at most", + pcd->max_arity); + } + if (ok) { + if (pcd->arg_tests_encoding[0] != 0) { + int i = 0; + int j; + const char *t = pcd->arg_tests_encoding; + pointer arglist = sc->args; + + do { + pointer arg = car(arglist); + j = (int)t[0]; + if (j == TST_LIST[0]) { + if (arg != sc->NIL && !is_pair(arg)) break; + } else { + if (!tests[j].fct(arg)) break; + } + + if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { + /* last test is replicated as necessary */ + t++; + } + arglist = cdr(arglist); + i++; + } while (i < n); + + if (i < n) { + ok = 0; + snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s", + pcd->name, + i + 1, + tests[j].kind, + type_to_string(type(car(arglist)))); + } + } + } + + return ok; +} + +/* ========== Initialization of internal keywords ========== */ + +/* Symbols representing syntax are tagged with (OP . '()). */ +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) { + pointer x, y; + pointer *slot; + + x = oblist_find_by_name(sc, name, &slot); + assert (x == sc->NIL); + + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL | T_SYNTAX; + setimmutable(car(x)); + y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL); + free_cell(sc, x); + setimmutable(get_tag(sc, y)); + *slot = immutable_cons(sc, y, *slot); +} + +/* Returns the opcode for the syntax represented by P. */ +static int syntaxnum(scheme *sc, pointer p) { + int op = ivalue_unchecked(car(get_tag(sc, p))); + assert (op < OP_MAXDEFINED); + return op; +} + +static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) { + pointer x, y; + + x = mk_symbol(sc, name); + y = mk_proc(sc,op); + new_slot_in_env(sc, x, y); +} + +static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { + pointer y; + + y = get_cell(sc, sc->NIL, sc->NIL); + typeflag(y) = (T_PROC | T_ATOM); + ivalue_unchecked(y) = (long) op; + set_num_integer(y); + return y; +} + +/* initialization of TinyScheme */ +#if USE_INTERFACE +INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { + return cons(sc,a,b); +} +INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { + return immutable_cons(sc,a,b); +} + +static const struct scheme_interface vtbl = { + scheme_define, + s_cons, + s_immutable_cons, + reserve_cells, + mk_integer, + mk_real, + mk_symbol, + gensym, + mk_string, + mk_counted_string, + mk_character, + mk_vector, + mk_foreign_func, + mk_foreign_object, + get_foreign_object_vtable, + get_foreign_object_data, + putstr, + putcharacter, + + is_string, + string_value, + is_number, + nvalue, + ivalue, + rvalue, + is_integer, + is_real, + is_character, + charvalue, + is_list, + is_vector, + list_length, + ivalue, + fill_vector, + vector_elem, + set_vector_elem, + is_port, + is_pair, + pair_car, + pair_cdr, + set_car, + set_cdr, + + is_symbol, + symname, + + is_syntax, + is_proc, + is_foreign, + syntaxname, + is_closure, + is_macro, + closure_code, + closure_env, + + is_continuation, + is_promise, + is_environment, + is_immutable, + setimmutable, + + scheme_load_file, + scheme_load_string, + port_from_file +}; +#endif + +scheme *scheme_init_new() { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init(sc)) { + free(sc); + return 0; + } else { + return sc; + } +} + +scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init_custom_alloc(sc,malloc,free)) { + free(sc); + return 0; + } else { + return sc; + } +} + + +int scheme_init(scheme *sc) { + return scheme_init_custom_alloc(sc,malloc,free); +} + +int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { + int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); + pointer x; + +#if USE_INTERFACE + sc->vptr=&vtbl; +#endif + sc->gensym_cnt=0; + sc->malloc=malloc; + sc->free=free; + sc->sink = &sc->_sink; + sc->NIL = &sc->_NIL; + sc->T = &sc->_HASHT; + sc->F = &sc->_HASHF; + sc->EOF_OBJ=&sc->_EOF_OBJ; + + sc->free_cell = &sc->_NIL; + sc->fcells = 0; + sc->inhibit_gc = GC_ENABLED; + sc->reserved_cells = 0; + sc->reserved_lineno = 0; + sc->no_memory=0; + sc->inport=sc->NIL; + sc->outport=sc->NIL; + sc->save_inport=sc->NIL; + sc->loadport=sc->NIL; + sc->nesting=0; + memset (sc->nesting_stack, 0, sizeof sc->nesting_stack); + sc->interactive_repl=0; + sc->strbuff = sc->malloc(STRBUFFSIZE); + if (sc->strbuff == 0) { + sc->no_memory=1; + return 0; + } + sc->strbuff_size = STRBUFFSIZE; + + sc->cell_segments = NULL; + if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { + sc->no_memory=1; + return 0; + } + sc->gc_verbose = 0; + dump_stack_initialize(sc); + sc->code = sc->NIL; + sc->tracing=0; + sc->flags = 0; + + /* init sc->NIL */ + typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK); + car(sc->NIL) = cdr(sc->NIL) = sc->NIL; + /* init T */ + typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK); + car(sc->T) = cdr(sc->T) = sc->T; + /* init F */ + typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK); + car(sc->F) = cdr(sc->F) = sc->F; + /* init EOF_OBJ */ + typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK); + car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; + /* init sink */ + typeflag(sc->sink) = (T_SINK | T_PAIR | MARK); + car(sc->sink) = cdr(sc->sink) = sc->NIL; + /* init c_nest */ + sc->c_nest = sc->NIL; + + sc->oblist = oblist_initial_value(sc); + /* init global_env */ + new_frame_in_env(sc, sc->NIL); + sc->global_env = sc->envir; + /* init else */ + x = mk_symbol(sc,"else"); + new_slot_in_env(sc, x, sc->T); + + assign_syntax(sc, OP_LAMBDA, "lambda"); + assign_syntax(sc, OP_QUOTE, "quote"); + assign_syntax(sc, OP_DEF0, "define"); + assign_syntax(sc, OP_IF0, "if"); + assign_syntax(sc, OP_BEGIN, "begin"); + assign_syntax(sc, OP_SET0, "set!"); + assign_syntax(sc, OP_LET0, "let"); + assign_syntax(sc, OP_LET0AST, "let*"); + assign_syntax(sc, OP_LET0REC, "letrec"); + assign_syntax(sc, OP_COND0, "cond"); + assign_syntax(sc, OP_DELAY, "delay"); + assign_syntax(sc, OP_AND0, "and"); + assign_syntax(sc, OP_OR0, "or"); + assign_syntax(sc, OP_C0STREAM, "cons-stream"); + assign_syntax(sc, OP_MACRO0, "macro"); + assign_syntax(sc, OP_CASE0, "case"); + + for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); + sc->QUOTE = mk_symbol(sc, "quote"); + sc->QQUOTE = mk_symbol(sc, "quasiquote"); + sc->UNQUOTE = mk_symbol(sc, "unquote"); + sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); + sc->FEED_TO = mk_symbol(sc, "=>"); + sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); + sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); + sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); +#if USE_COMPILE_HOOK + sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); +#endif + + return !sc->no_memory; +} + +void scheme_set_input_port_file(scheme *sc, FILE *fin) { + sc->inport=port_from_file(sc,fin,port_input); +} + +void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { + sc->inport=port_from_string(sc,start,past_the_end,port_input); +} + +void scheme_set_output_port_file(scheme *sc, FILE *fout) { + sc->outport=port_from_file(sc,fout,port_output); +} + +void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { + sc->outport=port_from_string(sc,start,past_the_end,port_output); +} + +void scheme_set_external_data(scheme *sc, void *p) { + sc->ext_data=p; +} + +void scheme_deinit(scheme *sc) { + struct cell_segment *s; + int i; + + sc->oblist=sc->NIL; + sc->global_env=sc->NIL; + dump_stack_free(sc); + sc->envir=sc->NIL; + sc->code=sc->NIL; + history_free(sc); + sc->args=sc->NIL; + sc->value=sc->NIL; + if(is_port(sc->inport)) { + typeflag(sc->inport) = T_ATOM; + } + sc->inport=sc->NIL; + sc->outport=sc->NIL; + if(is_port(sc->save_inport)) { + typeflag(sc->save_inport) = T_ATOM; + } + sc->save_inport=sc->NIL; + if(is_port(sc->loadport)) { + typeflag(sc->loadport) = T_ATOM; + } + sc->loadport=sc->NIL; + + for(i=0; i<=sc->file_i; i++) { + port_clear_location(sc, &sc->load_stack[i]); + } + + sc->gc_verbose=0; + gc(sc,sc->NIL,sc->NIL); + + for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) { + /* nop */ + } + sc->free(sc->strbuff); +} + +void scheme_load_file(scheme *sc, FILE *fin) +{ scheme_load_named_file(sc,fin,0); } + +void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_file; + sc->load_stack[0].rep.stdio.file=fin; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + if(fin==stdin) { + sc->interactive_repl=1; + } + + port_init_location(sc, &sc->load_stack[0], + (fin != stdin && filename) + ? mk_string(sc, filename) + : NULL); + + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } + + port_clear_location(sc, &sc->load_stack[0]); +} + +void scheme_load_string(scheme *sc, const char *cmd) { + scheme_load_memory(sc, cmd, strlen(cmd), NULL); +} + +void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_string; + sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */ + sc->load_stack[0].rep.string.past_the_end = (char *) buf + len; + sc->load_stack[0].rep.string.curr = (char *) buf; + port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL); + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + sc->interactive_repl=0; + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } + + port_clear_location(sc, &sc->load_stack[0]); +} + +void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { + pointer x; + pointer *sslot; + x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot); + if (x != sc->NIL) { + set_slot_in_env(sc, x, value); + } else { + new_slot_spec_in_env(sc, symbol, value, sslot); + } +} + +#if !STANDALONE +void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) +{ + scheme_define(sc, + sc->global_env, + mk_symbol(sc,sr->name), + mk_foreign_func(sc, sr->f)); +} + +void scheme_register_foreign_func_list(scheme * sc, + scheme_registerable * list, + int count) +{ + int i; + for(i = 0; i < count; i++) + { + scheme_register_foreign_func(sc, list + i); + } +} + +pointer scheme_apply0(scheme *sc, const char *procname) +{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } + +void save_from_C_call(scheme *sc) +{ + pointer saved_data = + cons(sc, + car(sc->sink), + cons(sc, + sc->envir, + sc->dump)); + /* Push */ + sc->c_nest = cons(sc, saved_data, sc->c_nest); + /* Truncate the dump stack so TS will return here when done, not + directly resume pre-C-call operations. */ + dump_stack_reset(sc); +} +void restore_from_C_call(scheme *sc) +{ + car(sc->sink) = caar(sc->c_nest); + sc->envir = cadar(sc->c_nest); + sc->dump = cdr(cdar(sc->c_nest)); + /* Pop */ + sc->c_nest = cdr(sc->c_nest); +} + +/* "func" and "args" are assumed to be already eval'ed. */ +pointer scheme_call(scheme *sc, pointer func, pointer args) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->envir = sc->global_env; + sc->args = args; + sc->code = func; + sc->retcode = 0; + Eval_Cycle(sc, OP_APPLY); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + +pointer scheme_eval(scheme *sc, pointer obj) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->args = sc->NIL; + sc->code = obj; + sc->retcode = 0; + Eval_Cycle(sc, OP_EVAL); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + + +#endif + +/* ========== Main ========== */ + +#if STANDALONE + +#if defined(__APPLE__) && !defined (OSX) +int main() +{ + extern MacTS_main(int argc, char **argv); + char** argv; + int argc = ccommand(&argv); + MacTS_main(argc,argv); + return 0; +} +int MacTS_main(int argc, char **argv) { +#else +int main(int argc, char **argv) { +#endif + scheme sc; + FILE *fin; + char *file_name=InitFile; + int retcode; + int isfile=1; + + if(argc==1) { + printf(banner); + } + if(argc==2 && strcmp(argv[1],"-?")==0) { + printf("Usage: tinyscheme -?\n"); + printf("or: tinyscheme [ ...]\n"); + printf("followed by\n"); + printf(" -1 [ ...]\n"); + printf(" -c [ ...]\n"); + printf("assuming that the executable is named tinyscheme.\n"); + printf("Use - as filename for stdin.\n"); + return 1; + } + if(!scheme_init(&sc)) { + fprintf(stderr,"Could not initialize!\n"); + return 2; + } + scheme_set_input_port_file(&sc, stdin); + scheme_set_output_port_file(&sc, stdout); +#if USE_DL + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); +#endif + argv++; + if(access(file_name,0)!=0) { + char *p=getenv("TINYSCHEMEINIT"); + if(p!=0) { + file_name=p; + } + } + do { + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { + pointer args=sc.NIL; + isfile=file_name[1]=='1'; + file_name=*argv++; + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(isfile) { + fin=fopen(file_name,"r"); + } + for(;*argv;argv++) { + pointer value=mk_string(&sc,*argv); + args=cons(&sc,value,args); + } + args=reverse_in_place(&sc,sc.NIL,args); + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); + + } else { + fin=fopen(file_name,"r"); + } + if(isfile && fin==0) { + fprintf(stderr,"Could not open file %s\n",file_name); + } else { + if(isfile) { + scheme_load_named_file(&sc,fin,file_name); + } else { + scheme_load_string(&sc,file_name); + } + if(!isfile || fin!=stdin) { + if(sc.retcode!=0) { + fprintf(stderr,"Errors encountered reading %s\n",file_name); + } + if(isfile) { + fclose(fin); + } + } + } + file_name=*argv++; + } while(file_name!=0); + if(argc==1) { + scheme_load_named_file(&sc,stdin,0); + } + retcode=sc.retcode; + scheme_deinit(&sc); + + return retcode; +} + +#endif + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/gpgscm/scheme.h b/gpgscm/scheme.h new file mode 100644 index 0000000..6f917da --- /dev/null +++ b/gpgscm/scheme.h @@ -0,0 +1,290 @@ +/* SCHEME.H */ + +#ifndef _SCHEME_H +#define _SCHEME_H + +#include + +#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_COMPILE_HOOK 0 +# define USE_DL 0 +# define USE_PLIST 0 +# define USE_SMALL_INTEGERS 0 +# define USE_HISTORY 0 +#endif + + +#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 + +/* Keep a history of function calls. This enables a feature similar + * to stack traces. */ +#ifndef USE_HISTORY +# define USE_HISTORY 1 +#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 + +/* Compile functions using *compile-hook*. The default hook expands + * macros. */ +#ifndef USE_COMPILE_HOOK +# define USE_COMPILE_HOOK 1 +#endif + +/* Enable faster opcode dispatch. */ +#ifndef USE_THREADED_CODE +# define USE_THREADED_CODE 1 +#endif + +/* Use a static set of cells to represent small numbers. This set + * notably includes all opcodes, and hence saves a cell reservation + * during 's_save'. */ +#ifndef USE_SMALL_INTEGERS +# define USE_SMALL_INTEGERS 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 *); + +/* table of functions required for foreign objects */ +typedef struct foreign_object_vtable { + void (*finalize)(scheme *sc, void *data); + void (*to_string)(scheme *sc, char *out, size_t size, void *data); +} foreign_object_vtable; + +/* 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 void scheme_load_memory(scheme *sc, const char *buf, size_t len, + const char *filename); +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); +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data); +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); + pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data); + const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p); + void *(*get_foreign_object_data)(pointer p); + 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); + pointer (*mk_port_from_file)(scheme *sc, FILE *f, int kind); +}; +#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: +*/ diff --git a/gpgscm/small-integers.h b/gpgscm/small-integers.h new file mode 100644 index 0000000..46eda34 --- /dev/null +++ b/gpgscm/small-integers.h @@ -0,0 +1,847 @@ +/* Constant integer objects for TinySCHEME. + * + * Copyright (C) 2017 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +/* + * Ohne Worte. Generated using: + * + * $ n=0; while read line ; do \ + * echo "DEFINE_INTEGER($n)" ; \ + * n="$(expr $n + 1)" ; \ + * done <./init.scm >> small-integers.h + */ + +DEFINE_INTEGER(0) +DEFINE_INTEGER(1) +DEFINE_INTEGER(2) +DEFINE_INTEGER(3) +DEFINE_INTEGER(4) +DEFINE_INTEGER(5) +DEFINE_INTEGER(6) +DEFINE_INTEGER(7) +DEFINE_INTEGER(8) +DEFINE_INTEGER(9) +DEFINE_INTEGER(10) +DEFINE_INTEGER(11) +DEFINE_INTEGER(12) +DEFINE_INTEGER(13) +DEFINE_INTEGER(14) +DEFINE_INTEGER(15) +DEFINE_INTEGER(16) +DEFINE_INTEGER(17) +DEFINE_INTEGER(18) +DEFINE_INTEGER(19) +DEFINE_INTEGER(20) +DEFINE_INTEGER(21) +DEFINE_INTEGER(22) +DEFINE_INTEGER(23) +DEFINE_INTEGER(24) +DEFINE_INTEGER(25) +DEFINE_INTEGER(26) +DEFINE_INTEGER(27) +DEFINE_INTEGER(28) +DEFINE_INTEGER(29) +DEFINE_INTEGER(30) +DEFINE_INTEGER(31) +DEFINE_INTEGER(32) +DEFINE_INTEGER(33) +DEFINE_INTEGER(34) +DEFINE_INTEGER(35) +DEFINE_INTEGER(36) +DEFINE_INTEGER(37) +DEFINE_INTEGER(38) +DEFINE_INTEGER(39) +DEFINE_INTEGER(40) +DEFINE_INTEGER(41) +DEFINE_INTEGER(42) +DEFINE_INTEGER(43) +DEFINE_INTEGER(44) +DEFINE_INTEGER(45) +DEFINE_INTEGER(46) +DEFINE_INTEGER(47) +DEFINE_INTEGER(48) +DEFINE_INTEGER(49) +DEFINE_INTEGER(50) +DEFINE_INTEGER(51) +DEFINE_INTEGER(52) +DEFINE_INTEGER(53) +DEFINE_INTEGER(54) +DEFINE_INTEGER(55) +DEFINE_INTEGER(56) +DEFINE_INTEGER(57) +DEFINE_INTEGER(58) +DEFINE_INTEGER(59) +DEFINE_INTEGER(60) +DEFINE_INTEGER(61) +DEFINE_INTEGER(62) +DEFINE_INTEGER(63) +DEFINE_INTEGER(64) +DEFINE_INTEGER(65) +DEFINE_INTEGER(66) +DEFINE_INTEGER(67) +DEFINE_INTEGER(68) +DEFINE_INTEGER(69) +DEFINE_INTEGER(70) +DEFINE_INTEGER(71) +DEFINE_INTEGER(72) +DEFINE_INTEGER(73) +DEFINE_INTEGER(74) +DEFINE_INTEGER(75) +DEFINE_INTEGER(76) +DEFINE_INTEGER(77) +DEFINE_INTEGER(78) +DEFINE_INTEGER(79) +DEFINE_INTEGER(80) +DEFINE_INTEGER(81) +DEFINE_INTEGER(82) +DEFINE_INTEGER(83) +DEFINE_INTEGER(84) +DEFINE_INTEGER(85) +DEFINE_INTEGER(86) +DEFINE_INTEGER(87) +DEFINE_INTEGER(88) +DEFINE_INTEGER(89) +DEFINE_INTEGER(90) +DEFINE_INTEGER(91) +DEFINE_INTEGER(92) +DEFINE_INTEGER(93) +DEFINE_INTEGER(94) +DEFINE_INTEGER(95) +DEFINE_INTEGER(96) +DEFINE_INTEGER(97) +DEFINE_INTEGER(98) +DEFINE_INTEGER(99) +DEFINE_INTEGER(100) +DEFINE_INTEGER(101) +DEFINE_INTEGER(102) +DEFINE_INTEGER(103) +DEFINE_INTEGER(104) +DEFINE_INTEGER(105) +DEFINE_INTEGER(106) +DEFINE_INTEGER(107) +DEFINE_INTEGER(108) +DEFINE_INTEGER(109) +DEFINE_INTEGER(110) +DEFINE_INTEGER(111) +DEFINE_INTEGER(112) +DEFINE_INTEGER(113) +DEFINE_INTEGER(114) +DEFINE_INTEGER(115) +DEFINE_INTEGER(116) +DEFINE_INTEGER(117) +DEFINE_INTEGER(118) +DEFINE_INTEGER(119) +DEFINE_INTEGER(120) +DEFINE_INTEGER(121) +DEFINE_INTEGER(122) +DEFINE_INTEGER(123) +DEFINE_INTEGER(124) +DEFINE_INTEGER(125) +DEFINE_INTEGER(126) +DEFINE_INTEGER(127) +DEFINE_INTEGER(128) +DEFINE_INTEGER(129) +DEFINE_INTEGER(130) +DEFINE_INTEGER(131) +DEFINE_INTEGER(132) +DEFINE_INTEGER(133) +DEFINE_INTEGER(134) +DEFINE_INTEGER(135) +DEFINE_INTEGER(136) +DEFINE_INTEGER(137) +DEFINE_INTEGER(138) +DEFINE_INTEGER(139) +DEFINE_INTEGER(140) +DEFINE_INTEGER(141) +DEFINE_INTEGER(142) +DEFINE_INTEGER(143) +DEFINE_INTEGER(144) +DEFINE_INTEGER(145) +DEFINE_INTEGER(146) +DEFINE_INTEGER(147) +DEFINE_INTEGER(148) +DEFINE_INTEGER(149) +DEFINE_INTEGER(150) +DEFINE_INTEGER(151) +DEFINE_INTEGER(152) +DEFINE_INTEGER(153) +DEFINE_INTEGER(154) +DEFINE_INTEGER(155) +DEFINE_INTEGER(156) +DEFINE_INTEGER(157) +DEFINE_INTEGER(158) +DEFINE_INTEGER(159) +DEFINE_INTEGER(160) +DEFINE_INTEGER(161) +DEFINE_INTEGER(162) +DEFINE_INTEGER(163) +DEFINE_INTEGER(164) +DEFINE_INTEGER(165) +DEFINE_INTEGER(166) +DEFINE_INTEGER(167) +DEFINE_INTEGER(168) +DEFINE_INTEGER(169) +DEFINE_INTEGER(170) +DEFINE_INTEGER(171) +DEFINE_INTEGER(172) +DEFINE_INTEGER(173) +DEFINE_INTEGER(174) +DEFINE_INTEGER(175) +DEFINE_INTEGER(176) +DEFINE_INTEGER(177) +DEFINE_INTEGER(178) +DEFINE_INTEGER(179) +DEFINE_INTEGER(180) +DEFINE_INTEGER(181) +DEFINE_INTEGER(182) +DEFINE_INTEGER(183) +DEFINE_INTEGER(184) +DEFINE_INTEGER(185) +DEFINE_INTEGER(186) +DEFINE_INTEGER(187) +DEFINE_INTEGER(188) +DEFINE_INTEGER(189) +DEFINE_INTEGER(190) +DEFINE_INTEGER(191) +DEFINE_INTEGER(192) +DEFINE_INTEGER(193) +DEFINE_INTEGER(194) +DEFINE_INTEGER(195) +DEFINE_INTEGER(196) +DEFINE_INTEGER(197) +DEFINE_INTEGER(198) +DEFINE_INTEGER(199) +DEFINE_INTEGER(200) +DEFINE_INTEGER(201) +DEFINE_INTEGER(202) +DEFINE_INTEGER(203) +DEFINE_INTEGER(204) +DEFINE_INTEGER(205) +DEFINE_INTEGER(206) +DEFINE_INTEGER(207) +DEFINE_INTEGER(208) +DEFINE_INTEGER(209) +DEFINE_INTEGER(210) +DEFINE_INTEGER(211) +DEFINE_INTEGER(212) +DEFINE_INTEGER(213) +DEFINE_INTEGER(214) +DEFINE_INTEGER(215) +DEFINE_INTEGER(216) +DEFINE_INTEGER(217) +DEFINE_INTEGER(218) +DEFINE_INTEGER(219) +DEFINE_INTEGER(220) +DEFINE_INTEGER(221) +DEFINE_INTEGER(222) +DEFINE_INTEGER(223) +DEFINE_INTEGER(224) +DEFINE_INTEGER(225) +DEFINE_INTEGER(226) +DEFINE_INTEGER(227) +DEFINE_INTEGER(228) +DEFINE_INTEGER(229) +DEFINE_INTEGER(230) +DEFINE_INTEGER(231) +DEFINE_INTEGER(232) +DEFINE_INTEGER(233) +DEFINE_INTEGER(234) +DEFINE_INTEGER(235) +DEFINE_INTEGER(236) +DEFINE_INTEGER(237) +DEFINE_INTEGER(238) +DEFINE_INTEGER(239) +DEFINE_INTEGER(240) +DEFINE_INTEGER(241) +DEFINE_INTEGER(242) +DEFINE_INTEGER(243) +DEFINE_INTEGER(244) +DEFINE_INTEGER(245) +DEFINE_INTEGER(246) +DEFINE_INTEGER(247) +DEFINE_INTEGER(248) +DEFINE_INTEGER(249) +DEFINE_INTEGER(250) +DEFINE_INTEGER(251) +DEFINE_INTEGER(252) +DEFINE_INTEGER(253) +DEFINE_INTEGER(254) +DEFINE_INTEGER(255) +DEFINE_INTEGER(256) +DEFINE_INTEGER(257) +DEFINE_INTEGER(258) +DEFINE_INTEGER(259) +DEFINE_INTEGER(260) +DEFINE_INTEGER(261) +DEFINE_INTEGER(262) +DEFINE_INTEGER(263) +DEFINE_INTEGER(264) +DEFINE_INTEGER(265) +DEFINE_INTEGER(266) +DEFINE_INTEGER(267) +DEFINE_INTEGER(268) +DEFINE_INTEGER(269) +DEFINE_INTEGER(270) +DEFINE_INTEGER(271) +DEFINE_INTEGER(272) +DEFINE_INTEGER(273) +DEFINE_INTEGER(274) +DEFINE_INTEGER(275) +DEFINE_INTEGER(276) +DEFINE_INTEGER(277) +DEFINE_INTEGER(278) +DEFINE_INTEGER(279) +DEFINE_INTEGER(280) +DEFINE_INTEGER(281) +DEFINE_INTEGER(282) +DEFINE_INTEGER(283) +DEFINE_INTEGER(284) +DEFINE_INTEGER(285) +DEFINE_INTEGER(286) +DEFINE_INTEGER(287) +DEFINE_INTEGER(288) +DEFINE_INTEGER(289) +DEFINE_INTEGER(290) +DEFINE_INTEGER(291) +DEFINE_INTEGER(292) +DEFINE_INTEGER(293) +DEFINE_INTEGER(294) +DEFINE_INTEGER(295) +DEFINE_INTEGER(296) +DEFINE_INTEGER(297) +DEFINE_INTEGER(298) +DEFINE_INTEGER(299) +DEFINE_INTEGER(300) +DEFINE_INTEGER(301) +DEFINE_INTEGER(302) +DEFINE_INTEGER(303) +DEFINE_INTEGER(304) +DEFINE_INTEGER(305) +DEFINE_INTEGER(306) +DEFINE_INTEGER(307) +DEFINE_INTEGER(308) +DEFINE_INTEGER(309) +DEFINE_INTEGER(310) +DEFINE_INTEGER(311) +DEFINE_INTEGER(312) +DEFINE_INTEGER(313) +DEFINE_INTEGER(314) +DEFINE_INTEGER(315) +DEFINE_INTEGER(316) +DEFINE_INTEGER(317) +DEFINE_INTEGER(318) +DEFINE_INTEGER(319) +DEFINE_INTEGER(320) +DEFINE_INTEGER(321) +DEFINE_INTEGER(322) +DEFINE_INTEGER(323) +DEFINE_INTEGER(324) +DEFINE_INTEGER(325) +DEFINE_INTEGER(326) +DEFINE_INTEGER(327) +DEFINE_INTEGER(328) +DEFINE_INTEGER(329) +DEFINE_INTEGER(330) +DEFINE_INTEGER(331) +DEFINE_INTEGER(332) +DEFINE_INTEGER(333) +DEFINE_INTEGER(334) +DEFINE_INTEGER(335) +DEFINE_INTEGER(336) +DEFINE_INTEGER(337) +DEFINE_INTEGER(338) +DEFINE_INTEGER(339) +DEFINE_INTEGER(340) +DEFINE_INTEGER(341) +DEFINE_INTEGER(342) +DEFINE_INTEGER(343) +DEFINE_INTEGER(344) +DEFINE_INTEGER(345) +DEFINE_INTEGER(346) +DEFINE_INTEGER(347) +DEFINE_INTEGER(348) +DEFINE_INTEGER(349) +DEFINE_INTEGER(350) +DEFINE_INTEGER(351) +DEFINE_INTEGER(352) +DEFINE_INTEGER(353) +DEFINE_INTEGER(354) +DEFINE_INTEGER(355) +DEFINE_INTEGER(356) +DEFINE_INTEGER(357) +DEFINE_INTEGER(358) +DEFINE_INTEGER(359) +DEFINE_INTEGER(360) +DEFINE_INTEGER(361) +DEFINE_INTEGER(362) +DEFINE_INTEGER(363) +DEFINE_INTEGER(364) +DEFINE_INTEGER(365) +DEFINE_INTEGER(366) +DEFINE_INTEGER(367) +DEFINE_INTEGER(368) +DEFINE_INTEGER(369) +DEFINE_INTEGER(370) +DEFINE_INTEGER(371) +DEFINE_INTEGER(372) +DEFINE_INTEGER(373) +DEFINE_INTEGER(374) +DEFINE_INTEGER(375) +DEFINE_INTEGER(376) +DEFINE_INTEGER(377) +DEFINE_INTEGER(378) +DEFINE_INTEGER(379) +DEFINE_INTEGER(380) +DEFINE_INTEGER(381) +DEFINE_INTEGER(382) +DEFINE_INTEGER(383) +DEFINE_INTEGER(384) +DEFINE_INTEGER(385) +DEFINE_INTEGER(386) +DEFINE_INTEGER(387) +DEFINE_INTEGER(388) +DEFINE_INTEGER(389) +DEFINE_INTEGER(390) +DEFINE_INTEGER(391) +DEFINE_INTEGER(392) +DEFINE_INTEGER(393) +DEFINE_INTEGER(394) +DEFINE_INTEGER(395) +DEFINE_INTEGER(396) +DEFINE_INTEGER(397) +DEFINE_INTEGER(398) +DEFINE_INTEGER(399) +DEFINE_INTEGER(400) +DEFINE_INTEGER(401) +DEFINE_INTEGER(402) +DEFINE_INTEGER(403) +DEFINE_INTEGER(404) +DEFINE_INTEGER(405) +DEFINE_INTEGER(406) +DEFINE_INTEGER(407) +DEFINE_INTEGER(408) +DEFINE_INTEGER(409) +DEFINE_INTEGER(410) +DEFINE_INTEGER(411) +DEFINE_INTEGER(412) +DEFINE_INTEGER(413) +DEFINE_INTEGER(414) +DEFINE_INTEGER(415) +DEFINE_INTEGER(416) +DEFINE_INTEGER(417) +DEFINE_INTEGER(418) +DEFINE_INTEGER(419) +DEFINE_INTEGER(420) +DEFINE_INTEGER(421) +DEFINE_INTEGER(422) +DEFINE_INTEGER(423) +DEFINE_INTEGER(424) +DEFINE_INTEGER(425) +DEFINE_INTEGER(426) +DEFINE_INTEGER(427) +DEFINE_INTEGER(428) +DEFINE_INTEGER(429) +DEFINE_INTEGER(430) +DEFINE_INTEGER(431) +DEFINE_INTEGER(432) +DEFINE_INTEGER(433) +DEFINE_INTEGER(434) +DEFINE_INTEGER(435) +DEFINE_INTEGER(436) +DEFINE_INTEGER(437) +DEFINE_INTEGER(438) +DEFINE_INTEGER(439) +DEFINE_INTEGER(440) +DEFINE_INTEGER(441) +DEFINE_INTEGER(442) +DEFINE_INTEGER(443) +DEFINE_INTEGER(444) +DEFINE_INTEGER(445) +DEFINE_INTEGER(446) +DEFINE_INTEGER(447) +DEFINE_INTEGER(448) +DEFINE_INTEGER(449) +DEFINE_INTEGER(450) +DEFINE_INTEGER(451) +DEFINE_INTEGER(452) +DEFINE_INTEGER(453) +DEFINE_INTEGER(454) +DEFINE_INTEGER(455) +DEFINE_INTEGER(456) +DEFINE_INTEGER(457) +DEFINE_INTEGER(458) +DEFINE_INTEGER(459) +DEFINE_INTEGER(460) +DEFINE_INTEGER(461) +DEFINE_INTEGER(462) +DEFINE_INTEGER(463) +DEFINE_INTEGER(464) +DEFINE_INTEGER(465) +DEFINE_INTEGER(466) +DEFINE_INTEGER(467) +DEFINE_INTEGER(468) +DEFINE_INTEGER(469) +DEFINE_INTEGER(470) +DEFINE_INTEGER(471) +DEFINE_INTEGER(472) +DEFINE_INTEGER(473) +DEFINE_INTEGER(474) +DEFINE_INTEGER(475) +DEFINE_INTEGER(476) +DEFINE_INTEGER(477) +DEFINE_INTEGER(478) +DEFINE_INTEGER(479) +DEFINE_INTEGER(480) +DEFINE_INTEGER(481) +DEFINE_INTEGER(482) +DEFINE_INTEGER(483) +DEFINE_INTEGER(484) +DEFINE_INTEGER(485) +DEFINE_INTEGER(486) +DEFINE_INTEGER(487) +DEFINE_INTEGER(488) +DEFINE_INTEGER(489) +DEFINE_INTEGER(490) +DEFINE_INTEGER(491) +DEFINE_INTEGER(492) +DEFINE_INTEGER(493) +DEFINE_INTEGER(494) +DEFINE_INTEGER(495) +DEFINE_INTEGER(496) +DEFINE_INTEGER(497) +DEFINE_INTEGER(498) +DEFINE_INTEGER(499) +DEFINE_INTEGER(500) +DEFINE_INTEGER(501) +DEFINE_INTEGER(502) +DEFINE_INTEGER(503) +DEFINE_INTEGER(504) +DEFINE_INTEGER(505) +DEFINE_INTEGER(506) +DEFINE_INTEGER(507) +DEFINE_INTEGER(508) +DEFINE_INTEGER(509) +DEFINE_INTEGER(510) +DEFINE_INTEGER(511) +DEFINE_INTEGER(512) +DEFINE_INTEGER(513) +DEFINE_INTEGER(514) +DEFINE_INTEGER(515) +DEFINE_INTEGER(516) +DEFINE_INTEGER(517) +DEFINE_INTEGER(518) +DEFINE_INTEGER(519) +DEFINE_INTEGER(520) +DEFINE_INTEGER(521) +DEFINE_INTEGER(522) +DEFINE_INTEGER(523) +DEFINE_INTEGER(524) +DEFINE_INTEGER(525) +DEFINE_INTEGER(526) +DEFINE_INTEGER(527) +DEFINE_INTEGER(528) +DEFINE_INTEGER(529) +DEFINE_INTEGER(530) +DEFINE_INTEGER(531) +DEFINE_INTEGER(532) +DEFINE_INTEGER(533) +DEFINE_INTEGER(534) +DEFINE_INTEGER(535) +DEFINE_INTEGER(536) +DEFINE_INTEGER(537) +DEFINE_INTEGER(538) +DEFINE_INTEGER(539) +DEFINE_INTEGER(540) +DEFINE_INTEGER(541) +DEFINE_INTEGER(542) +DEFINE_INTEGER(543) +DEFINE_INTEGER(544) +DEFINE_INTEGER(545) +DEFINE_INTEGER(546) +DEFINE_INTEGER(547) +DEFINE_INTEGER(548) +DEFINE_INTEGER(549) +DEFINE_INTEGER(550) +DEFINE_INTEGER(551) +DEFINE_INTEGER(552) +DEFINE_INTEGER(553) +DEFINE_INTEGER(554) +DEFINE_INTEGER(555) +DEFINE_INTEGER(556) +DEFINE_INTEGER(557) +DEFINE_INTEGER(558) +DEFINE_INTEGER(559) +DEFINE_INTEGER(560) +DEFINE_INTEGER(561) +DEFINE_INTEGER(562) +DEFINE_INTEGER(563) +DEFINE_INTEGER(564) +DEFINE_INTEGER(565) +DEFINE_INTEGER(566) +DEFINE_INTEGER(567) +DEFINE_INTEGER(568) +DEFINE_INTEGER(569) +DEFINE_INTEGER(570) +DEFINE_INTEGER(571) +DEFINE_INTEGER(572) +DEFINE_INTEGER(573) +DEFINE_INTEGER(574) +DEFINE_INTEGER(575) +DEFINE_INTEGER(576) +DEFINE_INTEGER(577) +DEFINE_INTEGER(578) +DEFINE_INTEGER(579) +DEFINE_INTEGER(580) +DEFINE_INTEGER(581) +DEFINE_INTEGER(582) +DEFINE_INTEGER(583) +DEFINE_INTEGER(584) +DEFINE_INTEGER(585) +DEFINE_INTEGER(586) +DEFINE_INTEGER(587) +DEFINE_INTEGER(588) +DEFINE_INTEGER(589) +DEFINE_INTEGER(590) +DEFINE_INTEGER(591) +DEFINE_INTEGER(592) +DEFINE_INTEGER(593) +DEFINE_INTEGER(594) +DEFINE_INTEGER(595) +DEFINE_INTEGER(596) +DEFINE_INTEGER(597) +DEFINE_INTEGER(598) +DEFINE_INTEGER(599) +DEFINE_INTEGER(600) +DEFINE_INTEGER(601) +DEFINE_INTEGER(602) +DEFINE_INTEGER(603) +DEFINE_INTEGER(604) +DEFINE_INTEGER(605) +DEFINE_INTEGER(606) +DEFINE_INTEGER(607) +DEFINE_INTEGER(608) +DEFINE_INTEGER(609) +DEFINE_INTEGER(610) +DEFINE_INTEGER(611) +DEFINE_INTEGER(612) +DEFINE_INTEGER(613) +DEFINE_INTEGER(614) +DEFINE_INTEGER(615) +DEFINE_INTEGER(616) +DEFINE_INTEGER(617) +DEFINE_INTEGER(618) +DEFINE_INTEGER(619) +DEFINE_INTEGER(620) +DEFINE_INTEGER(621) +DEFINE_INTEGER(622) +DEFINE_INTEGER(623) +DEFINE_INTEGER(624) +DEFINE_INTEGER(625) +DEFINE_INTEGER(626) +DEFINE_INTEGER(627) +DEFINE_INTEGER(628) +DEFINE_INTEGER(629) +DEFINE_INTEGER(630) +DEFINE_INTEGER(631) +DEFINE_INTEGER(632) +DEFINE_INTEGER(633) +DEFINE_INTEGER(634) +DEFINE_INTEGER(635) +DEFINE_INTEGER(636) +DEFINE_INTEGER(637) +DEFINE_INTEGER(638) +DEFINE_INTEGER(639) +DEFINE_INTEGER(640) +DEFINE_INTEGER(641) +DEFINE_INTEGER(642) +DEFINE_INTEGER(643) +DEFINE_INTEGER(644) +DEFINE_INTEGER(645) +DEFINE_INTEGER(646) +DEFINE_INTEGER(647) +DEFINE_INTEGER(648) +DEFINE_INTEGER(649) +DEFINE_INTEGER(650) +DEFINE_INTEGER(651) +DEFINE_INTEGER(652) +DEFINE_INTEGER(653) +DEFINE_INTEGER(654) +DEFINE_INTEGER(655) +DEFINE_INTEGER(656) +DEFINE_INTEGER(657) +DEFINE_INTEGER(658) +DEFINE_INTEGER(659) +DEFINE_INTEGER(660) +DEFINE_INTEGER(661) +DEFINE_INTEGER(662) +DEFINE_INTEGER(663) +DEFINE_INTEGER(664) +DEFINE_INTEGER(665) +DEFINE_INTEGER(666) +DEFINE_INTEGER(667) +DEFINE_INTEGER(668) +DEFINE_INTEGER(669) +DEFINE_INTEGER(670) +DEFINE_INTEGER(671) +DEFINE_INTEGER(672) +DEFINE_INTEGER(673) +DEFINE_INTEGER(674) +DEFINE_INTEGER(675) +DEFINE_INTEGER(676) +DEFINE_INTEGER(677) +DEFINE_INTEGER(678) +DEFINE_INTEGER(679) +DEFINE_INTEGER(680) +DEFINE_INTEGER(681) +DEFINE_INTEGER(682) +DEFINE_INTEGER(683) +DEFINE_INTEGER(684) +DEFINE_INTEGER(685) +DEFINE_INTEGER(686) +DEFINE_INTEGER(687) +DEFINE_INTEGER(688) +DEFINE_INTEGER(689) +DEFINE_INTEGER(690) +DEFINE_INTEGER(691) +DEFINE_INTEGER(692) +DEFINE_INTEGER(693) +DEFINE_INTEGER(694) +DEFINE_INTEGER(695) +DEFINE_INTEGER(696) +DEFINE_INTEGER(697) +DEFINE_INTEGER(698) +DEFINE_INTEGER(699) +DEFINE_INTEGER(700) +DEFINE_INTEGER(701) +DEFINE_INTEGER(702) +DEFINE_INTEGER(703) +DEFINE_INTEGER(704) +DEFINE_INTEGER(705) +DEFINE_INTEGER(706) +DEFINE_INTEGER(707) +DEFINE_INTEGER(708) +DEFINE_INTEGER(709) +DEFINE_INTEGER(710) +DEFINE_INTEGER(711) +DEFINE_INTEGER(712) +DEFINE_INTEGER(713) +DEFINE_INTEGER(714) +DEFINE_INTEGER(715) +DEFINE_INTEGER(716) +DEFINE_INTEGER(717) +DEFINE_INTEGER(718) +DEFINE_INTEGER(719) +DEFINE_INTEGER(720) +DEFINE_INTEGER(721) +DEFINE_INTEGER(722) +DEFINE_INTEGER(723) +DEFINE_INTEGER(724) +DEFINE_INTEGER(725) +DEFINE_INTEGER(726) +DEFINE_INTEGER(727) +DEFINE_INTEGER(728) +DEFINE_INTEGER(729) +DEFINE_INTEGER(730) +DEFINE_INTEGER(731) +DEFINE_INTEGER(732) +DEFINE_INTEGER(733) +DEFINE_INTEGER(734) +DEFINE_INTEGER(735) +DEFINE_INTEGER(736) +DEFINE_INTEGER(737) +DEFINE_INTEGER(738) +DEFINE_INTEGER(739) +DEFINE_INTEGER(740) +DEFINE_INTEGER(741) +DEFINE_INTEGER(742) +DEFINE_INTEGER(743) +DEFINE_INTEGER(744) +DEFINE_INTEGER(745) +DEFINE_INTEGER(746) +DEFINE_INTEGER(747) +DEFINE_INTEGER(748) +DEFINE_INTEGER(749) +DEFINE_INTEGER(750) +DEFINE_INTEGER(751) +DEFINE_INTEGER(752) +DEFINE_INTEGER(753) +DEFINE_INTEGER(754) +DEFINE_INTEGER(755) +DEFINE_INTEGER(756) +DEFINE_INTEGER(757) +DEFINE_INTEGER(758) +DEFINE_INTEGER(759) +DEFINE_INTEGER(760) +DEFINE_INTEGER(761) +DEFINE_INTEGER(762) +DEFINE_INTEGER(763) +DEFINE_INTEGER(764) +DEFINE_INTEGER(765) +DEFINE_INTEGER(766) +DEFINE_INTEGER(767) +DEFINE_INTEGER(768) +DEFINE_INTEGER(769) +DEFINE_INTEGER(770) +DEFINE_INTEGER(771) +DEFINE_INTEGER(772) +DEFINE_INTEGER(773) +DEFINE_INTEGER(774) +DEFINE_INTEGER(775) +DEFINE_INTEGER(776) +DEFINE_INTEGER(777) +DEFINE_INTEGER(778) +DEFINE_INTEGER(779) +DEFINE_INTEGER(780) +DEFINE_INTEGER(781) +DEFINE_INTEGER(782) +DEFINE_INTEGER(783) +DEFINE_INTEGER(784) +DEFINE_INTEGER(785) +DEFINE_INTEGER(786) +DEFINE_INTEGER(787) +DEFINE_INTEGER(788) +DEFINE_INTEGER(789) +DEFINE_INTEGER(790) +DEFINE_INTEGER(791) +DEFINE_INTEGER(792) +DEFINE_INTEGER(793) +DEFINE_INTEGER(794) +DEFINE_INTEGER(795) +DEFINE_INTEGER(796) +DEFINE_INTEGER(797) +DEFINE_INTEGER(798) +DEFINE_INTEGER(799) +DEFINE_INTEGER(800) +DEFINE_INTEGER(801) +DEFINE_INTEGER(802) +DEFINE_INTEGER(803) +DEFINE_INTEGER(804) +DEFINE_INTEGER(805) +DEFINE_INTEGER(806) +DEFINE_INTEGER(807) +DEFINE_INTEGER(808) +DEFINE_INTEGER(809) +DEFINE_INTEGER(810) +DEFINE_INTEGER(811) +DEFINE_INTEGER(812) +DEFINE_INTEGER(813) +DEFINE_INTEGER(814) +DEFINE_INTEGER(815) +DEFINE_INTEGER(816) +DEFINE_INTEGER(817) diff --git a/gpgscm/t-child.c b/gpgscm/t-child.c new file mode 100644 index 0000000..f4e3a04 --- /dev/null +++ b/gpgscm/t-child.c @@ -0,0 +1,74 @@ +/* Sanity check for the process and IPC primitives. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include +#include +#include + +#ifdef _WIN32 +# include +# include +#endif + +int +main (int argc, char **argv) +{ + char buffer[4096]; + memset (buffer, 'A', sizeof buffer); +#if _WIN32 + if (! setmode (fileno (stdin), O_BINARY)) + return 23; + if (! setmode (fileno (stdout), O_BINARY)) + return 23; +#endif + + if (argc == 1) + return 2; + else if (strcmp (argv[1], "return0") == 0) + return 0; + else if (strcmp (argv[1], "return1") == 0) + return 1; + else if (strcmp (argv[1], "return77") == 0) + return 77; + else if (strcmp (argv[1], "hello_stdout") == 0) + fprintf (stdout, "hello"); + else if (strcmp (argv[1], "hello_stderr") == 0) + fprintf (stderr, "hello"); + else if (strcmp (argv[1], "stdout4096") == 0) + fwrite (buffer, 1, sizeof buffer, stdout); + else if (strcmp (argv[1], "stdout8192") == 0) + { + fwrite (buffer, 1, sizeof buffer, stdout); + fwrite (buffer, 1, sizeof buffer, stdout); + } + else if (strcmp (argv[1], "cat") == 0) + while (! feof (stdin)) + { + size_t bytes_read; + bytes_read = fread (buffer, 1, sizeof buffer, stdin); + fwrite (buffer, 1, bytes_read, stdout); + } + else + { + fprintf (stderr, "unknown command %s\n", argv[1]); + return 2; + } + return 0; +} diff --git a/gpgscm/t-child.scm b/gpgscm/t-child.scm new file mode 100644 index 0000000..fd1dcc3 --- /dev/null +++ b/gpgscm/t-child.scm @@ -0,0 +1,118 @@ +;; Tests for the low-level process and IPC primitives. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(echo "Testing process and IPC primitives...") + +(define (qualify executable) + (string-append executable (getenv "EXEEXT"))) + +(define child (qualify "t-child")) + +(assert (= 0 (call `(,(qualify "t-child") "return0")))) +(assert (= 1 (call `(,(qualify "t-child") "return1")))) +(assert (= 77 (call `(,(qualify "t-child") "return77")))) + +(let ((r (call-with-io `(,(qualify "t-child") "return0") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return1") ""))) + (assert (= 1 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return77") ""))) + (assert (= 77 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "hello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "hello" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "stdout4096") ""))) + (assert (= 0 (:retcode r))) + (assert (= 4096 (string-length (:stdout r)))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "stdout8192") ""))) + (assert (= 0 (:retcode r))) + (assert (= 8192 (string-length (:stdout r)))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello"))) + (assert (= 0 (:retcode r))) + (assert (string=? "hellohello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(define (spawn what) + (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO)) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return1"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(1 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return77"))) + (pid2 (spawn `(,(qualify "t-child") "return1")))) + (assert (equal? '(0 77 1) + (wait-processes '("child0" "child1" "child2") + (list pid0 pid1 pid2) #t)))) + +(let* ((p (pipe)) + (pid0 (spawn-process-fd + `(,(qualify "t-child") "hello_stdout") + CLOSED_FD (:write-end p) STDERR_FILENO)) + (_ (close (:write-end p))) + (pid1 (spawn-process-fd + `(,(qualify "t-child") "cat") + (:read-end p) STDOUT_FILENO STDERR_FILENO))) + (close (:read-end p)) + (assert + (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) +(echo " world.") + +(tr:do + (tr:pipe-do + (pipe:spawn `(,child stdout4096)) + (pipe:spawn `(,child cat))) + (tr:call-with-content (lambda (c) + (assert (= 4096 (string-length c)))))) +(tr:do + (tr:pipe-do + (pipe:spawn `(,child stdout8192)) + (pipe:spawn `(,child cat))) + (tr:call-with-content (lambda (c) + (assert (= 8192 (string-length c)))))) + +(echo "All good.") diff --git a/gpgscm/tests.scm b/gpgscm/tests.scm new file mode 100644 index 0000000..5141002 --- /dev/null +++ b/gpgscm/tests.scm @@ -0,0 +1,886 @@ +;; Common definitions for writing tests. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Reporting. +(define (echo . msg) + (for-each (lambda (x) (display x) (display " ")) msg) + (newline)) + +(define (info . msg) + (apply echo msg) + (flush-stdio)) + +(define (log . msg) + (if (> (*verbose*) 0) + (apply info msg))) + +(define (fail . msg) + (apply info msg) + (exit 1)) + +(define (skip . msg) + (apply info msg) + (exit 77)) + +(define (make-counter) + (let ((c 0)) + (lambda () + (let ((r c)) + (set! c (+ 1 c)) + r)))) + +(define *progress-nesting* 0) + +(define (call-with-progress msg what) + (set! *progress-nesting* (+ 1 *progress-nesting*)) + (if (= 1 *progress-nesting*) + (begin + (info msg) + (display " > ") + (flush-stdio) + (what (lambda (item) + (display item) + (display " ") + (flush-stdio))) + (info "< ")) + (begin + (what (lambda (item) (display ".") (flush-stdio))) + (display " ") + (flush-stdio))) + (set! *progress-nesting* (- *progress-nesting* 1))) + +(define (for-each-p msg proc lst . lsts) + (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts))) + +(define (for-each-p' msg proc fmt lst . lsts) + (call-with-progress + msg + (lambda (progress) + (apply for-each + `(,(lambda args + (progress (apply fmt args)) + (apply proc args)) + ,lst ,@lsts))))) + +;; Process management. +(define CLOSED_FD -1) +(define (call-with-fds what infd outfd errfd) + (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t)) +(define (call what) + (call-with-fds what + CLOSED_FD + (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD) + (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD))) + +;; Accessor functions for the results of 'spawn-process'. +(define :stdin car) +(define :stdout cadr) +(define :stderr caddr) +(define :pid cadddr) + +(define (call-with-io what in) + (let ((h (spawn-process what 0))) + (es-write (:stdin h) in) + (es-fclose (:stdin h)) + (let* ((out (es-read-all (:stdout h))) + (err (es-read-all (:stderr h))) + (result (wait-process (car what) (:pid h) #t))) + (es-fclose (:stdout h)) + (es-fclose (:stderr h)) + (if (> (*verbose*) 2) + (info "Child" (:pid h) "returned:" + `((command ,(stringify what)) + (status ,result) + (stdout ,out) + (stderr ,err)))) + (list result out err)))) + +;; Accessor function for the results of 'call-with-io'. ':stdout' and +;; ':stderr' can also be used. +(define :retcode car) + +(define (call-check what) + (let ((result (call-with-io what ""))) + (if (= 0 (:retcode result)) + (:stdout result) + (throw (string-append (stringify what) " failed") + (:stderr result))))) + +(define (call-popen command input-string) + (let ((result (call-with-io command input-string))) + (if (= 0 (:retcode result)) + (:stdout result) + (throw (:stderr result))))) + +;; +;; estream helpers. +;; + +(define (es-read-all stream) + (let loop + ((acc "")) + (if (es-feof stream) + acc + (loop (string-append acc (es-read stream 4096)))))) + +;; +;; File management. +;; +(define (file-exists? name) + (call-with-input-file name (lambda (port) #t))) + +(define (file=? a b) + (file-equal a b #t)) + +(define (text-file=? a b) + (file-equal a b #f)) + +(define (file-copy from to) + (catch '() (unlink to)) + (letfd ((source (open from (logior O_RDONLY O_BINARY))) + (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (splice source sink))) + +(define (text-file-copy from to) + (catch '() (unlink to)) + (letfd ((source (open from O_RDONLY)) + (sink (open to (logior O_WRONLY O_CREAT) #o600))) + (splice source sink))) + +(define (path-join . components) + (let loop ((acc #f) (rest (filter (lambda (s) + (not (string=? "" s))) components))) + (if (null? rest) + acc + (loop (if (string? acc) + (string-append acc "/" (car rest)) + (car rest)) + (cdr rest))))) +(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz")) +(assert (string=? (path-join "" "bar" "baz") "bar/baz")) + +;; Is PATH an absolute path? +(define (absolute-path? path) + (or (char=? #\/ (string-ref path 0)) + (and *win32* (char=? #\\ (string-ref path 0))) + (and *win32* + (char-alphabetic? (string-ref path 0)) + (char=? #\: (string-ref path 1)) + (or (char=? #\/ (string-ref path 2)) + (char=? #\\ (string-ref path 2)))))) + +;; Make PATH absolute. +(define (canonical-path path) + (if (absolute-path? path) path (path-join (getcwd) path))) + +(define (in-srcdir . names) + (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names)))) + +;; Split a list of paths. +(define (pathsep-split s) + (string-split s *pathsep*)) + +;; Join a list of paths. +(define (pathsep-join paths) + (foldr (lambda (a b) (string-append a (string *pathsep*) b)) + (car paths) + (cdr paths))) + +;; Try to find NAME in PATHS. Returns the full path name on success, +;; or raises an error. +(define (path-expand name paths) + (let loop ((path paths)) + (if (null? path) + (throw "Could not find" name "in" paths) + (let* ((qualified-name (path-join (car path) name)) + (file-exists (call-with-input-file qualified-name + (lambda (x) #t)))) + (if file-exists + qualified-name + (loop (cdr path))))))) + +;; Expand NAME using the gpgscm load path. Use like this: +;; (load (with-path "library.scm")) +(define (with-path name) + (catch name + (path-expand name (pathsep-split (getenv "GPGSCM_PATH"))))) + +(define (basename path) + (let ((i (string-index path #\/))) + (if (equal? i #f) + path + (basename (substring path (+ 1 i) (string-length path)))))) + +(define (basename-suffix path suffix) + (basename + (if (string-suffix? path suffix) + (substring path 0 (- (string-length path) (string-length suffix))) + path))) + +(define (dirname path) + (let ((i (string-rindex path #\/))) + (if i (substring path 0 i) "."))) +(assert (string=? "foo/bar" (dirname "foo/bar/baz"))) + +;; Helper for (pipe). +(define :read-end car) +(define :write-end cadr) + +;; let-like macro that manages file descriptors. +;; +;; (letfd ) +;; +;; Bind all variables given in and initialize each of them +;; to the given initial value, and close them after evaluating . +(define-macro (letfd bindings . body) + (let bind ((bindings' bindings)) + (if (null? bindings') + `(begin ,@body) + (let* ((binding (car bindings')) + (name (car binding)) + (initializer (cadr binding))) + `(let ((,name ,initializer)) + (finally (close ,name) + ,(bind (cdr bindings')))))))) + +(define-macro (with-working-directory new-directory . expressions) + (let ((new-dir (gensym)) + (old-dir (gensym))) + `(let* ((,new-dir ,new-directory) + (,old-dir (getcwd))) + (dynamic-wind + (lambda () (if ,new-dir (chdir ,new-dir))) + (lambda () ,@expressions) + (lambda () (chdir ,old-dir)))))) + +;; Make a temporary directory. If arguments are given, they are +;; joined using path-join, and must end in a component ending in +;; "XXXXXX". If no arguments are given, a suitable location and +;; generic name is used. Returns an absolute path. +(define (mkdtemp . components) + (canonical-path (_mkdtemp (if (null? components) + (path-join + (get-temp-path) + (string-append "gpgscm-" (get-isotime) "-" + (basename-suffix *scriptname* ".scm") + "-XXXXXX")) + (apply path-join components))))) + +;; Make a temporary directory and remove it at interpreter shutdown. +;; Note that there are macros that limit the lifetime of temporary +;; directories and files to a lexical scope. Use those if possible. +;; Otherwise this works like mkdtemp. +(define (mkdtemp-autoremove . components) + (let ((dir (apply mkdtemp components))) + (atexit (lambda () (unlink-recursively dir))) + dir)) + +(define-macro (with-temporary-working-directory . expressions) + (let ((tmp-sym (gensym))) + `(let* ((,tmp-sym (mkdtemp))) + (finally (unlink-recursively ,tmp-sym) + (with-working-directory ,tmp-sym + ,@expressions))))) + +(define (make-temporary-file . args) + (canonical-path (path-join + (mkdtemp) + (if (null? args) "a" (car args))))) + +(define (remove-temporary-file filename) + (catch '() + (unlink filename)) + (let ((dirname (substring filename 0 (string-rindex filename #\/)))) + (catch (echo "removing temporary directory" dirname "failed") + (rmdir dirname)))) + +;; let-like macro that manages temporary files. +;; +;; (lettmp ) +;; +;; Bind all variables given in , initialize each of them to +;; a string representing an unique path in the filesystem, and delete +;; them after evaluating . +(define-macro (lettmp bindings . body) + (let bind ((bindings' bindings)) + (if (null? bindings') + `(begin ,@body) + (let ((name (car bindings')) + (rest (cdr bindings'))) + `(let ((,name (make-temporary-file ,(symbol->string name)))) + (finally (remove-temporary-file ,name) + ,(bind rest))))))) + +(define (check-execution source transformer) + (lettmp (sink) + (transformer source sink))) + +(define (check-identity source transformer) + (lettmp (sink) + (transformer source sink) + (if (not (file=? source sink)) + (fail "mismatch")))) + +;; +;; Monadic pipe support. +;; + +(define pipeM + (package + (define (new procs source sink producer) + (package + (define (dump) + (write (list procs source sink producer)) + (newline)) + (define (add-proc command pid) + (new (cons (list command pid) procs) source sink producer)) + (define (commands) + (map car procs)) + (define (pids) + (map cadr procs)) + (define (set-source source') + (new procs source' sink producer)) + (define (set-sink sink') + (new procs source sink' producer)) + (define (set-producer producer') + (if producer + (throw "producer already set")) + (new procs source sink producer')))))) + + +(define (pipe:do . commands) + (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands)) + (if (null? cmds) + (begin + (if M::producer (M::producer)) + (if (not (null? M::procs)) + (let* ((retcodes (wait-processes (map stringify (M::commands)) + (M::pids) #t)) + (results (map (lambda (p r) (append p (list r))) + M::procs retcodes)) + (failed (filter (lambda (x) (not (= 0 (caddr x)))) + results))) + (if (not (null? failed)) + (throw failed))))) ; xxx nicer reporting + (if (and (= 2 (length cmds)) (number? (cadr cmds))) + ;; hack: if it's an fd, use it as sink + (let ((M' ((car cmds) (M::set-sink (cadr cmds))))) + (if (> M::source 2) (close M::source)) + (if (> (cadr cmds) 2) (close (cadr cmds))) + (loop M' '())) + (let ((M' ((car cmds) M))) + (if (> M::source 2) (close M::source)) + (loop M' (cdr cmds))))))) + +(define (pipe:open pathname flags) + (lambda (M) + (M::set-source (open pathname flags)))) + +(define (pipe:defer producer) + (lambda (M) + (let* ((p (outbound-pipe)) + (M' (M::set-source (:read-end p)))) + (M'::set-producer (lambda () + (producer (:write-end p)) + (close (:write-end p))))))) +(define (pipe:echo data) + (pipe:defer (lambda (sink) (display data (fdopen sink "wb"))))) + +(define (pipe:spawn command) + (lambda (M) + (define (do-spawn M new-source) + (let ((pid (spawn-process-fd command M::source M::sink + (if (> (*verbose*) 0) + STDERR_FILENO CLOSED_FD))) + (M' (M::set-source new-source))) + (M'::add-proc command pid))) + (if (= CLOSED_FD M::sink) + (let* ((p (pipe)) + (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p)))) + (close (:write-end p)) + (M'::set-sink CLOSED_FD)) + (do-spawn M CLOSED_FD)))) + +(define (pipe:splice sink) + (lambda (M) + (splice M::source sink) + (M::set-source CLOSED_FD))) + +(define (pipe:write-to pathname flags mode) + (open pathname flags mode)) + +;; +;; Monadic transformer support. +;; + +(define (tr:do . commands) + (let loop ((tmpfiles '()) (source #f) (cmds commands)) + (if (null? cmds) + (for-each remove-temporary-file tmpfiles) + (let* ((v ((car cmds) tmpfiles source)) + (tmpfiles' (car v)) + (sink (cadr v)) + (error (caddr v))) + (if error + (begin + (for-each remove-temporary-file tmpfiles') + (apply throw error))) + (loop tmpfiles' sink (cdr cmds)))))) + +(define (tr:open pathname) + (lambda (tmpfiles source) + (list tmpfiles pathname #f))) + +(define (tr:spawn input command) + (lambda (tmpfiles source) + (if (and (member '**in** command) (not source)) + (fail (string-append (stringify cmd) " needs an input"))) + (let* ((t (make-temporary-file)) + (cmd (map (lambda (x) + (cond + ((equal? '**in** x) source) + ((equal? '**out** x) t) + (else x))) command))) + (catch (list (cons t tmpfiles) t *error*) + (call-popen cmd input) + (if (and (member '**out** command) (not (file-exists? t))) + (fail (string-append (stringify cmd) + " did not produce '" t "'."))) + (list (cons t tmpfiles) t #f))))) + +(define (tr:write-to pathname) + (lambda (tmpfiles source) + (rename source pathname) + (list tmpfiles pathname #f))) + +(define (tr:pipe-do . commands) + (lambda (tmpfiles source) + (let ((t (make-temporary-file))) + (apply pipe:do + `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) + ,@commands + ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) + (list (cons t tmpfiles) t #f)))) + +(define (tr:assert-identity reference) + (lambda (tmpfiles source) + (if (not (file=? source reference)) + (fail "mismatch")) + (list tmpfiles source #f))) + +(define (tr:assert-weak-identity reference) + (lambda (tmpfiles source) + (if (not (text-file=? source reference)) + (fail "mismatch")) + (list tmpfiles source #f))) + +(define (tr:call-with-content function . args) + (lambda (tmpfiles source) + (catch (list tmpfiles source *error*) + (apply function `(,(call-with-input-file source read-all) ,@args))) + (list tmpfiles source #f))) + +;; +;; Developing and debugging tests. +;; + +;; Spawn an os shell. +(define (interactive-shell) + (call-with-fds `(,(getenv "SHELL") -i) 0 1 2)) + +;; +;; The main test framework. +;; + +(define semaphore + (package + (define (new n) + (package + (define (acquire!?) + (if (> n 0) + (begin + (set! n (- n 1)) + #t) + #f)) + (define (release!) + (set! n (+ n 1))))))) + +;; A pool of tests. +(define test-pool + (package + (define (new n) + (package + ;; A semaphore to restrict the number of spawned processes. + (define sem (semaphore::new n)) + + ;; A list of enqueued, but not yet run tests. + (define enqueued '()) + + ;; A list of running or finished processes. + (define procs '()) + + (define (add test) + (if (test::started?) + (set! procs (cons test procs)) + (if (sem::acquire!?) + (add (test::run-async)) + (set! enqueued (cons test enqueued)))) + (current-environment)) + + ;; Pop the last of the enqueued tests off the fifo queue. + (define (pop-test!) + (let ((i (length enqueued))) + (assert (> i 0)) + (cond + ((= i 1) + (let ((test (car enqueued))) + (set! enqueued '()) + test)) + (else + (let* ((tail (list-tail enqueued (- i 2))) + (test (cadr tail))) + (set-cdr! tail '()) + (assert (= (length enqueued) (- i 1))) + test))))) + + (define (pid->test pid) + (let ((t (filter (lambda (x) (= pid x::pid)) procs))) + (if (null? t) #f (car t)))) + (define (wait) + (if (null? enqueued) + ;; If no tests are enqueued, we can just block until all + ;; of them finished. + (wait' #t) + ;; Otherwise, we must not block, but give some tests the + ;; chance to finish so that we can start new ones. + (begin + (wait' #f) + (usleep (/ 1000000 10)) + (wait)))) + (define (wait' hang) + (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) + (if (null? unfinished) + (current-environment) + (let ((names (map (lambda (t) t::name) unfinished)) + (pids (map (lambda (t) t::pid) unfinished)) + (any #f)) + (for-each + (lambda (test retcode) + (unless (< retcode 0) + (test::set-end-time!) + (test:::set! 'retcode retcode) + (test::report) + (sem::release!) + (set! any #t))) + (map pid->test pids) + (wait-processes (map stringify names) pids hang)) + + ;; If some processes finished, try to start new ones. + (let loop () + (cond + ((not any) #f) + ((pair? enqueued) + (if (sem::acquire!?) + (let ((test (pop-test!))) + (add (test::run-async)) + (loop))))))))) + (current-environment)) + (define (filter-tests status) + (filter (lambda (p) (eq? status (p::status))) procs)) + (define (report) + (define (print-tests tests message) + (unless (null? tests) + (apply echo (cons message + (map (lambda (t) t::name) tests))))) + + (let ((failed (filter-tests 'FAIL)) + (xfailed (filter-tests 'XFAIL)) + (xpassed (filter-tests 'XPASS)) + (skipped (filter-tests 'SKIP))) + (echo "===================") + (echo (length procs) "tests run," + (length (filter-tests 'PASS)) "succeeded," + (length failed) "failed," + (length xfailed) "failed expectedly," + (length xpassed) "succeeded unexpectedly," + (length skipped) "skipped.") + (print-tests failed "Failed tests:") + (print-tests xfailed "Expectedly failed tests:") + (print-tests xpassed "Unexpectedly passed tests:") + (print-tests skipped "Skipped tests:") + (echo "===================") + (+ (length failed) (length xpassed)))) + + (define (xml) + (xx::document + (xx::tag 'testsuites + `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") + ("xsi:noNamespaceSchemaLocation" + "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd")) + (map (lambda (t) (t::xml)) procs)))))))) + +(define (verbosity n) + (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) + +(define (locate-test path) + (if (absolute-path? path) path (in-srcdir path))) + +;; A single test. +(define test + (begin + + ;; Private definitions. + + (define (isotime->junit t) + "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}" + "20170418T145809" + (string-append (substring t 0 4) + "-" + (substring t 4 6) + "-" + (substring t 6 11) + ":" + (substring t 11 13) + ":" + (substring t 13 15))) + + ;; If a tests name ends with a bang (!), it is expected to fail. + (define (expect-failure? name) + (string-suffix? name "!")) + ;; Strips the bang (if any). + (define (test-name name) + (if (expect-failure? name) + (substring name 0 (- (string-length name) 1)) + name)) + + (package + (define (scm setup name path . args) + ;; Start the process. + (define (spawn-scm args' in out err) + (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) + ,(locate-test (test-name path)) + ,@(if setup (force setup) '()) + ,@args' ,@args) in out err)) + (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name))) + + (define (binary setup name path . args) + ;; Start the process. + (define (spawn-binary args' in out err) + (spawn-process-fd `(,(test-name path) + ,@(if setup (force setup) '()) ,@args' ,@args) + in out err)) + (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name))) + + (define (new name directory spawn pid retcode logfd expect-failure) + (package + + ;; XXX: OO glue. + (define self (current-environment)) + (define (:set! key value) + (eval `(set! ,key ,value) (current-environment)) + (current-environment)) + + ;; The log is written here. + (define log-file-name #f) + + ;; Record time stamps. + (define timestamp #f) + (define start-time 0) + (define end-time 0) + + (define (set-start-time!) + (set! timestamp (isotime->junit (get-isotime))) + (set! start-time (get-time))) + (define (set-end-time!) + (set! end-time (get-time))) + + ;; Has the test been started yet? + (define (started?) + (number? pid)) + + (define (open-log-file) + (unless log-file-name + (set! log-file-name (string-append (basename name) ".log"))) + (catch '() (unlink log-file-name)) + (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) + + (define (run-sync . args) + (set-start-time!) + (letfd ((log (open-log-file))) + (with-working-directory directory + (let* ((p (inbound-pipe)) + (pid' (spawn args 0 (:write-end p) (:write-end p)))) + (close (:write-end p)) + (splice (:read-end p) STDERR_FILENO log) + (close (:read-end p)) + (set! pid pid') + (set! retcode (wait-process name pid' #t))))) + (report) + (current-environment)) + (define (run-sync-quiet . args) + (set-start-time!) + (with-working-directory directory + (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))) + (set! retcode (wait-process name pid #t)) + (set-end-time!) + (current-environment)) + (define (run-async . args) + (set-start-time!) + (let ((log (open-log-file))) + (with-working-directory directory + (set! pid (spawn args CLOSED_FD log log))) + (set! logfd log)) + (current-environment)) + (define (status) + (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))) + (t (if (not t') 'FAIL (cadr t')))) + (if expect-failure + (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t)) + t))) + (define (status-string) + (cadr (assoc (status) '((PASS "PASS") + (SKIP "SKIP") + (ERROR "ERROR") + (FAIL "FAIL") + (XPASS "XPASS") + (XFAIL "XFAIL"))))) + (define (report) + (unless (= logfd CLOSED_FD) + (seek logfd 0 SEEK_SET) + (splice logfd STDERR_FILENO) + (close logfd)) + (echo (string-append (status-string) ":") name)) + + (define (xml) + (xx::tag + 'testsuite + `((name ,name) + (time ,(- end-time start-time)) + (package ,(dirname name)) + (id 0) + (timestamp ,timestamp) + (hostname "unknown") + (tests 1) + (failures ,(if (eq? FAIL (status)) 1 0)) + (errors ,(if (eq? ERROR (status)) 1 0))) + (list + (xx::tag 'properties) + (xx::tag 'testcase + `((name ,(basename name)) + (classname ,(string-translate (dirname name) "/" ".")) + (time ,(- end-time start-time))) + `(,@(case (status) + ((PASS XFAIL) '()) + ((SKIP) (list (xx::tag 'skipped))) + ((ERROR) (list + (xx::tag 'error '((message "Unknown error."))))) + (else + (list (xx::tag 'failure '((message "Unknown error.")))))))) + (xx::tag 'system-out '() + (list (xx::textnode (read-all (open-input-file log-file-name))))) + (xx::tag 'system-err '() (list (xx::textnode ""))))))))))) + +;; Run the setup target to create an environment, then run all given +;; tests in parallel. +(define (run-tests-parallel tests n) + (let loop ((pool (test-pool::new n)) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + ((results::xml) (open-output-file "report.xml")) + (exit (results::report))) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add test) + (cdr tests')))))) + +;; Run the setup target to create an environment, then run all given +;; tests in sequence. +(define (run-tests-sequential tests) + (let loop ((pool (test-pool::new 1)) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + ((results::xml) (open-output-file "report.xml")) + (exit (results::report))) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add (test::run-sync)) + (cdr tests')))))) + +;; Run tests either in sequence or in parallel, depending on the +;; number of tests and the command line flags. +(define (run-tests tests) + (let ((parallel (flag "--parallel" *args*)) + (default-parallel-jobs 32)) + (if (and parallel (> (length tests) 1)) + (run-tests-parallel tests (if (and (pair? parallel) + (string->number (car parallel))) + (string->number (car parallel)) + default-parallel-jobs)) + (run-tests-sequential tests)))) + +;; Load all tests from the given path. +(define (load-tests . path) + (load (apply in-srcdir `(,@path "all-tests.scm"))) + all-tests) + +;; Helper to create environment caches from test functions. SETUP +;; must be a test implementing the producer side cache protocol. +;; Returns a promise containing the arguments that must be passed to a +;; test implementing the consumer side of the cache protocol. +(define (make-environment-cache setup) + (delay (with-temporary-working-directory + (let ((tarball (make-temporary-file "environment-cache"))) + (atexit (lambda () (remove-temporary-file tarball))) + (setup::run-sync '--create-tarball tarball) + (if (not (equal? 'PASS (setup::status))) + (fail "Setup failed.")) + `(--unpack-tarball ,tarball))))) + +;; Command line flag handling. Returns the elements following KEY in +;; ARGUMENTS up to the next argument, or #f if KEY is not in +;; ARGUMENTS. If 'KEY=XYZ' is encountered, then the singleton list +;; containing 'XYZ' is returned. +(define (flag key arguments) + (cond + ((null? arguments) + #f) + ((string=? key (car arguments)) + (let loop ((acc '()) + (args (cdr arguments))) + (if (or (null? args) (string-prefix? (car args) "--")) + (reverse acc) + (loop (cons (car args) acc) (cdr args))))) + ((string-prefix? (car arguments) (string-append key "=")) + (list (substring (car arguments) + (+ (string-length key) 1) + (string-length (car arguments))))) + ((string=? "--" (car arguments)) + #f) + (else + (flag key (cdr arguments))))) +(assert (equal? (flag "--xxx" '("--yyy")) #f)) +(assert (equal? (flag "--xxx" '("--xxx")) '())) +(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy"))) +(assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy"))) +(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy"))) diff --git a/gpgscm/time.scm b/gpgscm/time.scm new file mode 100644 index 0000000..a9b06d0 --- /dev/null +++ b/gpgscm/time.scm @@ -0,0 +1,42 @@ +;; Simple time manipulation library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; This library mimics what GnuPG thinks about expiration times. +;; Granularity is one second. Its focus is not on correctness. + +;; Conversion functions. +(define (minutes->seconds minutes) + (* minutes 60)) +(define (hours->seconds hours) + (* hours 60 60)) +(define (days->seconds days) + (* days 24 60 60)) +(define (weeks->seconds weeks) + (days->seconds (* weeks 7))) +(define (months->seconds months) + (days->seconds (* months 30))) +(define (years->seconds years) + (days->seconds (* years 365))) + +(define (time-matches? a b slack) + (< (abs (- a b)) slack)) +(assert (time-matches? (hours->seconds 1) (hours->seconds 2) (hours->seconds 2))) +(assert (time-matches? (hours->seconds 2) (hours->seconds 1) (hours->seconds 2))) +(assert (not (time-matches? (hours->seconds 4) (hours->seconds 1) (hours->seconds 2)))) +(assert (not (time-matches? (hours->seconds 1) (hours->seconds 4) (hours->seconds 2)))) diff --git a/gpgscm/xml.scm b/gpgscm/xml.scm new file mode 100644 index 0000000..771ec36 --- /dev/null +++ b/gpgscm/xml.scm @@ -0,0 +1,142 @@ +;; A tiny XML library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(define xx + (begin + + ;; Private declarations. + (define quote-text + '((#\< "<") + (#\> ">") + (#\& "&"))) + + (define quote-attribute-' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\' "'"))) + + (define quote-attribute-'' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))) + + (define (escape-string quotation string sink) + ;; This implementation is a bit awkward because iteration is so + ;; slow in TinySCHEME. We rely on string-index to skip to the + ;; next character we need to escape. We also avoid allocations + ;; wherever possible. + + ;; Given a list of integers or #f, return the sublist that + ;; starts with the lowest integer. + (define (min* x) + (let loop ((lowest x) (rest x)) + (if (null? rest) + lowest + (loop (if (or (null? lowest) (not (car lowest)) + (and (car rest) (> (car lowest) (car rest)))) rest lowest) + (cdr rest))))) + + (let ((i 0) (start 0) (len (string-length string)) + (indices (map (lambda (x) (string-index string (car x))) quotation)) + (next #f) (c #f)) + + ;; Set 'i' to the index of the next character that needs + ;; escaping, 'c' to the character that needs to be escaped, + ;; and update 'indices'. + (define (skip!) + (set! next (min* indices)) + (set! i (if (null? next) #f (car next))) + (if i + (begin + (set! c (string-ref string i)) + (set-car! next (string-index string c (+ 1 i)))) + (set! i (string-length string)))) + + (let loop () + (skip!) + (if (< i len) + (begin + (display (substring string start i) sink) + (display (cadr (assv c quotation)) sink) + (set! i (+ 1 i)) + (set! start i) + (loop)) + (display (substring string start len) sink))))) + + (let ((escape-string-s (lambda (quotation string) + (let ((sink (open-output-string))) + (escape-string quotation string sink) + (get-output-string sink))))) + (assert (equal? (escape-string-s quote-text "foo") "foo")) + (assert (equal? (escape-string-s quote-text "foo&") "foo&")) + (assert (equal? (escape-string-s quote-text "&foo") "&foo")) + (assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar")) + (assert (equal? (escape-string-s quote-text "foobar") "foo>bar"))) + + (define (escape quotation datum sink) + (cond + ((string? datum) (escape-string quotation datum sink)) + ((symbol? datum) (escape-string quotation (symbol->string datum) sink)) + ((number? datum) (display (number->string datum) sink)) + (else + (throw "Do not know how to encode" datum)))) + + (define (name->string name) + (cond + ((symbol? name) (symbol->string name)) + (else name))) + + (package + + (define (textnode string) + (lambda (sink) + (escape quote-text string sink))) + + (define (tag name . rest) + (let ((attributes (if (null? rest) '() (car rest))) + (children (if (> (length rest) 1) (cadr rest) '()))) + (lambda (sink) + (display "<" sink) + (display (name->string name) sink) + (unless (null? attributes) + (display " " sink) + (for-each (lambda (a) + (display (car a) sink) + (display "=\"" sink) + (escape quote-attribute-'' (cadr a) sink) + (display "\" " sink)) attributes)) + (if (null? children) + (display "/>\n" sink) + (begin + (display ">\n" sink) + (for-each (lambda (c) (c sink)) children) + (display "string name) sink) + (display ">\n" sink)))))) + + (define (document root . rest) + (let ((attributes (if (null? rest) '() (car rest)))) + (lambda (sink) + ;; xxx ignores attributes + (display "\n" sink) + (root sink) + (newline sink))))))) diff --git a/init.scm b/init.scm deleted file mode 100644 index 66bec0f..0000000 --- a/init.scm +++ /dev/null @@ -1,823 +0,0 @@ -; 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-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-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))))) - -;; Print the given history. -(define (vm-history-print history) - (let loop ((n 0) (skip 0) (frames history)) - (cond - ((null? frames) - #t) - ((> skip 0) - (loop 0 (- skip 1) (cdr frames))) - (else - (let ((f (car frames))) - (display n) - (display ": ") - (let ((tag (get-tag f))) - (when (and (pair? tag) (string? (car tag)) (number? (cdr tag))) - (display (basename (car tag))) - (display ":") - (display (+ 1 (cdr tag))) - (display ": "))) - (write f)) - (newline) - (loop (+ n 1) skip (cdr frames)))))) - -;;;; 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. Within the recovery expression -; the thrown exception is bound to *error*. Errors can be rethrown -; using (rethrow *error*). -; -; Finalization can be expressed using "finally": -; -; (finally (finalize-something called-purely-for side-effects) -; (whether-or-not something goes-wrong) -; (with-these calls)) -; -; The final expression is executed purely for its side-effects, -; both when the function exits successfully, and when an exception -; is thrown. -; -; 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*)) - -;; This throws an exception. -(define (throw message . args) - (throw' message args (cdr (*vm-history*)))) - -;; This is used by the vm to throw exceptions. -(define (throw' message args history) - (cond - ((and args (list? args) (= 2 (length args)) - (equal? *interpreter-exit* (car args))) - (*run-atexit-handlers*) - (quit (cadr args))) - ((more-handlers?) - ((pop-handler) message args history)) - (else - (display message) - (when (and args (not (null? args))) - (display ": ") - (if (and (pair? args) (string? (car args))) - (begin (display (car args)) - (unless (null? (cdr args)) - (newline) - (write (cdr args)))) - (write args))) - (newline) - (vm-history-print history) - (quit 1)))) - -;; Convenience function to rethrow the error. -(define (rethrow e) - (apply throw' e)) - -(macro (catch form) - (let ((label (gensym))) - `(call/cc (lambda (**exit**) - (push-handler (lambda *error* (**exit** ,(cadr form)))) - (let ((,label (begin ,@(cddr form)))) - (pop-handler) - ,label))))) - -(define-macro (finally final-expression . expressions) - (let ((result (gensym))) - `(let ((,result (catch (begin ,final-expression (rethrow *error*)) - ,@expressions))) - ,final-expression - ,result))) - -;; Make the vm use throw'. -(define *error-hook* throw') - - - -;; High-level mechanism to terminate the process is to throw an error -;; of the form (*interpreter-exit* status). This gives automatic -;; resource management a chance to clean up. -(define *interpreter-exit* (gensym)) - -;; Terminate the process returning STATUS to the parent. -(define (exit status) - (throw "interpreter exit" *interpreter-exit* status)) - -;; A list of functions run at interpreter shutdown. -(define *atexit-handlers* (list)) - -;; Execute all these functions. -(define (*run-atexit-handlers*) - (unless (null? *atexit-handlers*) - (let ((proc (car *atexit-handlers*))) - ;; Drop proc from the list so that it will not get - ;; executed again even if it raises an exception. - (set! *atexit-handlers* (cdr *atexit-handlers*)) - (proc) - (*run-atexit-handlers*)))) - -;; Register a function to be run at interpreter shutdown. -(define (atexit proc) - (set! *atexit-handlers* (cons proc *atexit-handlers*))) - - - -;;;;; 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) - -(macro (package form) - `(apply (lambda () - ,@(cdr form) - (current-environment)))) - -(define-macro (export name . expressions) - `(define ,name - (begin - ,@expressions))) - -;;;;; 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) diff --git a/lib.scm b/lib.scm deleted file mode 100644 index 258f692..0000000 --- a/lib.scm +++ /dev/null @@ -1,307 +0,0 @@ -;; Additional library functions for TinySCHEME. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(macro (assert form) - (let ((tag (get-tag form))) - `(if (not ,(cadr form)) - (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag))) - `(string-append ,(car tag) ":" - ,(number->string (+ 1 (cdr tag))) - ": Assertion failed: ") - "Assertion failed: ") - (quote ,(cadr form)))))) -(assert #t) -(assert (not #f)) - -;; Trace displays and returns the given value. A debugging aid. -(define (trace x) - (display x) - (newline) - x) - -;; Stringification. -(define (stringify expression) - (let ((p (open-output-string))) - (write expression p) - (get-output-string p))) - -(define (filter pred lst) - (cond ((null? lst) '()) - ((pred (car lst)) - (cons (car lst) (filter pred (cdr lst)))) - (else (filter pred (cdr lst))))) - -(define (any p l) - (cond ((null? l) #f) - ((p (car l)) #t) - (else (any p (cdr l))))) - -(define (all p l) - (cond ((null? l) #t) - ((not (p (car l))) #f) - (else (all p (cdr l))))) - -;; Return the first element of a list. -(define first car) - -;; Return the last element of a list. -(define (last lst) - (if (null? (cdr lst)) - (car lst) - (last (cdr lst)))) - -;; Compute the powerset of a list. -(define (powerset set) - (if (null? set) - '(()) - (let ((rst (powerset (cdr set)))) - (append (map (lambda (x) (cons (car set) x)) - rst) - rst)))) - -;; Is PREFIX a prefix of S? -(define (string-prefix? s prefix) - (and (>= (string-length s) (string-length prefix)) - (string=? prefix (substring s 0 (string-length prefix))))) -(assert (string-prefix? "Scheme" "Sch")) - -;; Is SUFFIX a suffix of S? -(define (string-suffix? s suffix) - (and (>= (string-length s) (string-length suffix)) - (string=? suffix (substring s (- (string-length s) - (string-length suffix)) - (string-length s))))) -(assert (string-suffix? "Scheme" "eme")) - -;; Locate the first occurrence of needle in haystack starting at offset. -(ffi-define (string-index haystack needle [offset])) -(assert (= 2 (string-index "Hallo" #\l))) -(assert (= 3 (string-index "Hallo" #\l 3))) -(assert (equal? #f (string-index "Hallo" #\.))) - -;; Locate the last occurrence of needle in haystack starting at offset. -(ffi-define (string-rindex haystack needle [offset])) -(assert (= 3 (string-rindex "Hallo" #\l))) -(assert (equal? #f (string-rindex "Hallo" #\a 2))) -(assert (equal? #f (string-rindex "Hallo" #\.))) - -;; Split HAYSTACK at each character that makes PREDICATE true at most -;; N times. -(define (string-split-pln haystack predicate lookahead n) - (let ((length (string-length haystack))) - (define (split acc offset n) - (if (>= offset length) - (reverse! acc) - (let ((i (lookahead haystack offset))) - (if (or (eq? i #f) (= 0 n)) - (reverse! (cons (substring haystack offset length) acc)) - (split (cons (substring haystack offset i) acc) - (+ i 1) (- n 1)))))) - (split '() 0 n))) - -(define (string-indexp haystack offset predicate) - (cond - ((= (string-length haystack) offset) - #f) - ((predicate (string-ref haystack offset)) - offset) - (else - (string-indexp haystack (+ 1 offset) predicate)))) - -;; Split HAYSTACK at each character that makes PREDICATE true at most -;; N times. -(define (string-splitp haystack predicate n) - (string-split-pln haystack predicate - (lambda (haystack offset) - (string-indexp haystack offset predicate)) - n)) -(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1))) -(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1))) -(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1))) - -;; Split haystack at delimiter at most n times. -(define (string-splitn haystack delimiter n) - (string-split-pln haystack - (lambda (c) (char=? c delimiter)) - (lambda (haystack offset) - (string-index haystack delimiter offset)) - n)) -(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1)))) -(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1)))) -(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1)))) - -;; Split haystack at delimiter. -(define (string-split haystack delimiter) - (string-splitn haystack delimiter -1)) -(assert (= 3 (length (string-split "foo:bar:baz" #\:)))) -(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:)))) -(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:)))) -(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:)))) - -;; Split haystack at newlines. -(define (string-split-newlines haystack) - (if *win32* - (map (lambda (line) (if (string-suffix? line "\r") - (substring line 0 (- (string-length line) 1)) - line)) - (string-split haystack #\newline)) - (string-split haystack #\newline))) - -;; Trim the prefix of S containing only characters that make PREDICATE -;; true. -(define (string-ltrim predicate s) - (if (string=? s "") - "" - (let loop ((s' (string->list s))) - (if (predicate (car s')) - (loop (cdr s')) - (list->string s'))))) -(assert (string=? "" (string-ltrim char-whitespace? ""))) -(assert (string=? "foo" (string-ltrim char-whitespace? " foo"))) - -;; Trim the suffix of S containing only characters that make PREDICATE -;; true. -(define (string-rtrim predicate s) - (if (string=? s "") - "" - (let loop ((s' (reverse! (string->list s)))) - (if (predicate (car s')) - (loop (cdr s')) - (list->string (reverse! s')))))) -(assert (string=? "" (string-rtrim char-whitespace? ""))) -(assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) - -;; Trim both the prefix and suffix of S containing only characters -;; that make PREDICATE true. -(define (string-trim predicate s) - (string-ltrim predicate (string-rtrim predicate s))) -(assert (string=? "" (string-trim char-whitespace? ""))) -(assert (string=? "foo" (string-trim char-whitespace? " foo "))) - -;; Check if needle is contained in haystack. -(ffi-define (string-contains? haystack needle)) -(assert (string-contains? "Hallo" "llo")) -(assert (not (string-contains? "Hallo" "olla"))) - -;; Translate characters. -(define (string-translate s from to) - (list->string (map (lambda (c) - (let ((i (string-index from c))) - (if i (string-ref to i) c))) (string->list s)))) -(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar")) - -;; Read a word from port P. -(define (read-word . p) - (list->string - (let f () - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) '()) - ((char-alphabetic? c) - (apply read-char p) - (cons c (f))) - (else - (apply read-char p) - '())))))) - -(define (list->string-reversed lst) - (let* ((len (length lst)) - (str (make-string len))) - (let loop ((i (- len 1)) - (l lst)) - (if (< i 0) - (begin - (assert (null? l)) - str) - (begin - (string-set! str i (car l)) - (loop (- i 1) (cdr l))))))) - -;; Read a line from port P. -(define (read-line . p) - (let loop ((acc '())) - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) - (if (null? acc) - c ;; #eof - (list->string-reversed acc))) - ((char=? c #\newline) - (apply read-char p) - (list->string-reversed acc)) - (else - (apply read-char p) - (loop (cons c acc))))))) - -;; Read everything from port P. -(define (read-all . p) - (let loop ((acc (open-output-string))) - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) (get-output-string acc)) - (else - (write-char (apply read-char p) acc) - (loop acc)))))) - -;; -;; Windows support. -;; - -;; Like call-with-input-file but opens the file in 'binary' mode. -(define (call-with-binary-input-file filename proc) - (letfd ((fd (open filename (logior O_RDONLY O_BINARY)))) - (proc (fdopen fd "rb")))) - -;; Like call-with-output-file but opens the file in 'binary' mode. -(define (call-with-binary-output-file filename proc) - (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600))) - (proc (fdopen fd "wb")))) - -;; -;; Libc functions. -;; - -;; Change the read/write offset. -(ffi-define (seek fd offset whence)) - -;; Constants for WHENCE. -(ffi-define SEEK_SET) -(ffi-define SEEK_CUR) -(ffi-define SEEK_END) - -;; Get our process id. -(ffi-define (getpid)) - -;; Copy data from file descriptor SOURCE to every file descriptor in -;; SINKS. -(ffi-define (splice source . sinks)) - -;; -;; Random numbers. -;; - -;; Seed the random number generator. -(ffi-define (srandom seed)) - -;; Get a pseudo-random number between 0 (inclusive) and SCALE -;; (exclusive). -(ffi-define (random scale)) - -;; Create a string of the given SIZE containing pseudo-random data. -(ffi-define (make-random-string size)) diff --git a/main.c b/main.c deleted file mode 100644 index 5540ac3..0000000 --- a/main.c +++ /dev/null @@ -1,359 +0,0 @@ -/* TinyScheme-based test driver. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#if HAVE_MMAP -#include -#endif - -#include "private.h" -#include "scheme.h" -#include "scheme-private.h" -#include "ffi.h" -#include "../common/i18n.h" -#include "../../common/argparse.h" -#include "../../common/init.h" -#include "../../common/logging.h" -#include "../../common/strlist.h" -#include "../../common/sysutils.h" -#include "../../common/util.h" - -/* The TinyScheme banner. Unfortunately, it isn't in the header - file. */ -#define ts_banner "TinyScheme 1.41" - -int verbose; - - - -/* Constants to identify the commands and options. */ -enum cmd_and_opt_values - { - aNull = 0, - oVerbose = 'v', - }; - -/* The list of commands and options. */ -static ARGPARSE_OPTS opts[] = - { - ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")), - ARGPARSE_end (), - }; - -char *scmpath = ""; -size_t scmpath_len = 0; - -/* Command line parsing. */ -static void -parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) -{ - int no_more_options = 0; - - while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts)) - { - switch (pargs->r_opt) - { - case oVerbose: - verbose++; - break; - - default: - pargs->err = 2; - break; - } - } -} - -/* Print usage information and provide strings for help. */ -static const char * -my_strusage( int level ) -{ - const char *p; - - switch (level) - { - case 11: p = "gpgscm (@GNUPG@)"; - break; - case 13: p = VERSION; break; - case 17: p = PRINTABLE_OS_NAME; break; - case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break; - - case 1: - case 40: - p = _("Usage: gpgscm [options] [file] (-h for help)"); - break; - case 41: - p = _("Syntax: gpgscm [options] [file]\n" - "Execute the given Scheme program, or spawn interactive shell.\n"); - break; - - default: p = NULL; break; - } - return p; -} - - - -static int -path_absolute_p (const char *p) -{ -#if _WIN32 - return ((strlen (p) > 2 && p[1] == ':' && (p[2] == '\\' || p[2] == '/')) - || p[0] == '\\' || p[0] == '/'); -#else - return p[0] == '/'; -#endif -} - - -/* Load the Scheme program from FILE_NAME. If FILE_NAME is not an - absolute path, and LOOKUP_IN_PATH is given, then it is qualified - with the values in scmpath until the file is found. */ -static gpg_error_t -load (scheme *sc, char *file_name, - int lookup_in_cwd, int lookup_in_path) -{ - gpg_error_t err = 0; - size_t n; - const char *directory; - char *qualified_name = file_name; - int use_path; - FILE *h = NULL; - - use_path = - lookup_in_path && ! (path_absolute_p (file_name) || scmpath_len == 0); - - if (path_absolute_p (file_name) || lookup_in_cwd || scmpath_len == 0) - { - h = fopen (file_name, "r"); - if (! h) - err = gpg_error_from_syserror (); - } - - if (h == NULL && use_path) - for (directory = scmpath, n = scmpath_len; n; - directory += strlen (directory) + 1, n--) - { - if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0) - return gpg_error_from_syserror (); - - h = fopen (qualified_name, "r"); - if (h) - { - err = 0; - break; - } - - if (n > 1) - { - free (qualified_name); - continue; /* Try again! */ - } - - err = gpg_error_from_syserror (); - } - - if (h == NULL) - { - /* Failed and no more elements in scmpath to try. */ - fprintf (stderr, "Could not read %s: %s.\n", - qualified_name, gpg_strerror (err)); - if (lookup_in_path) - fprintf (stderr, - "Consider using GPGSCM_PATH to specify the location " - "of the Scheme library.\n"); - goto leave; - } - if (verbose > 2) - fprintf (stderr, "Loading %s...\n", qualified_name); - -#if HAVE_MMAP - /* Always try to mmap the file. This allows the pages to be shared - * between processes. If anything fails, we fall back to using - * buffered streams. */ - if (1) - { - struct stat st; - void *map; - size_t len; - int fd = fileno (h); - - if (fd < 0) - goto fallback; - - if (fstat (fd, &st)) - goto fallback; - - len = (size_t) st.st_size; - if ((off_t) len != st.st_size) - goto fallback; /* Truncated. */ - - map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0); - if (map == MAP_FAILED) - goto fallback; - - scheme_load_memory (sc, map, len, qualified_name); - munmap (map, len); - } - else - fallback: -#endif - scheme_load_named_file (sc, h, qualified_name); - fclose (h); - - if (sc->retcode && sc->nesting) - { - fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); - err = gpg_error (GPG_ERR_GENERAL); - } - - leave: - if (file_name != qualified_name) - free (qualified_name); - return err; -} - - - -int -main (int argc, char **argv) -{ - int retcode; - gpg_error_t err; - char *argv0; - ARGPARSE_ARGS pargs; - scheme *sc; - char *p; -#if _WIN32 - char pathsep = ';'; -#else - char pathsep = ':'; -#endif - char *script = NULL; - - /* Save argv[0] so that we can re-exec. */ - argv0 = argv[0]; - - /* Parse path. */ - if (getenv ("GPGSCM_PATH")) - scmpath = getenv ("GPGSCM_PATH"); - - p = scmpath = strdup (scmpath); - if (p == NULL) - return 2; - - if (*p) - scmpath_len++; - for (; *p; p++) - if (*p == pathsep) - *p = 0, scmpath_len++; - - set_strusage (my_strusage); - log_set_prefix ("gpgscm", GPGRT_LOG_WITH_PREFIX); - - /* Make sure that our subsystems are ready. */ - i18n_init (); - init_common_subsystems (&argc, &argv); - - if (!gcry_check_version (NEED_LIBGCRYPT_VERSION)) - { - fputs ("libgcrypt version mismatch\n", stderr); - exit (2); - } - - /* Parse the command line. */ - pargs.argc = &argc; - pargs.argv = &argv; - pargs.flags = 0; - parse_arguments (&pargs, opts); - - if (log_get_errorcount (0)) - exit (2); - - sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free); - if (! sc) { - fprintf (stderr, "Could not initialize TinyScheme!\n"); - return 2; - } - scheme_set_input_port_file (sc, stdin); - scheme_set_output_port_file (sc, stderr); - - if (argc) - { - script = argv[0]; - argc--, argv++; - } - - err = load (sc, "init.scm", 0, 1); - if (! err) - err = load (sc, "ffi.scm", 0, 1); - if (! err) - err = ffi_init (sc, argv0, script ? script : "interactive", - argc, (const char **) argv); - if (! err) - err = load (sc, "lib.scm", 0, 1); - if (! err) - err = load (sc, "repl.scm", 0, 1); - if (! err) - err = load (sc, "xml.scm", 0, 1); - if (! err) - err = load (sc, "tests.scm", 0, 1); - if (! err) - err = load (sc, "gnupg.scm", 0, 1); - if (err) - { - fprintf (stderr, "Error initializing gpgscm: %s.\n", - gpg_strerror (err)); - exit (2); - } - - if (script == NULL) - { - /* Interactive shell. */ - fprintf (stderr, "gpgscm/"ts_banner".\n"); - scheme_load_string (sc, "(interactive-repl)"); - } - else - { - err = load (sc, script, 1, 1); - if (err) - log_fatal ("%s: %s", script, gpg_strerror (err)); - } - - retcode = sc->retcode; - scheme_load_string (sc, "(*run-atexit-handlers*)"); - scheme_deinit (sc); - xfree (sc); - return retcode; -} diff --git a/makefile.scm b/makefile.scm deleted file mode 100644 index 32fae3a..0000000 --- a/makefile.scm +++ /dev/null @@ -1,76 +0,0 @@ -;; Support for parsing Makefiles -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(define (parse-makefile port key) - (define (is-continuation? tokens) - (string=? (last tokens) "\\")) - (define (valid-token? s) - (< 0 (string-length s))) - (define (drop-continuations tokens) - (let loop ((acc '()) (tks tokens)) - (if (null? tks) - (reverse acc) - (loop (if (string=? "\\" (car tks)) - acc - (cons (car tks) acc)) (cdr tks))))) - (let next ((acc '()) (found #f)) - (let ((line (read-line port))) - (if (eof-object? line) - acc - (let ((tokens (filter valid-token? - (string-splitp (string-trim char-whitespace? - line) - char-whitespace? -1)))) - (cond - ((or (null? tokens) - (string-prefix? (car tokens) "#") - (and (not found) (not (and (string=? key (car tokens)) - (string=? "=" (cadr tokens)))))) - (next acc found)) - ((not found) - (assert (and (string=? key (car tokens)) - (string=? "=" (cadr tokens)))) - (if (is-continuation? tokens) - (next (drop-continuations (cddr tokens)) #t) - (drop-continuations (cddr tokens)))) - (else - (assert found) - (if (is-continuation? tokens) - (next (append acc (drop-continuations tokens)) found) - (append acc (drop-continuations tokens)))))))))) - -(define (parse-makefile-expand filename expand key) - (define (variable? v) - (and (string-prefix? v "$(") (string-suffix? v ")"))) - - (let expand-all ((values (parse-makefile (open-input-file filename) key))) - (if (any variable? values) - (expand-all - (let expand-one ((acc '()) (v values)) - (cond - ((null? v) - acc) - ((variable? (car v)) - (let ((makefile (open-input-file filename)) - (key (substring (car v) 2 (- (string-length (car v)) 1)))) - (expand-one (append acc (expand filename makefile key)) - (cdr v)))) - (else - (expand-one (append acc (list (car v))) (cdr v)))))) - values))) diff --git a/opdefines.h b/opdefines.h deleted file mode 100644 index 61f7971..0000000 --- a/opdefines.h +++ /dev/null @@ -1,205 +0,0 @@ -_OP_DEF("load", 1, 1, TST_STRING, OP_LOAD ) -_OP_DEF(0, 0, 0, 0, OP_T0LVL ) -_OP_DEF(0, 0, 0, 0, OP_T1LVL ) -_OP_DEF(0, 0, 0, 0, OP_READ_INTERNAL ) -_OP_DEF("gensym", 0, 0, 0, OP_GENSYM ) -_OP_DEF(0, 0, 0, 0, OP_VALUEPRINT ) -_OP_DEF(0, 0, 0, 0, OP_EVAL ) -#if USE_TRACING -_OP_DEF(0, 0, 0, 0, OP_REAL_EVAL ) -#endif -_OP_DEF(0, 0, 0, 0, OP_E0ARGS ) -_OP_DEF(0, 0, 0, 0, OP_E1ARGS ) -#if USE_HISTORY -_OP_DEF(0, 0, 0, 0, OP_CALLSTACK_POP ) -#endif -_OP_DEF(0, 0, 0, 0, OP_APPLY_CODE ) -_OP_DEF(0, 0, 0, 0, OP_APPLY ) -#if USE_TRACING -_OP_DEF(0, 0, 0, 0, OP_REAL_APPLY ) -_OP_DEF("tracing", 1, 1, TST_NATURAL, OP_TRACING ) -#endif -_OP_DEF(0, 0, 0, 0, OP_DOMACRO ) -_OP_DEF(0, 0, 0, 0, OP_LAMBDA ) -_OP_DEF(0, 0, 0, 0, OP_LAMBDA1 ) -_OP_DEF("make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) -_OP_DEF(0, 0, 0, 0, OP_QUOTE ) -_OP_DEF(0, 0, 0, 0, OP_DEF0 ) -_OP_DEF(0, 0, 0, 0, OP_DEF1 ) -_OP_DEF("defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) -_OP_DEF(0, 0, 0, 0, OP_BEGIN ) -_OP_DEF(0, 0, 0, 0, OP_IF0 ) -_OP_DEF(0, 0, 0, 0, OP_IF1 ) -_OP_DEF(0, 0, 0, 0, OP_SET0 ) -_OP_DEF(0, 0, 0, 0, OP_SET1 ) -_OP_DEF(0, 0, 0, 0, OP_LET0 ) -_OP_DEF(0, 0, 0, 0, OP_LET1 ) -_OP_DEF(0, 0, 0, 0, OP_LET2 ) -_OP_DEF(0, 0, 0, 0, OP_LET0AST ) -_OP_DEF(0, 0, 0, 0, OP_LET1AST ) -_OP_DEF(0, 0, 0, 0, OP_LET2AST ) -_OP_DEF(0, 0, 0, 0, OP_LET0REC ) -_OP_DEF(0, 0, 0, 0, OP_LET1REC ) -_OP_DEF(0, 0, 0, 0, OP_LET2REC ) -_OP_DEF(0, 0, 0, 0, OP_COND0 ) -_OP_DEF(0, 0, 0, 0, OP_COND1 ) -_OP_DEF(0, 0, 0, 0, OP_DELAY ) -_OP_DEF(0, 0, 0, 0, OP_AND0 ) -_OP_DEF(0, 0, 0, 0, OP_AND1 ) -_OP_DEF(0, 0, 0, 0, OP_OR0 ) -_OP_DEF(0, 0, 0, 0, OP_OR1 ) -_OP_DEF(0, 0, 0, 0, OP_C0STREAM ) -_OP_DEF(0, 0, 0, 0, OP_C1STREAM ) -_OP_DEF(0, 0, 0, 0, OP_MACRO0 ) -_OP_DEF(0, 0, 0, 0, OP_MACRO1 ) -_OP_DEF(0, 0, 0, 0, OP_CASE0 ) -_OP_DEF(0, 0, 0, 0, OP_CASE1 ) -_OP_DEF(0, 0, 0, 0, OP_CASE2 ) -_OP_DEF("eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) -_OP_DEF("apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) -_OP_DEF("call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) -#if USE_MATH -_OP_DEF("inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) -_OP_DEF("exp", 1, 1, TST_NUMBER, OP_EXP ) -_OP_DEF("log", 1, 1, TST_NUMBER, OP_LOG ) -_OP_DEF("sin", 1, 1, TST_NUMBER, OP_SIN ) -_OP_DEF("cos", 1, 1, TST_NUMBER, OP_COS ) -_OP_DEF("tan", 1, 1, TST_NUMBER, OP_TAN ) -_OP_DEF("asin", 1, 1, TST_NUMBER, OP_ASIN ) -_OP_DEF("acos", 1, 1, TST_NUMBER, OP_ACOS ) -_OP_DEF("atan", 1, 2, TST_NUMBER, OP_ATAN ) -_OP_DEF("sqrt", 1, 1, TST_NUMBER, OP_SQRT ) -_OP_DEF("expt", 2, 2, TST_NUMBER, OP_EXPT ) -_OP_DEF("floor", 1, 1, TST_NUMBER, OP_FLOOR ) -_OP_DEF("ceiling", 1, 1, TST_NUMBER, OP_CEILING ) -_OP_DEF("truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) -_OP_DEF("round", 1, 1, TST_NUMBER, OP_ROUND ) -#endif -_OP_DEF("+", 0, INF_ARG, TST_NUMBER, OP_ADD ) -_OP_DEF("-", 1, INF_ARG, TST_NUMBER, OP_SUB ) -_OP_DEF("*", 0, INF_ARG, TST_NUMBER, OP_MUL ) -_OP_DEF("/", 1, INF_ARG, TST_NUMBER, OP_DIV ) -_OP_DEF("quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) -_OP_DEF("remainder", 2, 2, TST_INTEGER, OP_REM ) -_OP_DEF("modulo", 2, 2, TST_INTEGER, OP_MOD ) -_OP_DEF("car", 1, 1, TST_PAIR, OP_CAR ) -_OP_DEF("cdr", 1, 1, TST_PAIR, OP_CDR ) -_OP_DEF("cons", 2, 2, TST_NONE, OP_CONS ) -_OP_DEF("set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) -_OP_DEF("set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) -_OP_DEF("char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) -_OP_DEF("integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) -_OP_DEF("char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) -_OP_DEF("char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) -_OP_DEF("symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) -_OP_DEF("atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) -_OP_DEF("string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) -_OP_DEF("string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) -_OP_DEF("make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) -_OP_DEF("string-length", 1, 1, TST_STRING, OP_STRLEN ) -_OP_DEF("string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) -_OP_DEF("string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) -_OP_DEF("string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) -_OP_DEF("substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) -_OP_DEF("vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) -_OP_DEF("make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) -_OP_DEF("vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) -_OP_DEF("vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) -_OP_DEF("vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) -_OP_DEF("not", 1, 1, TST_NONE, OP_NOT ) -_OP_DEF("boolean?", 1, 1, TST_NONE, OP_BOOLP ) -_OP_DEF("eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) -_OP_DEF("null?", 1, 1, TST_NONE, OP_NULLP ) -_OP_DEF("=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) -_OP_DEF("<", 2, INF_ARG, TST_NUMBER, OP_LESS ) -_OP_DEF(">", 2, INF_ARG, TST_NUMBER, OP_GRE ) -_OP_DEF("<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) -_OP_DEF(">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) -_OP_DEF("symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) -_OP_DEF("number?", 1, 1, TST_ANY, OP_NUMBERP ) -_OP_DEF("string?", 1, 1, TST_ANY, OP_STRINGP ) -_OP_DEF("integer?", 1, 1, TST_ANY, OP_INTEGERP ) -_OP_DEF("real?", 1, 1, TST_ANY, OP_REALP ) -_OP_DEF("char?", 1, 1, TST_ANY, OP_CHARP ) -#if USE_CHAR_CLASSIFIERS -_OP_DEF("char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) -_OP_DEF("char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) -_OP_DEF("char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) -_OP_DEF("char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) -_OP_DEF("char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) -#endif -_OP_DEF("port?", 1, 1, TST_ANY, OP_PORTP ) -_OP_DEF("input-port?", 1, 1, TST_ANY, OP_INPORTP ) -_OP_DEF("output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) -_OP_DEF("procedure?", 1, 1, TST_ANY, OP_PROCP ) -_OP_DEF("pair?", 1, 1, TST_ANY, OP_PAIRP ) -_OP_DEF("list?", 1, 1, TST_ANY, OP_LISTP ) -_OP_DEF("environment?", 1, 1, TST_ANY, OP_ENVP ) -_OP_DEF("vector?", 1, 1, TST_ANY, OP_VECTORP ) -_OP_DEF("eq?", 2, 2, TST_ANY, OP_EQ ) -_OP_DEF("eqv?", 2, 2, TST_ANY, OP_EQV ) -_OP_DEF("force", 1, 1, TST_ANY, OP_FORCE ) -_OP_DEF(0, 0, 0, 0, OP_SAVE_FORCED ) -_OP_DEF("write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) -_OP_DEF("write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) -_OP_DEF("display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) -_OP_DEF("newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) -_OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 ) -_OP_DEF(0, 0, 0, 0, OP_ERR1 ) -_OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE ) -_OP_DEF("reverse!", 1, 1, TST_LIST, OP_REVERSE_IN_PLACE ) -_OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) -_OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND ) -#if USE_PLIST -_OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) -_OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) -#endif -_OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE ) -_OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) -_OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) -_OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT ) -_OP_DEF("gc", 0, 0, 0, OP_GC ) -_OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) -_OP_DEF("new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) -_OP_DEF("oblist", 0, 0, 0, OP_OBLIST ) -_OP_DEF("current-input-port", 0, 0, 0, OP_CURR_INPORT ) -_OP_DEF("current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) -_OP_DEF("open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) -_OP_DEF("open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) -_OP_DEF("open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) -#if USE_STRING_PORTS -_OP_DEF("open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) -_OP_DEF("open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) -_OP_DEF("open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) -_OP_DEF("get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) -#endif -_OP_DEF("close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) -_OP_DEF("close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) -_OP_DEF("interaction-environment", 0, 0, 0, OP_INT_ENV ) -_OP_DEF("current-environment", 0, 0, 0, OP_CURR_ENV ) -_OP_DEF("read", 0, 1, TST_INPORT, OP_READ ) -_OP_DEF("read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) -_OP_DEF("peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) -_OP_DEF("char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) -_OP_DEF("set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) -_OP_DEF("set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) -_OP_DEF(0, 0, 0, 0, OP_RDSEXPR ) -_OP_DEF(0, 0, 0, 0, OP_RDLIST ) -_OP_DEF(0, 0, 0, 0, OP_RDDOT ) -_OP_DEF(0, 0, 0, 0, OP_RDQUOTE ) -_OP_DEF(0, 0, 0, 0, OP_RDQQUOTE ) -_OP_DEF(0, 0, 0, 0, OP_RDQQUOTEVEC ) -_OP_DEF(0, 0, 0, 0, OP_RDUNQUOTE ) -_OP_DEF(0, 0, 0, 0, OP_RDUQTSP ) -_OP_DEF(0, 0, 0, 0, OP_RDVEC ) -_OP_DEF(0, 0, 0, 0, OP_P0LIST ) -_OP_DEF(0, 0, 0, 0, OP_P1LIST ) -_OP_DEF(0, 0, 0, 0, OP_PVECFROM ) -_OP_DEF("length", 1, 1, TST_LIST, OP_LIST_LENGTH ) -_OP_DEF("assq", 2, 2, TST_NONE, OP_ASSQ ) -_OP_DEF("get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) -_OP_DEF("closure?", 1, 1, TST_NONE, OP_CLOSUREP ) -_OP_DEF("macro?", 1, 1, TST_NONE, OP_MACROP ) -_OP_DEF("*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) - -#undef _OP_DEF diff --git a/private.h b/private.h deleted file mode 100644 index 6e330e0..0000000 --- a/private.h +++ /dev/null @@ -1,26 +0,0 @@ -/* TinyScheme-based test driver. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#ifndef __GPGSCM_PRIVATE_H__ -#define __GPGSCM_PRIVATE_H__ - -extern int verbose; - -#endif /* __GPGSCM_PRIVATE_H__ */ diff --git a/repl.scm b/repl.scm deleted file mode 100644 index 833ec0d..0000000 --- a/repl.scm +++ /dev/null @@ -1,69 +0,0 @@ -;; A read-evaluate-print-loop for gpgscm. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Interactive repl using 'prompt' function. P must be a function -;; that given the current entered prefix returns the prompt to -;; display. -(define (repl p environment) - (call/cc - (lambda (exit) - (let loop ((prefix "")) - (let ((line (prompt (p prefix)))) - (if (and (not (eof-object? line)) (= 0 (string-length line))) - (exit (loop prefix))) - (if (not (eof-object? line)) - (let* ((next (string-append prefix line)) - (c (catch (begin (echo "Parse error:" *error*) - (loop prefix)) - (read (open-input-string next))))) - (if (not (eof-object? c)) - (begin - (catch (begin - (display (car *error*)) - (when (and (cadr *error*) - (not (null? (cadr *error*)))) - (display ": ") - (write (cadr *error*))) - (newline) - (vm-history-print (caddr *error*))) - (echo " ===>" (eval c environment))) - (exit (loop "")))) - (exit (loop next))))))))) - -(define (prompt-append-prefix prompt prefix) - (string-append prompt (if (> (string-length prefix) 0) - (string-append prefix "...") - "> "))) - -;; Default repl run by main.c. -(define (interactive-repl . environment) - (repl (lambda (p) (prompt-append-prefix "gpgscm " p)) - (if (null? environment) (interaction-environment) (car environment)))) - -;; Ask a yes/no question. -(define (prompt-yes-no? question default) - (let ((answer (prompt (string-append question "? [" - (if default "Y/n" "y/N") "] ")))) - (cond - ((= 0 (string-length answer)) - default) - ((or (equal? "y" answer) (equal? "Y" answer)) - #t) - (else - #f)))) diff --git a/scheme-config.h b/scheme-config.h deleted file mode 100644 index 15ca969..0000000 --- a/scheme-config.h +++ /dev/null @@ -1,32 +0,0 @@ -/* TinyScheme configuration. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#define STANDALONE 0 -#define USE_MATH 0 -#define USE_CHAR_CLASSIFIERS 1 -#define USE_ASCII_NAMES 1 -#define USE_STRING_PORTS 1 -#define USE_ERROR_HOOK 1 -#define USE_TRACING 1 -#define USE_COLON_HOOK 1 -#define USE_DL 0 -#define USE_PLIST 0 -#define USE_INTERFACE 1 -#define SHOW_ERROR_LINE 1 diff --git a/scheme-private.h b/scheme-private.h deleted file mode 100644 index 7f92bda..0000000 --- a/scheme-private.h +++ /dev/null @@ -1,274 +0,0 @@ -/* scheme-private.h */ - -#ifndef _SCHEME_PRIVATE_H -#define _SCHEME_PRIVATE_H - -#include -#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; - } stdio; - struct { - char *start; - char *past_the_end; - char *curr; - } string; - } rep; -#if SHOW_ERROR_LINE - pointer curr_line; - pointer filename; -#endif -} port; - -/* cell structure */ -struct cell { - uintptr_t _flag; - union { - num _number; - struct { - char *_svalue; - int _length; - } _string; - port *_port; - foreign_func _ff; - struct { - struct cell *_car; - struct cell *_cdr; - } _cons; - struct { - size_t _length; - pointer _elements[0]; - } _vector; - struct { - char *_data; - const foreign_object_vtable *_vtable; - } _foreign_object; - } _object; -}; - -#if USE_HISTORY -/* The history is a two-dimensional ring buffer. A donut-shaped data - * structure. This data structure is inspired by MIT/GNU Scheme. */ -struct history { - /* Number of calls to store. Must be a power of two. */ - size_t N; - - /* Number of tail-calls to store in each call frame. Must be a - * power of two. */ - size_t M; - - /* Masks for fast index calculations. */ - size_t mask_N; - size_t mask_M; - - /* A vector of size N containing calls. */ - pointer callstack; - - /* A vector of size N containing vectors of size M containing tail - * calls. */ - pointer tailstacks; - - /* Our current position. */ - size_t n; - size_t *m; -}; -#endif - -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 - -/* If less than # of cells are recovered in a garbage collector run, - * allocate a new cell segment to avoid fruitless collection cycles in - * the near future. */ -#ifndef CELL_MINRECOVER -#define CELL_MINRECOVER (CELL_SEGSIZE >> 2) -#endif -struct cell_segment *cell_segments; - -/* 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 */ -pointer frame_freelist; - -#if USE_HISTORY -struct history history; /* we keep track of the call history for - * error messages */ -#endif - -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* */ -#if USE_COMPILE_HOOK -pointer COMPILE_HOOK; /* *compile-hook* */ -#endif - -pointer free_cell; /* pointer to top of free cells */ -long fcells; /* # of free cells */ -size_t inhibit_gc; /* nesting of gc_disable */ -size_t reserved_cells; /* # of reserved cells */ -#ifndef NDEBUG -int reserved_lineno; /* location of last reservation */ -#endif - -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; -size_t strbuff_size; -FILE *tmpfp; -int tok; -int print_flag; -pointer value; -unsigned int flags; - -void *ext_data; /* For the benefit of foreign functions */ -long gensym_cnt; - -const struct scheme_interface *vptr; -}; - -/* operator code */ -enum scheme_opcodes { -#define _OP_DEF(A,B,C,D,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); - -int is_foreign_object(pointer p); -const foreign_object_vtable *get_foreign_object_vtable(pointer p); -void *get_foreign_object_data(pointer p); - -#ifdef __cplusplus -} -#endif - -#endif - -/* -Local variables: -c-file-style: "k&r" -End: -*/ diff --git a/scheme.c b/scheme.c deleted file mode 100644 index 4384841..0000000 --- a/scheme.c +++ /dev/null @@ -1,6028 +0,0 @@ -/* T I N Y S C H E M E 1 . 4 1 - * Dimitrios Souflis (dsouflis@acm.org) - * Based on MiniScheme (original credits follow) - * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) - * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp - * (MINISCM) This version has been modified by R.C. Secrist. - * (MINISCM) - * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. - * (MINISCM) - * (MINISCM) This is a revised and modified version by Akira KIDA. - * (MINISCM) current version is 0.85k4 (15 May 1994) - * - */ - -#ifdef HAVE_CONFIG_H -# include -#endif - -#define _SCHEME_SOURCE -#include "scheme-private.h" -#ifndef WIN32 -# include -#endif -#ifdef WIN32 -#define snprintf _snprintf -#endif -#if USE_DL -# include "dynload.h" -#endif -#if USE_MATH -# include -#endif - -#include -#include -#include -#include -#include - -#if USE_STRCASECMP -#include -# ifndef __APPLE__ -# define stricmp strcasecmp -# endif -#endif - -/* Used for documentation purposes, to signal functions in 'interface' */ -#define INTERFACE - -#define TOK_EOF (-1) -#define TOK_LPAREN 0 -#define TOK_RPAREN 1 -#define TOK_DOT 2 -#define TOK_ATOM 3 -#define TOK_QUOTE 4 -#define TOK_COMMENT 5 -#define TOK_DQUOTE 6 -#define TOK_BQUOTE 7 -#define TOK_COMMA 8 -#define TOK_ATMARK 9 -#define TOK_SHARP 10 -#define TOK_SHARP_CONST 11 -#define TOK_VEC 12 - -#define BACKQUOTE '`' -#define DELIMITERS "()\";\f\t\v\n\r " - -/* - * Basic memory allocation units - */ - -#define banner "TinyScheme 1.41" - -#include -#include -#include - -#ifdef __APPLE__ -static int stricmp(const char *s1, const char *s2) -{ - unsigned char c1, c2; - do { - c1 = tolower(*s1); - c2 = tolower(*s2); - if (c1 < c2) - return -1; - else if (c1 > c2) - return 1; - s1++, s2++; - } while (c1 != 0); - return 0; -} -#endif /* __APPLE__ */ - -#if USE_STRLWR && !defined(HAVE_STRLWR) -static const char *strlwr(char *s) { - const char *p=s; - while(*s) { - *s=tolower(*s); - s++; - } - return p; -} -#endif - -#ifndef prompt -# define prompt "ts> " -#endif - -#ifndef InitFile -# define InitFile "init.scm" -#endif - -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - - - -/* All types have the LSB set. The garbage collector takes advantage - * of that to identify types. */ -enum scheme_types { - T_STRING = 1 << 1 | 1, - T_NUMBER = 2 << 1 | 1, - T_SYMBOL = 3 << 1 | 1, - T_PROC = 4 << 1 | 1, - T_PAIR = 5 << 1 | 1, - T_CLOSURE = 6 << 1 | 1, - T_CONTINUATION = 7 << 1 | 1, - T_FOREIGN = 8 << 1 | 1, - T_CHARACTER = 9 << 1 | 1, - T_PORT = 10 << 1 | 1, - T_VECTOR = 11 << 1 | 1, - T_MACRO = 12 << 1 | 1, - T_PROMISE = 13 << 1 | 1, - T_ENVIRONMENT = 14 << 1 | 1, - T_FOREIGN_OBJECT = 15 << 1 | 1, - T_BOOLEAN = 16 << 1 | 1, - T_NIL = 17 << 1 | 1, - T_EOF_OBJ = 18 << 1 | 1, - T_SINK = 19 << 1 | 1, - T_FRAME = 20 << 1 | 1, - T_LAST_SYSTEM_TYPE = 20 << 1 | 1 -}; - -static const char * -type_to_string (enum scheme_types typ) -{ - switch (typ) - { - case T_STRING: return "string"; - case T_NUMBER: return "number"; - case T_SYMBOL: return "symbol"; - case T_PROC: return "proc"; - case T_PAIR: return "pair"; - case T_CLOSURE: return "closure"; - case T_CONTINUATION: return "continuation"; - case T_FOREIGN: return "foreign"; - case T_CHARACTER: return "character"; - case T_PORT: return "port"; - case T_VECTOR: return "vector"; - case T_MACRO: return "macro"; - case T_PROMISE: return "promise"; - case T_ENVIRONMENT: return "environment"; - case T_FOREIGN_OBJECT: return "foreign object"; - case T_BOOLEAN: return "boolean"; - case T_NIL: return "nil"; - case T_EOF_OBJ: return "eof object"; - case T_SINK: return "sink"; - case T_FRAME: return "frame"; - } - assert (! "not reached"); -} - -/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ -#define TYPE_BITS 6 -#define ADJ (1 << TYPE_BITS) -#define T_MASKTYPE (ADJ - 1) - /* 0000000000111111 */ -#define T_TAGGED 1024 /* 0000010000000000 */ -#define T_FINALIZE 2048 /* 0000100000000000 */ -#define T_SYNTAX 4096 /* 0001000000000000 */ -#define T_IMMUTABLE 8192 /* 0010000000000000 */ -#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ -#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ -#define MARK 32768 /* 1000000000000000 */ -#define UNMARK 32767 /* 0111111111111111 */ - - -static num num_add(num a, num b); -static num num_mul(num a, num b); -static num num_div(num a, num b); -static num num_intdiv(num a, num b); -static num num_sub(num a, num b); -static num num_rem(num a, num b); -static num num_mod(num a, num b); -static int num_eq(num a, num b); -static int num_gt(num a, num b); -static int num_ge(num a, num b); -static int num_lt(num a, num b); -static int num_le(num a, num b); - -#if USE_MATH -static double round_per_R5RS(double x); -#endif -static int is_zero_double(double x); -static INLINE int num_is_integer(pointer p) { - return ((p)->_object._number.is_fixnum); -} - -static const struct num num_zero = { 1, {0} }; -static const struct num num_one = { 1, {1} }; - -/* macros for cell operations */ -#define typeflag(p) ((p)->_flag) -#define type(p) (typeflag(p)&T_MASKTYPE) -#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ)) - -INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } -#define strvalue(p) ((p)->_object._string._svalue) -#define strlength(p) ((p)->_object._string._length) - -INTERFACE static int is_list(scheme *sc, pointer p); -INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } -/* Given a vector, return it's length. */ -#define vector_length(v) (v)->_object._vector._length -/* Given a vector length, compute the amount of cells required to - * represent it. */ -#define vector_size(len) (1 + ((len) - 1 + 2) / 3) -INTERFACE static void fill_vector(pointer vec, pointer obj); -INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem); -INTERFACE static pointer vector_elem(pointer vec, int ielem); -INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); -INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } -INTERFACE INLINE int is_integer(pointer p) { - if (!is_number(p)) - return 0; - if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) - return 1; - return 0; -} - -INTERFACE INLINE int is_real(pointer p) { - return is_number(p) && (!(p)->_object._number.is_fixnum); -} - -INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } -INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } -INLINE num nvalue(pointer p) { return ((p)->_object._number); } -INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } -INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } -#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) -#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) -#define set_num_integer(p) (p)->_object._number.is_fixnum=1; -#define set_num_real(p) (p)->_object._number.is_fixnum=0; -INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } - -INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } -INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } -INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } - -INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } -#define car(p) ((p)->_object._cons._car) -#define cdr(p) ((p)->_object._cons._cdr) -INTERFACE pointer pair_car(pointer p) { return car(p); } -INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } -INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } -INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } - -INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } -INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } -#if USE_PLIST -SCHEME_EXPORT INLINE int hasprop(pointer p) { return (is_symbol(p)); } -#define symprop(p) cdr(p) -#endif - -INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } -INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } -INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } -INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } -#define procnum(p) ivalue_unchecked(p) -static const char *procname(pointer x); - -INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } -INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } -INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } -INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } - -INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } -#define cont_dump(p) cdr(p) - -INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); } -INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) { - return p->_object._foreign_object._vtable; -} -INTERFACE void *get_foreign_object_data(pointer p) { - return p->_object._foreign_object._data; -} - -/* To do: promise should be forced ONCE only */ -INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } - -INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } -#define setenvironment(p) typeflag(p) = T_ENVIRONMENT - -INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); } -#define setframe(p) settype(p, T_FRAME) - -#define is_atom(p) (typeflag(p)&T_ATOM) -#define setatom(p) typeflag(p) |= T_ATOM -#define clratom(p) typeflag(p) &= CLRATOM - -#define is_mark(p) (typeflag(p)&MARK) -#define setmark(p) typeflag(p) |= MARK -#define clrmark(p) typeflag(p) &= UNMARK - -INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } -/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ -INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } - -#define caar(p) car(car(p)) -#define cadr(p) car(cdr(p)) -#define cdar(p) cdr(car(p)) -#define cddr(p) cdr(cdr(p)) -#define cadar(p) car(cdr(car(p))) -#define caddr(p) car(cdr(cdr(p))) -#define cdaar(p) cdr(car(car(p))) -#define cadaar(p) car(cdr(car(car(p)))) -#define cadddr(p) car(cdr(cdr(cdr(p)))) -#define cddddr(p) cdr(cdr(cdr(cdr(p)))) - -#if USE_HISTORY -static pointer history_flatten(scheme *sc); -static void history_mark(scheme *sc); -#else -# define history_mark(SC) (void) 0 -# define history_flatten(SC) (SC)->NIL -#endif - -#if USE_CHAR_CLASSIFIERS -static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } -static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } -static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } -static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } -static INLINE int Cislower(int c) { return isascii(c) && islower(c); } -#endif - -#if USE_ASCII_NAMES -static const char charnames[32][3]={ - "nul", - "soh", - "stx", - "etx", - "eot", - "enq", - "ack", - "bel", - "bs", - "ht", - "lf", - "vt", - "ff", - "cr", - "so", - "si", - "dle", - "dc1", - "dc2", - "dc3", - "dc4", - "nak", - "syn", - "etb", - "can", - "em", - "sub", - "esc", - "fs", - "gs", - "rs", - "us" -}; - -static int is_ascii_name(const char *name, int *pc) { - int i; - for(i=0; i<32; i++) { - if (strncasecmp(name, charnames[i], 3) == 0) { - *pc=i; - return 1; - } - } - if (strcasecmp(name, "del") == 0) { - *pc=127; - return 1; - } - return 0; -} - -#endif - -static int file_push(scheme *sc, pointer fname); -static void file_pop(scheme *sc); -static int file_interactive(scheme *sc); -static INLINE int is_one_of(char *s, int c); -static int alloc_cellseg(scheme *sc, int n); -static long binary_decode(const char *s); -static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); -static pointer _get_cell(scheme *sc, pointer a, pointer b); -static pointer reserve_cells(scheme *sc, int n); -static pointer get_consecutive_cells(scheme *sc, int n); -static pointer find_consecutive_cells(scheme *sc, int n); -static int finalize_cell(scheme *sc, pointer a); -static int count_consecutive_cells(pointer x, int needed); -static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); -static pointer mk_number(scheme *sc, num n); -static char *store_string(scheme *sc, int len, const char *str, char fill); -static pointer mk_vector(scheme *sc, int len); -static pointer mk_atom(scheme *sc, char *q); -static pointer mk_sharp_const(scheme *sc, char *name); -static pointer mk_port(scheme *sc, port *p); -static pointer port_from_filename(scheme *sc, const char *fn, int prop); -static pointer port_from_file(scheme *sc, FILE *, int prop); -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); -static port *port_rep_from_file(scheme *sc, FILE *, int prop); -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static void port_close(scheme *sc, pointer p, int flag); -static void mark(pointer a); -static void gc(scheme *sc, pointer a, pointer b); -static int basic_inchar(port *pt); -static int inchar(scheme *sc); -static void backchar(scheme *sc, int c); -static char *readstr_upto(scheme *sc, char *delim); -static pointer readstrexp(scheme *sc); -static INLINE int skipspace(scheme *sc); -static int token(scheme *sc); -static void printslashstring(scheme *sc, char *s, int len); -static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); -static void printatom(scheme *sc, pointer l, int f); -static pointer mk_proc(scheme *sc, enum scheme_opcodes op); -static pointer mk_closure(scheme *sc, pointer c, pointer e); -static pointer mk_continuation(scheme *sc, pointer d); -static pointer reverse(scheme *sc, pointer term, pointer list); -static pointer reverse_in_place(scheme *sc, pointer term, pointer list); -static pointer revappend(scheme *sc, pointer a, pointer b); -static void dump_stack_preallocate_frame(scheme *sc); -static void dump_stack_mark(scheme *); -struct op_code_info { - char name[31]; /* strlen ("call-with-current-continuation") + 1 */ - unsigned char min_arity; - unsigned char max_arity; - char arg_tests_encoding[3]; -}; -static const struct op_code_info dispatch_table[]; -static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size); -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); -static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name); -static int syntaxnum(scheme *sc, pointer p); -static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name); - -#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) -#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) - -static num num_add(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue+b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)+num_rvalue(b); - } - return ret; -} - -static num num_mul(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue*b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)*num_rvalue(b); - } - return ret; -} - -static num num_div(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_intdiv(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_sub(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue-b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)-num_rvalue(b); - } - return ret; -} - -static num num_rem(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - /* remainder should have same sign as second operand */ - if (res > 0) { - if (e1 < 0) { - res -= labs(e2); - } - } else if (res < 0) { - if (e1 > 0) { - res += labs(e2); - } - } - ret.value.ivalue=res; - return ret; -} - -static num num_mod(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - /* modulo should have same sign as second operand */ - if (res * e2 < 0) { - res += e2; - } - ret.value.ivalue=res; - return ret; -} - -static int num_eq(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue==b.value.ivalue; - } else { - ret=num_rvalue(a)==num_rvalue(b); - } - return ret; -} - - -static int num_gt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue>b.value.ivalue; - } else { - ret=num_rvalue(a)>num_rvalue(b); - } - return ret; -} - -static int num_ge(num a, num b) { - return !num_lt(a,b); -} - -static int num_lt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivaluedce) { - return ce; - } else if(dfl-DBL_MIN; -} - -static long binary_decode(const char *s) { - long x=0; - - while(*s!=0 && (*s=='1' || *s=='0')) { - x<<=1; - x+=*s-'0'; - s++; - } - - return x; -} - - - -/* - * Copying values. - * - * Occasionally, we need to copy a value from one location in the - * storage to another. Scheme objects are fine. Some primitive - * objects, however, require finalization, usually to free resources. - * - * For these values, we either make a copy or acquire a reference. - */ - -/* - * Copy SRC to DST. - * - * Copies the representation of SRC to DST. This makes SRC - * indistinguishable from DST from the perspective of a Scheme - * expression modulo the fact that they reside at a different location - * in the store. - * - * Conditions: - * - * - SRC must not be a vector. - * - Caller must ensure that any resources associated with the - * value currently stored in DST is accounted for. - */ -static void -copy_value(scheme *sc, pointer dst, pointer src) -{ - memcpy(dst, src, sizeof *src); - - /* We may need to make a copy or acquire a reference. */ - if (typeflag(dst) & T_FINALIZE) - switch (type(dst)) { - case T_STRING: - strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0); - break; - case T_PORT: - /* XXX acquire reference */ - assert (!"implemented"); - break; - case T_FOREIGN_OBJECT: - /* XXX acquire reference */ - assert (!"implemented"); - break; - case T_VECTOR: - assert (!"vectors cannot be copied"); - } -} - - - -/* Tags are like property lists, but can be attached to arbitrary - * values. */ - -static pointer -mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) -{ - pointer r, t; - - assert(! is_vector(v)); - - r = get_consecutive_cells(sc, 2); - if (r == sc->sink) - return sc->sink; - - copy_value(sc, r, v); - typeflag(r) |= T_TAGGED; - - t = r + 1; - typeflag(t) = T_PAIR; - car(t) = tag_car; - cdr(t) = tag_cdr; - - return r; -} - -static INLINE int -has_tag(pointer v) -{ - return !! (typeflag(v) & T_TAGGED); -} - -static INLINE pointer -get_tag(scheme *sc, pointer v) -{ - if (has_tag(v)) - return v + 1; - return sc->NIL; -} - - - -/* Low-level allocator. - * - * Memory is allocated in segments. Every segment holds a fixed - * number of cells. Segments are linked into a list, sorted in - * reverse address order (i.e. those with a higher address first). - * This is used in the garbage collector to build the freelist in - * address order. - */ - -struct cell_segment -{ - struct cell_segment *next; - void *alloc; - pointer cells; - size_t cells_len; -}; - -/* Allocate a new cell segment but do not make it available yet. */ -static int -_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment) -{ - int adj = ADJ; - void *cp; - - if (adj < sizeof(struct cell)) - adj = sizeof(struct cell); - - /* The segment header is conveniently allocated with the cells. */ - cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj); - if (cp == NULL) - return 1; - - *segment = cp; - (*segment)->next = NULL; - (*segment)->alloc = cp; - cp = (void *) ((uintptr_t) cp + sizeof **segment); - - /* adjust in TYPE_BITS-bit boundary */ - if (((uintptr_t) cp) % adj != 0) - cp = (void *) (adj * ((uintptr_t) cp / adj + 1)); - - (*segment)->cells = cp; - (*segment)->cells_len = len; - return 0; -} - -/* Deallocate a cell segment. Returns the next cell segment. - * Convenient for deallocation in a loop. */ -static struct cell_segment * -_dealloc_cellseg(scheme *sc, struct cell_segment *segment) -{ - - struct cell_segment *next; - - if (segment == NULL) - return NULL; - - next = segment->next; - sc->free(segment->alloc); - return next; -} - -/* allocate new cell segment */ -static int alloc_cellseg(scheme *sc, int n) { - pointer last; - pointer p; - int k; - - for (k = 0; k < n; k++) { - struct cell_segment *new, **s; - if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) { - return k; - } - /* insert new segment in reverse address order */ - for (s = &sc->cell_segments; - *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc; - s = &(*s)->next) { - /* walk */ - } - new->next = *s; - *s = new; - - sc->fcells += new->cells_len; - last = new->cells + new->cells_len - 1; - for (p = new->cells; p <= last; p++) { - typeflag(p) = 0; - cdr(p) = p + 1; - car(p) = sc->NIL; - } - /* insert new cells in address order on free list */ - if (sc->free_cell == sc->NIL || p < sc->free_cell) { - cdr(last) = sc->free_cell; - sc->free_cell = new->cells; - } else { - p = sc->free_cell; - while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p)) - p = cdr(p); - cdr(last) = cdr(p); - cdr(p) = new->cells; - } - } - return n; -} - - - -/* Controlling the garbage collector. - * - * Every time a cell is allocated, the interpreter may run out of free - * cells and do a garbage collection. This is problematic because it - * might garbage collect objects that have been allocated, but are not - * yet made available to the interpreter. - * - * Previously, we would plug such newly allocated cells into the list - * of newly allocated objects rooted at car(sc->sink), but that - * requires allocating yet another cell increasing pressure on the - * memory management system. - * - * A faster alternative is to preallocate the cells needed for an - * operation and make sure the garbage collection is not run until all - * allocated objects are plugged in. This can be done with gc_disable - * and gc_enable. - */ - -/* The garbage collector is enabled if the inhibit counter is - * zero. */ -#define GC_ENABLED 0 - -/* For now we provide a way to disable this optimization for - * benchmarking and because it produces slightly smaller code. */ -#ifndef USE_GC_LOCKING -# define USE_GC_LOCKING 1 -#endif - -/* To facilitate nested calls to gc_disable, functions that allocate - * more than one cell may define a macro, e.g. foo_allocates. This - * macro can be used to compute the amount of preallocation at the - * call site with the help of this macro. */ -#define gc_reservations(fn) fn ## _allocates - -#if USE_GC_LOCKING - -/* Report a shortage in reserved cells, and terminate the program. */ -static void -gc_reservation_failure(struct scheme *sc) -{ -#ifdef NDEBUG - fprintf(stderr, - "insufficient reservation\n") -#else - fprintf(stderr, - "insufficient %s reservation in line %d\n", - sc->frame_freelist == sc->NIL ? "frame" : "cell", - sc->reserved_lineno); -#endif - abort(); -} - -/* Disable the garbage collection and reserve the given number of - * cells. gc_disable may be nested, but the enclosing reservation - * must include the reservations of all nested calls. Note: You must - * re-enable the gc before calling Error_X. */ -static void -_gc_disable(struct scheme *sc, size_t reserve, int lineno) -{ - if (sc->inhibit_gc == 0) { - reserve_cells(sc, (reserve)); - sc->reserved_cells = (reserve); -#ifdef NDEBUG - (void) lineno; -#else - sc->reserved_lineno = lineno; -#endif - } else if (sc->reserved_cells < (reserve)) - gc_reservation_failure (sc); - sc->inhibit_gc += 1; -} -#define gc_disable(sc, reserve) \ - do { \ - if (sc->frame_freelist == sc->NIL) { \ - if (gc_enabled(sc)) \ - dump_stack_preallocate_frame(sc); \ - else \ - gc_reservation_failure(sc); \ - } \ - _gc_disable (sc, reserve, __LINE__); \ - } while (0) - -/* Enable the garbage collector. */ -#define gc_enable(sc) \ - do { \ - assert(sc->inhibit_gc); \ - sc->inhibit_gc -= 1; \ - } while (0) - -/* Test whether the garbage collector is enabled. */ -#define gc_enabled(sc) \ - (sc->inhibit_gc == GC_ENABLED) - -/* Consume a reserved cell. */ -#define gc_consume(sc) \ - do { \ - assert(! gc_enabled (sc)); \ - if (sc->reserved_cells == 0) \ - gc_reservation_failure (sc); \ - sc->reserved_cells -= 1; \ - } while (0) - -#else /* USE_GC_LOCKING */ - -#define gc_reservation_failure(sc) (void) 0 -#define gc_disable(sc, reserve) \ - do { \ - if (sc->frame_freelist == sc->NIL) \ - dump_stack_preallocate_frame(sc); \ - } while (0) -#define gc_enable(sc) (void) 0 -#define gc_enabled(sc) 1 -#define gc_consume(sc) (void) 0 - -#endif /* USE_GC_LOCKING */ - -static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { - if (! gc_enabled (sc) || sc->free_cell != sc->NIL) { - pointer x = sc->free_cell; - if (! gc_enabled (sc)) - gc_consume (sc); - sc->free_cell = cdr(x); - --sc->fcells; - return (x); - } - assert (gc_enabled (sc)); - return _get_cell (sc, a, b); -} - - -/* get new cell. parameter a, b is marked by gc. */ -static pointer _get_cell(scheme *sc, pointer a, pointer b) { - pointer x; - - if(sc->no_memory) { - return sc->sink; - } - - assert (gc_enabled (sc)); - if (sc->free_cell == sc->NIL) { - gc(sc,a, b); - if (sc->free_cell == sc->NIL) { - sc->no_memory=1; - return sc->sink; - } - } - x = sc->free_cell; - sc->free_cell = cdr(x); - --sc->fcells; - return (x); -} - -/* make sure that there is a given number of cells free */ -static pointer reserve_cells(scheme *sc, int n) { - if(sc->no_memory) { - return sc->NIL; - } - - /* Are there enough cells available? */ - if (sc->fcells < n) { - /* If not, try gc'ing some */ - gc(sc, sc->NIL, sc->NIL); - if (sc->fcells < n) { - /* If there still aren't, try getting more heap */ - if (!alloc_cellseg(sc,1)) { - sc->no_memory=1; - return sc->NIL; - } - } - if (sc->fcells < n) { - /* If all fail, report failure */ - sc->no_memory=1; - return sc->NIL; - } - } - return (sc->T); -} - -static pointer get_consecutive_cells(scheme *sc, int n) { - pointer x; - - if(sc->no_memory) { return sc->sink; } - - /* Are there any cells available? */ - x=find_consecutive_cells(sc,n); - if (x != sc->NIL) { return x; } - - /* If not, try gc'ing some */ - gc(sc, sc->NIL, sc->NIL); - x=find_consecutive_cells(sc,n); - if (x != sc->NIL) { return x; } - - /* If there still aren't, try getting more heap */ - if (!alloc_cellseg(sc,1)) - { - sc->no_memory=1; - return sc->sink; - } - - x=find_consecutive_cells(sc,n); - if (x != sc->NIL) { return x; } - - /* If all fail, report failure */ - sc->no_memory=1; - return sc->sink; -} - -static int count_consecutive_cells(pointer x, int needed) { - int n=1; - while(cdr(x)==x+1) { - x=cdr(x); - n++; - if(n>needed) return n; - } - return n; -} - -static pointer find_consecutive_cells(scheme *sc, int n) { - pointer *pp; - int cnt; - - pp=&sc->free_cell; - while(*pp!=sc->NIL) { - cnt=count_consecutive_cells(*pp,n); - if(cnt>=n) { - pointer x=*pp; - *pp=cdr(*pp+n-1); - sc->fcells -= n; - return x; - } - pp=&cdr(*pp+cnt-1); - } - return sc->NIL; -} - -/* Free a cell. This is dangerous. Only free cells that are not - * referenced. */ -static INLINE void -free_cell(scheme *sc, pointer a) -{ - cdr(a) = sc->free_cell; - sc->free_cell = a; - sc->fcells += 1; -} - -/* Free a cell and retrieve its content. This is dangerous. Only - * free cells that are not referenced. */ -static INLINE void -free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr) -{ - *r_car = car(a); - *r_cdr = cdr(a); - free_cell(sc, a); -} - -/* To retain recent allocs before interpreter knows about them - - Tehom */ - -static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) -{ - pointer holder = get_cell_x(sc, recent, extra); - typeflag(holder) = T_PAIR | T_IMMUTABLE; - car(holder) = recent; - cdr(holder) = car(sc->sink); - car(sc->sink) = holder; -} - -static INLINE void ok_to_freely_gc(scheme *sc) -{ - pointer a = car(sc->sink), next; - car(sc->sink) = sc->NIL; - while (a != sc->NIL) - { - next = cdr(a); - free_cell(sc, a); - a = next; - } -} - -static pointer get_cell(scheme *sc, pointer a, pointer b) -{ - pointer cell = get_cell_x(sc, a, b); - /* For right now, include "a" and "b" in "cell" so that gc doesn't - think they are garbage. */ - /* Tentatively record it as a pair so gc understands it. */ - typeflag(cell) = T_PAIR; - car(cell) = a; - cdr(cell) = b; - if (gc_enabled (sc)) - push_recent_alloc(sc, cell, sc->NIL); - return cell; -} - -static pointer get_vector_object(scheme *sc, int len, pointer init) -{ - pointer cells = get_consecutive_cells(sc, vector_size(len)); - int i; - int alloc_len = 1 + 3 * (vector_size(len) - 1); - if(sc->no_memory) { return sc->sink; } - /* Record it as a vector so that gc understands it. */ - typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE); - vector_length(cells) = len; - fill_vector(cells,init); - - /* Initialize the unused slots at the end. */ - assert (alloc_len - len < 3); - for (i = len; i < alloc_len; i++) - cells->_object._vector._elements[i] = sc->NIL; - - if (gc_enabled (sc)) - push_recent_alloc(sc, cells, sc->NIL); - return cells; -} - -/* Medium level cell allocation */ - -/* get new cons cell */ -pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { - pointer x = get_cell(sc,a, b); - - typeflag(x) = T_PAIR; - if(immutable) { - setimmutable(x); - } - car(x) = a; - cdr(x) = b; - return (x); -} - - -/* ========== oblist implementation ========== */ - -#ifndef USE_OBJECT_LIST - -static int hash_fn(const char *key, int table_size); - -static pointer oblist_initial_value(scheme *sc) -{ - /* There are about 768 symbols used after loading the - * interpreter. */ - return mk_vector(sc, 1009); -} - -/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not - * exist. In that case, SLOT points to the point where the new symbol - * is to be inserted. */ -static INLINE pointer -oblist_find_by_name(scheme *sc, const char *name, pointer **slot) -{ - int location; - pointer x; - char *s; - int d; - - location = hash_fn(name, vector_length(sc->oblist)); - for (*slot = vector_elem_slot(sc->oblist, location), x = **slot; - x != sc->NIL; *slot = &cdr(x), x = **slot) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - d = stricmp(name, s); - if (d == 0) - return car(x); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - return sc->NIL; -} - -static pointer oblist_all_symbols(scheme *sc) -{ - int i; - pointer x; - pointer ob_list = sc->NIL; - - for (i = 0; i < vector_length(sc->oblist); i++) { - for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { - ob_list = cons(sc, x, ob_list); - } - } - return ob_list; -} - -#else - -static pointer oblist_initial_value(scheme *sc) -{ - return sc->NIL; -} - -/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not - * exist. In that case, SLOT points to the point where the new symbol - * is to be inserted. */ -static INLINE pointer -oblist_find_by_name(scheme *sc, const char *name, pointer **slot) -{ - pointer x; - char *s; - int d; - - for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - d = stricmp(name, s); - if (d == 0) - return car(x); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - return sc->NIL; -} - -static pointer oblist_all_symbols(scheme *sc) -{ - return sc->oblist; -} - -#endif - -/* Add a new symbol NAME at SLOT. SLOT must be obtained using - * oblist_find_by_name, and no insertion must be done between - * obtaining the SLOT and calling this function. Returns the new - * symbol. */ -static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) -{ -#define oblist_add_by_name_allocates 3 - pointer x; - - gc_disable(sc, gc_reservations (oblist_add_by_name)); - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - *slot = immutable_cons(sc, x, *slot); - gc_enable(sc); - return x; -} - - - -static pointer mk_port(scheme *sc, port *p) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = T_PORT|T_ATOM|T_FINALIZE; - x->_object._port=p; - return (x); -} - -pointer mk_foreign_func(scheme *sc, foreign_func f) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = (T_FOREIGN | T_ATOM); - x->_object._ff=f; - return (x); -} - -pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE); - x->_object._foreign_object._vtable=vtable; - x->_object._foreign_object._data = data; - return (x); -} - -INTERFACE pointer mk_character(scheme *sc, int c) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_CHARACTER | T_ATOM); - ivalue_unchecked(x)= c; - set_num_integer(x); - return (x); -} - - - -#if USE_SMALL_INTEGERS - -static const struct cell small_integers[] = { -#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}}, -#include "small-integers.h" -#undef DEFINE_INTEGER - {0} -}; - -#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1) - -static INLINE pointer -mk_small_integer(scheme *sc, long n) -{ -#define mk_small_integer_allocates 0 - (void) sc; - assert(0 <= n && n < MAX_SMALL_INTEGER); - return (pointer) &small_integers[n]; -} -#else - -#define mk_small_integer_allocates 1 -#define mk_small_integer mk_integer - -#endif - -/* get number atom (integer) */ -INTERFACE pointer mk_integer(scheme *sc, long n) { - pointer x; - -#if USE_SMALL_INTEGERS - if (0 <= n && n < MAX_SMALL_INTEGER) - return mk_small_integer(sc, n); -#endif - - x = get_cell(sc,sc->NIL, sc->NIL); - typeflag(x) = (T_NUMBER | T_ATOM); - ivalue_unchecked(x)= n; - set_num_integer(x); - return (x); -} - - - -INTERFACE pointer mk_real(scheme *sc, double n) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_NUMBER | T_ATOM); - rvalue_unchecked(x)= n; - set_num_real(x); - return (x); -} - -static pointer mk_number(scheme *sc, num n) { - if(n.is_fixnum) { - return mk_integer(sc,n.value.ivalue); - } else { - return mk_real(sc,n.value.rvalue); - } -} - -/* allocate name to string area */ -static char *store_string(scheme *sc, int len_str, const char *str, char fill) { - char *q; - - q=(char*)sc->malloc(len_str+1); - if(q==0) { - sc->no_memory=1; - return sc->strbuff; - } - if(str!=0) { - memcpy (q, str, len_str); - q[len_str]=0; - } else { - memset(q, fill, len_str); - q[len_str]=0; - } - return (q); -} - -/* get new string */ -INTERFACE pointer mk_string(scheme *sc, const char *str) { - return mk_counted_string(sc,str,strlen(str)); -} - -INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); - strvalue(x) = store_string(sc,len,str,0); - strlength(x) = len; - return (x); -} - -INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); - strvalue(x) = store_string(sc,len,0,fill); - strlength(x) = len; - return (x); -} - -INTERFACE static pointer mk_vector(scheme *sc, int len) -{ return get_vector_object(sc,len,sc->NIL); } - -INTERFACE static void fill_vector(pointer vec, pointer obj) { - size_t i; - assert (is_vector (vec)); - for(i = 0; i < vector_length(vec); i++) { - vec->_object._vector._elements[i] = obj; - } -} - -INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) { - assert (is_vector (vec)); - assert (ielem < vector_length(vec)); - return &vec->_object._vector._elements[ielem]; -} - -INTERFACE static pointer vector_elem(pointer vec, int ielem) { - assert (is_vector (vec)); - assert (ielem < vector_length(vec)); - return vec->_object._vector._elements[ielem]; -} - -INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { - assert (is_vector (vec)); - assert (ielem < vector_length(vec)); - vec->_object._vector._elements[ielem] = a; - return a; -} - -/* get new symbol */ -INTERFACE pointer mk_symbol(scheme *sc, const char *name) { -#define mk_symbol_allocates oblist_add_by_name_allocates - pointer x; - pointer *slot; - - /* first check oblist */ - x = oblist_find_by_name(sc, name, &slot); - if (x != sc->NIL) { - return (x); - } else { - x = oblist_add_by_name(sc, name, slot); - return (x); - } -} - -INTERFACE pointer gensym(scheme *sc) { - pointer x; - pointer *slot; - char name[40]; - - for(; sc->gensym_cntgensym_cnt++) { - snprintf(name,40,"gensym-%ld",sc->gensym_cnt); - - /* first check oblist */ - x = oblist_find_by_name(sc, name, &slot); - - if (x != sc->NIL) { - continue; - } else { - x = oblist_add_by_name(sc, name, slot); - return (x); - } - } - - return sc->NIL; -} - -/* double the size of the string buffer */ -static int expand_strbuff(scheme *sc) { - size_t new_size = sc->strbuff_size * 2; - char *new_buffer = sc->malloc(new_size); - if (new_buffer == 0) { - sc->no_memory = 1; - return 1; - } - memcpy(new_buffer, sc->strbuff, sc->strbuff_size); - sc->free(sc->strbuff); - sc->strbuff = new_buffer; - sc->strbuff_size = new_size; - return 0; -} - -/* make symbol or number atom from string */ -static pointer mk_atom(scheme *sc, char *q) { - char c, *p; - int has_dec_point=0; - int has_fp_exp = 0; - -#if USE_COLON_HOOK - char *next; - next = p = q; - while ((next = strstr(next, "::")) != 0) { - /* Keep looking for the last occurrence. */ - p = next; - next = next + 2; - } - - if (p != q) { - *p=0; - return cons(sc, sc->COLON_HOOK, - cons(sc, - cons(sc, - sc->QUOTE, - cons(sc, mk_symbol(sc, strlwr(p + 2)), - sc->NIL)), - cons(sc, mk_atom(sc, q), sc->NIL))); - } -#endif - - p = q; - c = *p++; - if ((c == '+') || (c == '-')) { - c = *p++; - if (c == '.') { - has_dec_point=1; - c = *p++; - } - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (c == '.') { - has_dec_point=1; - c = *p++; - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - - for ( ; (c = *p) != 0; ++p) { - if (!isdigit(c)) { - if(c=='.') { - if(!has_dec_point) { - has_dec_point=1; - continue; - } - } - else if ((c == 'e') || (c == 'E')) { - if(!has_fp_exp) { - has_dec_point = 1; /* decimal point illegal - from now on */ - p++; - if ((*p == '-') || (*p == '+') || isdigit(*p)) { - continue; - } - } - } - return (mk_symbol(sc, strlwr(q))); - } - } - if(has_dec_point) { - return mk_real(sc,atof(q)); - } - return (mk_integer(sc, atol(q))); -} - -/* make constant */ -static pointer mk_sharp_const(scheme *sc, char *name) { - long x; - char tmp[STRBUFFSIZE]; - - if (!strcmp(name, "t")) - return (sc->T); - else if (!strcmp(name, "f")) - return (sc->F); - else if (*name == 'o') {/* #o (octal) */ - snprintf(tmp, STRBUFFSIZE, "0%s", name+1); - sscanf(tmp, "%lo", (long unsigned *)&x); - return (mk_integer(sc, x)); - } else if (*name == 'd') { /* #d (decimal) */ - sscanf(name+1, "%ld", (long int *)&x); - return (mk_integer(sc, x)); - } else if (*name == 'x') { /* #x (hex) */ - snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); - sscanf(tmp, "%lx", (long unsigned *)&x); - return (mk_integer(sc, x)); - } else if (*name == 'b') { /* #b (binary) */ - x = binary_decode(name+1); - return (mk_integer(sc, x)); - } else if (*name == '\\') { /* #\w (character) */ - int c=0; - if(stricmp(name+1,"space")==0) { - c=' '; - } else if(stricmp(name+1,"newline")==0) { - c='\n'; - } else if(stricmp(name+1,"return")==0) { - c='\r'; - } else if(stricmp(name+1,"tab")==0) { - c='\t'; - } else if(name[1]=='x' && name[2]!=0) { - int c1=0; - if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { - c=c1; - } else { - return sc->NIL; - } -#if USE_ASCII_NAMES - } else if(is_ascii_name(name+1,&c)) { - /* nothing */ -#endif - } else if(name[2]==0) { - c=name[1]; - } else { - return sc->NIL; - } - return mk_character(sc,c); - } else - return (sc->NIL); -} - -/* ========== garbage collector ========== */ - -const int frame_length; -static void dump_stack_deallocate_frame(scheme *sc, pointer frame); - -/*-- - * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, - * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, - * for marking. - */ -static void mark(pointer a) { - pointer t, q, p; - - t = (pointer) 0; - p = a; -E2: if (! is_mark(p)) - setmark(p); - if (is_vector(p) || is_frame(p)) { - int i; - int len = is_vector(p) ? vector_length(p) : frame_length; - for (i = 0; i < len; i++) { - mark(p->_object._vector._elements[i]); - } - } -#if SHOW_ERROR_LINE - else if (is_port(p)) { - port *pt = p->_object._port; - mark(pt->curr_line); - mark(pt->filename); - } -#endif - /* Mark tag if p has one. */ - if (has_tag(p)) - mark(p + 1); - if (is_atom(p)) - goto E6; - /* E4: down car */ - q = car(p); - if (q && !is_mark(q)) { - setatom(p); /* a note that we have moved car */ - car(p) = t; - t = p; - p = q; - goto E2; - } -E5: q = cdr(p); /* down cdr */ - if (q && !is_mark(q)) { - cdr(p) = t; - t = p; - p = q; - goto E2; - } -E6: /* up. Undo the link switching from steps E4 and E5. */ - if (!t) - return; - q = t; - if (is_atom(q)) { - clratom(q); - t = car(q); - car(q) = p; - p = q; - goto E5; - } else { - t = cdr(q); - cdr(q) = p; - p = q; - goto E6; - } -} - -/* garbage collection. parameter a, b is marked. */ -static void gc(scheme *sc, pointer a, pointer b) { - pointer p; - struct cell_segment *s; - int i; - - assert (gc_enabled (sc)); - - if(sc->gc_verbose) { - putstr(sc, "gc..."); - } - - /* mark system globals */ - mark(sc->oblist); - mark(sc->global_env); - - /* mark current registers */ - mark(sc->args); - mark(sc->envir); - mark(sc->code); - history_mark(sc); - dump_stack_mark(sc); - mark(sc->value); - mark(sc->inport); - mark(sc->save_inport); - mark(sc->outport); - mark(sc->loadport); - for (i = 0; i <= sc->file_i; i++) { - mark(sc->load_stack[i].filename); - mark(sc->load_stack[i].curr_line); - } - - /* Mark recent objects the interpreter doesn't know about yet. */ - mark(car(sc->sink)); - /* Mark any older stuff above nested C calls */ - mark(sc->c_nest); - - /* mark variables a, b */ - mark(a); - mark(b); - - /* garbage collect */ - clrmark(sc->NIL); - sc->fcells = 0; - sc->free_cell = sc->NIL; - /* free-list is kept sorted by address so as to maintain consecutive - ranges, if possible, for use with vectors. Here we scan the cells - (which are also kept sorted by address) downwards to build the - free-list in sorted order. - */ - for (s = sc->cell_segments; s; s = s->next) { - p = s->cells + s->cells_len; - while (--p >= s->cells) { - if ((typeflag(p) & 1) == 0) - /* All types have the LSB set. This is not a typeflag. */ - continue; - if (is_mark(p)) { - clrmark(p); - } else { - /* reclaim cell */ - if ((typeflag(p) & T_FINALIZE) == 0 - || finalize_cell(sc, p)) { - /* Reclaim cell. */ - ++sc->fcells; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; - } - } - } - } - - if (sc->gc_verbose) { - char msg[80]; - snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); - putstr(sc,msg); - } - - /* if only a few recovered, get more to avoid fruitless gc's */ - if (sc->fcells < CELL_MINRECOVER - && alloc_cellseg(sc, 1) == 0) - sc->no_memory = 1; -} - -/* Finalize A. Returns true if a can be added to the list of free - * cells. */ -static int -finalize_cell(scheme *sc, pointer a) -{ - switch (type(a)) { - case T_STRING: - sc->free(strvalue(a)); - break; - - case T_PORT: - if(a->_object._port->kind&port_file - && a->_object._port->rep.stdio.closeit) { - port_close(sc,a,port_input|port_output); - } else if (a->_object._port->kind & port_srfi6) { - sc->free(a->_object._port->rep.string.start); - } - sc->free(a->_object._port); - break; - - case T_FOREIGN_OBJECT: - a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); - break; - - case T_VECTOR: - do { - int i; - for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { - pointer p = a + i; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; - sc->fcells += 1; - } - } while (0); - break; - - case T_FRAME: - dump_stack_deallocate_frame(sc, a); - return 0; /* Do not free cell. */ - } - - return 1; /* Free cell. */ -} - -#if SHOW_ERROR_LINE -static void -port_clear_location (scheme *sc, port *p) -{ - p->curr_line = sc->NIL; - p->filename = sc->NIL; -} - -static void -port_increment_current_line (scheme *sc, port *p, long delta) -{ - if (delta == 0) - return; - - p->curr_line = - mk_integer(sc, ivalue_unchecked(p->curr_line) + delta); -} - -static void -port_init_location (scheme *sc, port *p, pointer name) -{ - p->curr_line = mk_integer(sc, 0); - p->filename = name ? name : mk_string(sc, ""); -} - -#else - -static void -port_clear_location (scheme *sc, port *p) -{ -} - -static void -port_increment_current_line (scheme *sc, port *p, long delta) -{ -} - -static void -port_init_location (scheme *sc, port *p, pointer name) -{ -} - -#endif - -/* ========== Routines for Reading ========== */ - -static int file_push(scheme *sc, pointer fname) { - FILE *fin = NULL; - - if (sc->file_i == MAXFIL-1) - return 0; - fin = fopen(string_value(fname), "r"); - if(fin!=0) { - sc->file_i++; - sc->load_stack[sc->file_i].kind=port_file|port_input; - sc->load_stack[sc->file_i].rep.stdio.file=fin; - sc->load_stack[sc->file_i].rep.stdio.closeit=1; - sc->nesting_stack[sc->file_i]=0; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - port_init_location(sc, &sc->load_stack[sc->file_i], fname); - } - return fin!=0; -} - -static void file_pop(scheme *sc) { - if(sc->file_i != 0) { - sc->nesting=sc->nesting_stack[sc->file_i]; - port_close(sc,sc->loadport,port_input); - port_clear_location(sc, &sc->load_stack[sc->file_i]); - sc->file_i--; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - } -} - -static int file_interactive(scheme *sc) { - return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin - && sc->inport->_object._port->kind&port_file; -} - -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { - FILE *f; - char *rw; - port *pt; - if(prop==(port_input|port_output)) { - rw="a+"; - } else if(prop==port_output) { - rw="w"; - } else { - rw="r"; - } - f=fopen(fn,rw); - if(f==0) { - return 0; - } - pt=port_rep_from_file(sc,f,prop); - pt->rep.stdio.closeit=1; - port_init_location(sc, pt, mk_string(sc, fn)); - return pt; -} - -static pointer port_from_filename(scheme *sc, const char *fn, int prop) { - port *pt; - pt=port_rep_from_filename(sc,fn,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_file(scheme *sc, FILE *f, int prop) -{ - port *pt; - - pt = (port *)sc->malloc(sizeof *pt); - if (pt == NULL) { - return NULL; - } - pt->kind = port_file | prop; - pt->rep.stdio.file = f; - pt->rep.stdio.closeit = 0; - port_init_location(sc, pt, NULL); - return pt; -} - -static pointer port_from_file(scheme *sc, FILE *f, int prop) { - port *pt; - pt=port_rep_from_file(sc,f,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - pt->kind=port_string|prop; - pt->rep.string.start=start; - pt->rep.string.curr=start; - pt->rep.string.past_the_end=past_the_end; - port_init_location(sc, pt, NULL); - return pt; -} - -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=port_rep_from_string(sc,start,past_the_end,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -#define BLOCK_SIZE 256 - -static port *port_rep_from_scratch(scheme *sc) { - port *pt; - char *start; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - start=sc->malloc(BLOCK_SIZE); - if(start==0) { - return 0; - } - memset(start,' ',BLOCK_SIZE-1); - start[BLOCK_SIZE-1]='\0'; - pt->kind=port_string|port_output|port_srfi6; - pt->rep.string.start=start; - pt->rep.string.curr=start; - pt->rep.string.past_the_end=start+BLOCK_SIZE-1; - port_init_location(sc, pt, NULL); - return pt; -} - -static pointer port_from_scratch(scheme *sc) { - port *pt; - pt=port_rep_from_scratch(sc); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static void port_close(scheme *sc, pointer p, int flag) { - port *pt=p->_object._port; - pt->kind&=~flag; - if((pt->kind & (port_input|port_output))==0) { - /* Cleanup is here so (close-*-port) functions could work too */ - port_clear_location(sc, pt); - if(pt->kind&port_file) { - fclose(pt->rep.stdio.file); - } - pt->kind=port_free; - } -} - -/* get new character from input file */ -static int inchar(scheme *sc) { - int c; - port *pt; - - pt = sc->inport->_object._port; - if(pt->kind & port_saw_EOF) - { return EOF; } - c = basic_inchar(pt); - if(c == EOF && sc->inport == sc->loadport) { - /* Instead, set port_saw_EOF */ - pt->kind |= port_saw_EOF; - - /* file_pop(sc); */ - return EOF; - /* NOTREACHED */ - } - return c; -} - -static int basic_inchar(port *pt) { - if(pt->kind & port_file) { - return fgetc(pt->rep.stdio.file); - } else { - if(*pt->rep.string.curr == 0 || - pt->rep.string.curr == pt->rep.string.past_the_end) { - return EOF; - } else { - return *pt->rep.string.curr++; - } - } -} - -/* back character to input buffer */ -static void backchar(scheme *sc, int c) { - port *pt; - if(c==EOF) return; - pt=sc->inport->_object._port; - if(pt->kind&port_file) { - ungetc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.start) { - --pt->rep.string.curr; - } - } -} - -static int realloc_port_string(scheme *sc, port *p) -{ - char *start=p->rep.string.start; - size_t old_size = p->rep.string.past_the_end - start; - size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; - char *str=sc->malloc(new_size); - if(str) { - memset(str,' ',new_size-1); - str[new_size-1]='\0'; - memcpy(str, start, old_size); - p->rep.string.start=str; - p->rep.string.past_the_end=str+new_size-1; - p->rep.string.curr-=start-str; - sc->free(start); - return 1; - } else { - return 0; - } -} - -INTERFACE void putstr(scheme *sc, const char *s) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputs(s,pt->rep.stdio.file); - } else { - for(;*s;s++) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s; - } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { - *pt->rep.string.curr++=*s; - } - } - } -} - -static void putchars(scheme *sc, const char *s, int len) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fwrite(s,1,len,pt->rep.stdio.file); - } else { - for(;len;len--) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s++; - } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { - *pt->rep.string.curr++=*s++; - } - } - } -} - -INTERFACE void putcharacter(scheme *sc, int c) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=c; - } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { - *pt->rep.string.curr++=c; - } - } -} - -/* read characters up to delimiter, but cater to character constants */ -static char *readstr_upto(scheme *sc, char *delim) { - char *p = sc->strbuff; - - while ((p - sc->strbuff < sc->strbuff_size) && - !is_one_of(delim, (*p++ = inchar(sc)))); - - if(p == sc->strbuff+2 && p[-2] == '\\') { - *p=0; - } else { - backchar(sc,p[-1]); - *--p = '\0'; - } - return sc->strbuff; -} - -/* read string expression "xxx...xxx" */ -static pointer readstrexp(scheme *sc) { - char *p = sc->strbuff; - int c; - int c1=0; - enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; - - for (;;) { - c=inchar(sc); - if(c == EOF) { - return sc->F; - } - if(p-sc->strbuff > (sc->strbuff_size)-1) { - ptrdiff_t offset = p - sc->strbuff; - if (expand_strbuff(sc) != 0) { - return sc->F; - } - p = sc->strbuff + offset; - } - switch(state) { - case st_ok: - switch(c) { - case '\\': - state=st_bsl; - break; - case '"': - *p=0; - return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); - default: - *p++=c; - break; - } - break; - case st_bsl: - switch(c) { - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - state=st_oct1; - c1=c-'0'; - break; - case 'x': - case 'X': - state=st_x1; - c1=0; - break; - case 'n': - *p++='\n'; - state=st_ok; - break; - case 't': - *p++='\t'; - state=st_ok; - break; - case 'r': - *p++='\r'; - state=st_ok; - break; - case '"': - *p++='"'; - state=st_ok; - break; - default: - *p++=c; - state=st_ok; - break; - } - break; - case st_x1: - case st_x2: - c=toupper(c); - if(c>='0' && c<='F') { - if(c<='9') { - c1=(c1<<4)+c-'0'; - } else { - c1=(c1<<4)+c-'A'+10; - } - if(state==st_x1) { - state=st_x2; - } else { - *p++=c1; - state=st_ok; - } - } else { - return sc->F; - } - break; - case st_oct1: - case st_oct2: - if (c < '0' || c > '7') - { - *p++=c1; - backchar(sc, c); - state=st_ok; - } - else - { - if (state==st_oct2 && c1 >= 32) - return sc->F; - - c1=(c1<<3)+(c-'0'); - - if (state == st_oct1) - state=st_oct2; - else - { - *p++=c1; - state=st_ok; - } - } - break; - - } - } -} - -/* check c is in chars */ -static INLINE int is_one_of(char *s, int c) { - if(c==EOF) return 1; - while (*s) - if (*s++ == c) - return (1); - return (0); -} - -/* skip white characters */ -static INLINE int skipspace(scheme *sc) { - int c = 0, curr_line = 0; - - do { - c=inchar(sc); -#if SHOW_ERROR_LINE - if(c=='\n') - curr_line++; -#endif - } while (isspace(c)); - - /* record it */ - port_increment_current_line(sc, &sc->load_stack[sc->file_i], curr_line); - - if(c!=EOF) { - backchar(sc,c); - return 1; - } - else - { return EOF; } -} - -/* get token */ -static int token(scheme *sc) { - int c; - c = skipspace(sc); - if(c == EOF) { return (TOK_EOF); } - switch (c=inchar(sc)) { - case EOF: - return (TOK_EOF); - case '(': - return (TOK_LPAREN); - case ')': - return (TOK_RPAREN); - case '.': - c=inchar(sc); - if(is_one_of(" \n\t",c)) { - return (TOK_DOT); - } else { - backchar(sc,c); - backchar(sc,'.'); - return TOK_ATOM; - } - case '\'': - return (TOK_QUOTE); - case ';': - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - - if(c == '\n') - port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); - - if(c == EOF) - { return (TOK_EOF); } - else - { return (token(sc));} - case '"': - return (TOK_DQUOTE); - case BACKQUOTE: - return (TOK_BQUOTE); - case ',': - if ((c=inchar(sc)) == '@') { - return (TOK_ATMARK); - } else { - backchar(sc,c); - return (TOK_COMMA); - } - case '#': - c=inchar(sc); - if (c == '(') { - return (TOK_VEC); - } else if(c == '!') { - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - - if(c == '\n') - port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); - - if(c == EOF) - { return (TOK_EOF); } - else - { return (token(sc));} - } else { - backchar(sc,c); - if(is_one_of(" tfodxb\\",c)) { - return TOK_SHARP_CONST; - } else { - return (TOK_SHARP); - } - } - default: - backchar(sc,c); - return (TOK_ATOM); - } -} - -/* ========== Routines for Printing ========== */ -#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) - -static void printslashstring(scheme *sc, char *p, int len) { - int i; - unsigned char *s=(unsigned char*)p; - putcharacter(sc,'"'); - for ( i=0; iNIL) { - p = "()"; - } else if (l == sc->T) { - p = "#t"; - } else if (l == sc->F) { - p = "#f"; - } else if (l == sc->EOF_OBJ) { - p = "#"; - } else if (is_port(l)) { - p = "#"; - } else if (is_number(l)) { - p = sc->strbuff; - if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { - if(num_is_integer(l)) { - snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); - } else { - snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); - /* r5rs says there must be a '.' (unless 'e'?) */ - f = strcspn(p, ".e"); - if (p[f] == 0) { - p[f] = '.'; /* not found, so add '.0' at the end */ - p[f+1] = '0'; - p[f+2] = 0; - } - } - } else { - long v = ivalue(l); - if (f == 16) { - if (v >= 0) - snprintf(p, STRBUFFSIZE, "%lx", v); - else - snprintf(p, STRBUFFSIZE, "-%lx", -v); - } else if (f == 8) { - if (v >= 0) - snprintf(p, STRBUFFSIZE, "%lo", v); - else - snprintf(p, STRBUFFSIZE, "-%lo", -v); - } else if (f == 2) { - unsigned long b = (v < 0) ? -v : v; - p = &p[STRBUFFSIZE-1]; - *p = 0; - do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); - if (v < 0) *--p = '-'; - } - } - } else if (is_string(l)) { - if (!f) { - *pp = strvalue(l); - *plen = strlength(l); - return; - } else { /* Hack, uses the fact that printing is needed */ - *pp=sc->strbuff; - *plen=0; - printslashstring(sc, strvalue(l), strlength(l)); - return; - } - } else if (is_character(l)) { - int c=charvalue(l); - p = sc->strbuff; - if (!f) { - p[0]=c; - p[1]=0; - } else { - switch(c) { - case ' ': - p = "#\\space"; - break; - case '\n': - p = "#\\newline"; - break; - case '\r': - p = "#\\return"; - break; - case '\t': - p = "#\\tab"; - break; - default: -#if USE_ASCII_NAMES - if(c==127) { - p = "#\\del"; - break; - } else if(c<32) { - snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]); - break; - } -#else - if(c<32) { - snprintf(p,STRBUFFSIZE,"#\\x%x",c); - break; - } -#endif - snprintf(p,STRBUFFSIZE,"#\\%c",c); - break; - } - } - } else if (is_symbol(l)) { - p = symname(l); - } else if (is_proc(l)) { - p = sc->strbuff; - snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); - } else if (is_macro(l)) { - p = "#"; - } else if (is_closure(l)) { - p = "#"; - } else if (is_promise(l)) { - p = "#"; - } else if (is_foreign(l)) { - p = sc->strbuff; - snprintf(p,STRBUFFSIZE,"#", procnum(l)); - } else if (is_continuation(l)) { - p = "#"; - } else if (is_foreign_object(l)) { - p = sc->strbuff; - l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data); - } else { - p = "#"; - } - *pp=p; - *plen=strlen(p); -} -/* ========== Routines for Evaluation Cycle ========== */ - -/* make closure. c is code. e is environment */ -static pointer mk_closure(scheme *sc, pointer c, pointer e) { - pointer x = get_cell(sc, c, e); - - typeflag(x) = T_CLOSURE; - car(x) = c; - cdr(x) = e; - return (x); -} - -/* make continuation. */ -static pointer mk_continuation(scheme *sc, pointer d) { - pointer x = get_cell(sc, sc->NIL, d); - - typeflag(x) = T_CONTINUATION; - cont_dump(x) = d; - return (x); -} - -static pointer list_star(scheme *sc, pointer d) { - pointer p, q; - if(cdr(d)==sc->NIL) { - return car(d); - } - p=cons(sc,car(d),cdr(d)); - q=p; - while(cdr(cdr(p))!=sc->NIL) { - d=cons(sc,car(p),cdr(p)); - if(cdr(cdr(p))!=sc->NIL) { - p=cdr(d); - } - } - cdr(p)=car(cdr(p)); - return q; -} - -/* reverse list -- produce new list */ -static pointer reverse(scheme *sc, pointer term, pointer list) { -/* a must be checked by gc */ - pointer a = list, p = term; - - for ( ; is_pair(a); a = cdr(a)) { - p = cons(sc, car(a), p); - } - return (p); -} - -/* reverse list --- in-place */ -static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { - pointer p = list, result = term, q; - - while (p != sc->NIL) { - q = cdr(p); - cdr(p) = result; - result = p; - p = q; - } - return (result); -} - -/* append list -- produce new list (in reverse order) */ -static pointer revappend(scheme *sc, pointer a, pointer b) { - pointer result = a; - pointer p = b; - - while (is_pair(p)) { - result = cons(sc, car(p), result); - p = cdr(p); - } - - if (p == sc->NIL) { - return result; - } - - return sc->F; /* signal an error */ -} - -/* equivalence of atoms */ -int eqv(pointer a, pointer b) { - if (is_string(a)) { - if (is_string(b)) - return (strvalue(a) == strvalue(b)); - else - return (0); - } else if (is_number(a)) { - if (is_number(b)) { - if (num_is_integer(a) == num_is_integer(b)) - return num_eq(nvalue(a),nvalue(b)); - } - return (0); - } else if (is_character(a)) { - if (is_character(b)) - return charvalue(a)==charvalue(b); - else - return (0); - } else if (is_port(a)) { - if (is_port(b)) - return a==b; - else - return (0); - } else if (is_proc(a)) { - if (is_proc(b)) - return procnum(a)==procnum(b); - else - return (0); - } else { - return (a == b); - } -} - -/* true or false value macro */ -/* () is #t in R5RS */ -#define is_true(p) ((p) != sc->F) -#define is_false(p) ((p) == sc->F) - - -/* ========== Environment implementation ========== */ - -#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) - -static int hash_fn(const char *key, int table_size) -{ - unsigned int hashed = 0; - const char *c; - int bits_per_int = sizeof(unsigned int)*8; - - for (c = key; *c; c++) { - /* letters have about 5 bits in them */ - hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); - hashed ^= *c; - } - return hashed % table_size; -} -#endif - -/* Compares A and B. Returns an integer less than, equal to, or - * greater than zero if A is stored at a memory location that is - * numerical less than, equal to, or greater than that of B. */ -static int -pointercmp(pointer a, pointer b) -{ - uintptr_t a_n = (uintptr_t) a; - uintptr_t b_n = (uintptr_t) b; - - if (a_n < b_n) - return -1; - if (a_n > b_n) - return 1; - return 0; -} - -#ifndef USE_ALIST_ENV - -/* - * In this implementation, each frame of the environment may be - * a hash table: a vector of alists hashed by variable name. - * In practice, we use a vector only for the initial frame; - * subsequent frames are too small and transient for the lookup - * speed to out-weigh the cost of making a new vector. - */ - -static void new_frame_in_env(scheme *sc, pointer old_env) -{ - pointer new_frame; - - /* The interaction-environment has about 480 variables in it. */ - if (old_env == sc->NIL) { - new_frame = mk_vector(sc, 751); - } else { - new_frame = sc->NIL; - } - - gc_disable(sc, 1); - sc->envir = immutable_cons(sc, new_frame, old_env); - gc_enable(sc); - setenvironment(sc->envir); -} - -/* Find the slot in ENV under the key HDL. If ALL is given, look in - * all environments enclosing ENV. If the lookup fails, and SSLOT is - * given, the position where the new slot has to be inserted is stored - * at SSLOT. */ -static pointer -find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) -{ - pointer x,y; - int location; - pointer *sl; - int d; - assert(is_symbol(hdl)); - - for (x = env; x != sc->NIL; x = cdr(x)) { - if (is_vector(car(x))) { - location = hash_fn(symname(hdl), vector_length(car(x))); - sl = vector_elem_slot(car(x), location); - } else { - sl = &car(x); - } - for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) { - d = pointercmp(caar(y), hdl); - if (d == 0) - return car(y); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - - if (x == env && sslot) - *sslot = sl; /* Insert here. */ - - if (!all) - return sc->NIL; /* Miss, and stop looking. */ - } - - return sc->NIL; /* Not found in any environment. */ -} - -#else /* USE_ALIST_ENV */ - -static INLINE void new_frame_in_env(scheme *sc, pointer old_env) -{ - sc->envir = immutable_cons(sc, sc->NIL, old_env); - setenvironment(sc->envir); -} - -/* Find the slot in ENV under the key HDL. If ALL is given, look in - * all environments enclosing ENV. If the lookup fails, and SSLOT is - * given, the position where the new slot has to be inserted is stored - * at SSLOT. */ -static pointer -find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) -{ - pointer x,y; - pointer *sl; - int d; - assert(is_symbol(hdl)); - - for (x = env; x != sc->NIL; x = cdr(x)) { - for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) { - d = pointercmp(caar(y), hdl); - if (d == 0) - return car(y); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - - if (x == env && sslot) - *sslot = sl; /* Insert here. */ - - if (!all) - return sc->NIL; /* Miss, and stop looking. */ - } - - return sc->NIL; /* Not found in any environment. */ -} - -#endif /* USE_ALIST_ENV else */ - -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) -{ - return find_slot_spec_in_env(sc, env, hdl, all, NULL); -} - -/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using - * find_slot_spec_in_env, and no insertion must be done between - * obtaining SSLOT and the call to this function. */ -static INLINE void new_slot_spec_in_env(scheme *sc, - pointer variable, pointer value, - pointer *sslot) -{ -#define new_slot_spec_in_env_allocates 2 - pointer slot; - gc_disable(sc, gc_reservations (new_slot_spec_in_env)); - slot = immutable_cons(sc, variable, value); - *sslot = immutable_cons(sc, slot, *sslot); - gc_enable(sc); -} - -static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) -{ -#define new_slot_in_env_allocates new_slot_spec_in_env_allocates - pointer slot; - pointer *sslot; - assert(is_symbol(variable)); - slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot); - assert(slot == sc->NIL); - new_slot_spec_in_env(sc, variable, value, sslot); -} - -static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) -{ - (void)sc; - cdr(slot) = value; -} - -static INLINE pointer slot_value_in_env(pointer slot) -{ - return cdr(slot); -} - - -/* ========== Evaluation Cycle ========== */ - - -static enum scheme_opcodes -_Error_1(scheme *sc, const char *s, pointer a) { - const char *str = s; - pointer history; -#if USE_ERROR_HOOK - pointer x; - pointer hdl=sc->ERROR_HOOK; -#endif - -#if SHOW_ERROR_LINE - char sbuf[STRBUFFSIZE]; -#endif - - history = history_flatten(sc); - -#if SHOW_ERROR_LINE - /* make sure error is not in REPL */ - if (((sc->load_stack[sc->file_i].kind & port_file) == 0 - || sc->load_stack[sc->file_i].rep.stdio.file != stdin)) { - pointer tag; - const char *fname; - int ln; - - if (history != sc->NIL && has_tag(car(history)) - && (tag = get_tag(sc, car(history))) - && is_string(car(tag)) && is_integer(cdr(tag))) { - fname = string_value(car(tag)); - ln = ivalue_unchecked(cdr(tag)); - } else { - fname = string_value(sc->load_stack[sc->file_i].filename); - ln = ivalue_unchecked(sc->load_stack[sc->file_i].curr_line); - } - - /* should never happen */ - if(!fname) fname = ""; - - /* we started from 0 */ - ln++; - snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s); - - str = (const char*)sbuf; - } -#endif - -#if USE_ERROR_HOOK - x=find_slot_in_env(sc,sc->envir,hdl,1); - if (x != sc->NIL) { - sc->code = cons(sc, cons(sc, sc->QUOTE, - cons(sc, history, sc->NIL)), - sc->NIL); - if(a!=0) { - sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)), - sc->code); - } else { - sc->code = cons(sc, sc->F, sc->code); - } - sc->code = cons(sc, mk_string(sc, str), sc->code); - setimmutable(car(sc->code)); - sc->code = cons(sc, slot_value_in_env(x), sc->code); - return OP_EVAL; - } -#endif - - if(a!=0) { - sc->args = cons(sc, (a), sc->NIL); - } else { - sc->args = sc->NIL; - } - sc->args = cons(sc, mk_string(sc, str), sc->args); - setimmutable(car(sc->args)); - return OP_ERR0; -} -#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; } -#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; } - -/* Too small to turn into function */ -# define BEGIN do { -# define END } while (0) - - - -/* Flags. The interpreter has a flags field. When the interpreter - * pushes a frame to the dump stack, it is encoded with the opcode. - * Therefore, we do not use the least significant byte. */ - -/* Masks used to encode and decode opcode and flags. */ -#define S_OP_MASK 0x000000ff -#define S_FLAG_MASK 0xffffff00 - -/* Set if the interpreter evaluates an expression in a tail context - * (see R5RS, section 3.5). If a function, procedure, or continuation - * is invoked while this flag is set, the call is recorded as tail - * call in the history buffer. */ -#define S_FLAG_TAIL_CONTEXT 0x00000100 - -/* Set flag F. */ -#define s_set_flag(sc, f) \ - BEGIN \ - (sc)->flags |= S_FLAG_ ## f; \ - END - -/* Clear flag F. */ -#define s_clear_flag(sc, f) \ - BEGIN \ - (sc)->flags &= ~ S_FLAG_ ## f; \ - END - -/* Check if flag F is set. */ -#define s_get_flag(sc, f) \ - !!((sc)->flags & S_FLAG_ ## f) - - - -/* Bounce back to Eval_Cycle and execute A. */ -#define s_goto(sc, a) { op = (a); goto dispatch; } - -#if USE_THREADED_CODE - -/* Do not bounce back to Eval_Cycle but execute A by jumping directly - * to it. */ -#define s_thread_to(sc, a) \ - BEGIN \ - op = (a); \ - goto a; \ - END - -/* Define a label OP and emit a case statement for OP. For use in the - * dispatch function. The slightly peculiar goto that is never - * executed avoids warnings about unused labels. */ -#define CASE(OP) case OP: if (0) goto OP; OP - -#else /* USE_THREADED_CODE */ -#define s_thread_to(sc, a) s_goto(sc, a) -#define CASE(OP) case OP -#endif /* USE_THREADED_CODE */ - -/* Return to the previous frame on the dump stack, setting the current - * value to A. */ -#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0)) - -/* Return to the previous frame on the dump stack, setting the current - * value to A, and re-enable the garbage collector. */ -#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1)) - -static INLINE void dump_stack_reset(scheme *sc) -{ - sc->dump = sc->NIL; -} - -static INLINE void dump_stack_initialize(scheme *sc) -{ - dump_stack_reset(sc); - sc->frame_freelist = sc->NIL; -} - -static void dump_stack_free(scheme *sc) -{ - dump_stack_initialize(sc); -} - -const int frame_length = 4; - -static pointer -dump_stack_make_frame(scheme *sc) -{ - pointer frame; - - frame = mk_vector(sc, frame_length); - if (! sc->no_memory) - setframe(frame); - - return frame; -} - -static INLINE pointer * -frame_slots(pointer frame) -{ - return &frame->_object._vector._elements[0]; -} - -#define frame_payload vector_length - -static pointer -dump_stack_allocate_frame(scheme *sc) -{ - pointer frame = sc->frame_freelist; - if (frame == sc->NIL) { - if (gc_enabled(sc)) - frame = dump_stack_make_frame(sc); - else - gc_reservation_failure(sc); - } else - sc->frame_freelist = *frame_slots(frame); - return frame; -} - -static void -dump_stack_deallocate_frame(scheme *sc, pointer frame) -{ - pointer *p = frame_slots(frame); - *p++ = sc->frame_freelist; - *p++ = sc->NIL; - *p++ = sc->NIL; - *p++ = sc->NIL; - sc->frame_freelist = frame; -} - -static void -dump_stack_preallocate_frame(scheme *sc) -{ - pointer frame = dump_stack_make_frame(sc); - if (! sc->no_memory) - dump_stack_deallocate_frame(sc, frame); -} - -static enum scheme_opcodes -_s_return(scheme *sc, pointer a, int enable_gc) { - pointer dump = sc->dump; - pointer *p; - unsigned long v; - enum scheme_opcodes next_op; - sc->value = (a); - if (enable_gc) - gc_enable(sc); - if (dump == sc->NIL) - return OP_QUIT; - v = frame_payload(dump); - next_op = (int) (v & S_OP_MASK); - sc->flags = v & S_FLAG_MASK; - p = frame_slots(dump); - sc->args = *p++; - sc->envir = *p++; - sc->code = *p++; - sc->dump = *p++; - dump_stack_deallocate_frame(sc, dump); - return next_op; -} - -static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { -#define s_save_allocates 0 - pointer dump; - pointer *p; - gc_disable(sc, gc_reservations (s_save)); - dump = dump_stack_allocate_frame(sc); - frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op); - p = frame_slots(dump); - *p++ = args; - *p++ = sc->envir; - *p++ = code; - *p++ = sc->dump; - sc->dump = dump; - gc_enable(sc); -} - -static INLINE void dump_stack_mark(scheme *sc) -{ - mark(sc->dump); - mark(sc->frame_freelist); -} - - - -#if USE_HISTORY - -static void -history_free(scheme *sc) -{ - sc->free(sc->history.m); - sc->history.tailstacks = sc->NIL; - sc->history.callstack = sc->NIL; -} - -static pointer -history_init(scheme *sc, size_t N, size_t M) -{ - size_t i; - struct history *h = &sc->history; - - h->N = N; - h->mask_N = N - 1; - h->n = N - 1; - assert ((N & h->mask_N) == 0); - - h->M = M; - h->mask_M = M - 1; - assert ((M & h->mask_M) == 0); - - h->callstack = mk_vector(sc, N); - if (h->callstack == sc->sink) - goto fail; - - h->tailstacks = mk_vector(sc, N); - for (i = 0; i < N; i++) { - pointer tailstack = mk_vector(sc, M); - if (tailstack == sc->sink) - goto fail; - set_vector_elem(h->tailstacks, i, tailstack); - } - - h->m = sc->malloc(N * sizeof *h->m); - if (h->m == NULL) - goto fail; - - for (i = 0; i < N; i++) - h->m[i] = 0; - - return sc->T; - -fail: - history_free(sc); - return sc->F; -} - -static void -history_mark(scheme *sc) -{ - struct history *h = &sc->history; - mark(h->callstack); - mark(h->tailstacks); -} - -#define add_mod(a, b, mask) (((a) + (b)) & (mask)) -#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask) - -static INLINE void -tailstack_clear(scheme *sc, pointer v) -{ - assert(is_vector(v)); - /* XXX optimize */ - fill_vector(v, sc->NIL); -} - -static pointer -callstack_pop(scheme *sc) -{ - struct history *h = &sc->history; - size_t n = h->n; - pointer item; - - if (h->callstack == sc->NIL) - return sc->NIL; - - item = vector_elem(h->callstack, n); - /* Clear our frame so that it can be gc'ed and we don't run into it - * when walking the history. */ - set_vector_elem(h->callstack, n, sc->NIL); - tailstack_clear(sc, vector_elem(h->tailstacks, n)); - - /* Exit from the frame. */ - h->n = sub_mod(h->n, 1, h->mask_N); - - return item; -} - -static void -callstack_push(scheme *sc, pointer item) -{ - struct history *h = &sc->history; - size_t n = h->n; - - if (h->callstack == sc->NIL) - return; - - /* Enter a new frame. */ - n = h->n = add_mod(n, 1, h->mask_N); - - /* Initialize tail stack. */ - tailstack_clear(sc, vector_elem(h->tailstacks, n)); - h->m[n] = h->mask_M; - - set_vector_elem(h->callstack, n, item); -} - -static void -tailstack_push(scheme *sc, pointer item) -{ - struct history *h = &sc->history; - size_t n = h->n; - size_t m = h->m[n]; - - if (h->callstack == sc->NIL) - return; - - /* Enter a new tail frame. */ - m = h->m[n] = add_mod(m, 1, h->mask_M); - set_vector_elem(vector_elem(h->tailstacks, n), m, item); -} - -static pointer -tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n, - pointer acc) -{ - struct history *h = &sc->history; - pointer frame; - - assert(i <= h->M); - assert(n < h->M); - - if (acc == sc->sink) - return sc->sink; - - if (i == 0) { - /* We reached the end, but we did not see a unused frame. Signal - this using '... . */ - return cons(sc, mk_symbol(sc, "..."), acc); - } - - frame = vector_elem(tailstack, n); - if (frame == sc->NIL) { - /* A unused frame. We reached the end of the history. */ - return acc; - } - - /* Add us. */ - acc = cons(sc, frame, acc); - - return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M), - acc); -} - -static pointer -callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc) -{ - struct history *h = &sc->history; - pointer frame; - - assert(i <= h->N); - assert(n < h->N); - - if (acc == sc->sink) - return sc->sink; - - if (i == 0) { - /* We reached the end, but we did not see a unused frame. Signal - this using '... . */ - return cons(sc, mk_symbol(sc, "..."), acc); - } - - frame = vector_elem(h->callstack, n); - if (frame == sc->NIL) { - /* A unused frame. We reached the end of the history. */ - return acc; - } - - /* First, emit the tail calls. */ - acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n], - acc); - - /* Then us. */ - acc = cons(sc, frame, acc); - - return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc); -} - -static pointer -history_flatten(scheme *sc) -{ - struct history *h = &sc->history; - pointer history; - - if (h->callstack == sc->NIL) - return sc->NIL; - - history = callstack_flatten(sc, h->N, h->n, sc->NIL); - if (history == sc->sink) - return sc->sink; - - return reverse_in_place(sc, sc->NIL, history); -} - -#undef add_mod -#undef sub_mod - -#else /* USE_HISTORY */ - -#define history_init(SC, A, B) (void) 0 -#define history_free(SC) (void) 0 -#define callstack_pop(SC) (void) 0 -#define callstack_push(SC, X) (void) 0 -#define tailstack_push(SC, X) (void) 0 - -#endif /* USE_HISTORY */ - - - -#if USE_PLIST -static pointer -get_property(scheme *sc, pointer obj, pointer key) -{ - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - return cdar(x); - - return sc->NIL; -} - -static pointer -set_property(scheme *sc, pointer obj, pointer key, pointer value) -{ -#define set_property_allocates 2 - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - cdar(x) = value; - else { - gc_disable(sc, gc_reservations(set_property)); - symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); - gc_enable(sc); - } - - return sc->T; -} -#endif - - - -static int is_list(scheme *sc, pointer a) -{ return list_length(sc,a) >= 0; } - -/* Result is: - proper list: length - circular list: -1 - not even a pair: -2 - dotted list: -2 minus length before dot -*/ -int list_length(scheme *sc, pointer a) { - int i=0; - pointer slow, fast; - - slow = fast = a; - while (1) - { - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - fast = cdr(fast); - ++i; - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - ++i; - fast = cdr(fast); - - /* Safe because we would have already returned if `fast' - encountered a non-pair. */ - slow = cdr(slow); - if (fast == slow) - { - /* the fast pointer has looped back around and caught up - with the slow pointer, hence the structure is circular, - not of finite length, and therefore not a list */ - return -1; - } - } -} - - - -#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) - -/* kernel of this interpreter */ -static void -Eval_Cycle(scheme *sc, enum scheme_opcodes op) { - for (;;) { - pointer x, y; - pointer callsite; - num v; -#if USE_MATH - double dd; -#endif - int (*comp_func)(num, num) = NULL; - const struct op_code_info *pcd; - - dispatch: - pcd = &dispatch_table[op]; - if (pcd->name[0] != 0) { /* if built-in function, check arguments */ - char msg[STRBUFFSIZE]; - if (! check_arguments (sc, pcd, msg, sizeof msg)) { - s_goto(sc, _Error_1(sc, msg, 0)); - } - } - - if(sc->no_memory) { - fprintf(stderr,"No memory!\n"); - exit(1); - } - ok_to_freely_gc(sc); - - switch (op) { - CASE(OP_LOAD): /* load */ - if(file_interactive(sc)) { - fprintf(sc->outport->_object._port->rep.stdio.file, - "Loading %s\n", strvalue(car(sc->args))); - } - if (!file_push(sc, car(sc->args))) { - Error_1(sc,"unable to open", car(sc->args)); - } - else - { - sc->args = mk_integer(sc,sc->file_i); - s_thread_to(sc,OP_T0LVL); - } - - CASE(OP_T0LVL): /* top level */ - /* If we reached the end of file, this loop is done. */ - if(sc->loadport->_object._port->kind & port_saw_EOF) - { - if(sc->file_i == 0) - { - sc->args=sc->NIL; - sc->nesting = sc->nesting_stack[0]; - s_thread_to(sc,OP_QUIT); - } - else - { - file_pop(sc); - s_return(sc,sc->value); - } - /* NOTREACHED */ - } - - /* If interactive, be nice to user. */ - if(file_interactive(sc)) - { - sc->envir = sc->global_env; - dump_stack_reset(sc); - putstr(sc,"\n"); - putstr(sc,prompt); - } - - /* Set up another iteration of REPL */ - sc->nesting=0; - sc->save_inport=sc->inport; - sc->inport = sc->loadport; - s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); - s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); - s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); - s_thread_to(sc,OP_READ_INTERNAL); - - CASE(OP_T1LVL): /* top level */ - sc->code = sc->value; - sc->inport=sc->save_inport; - s_thread_to(sc,OP_EVAL); - - CASE(OP_READ_INTERNAL): /* internal read */ - sc->tok = token(sc); - if(sc->tok==TOK_EOF) - { s_return(sc,sc->EOF_OBJ); } - s_thread_to(sc,OP_RDSEXPR); - - CASE(OP_GENSYM): - s_return(sc, gensym(sc)); - - CASE(OP_VALUEPRINT): /* print evaluation result */ - /* OP_VALUEPRINT is always pushed, because when changing from - non-interactive to interactive mode, it needs to be - already on the stack */ - if(sc->tracing) { - putstr(sc,"\nGives: "); - } - if(file_interactive(sc)) { - sc->print_flag = 1; - sc->args = sc->value; - s_thread_to(sc,OP_P0LIST); - } else { - s_return(sc,sc->value); - } - - CASE(OP_EVAL): /* main part of evaluation */ -#if USE_TRACING - if(sc->tracing) { - /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ - s_save(sc,OP_REAL_EVAL,sc->args,sc->code); - sc->args=sc->code; - putstr(sc,"\nEval: "); - s_thread_to(sc,OP_P0LIST); - } - /* fall through */ - CASE(OP_REAL_EVAL): -#endif - if (is_symbol(sc->code)) { /* symbol */ - x=find_slot_in_env(sc,sc->envir,sc->code,1); - if (x != sc->NIL) { - s_return(sc,slot_value_in_env(x)); - } else { - Error_1(sc, "eval: unbound variable", sc->code); - } - } else if (is_pair(sc->code)) { - if (is_syntax(x = car(sc->code))) { /* SYNTAX */ - sc->code = cdr(sc->code); - s_goto(sc, syntaxnum(sc, x)); - } else {/* first, eval top element and eval arguments */ - s_save(sc,OP_E0ARGS, sc->NIL, sc->code); - /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ - sc->code = car(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } - } else { - s_return(sc,sc->code); - } - - CASE(OP_E0ARGS): /* eval arguments */ - if (is_macro(sc->value)) { /* macro expansion */ - gc_disable(sc, 1 + gc_reservations (s_save)); - s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); - sc->args = cons(sc,sc->code, sc->NIL); - gc_enable(sc); - sc->code = sc->value; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_APPLY); - } else { - gc_disable(sc, 1); - sc->args = cons(sc, sc->code, sc->NIL); - gc_enable(sc); - sc->code = cdr(sc->code); - s_thread_to(sc,OP_E1ARGS); - } - - CASE(OP_E1ARGS): /* eval arguments */ - gc_disable(sc, 1); - sc->args = cons(sc, sc->value, sc->args); - gc_enable(sc); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); - sc->code = car(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - s_thread_to(sc,OP_APPLY_CODE); - } - -#if USE_TRACING - CASE(OP_TRACING): { - int tr=sc->tracing; - sc->tracing=ivalue(car(sc->args)); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, tr)); - } -#endif - -#if USE_HISTORY - CASE(OP_CALLSTACK_POP): /* pop the call stack */ - callstack_pop(sc); - s_return(sc, sc->value); -#endif - - CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)', - * record in the history as invoked from - * 'car(args)' */ - free_cons(sc, sc->args, &callsite, &sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - /* Fallthrough. */ - - CASE(OP_APPLY): /* apply 'code' to 'args' */ -#if USE_TRACING - if(sc->tracing) { - s_save(sc,OP_REAL_APPLY,sc->args,sc->code); - sc->print_flag = 1; - /* sc->args=cons(sc,sc->code,sc->args);*/ - putstr(sc,"\nApply to: "); - s_thread_to(sc,OP_P0LIST); - } - /* fall through */ - CASE(OP_REAL_APPLY): -#endif -#if USE_HISTORY - if (op != OP_APPLY_CODE) - callsite = sc->code; - if (s_get_flag(sc, TAIL_CONTEXT)) { - /* We are evaluating a tail call. */ - tailstack_push(sc, callsite); - } else { - callstack_push(sc, callsite); - s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL); - } -#endif - - if (is_proc(sc->code)) { - s_goto(sc,procnum(sc->code)); /* PROCEDURE */ - } else if (is_foreign(sc->code)) - { - /* Keep nested calls from GC'ing the arglist */ - push_recent_alloc(sc,sc->args,sc->NIL); - x=sc->code->_object._ff(sc,sc->args); - s_return(sc,x); - } else if (is_closure(sc->code) || is_macro(sc->code) - || is_promise(sc->code)) { /* CLOSURE */ - /* Should not accept promise */ - /* make environment */ - new_frame_in_env(sc, closure_env(sc->code)); - for (x = car(closure_code(sc->code)), y = sc->args; - is_pair(x); x = cdr(x), y = cdr(y)) { - if (y == sc->NIL) { - Error_1(sc, "not enough arguments, missing", x); - } else if (is_symbol(car(x))) { - new_slot_in_env(sc, car(x), car(y)); - } else { - Error_1(sc, "syntax error in closure: not a symbol", car(x)); - } - } - - if (x == sc->NIL) { - if (y != sc->NIL) { - Error_0(sc, "too many arguments"); - } - } else if (is_symbol(x)) - new_slot_in_env(sc, x, y); - else { - Error_1(sc, "syntax error in closure: not a symbol", x); - } - sc->code = cdr(closure_code(sc->code)); - sc->args = sc->NIL; - s_set_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_BEGIN); - } else if (is_continuation(sc->code)) { /* CONTINUATION */ - sc->dump = cont_dump(sc->code); - s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); - } else { - Error_1(sc,"illegal function",sc->code); - } - - CASE(OP_DOMACRO): /* do macro */ - sc->code = sc->value; - s_thread_to(sc,OP_EVAL); - -#if USE_COMPILE_HOOK - CASE(OP_LAMBDA): /* lambda */ - /* If the hook is defined, apply it to sc->code, otherwise - set sc->value fall through */ - { - pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); - if(f==sc->NIL) { - sc->value = sc->code; - /* Fallthru */ - } else { - gc_disable(sc, 1 + gc_reservations (s_save)); - s_save(sc,OP_LAMBDA1,sc->args,sc->code); - sc->args=cons(sc,sc->code,sc->NIL); - gc_enable(sc); - sc->code=slot_value_in_env(f); - s_thread_to(sc,OP_APPLY); - } - } - /* Fallthrough. */ -#else - CASE(OP_LAMBDA): /* lambda */ - sc->value = sc->code; - /* Fallthrough. */ -#endif - - CASE(OP_LAMBDA1): - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); - - - CASE(OP_MKCLOSURE): /* make-closure */ - x=car(sc->args); - if(car(x)==sc->LAMBDA) { - x=cdr(x); - } - if(cdr(sc->args)==sc->NIL) { - y=sc->envir; - } else { - y=cadr(sc->args); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_closure(sc, x, y)); - - CASE(OP_QUOTE): /* quote */ - s_return(sc,car(sc->code)); - - CASE(OP_DEF0): /* define */ - if(is_immutable(car(sc->code))) - Error_1(sc,"define: unable to alter immutable", car(sc->code)); - - if (is_pair(car(sc->code))) { - x = caar(sc->code); - gc_disable(sc, 2); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - gc_enable(sc); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_DEF1, sc->NIL, x); - s_thread_to(sc,OP_EVAL); - - CASE(OP_DEF1): { /* define */ - pointer *sslot; - x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_spec_in_env(sc, sc->code, sc->value, sslot); - } - s_return(sc,sc->code); - } - - CASE(OP_DEFP): /* defined? */ - x=sc->envir; - if(cdr(sc->args)!=sc->NIL) { - x=cadr(sc->args); - } - s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); - - CASE(OP_SET0): /* set! */ - if(is_immutable(car(sc->code))) - Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); - s_save(sc,OP_SET1, sc->NIL, car(sc->code)); - sc->code = cadr(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_SET1): /* set! */ - y=find_slot_in_env(sc,sc->envir,sc->code,1); - if (y != sc->NIL) { - set_slot_in_env(sc, y, sc->value); - s_return(sc,sc->value); - } else { - Error_1(sc, "set!: unbound variable", sc->code); - } - - - CASE(OP_BEGIN): /* begin */ - { - int last; - - if (!is_pair(sc->code)) { - s_return(sc,sc->code); - } - - last = cdr(sc->code) == sc->NIL; - if (!last) { - s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); - } - sc->code = car(sc->code); - if (! last) - /* This is not the end of the list. This is not a tail - * position. */ - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } - - CASE(OP_IF0): /* if */ - s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_IF1): /* if */ - if (is_true(sc->value)) - sc->code = car(sc->code); - else - sc->code = cadr(sc->code); /* (if #f 1) ==> () because - * car(sc->NIL) = sc->NIL */ - s_thread_to(sc,OP_EVAL); - - CASE(OP_LET0): /* let */ - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); - s_thread_to(sc,OP_LET1); - - CASE(OP_LET1): /* let (calculate parameters) */ - gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0)); - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { - gc_enable(sc); - Error_1(sc, "Bad syntax of binding spec in let", - car(sc->code)); - } - s_save(sc,OP_LET1, sc->args, cdr(sc->code)); - gc_enable(sc); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - gc_enable(sc); - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_thread_to(sc,OP_LET2); - } - - CASE(OP_LET2): /* let */ - new_frame_in_env(sc, sc->envir); - for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; - y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - if (is_symbol(car(sc->code))) { /* named let */ - for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { - if (!is_pair(x)) - Error_1(sc, "Bad syntax of binding in let", x); - if (!is_list(sc, car(x))) - Error_1(sc, "Bad syntax of binding in let", car(x)); - gc_disable(sc, 1); - sc->args = cons(sc, caar(x), sc->args); - gc_enable(sc); - } - gc_disable(sc, 2 + gc_reservations (new_slot_in_env)); - x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); - new_slot_in_env(sc, car(sc->code), x); - gc_enable(sc); - sc->code = cddr(sc->code); - sc->args = sc->NIL; - } else { - sc->code = cdr(sc->code); - sc->args = sc->NIL; - } - s_thread_to(sc,OP_BEGIN); - - CASE(OP_LET0AST): /* let* */ - if (car(sc->code) == sc->NIL) { - new_frame_in_env(sc, sc->envir); - sc->code = cdr(sc->code); - s_thread_to(sc,OP_BEGIN); - } - if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { - Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code)); - } - s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); - sc->code = cadaar(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_LET1AST): /* let* (make new frame) */ - new_frame_in_env(sc, sc->envir); - s_thread_to(sc,OP_LET2AST); - - CASE(OP_LET2AST): /* let* (calculate parameters) */ - new_slot_in_env(sc, caar(sc->code), sc->value); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET2AST, sc->args, sc->code); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - sc->code = sc->args; - sc->args = sc->NIL; - s_thread_to(sc,OP_BEGIN); - } - - CASE(OP_LET0REC): /* letrec */ - new_frame_in_env(sc, sc->envir); - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = car(sc->code); - s_thread_to(sc,OP_LET1REC); - - CASE(OP_LET1REC): /* letrec (calculate parameters) */ - gc_disable(sc, 1); - sc->args = cons(sc, sc->value, sc->args); - gc_enable(sc); - if (is_pair(sc->code)) { /* continue */ - if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { - Error_1(sc, "Bad syntax of binding spec in letrec", - car(sc->code)); - } - s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_thread_to(sc,OP_LET2REC); - } - - CASE(OP_LET2REC): /* letrec */ - for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - sc->code = cdr(sc->code); - sc->args = sc->NIL; - s_thread_to(sc,OP_BEGIN); - - CASE(OP_COND0): /* cond */ - if (!is_pair(sc->code)) { - Error_0(sc,"syntax error in cond"); - } - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_COND1): /* cond */ - if (is_true(sc->value)) { - if ((sc->code = cdar(sc->code)) == sc->NIL) { - s_return(sc,sc->value); - } - if(!sc->code || car(sc->code)==sc->FEED_TO) { - if(!is_pair(cdr(sc->code))) { - Error_0(sc,"syntax error in cond"); - } - gc_disable(sc, 4); - x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); - sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); - gc_enable(sc); - s_thread_to(sc,OP_EVAL); - } - s_thread_to(sc,OP_BEGIN); - } else { - if ((sc->code = cdr(sc->code)) == sc->NIL) { - s_return(sc,sc->NIL); - } else { - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } - } - - CASE(OP_DELAY): /* delay */ - gc_disable(sc, 2); - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return_enable_gc(sc,x); - - CASE(OP_AND0): /* and */ - if (sc->code == sc->NIL) { - s_return(sc,sc->T); - } - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_AND1): /* and */ - if (is_false(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - } - - CASE(OP_OR0): /* or */ - if (sc->code == sc->NIL) { - s_return(sc,sc->F); - } - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_OR1): /* or */ - if (is_true(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - } - - CASE(OP_C0STREAM): /* cons-stream */ - s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_C1STREAM): /* cons-stream */ - sc->args = sc->value; /* save sc->value to register sc->args for gc */ - gc_disable(sc, 3); - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return_enable_gc(sc, cons(sc, sc->args, x)); - - CASE(OP_MACRO0): /* macro */ - if (is_pair(car(sc->code))) { - x = caar(sc->code); - gc_disable(sc, 2); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - gc_enable(sc); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_MACRO1, sc->NIL, x); - s_thread_to(sc,OP_EVAL); - - CASE(OP_MACRO1): { /* macro */ - pointer *sslot; - typeflag(sc->value) = T_MACRO; - x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_spec_in_env(sc, sc->code, sc->value, sslot); - } - s_return(sc,sc->code); - } - - CASE(OP_CASE0): /* case */ - s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_CASE1): /* case */ - for (x = sc->code; x != sc->NIL; x = cdr(x)) { - if (!is_pair(y = caar(x))) { - break; - } - for ( ; y != sc->NIL; y = cdr(y)) { - if (eqv(car(y), sc->value)) { - break; - } - } - if (y != sc->NIL) { - break; - } - } - if (x != sc->NIL) { - if (is_pair(caar(x))) { - sc->code = cdar(x); - s_thread_to(sc,OP_BEGIN); - } else {/* else */ - s_save(sc,OP_CASE2, sc->NIL, cdar(x)); - sc->code = caar(x); - s_thread_to(sc,OP_EVAL); - } - } else { - s_return(sc,sc->NIL); - } - - CASE(OP_CASE2): /* case */ - if (is_true(sc->value)) { - s_thread_to(sc,OP_BEGIN); - } else { - s_return(sc,sc->NIL); - } - - CASE(OP_PAPPLY): /* apply */ - sc->code = car(sc->args); - sc->args = list_star(sc,cdr(sc->args)); - /*sc->args = cadr(sc->args);*/ - s_thread_to(sc,OP_APPLY); - - CASE(OP_PEVAL): /* eval */ - if(cdr(sc->args)!=sc->NIL) { - sc->envir=cadr(sc->args); - } - sc->code = car(sc->args); - s_thread_to(sc,OP_EVAL); - - CASE(OP_CONTINUATION): /* call-with-current-continuation */ - sc->code = car(sc->args); - gc_disable(sc, 2); - sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); - gc_enable(sc); - s_thread_to(sc,OP_APPLY); - -#if USE_MATH - CASE(OP_INEX2EX): /* inexact->exact */ - x=car(sc->args); - if(num_is_integer(x)) { - s_return(sc,x); - } else if(modf(rvalue_unchecked(x),&dd)==0.0) { - s_return(sc,mk_integer(sc,ivalue(x))); - } else { - Error_1(sc, "inexact->exact: not integral", x); - } - - CASE(OP_EXP): - x=car(sc->args); - s_return(sc, mk_real(sc, exp(rvalue(x)))); - - CASE(OP_LOG): - x=car(sc->args); - s_return(sc, mk_real(sc, log(rvalue(x)))); - - CASE(OP_SIN): - x=car(sc->args); - s_return(sc, mk_real(sc, sin(rvalue(x)))); - - CASE(OP_COS): - x=car(sc->args); - s_return(sc, mk_real(sc, cos(rvalue(x)))); - - CASE(OP_TAN): - x=car(sc->args); - s_return(sc, mk_real(sc, tan(rvalue(x)))); - - CASE(OP_ASIN): - x=car(sc->args); - s_return(sc, mk_real(sc, asin(rvalue(x)))); - - CASE(OP_ACOS): - x=car(sc->args); - s_return(sc, mk_real(sc, acos(rvalue(x)))); - - CASE(OP_ATAN): - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - s_return(sc, mk_real(sc, atan(rvalue(x)))); - } else { - pointer y=cadr(sc->args); - s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); - } - - CASE(OP_SQRT): - x=car(sc->args); - s_return(sc, mk_real(sc, sqrt(rvalue(x)))); - - CASE(OP_EXPT): { - double result; - int real_result=1; - pointer y=cadr(sc->args); - x=car(sc->args); - if (num_is_integer(x) && num_is_integer(y)) - real_result=0; - /* This 'if' is an R5RS compatibility fix. */ - /* NOTE: Remove this 'if' fix for R6RS. */ - if (rvalue(x) == 0 && rvalue(y) < 0) { - result = 0.0; - } else { - result = pow(rvalue(x),rvalue(y)); - } - /* Before returning integer result make sure we can. */ - /* If the test fails, result is too big for integer. */ - if (!real_result) - { - long result_as_long = (long)result; - if (result != (double)result_as_long) - real_result = 1; - } - if (real_result) { - s_return(sc, mk_real(sc, result)); - } else { - s_return(sc, mk_integer(sc, result)); - } - } - - CASE(OP_FLOOR): - x=car(sc->args); - s_return(sc, mk_real(sc, floor(rvalue(x)))); - - CASE(OP_CEILING): - x=car(sc->args); - s_return(sc, mk_real(sc, ceil(rvalue(x)))); - - CASE(OP_TRUNCATE ): { - double rvalue_of_x ; - x=car(sc->args); - rvalue_of_x = rvalue(x) ; - if (rvalue_of_x > 0) { - s_return(sc, mk_real(sc, floor(rvalue_of_x))); - } else { - s_return(sc, mk_real(sc, ceil(rvalue_of_x))); - } - } - - CASE(OP_ROUND): - x=car(sc->args); - if (num_is_integer(x)) - s_return(sc, x); - s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); -#endif - - CASE(OP_ADD): /* + */ - v=num_zero; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_add(v,nvalue(car(x))); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_MUL): /* * */ - v=num_one; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_mul(v,nvalue(car(x))); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_SUB): /* - */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_zero; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - v=num_sub(v,nvalue(car(x))); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_DIV): /* / */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (!is_zero_double(rvalue(car(x)))) - v=num_div(v,nvalue(car(x))); - else { - Error_0(sc,"/: division by zero"); - } - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_INTDIV): /* quotient */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (ivalue(car(x)) != 0) - v=num_intdiv(v,nvalue(car(x))); - else { - Error_0(sc,"quotient: division by zero"); - } - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_REM): /* remainder */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_rem(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"remainder: division by zero"); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_MOD): /* modulo */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_mod(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"modulo: division by zero"); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_CAR): /* car */ - s_return(sc,caar(sc->args)); - - CASE(OP_CDR): /* cdr */ - s_return(sc,cdar(sc->args)); - - CASE(OP_CONS): /* cons */ - cdr(sc->args) = cadr(sc->args); - s_return(sc,sc->args); - - CASE(OP_SETCAR): /* set-car! */ - if(!is_immutable(car(sc->args))) { - caar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-car!: unable to alter immutable pair"); - } - - CASE(OP_SETCDR): /* set-cdr! */ - if(!is_immutable(car(sc->args))) { - cdar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-cdr!: unable to alter immutable pair"); - } - - CASE(OP_CHAR2INT): { /* char->integer */ - char c; - c=(char)ivalue(car(sc->args)); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c)); - } - - CASE(OP_INT2CHAR): { /* integer->char */ - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_character(sc, (char) c)); - } - - CASE(OP_CHARUPCASE): { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=toupper(c); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_character(sc, (char) c)); - } - - CASE(OP_CHARDNCASE): { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=tolower(c); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_character(sc, (char) c)); - } - - CASE(OP_STR2SYM): /* string->symbol */ - gc_disable(sc, gc_reservations (mk_symbol)); - s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args)))); - - CASE(OP_STR2ATOM): /* string->atom */ { - char *s=strvalue(car(sc->args)); - long pf = 0; - if(cdr(sc->args)!=sc->NIL) { - /* we know cadr(sc->args) is a natural number */ - /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked(cadr(sc->args)); - if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { - /* base is OK */ - } - else { - pf = -1; - } - } - if (pf < 0) { - Error_1(sc, "string->atom: bad base", cadr(sc->args)); - } else if(*s=='#') /* no use of base! */ { - s_return(sc, mk_sharp_const(sc, s+1)); - } else { - if (pf == 0 || pf == 10) { - s_return(sc, mk_atom(sc, s)); - } - else { - char *ep; - long iv = strtol(s,&ep,(int )pf); - if (*ep == 0) { - s_return(sc, mk_integer(sc, iv)); - } - else { - s_return(sc, sc->F); - } - } - } - } - - CASE(OP_SYM2STR): /* symbol->string */ - gc_disable(sc, 1); - x=mk_string(sc,symname(car(sc->args))); - setimmutable(x); - s_return_enable_gc(sc, x); - - CASE(OP_ATOM2STR): /* atom->string */ { - long pf = 0; - x=car(sc->args); - if(cdr(sc->args)!=sc->NIL) { - /* we know cadr(sc->args) is a natural number */ - /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked(cadr(sc->args)); - if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { - /* base is OK */ - } - else { - pf = -1; - } - } - if (pf < 0) { - Error_1(sc, "atom->string: bad base", cadr(sc->args)); - } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { - char *p; - int len; - atom2str(sc,x,(int )pf,&p,&len); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_counted_string(sc, p, len)); - } else { - Error_1(sc, "atom->string: not an atom", x); - } - } - - CASE(OP_MKSTRING): { /* make-string */ - int fill=' '; - int len; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=charvalue(cadr(sc->args)); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill)); - } - - CASE(OP_STRLEN): /* string-length */ - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args)))); - - CASE(OP_STRREF): { /* string-ref */ - char *str; - int index; - - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - - if(index>=strlength(car(sc->args))) { - Error_1(sc, "string-ref: out of bounds", cadr(sc->args)); - } - - gc_disable(sc, 1); - s_return_enable_gc(sc, - mk_character(sc, ((unsigned char*) str)[index])); - } - - CASE(OP_STRSET): { /* string-set! */ - char *str; - int index; - int c; - - if(is_immutable(car(sc->args))) { - Error_1(sc, "string-set!: unable to alter immutable string", - car(sc->args)); - } - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - if(index>=strlength(car(sc->args))) { - Error_1(sc, "string-set!: out of bounds", cadr(sc->args)); - } - - c=charvalue(caddr(sc->args)); - - str[index]=(char)c; - s_return(sc,car(sc->args)); - } - - CASE(OP_STRAPPEND): { /* string-append */ - /* in 1.29 string-append was in Scheme in init.scm but was too slow */ - int len = 0; - pointer newstr; - char *pos; - - /* compute needed length for new string */ - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - len += strlength(car(x)); - } - gc_disable(sc, 1); - newstr = mk_empty_string(sc, len, ' '); - /* store the contents of the argument strings into the new string */ - for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; - pos += strlength(car(x)), x = cdr(x)) { - memcpy(pos, strvalue(car(x)), strlength(car(x))); - } - s_return_enable_gc(sc, newstr); - } - - CASE(OP_SUBSTR): { /* substring */ - char *str; - int index0; - int index1; - - str=strvalue(car(sc->args)); - - index0=ivalue(cadr(sc->args)); - - if(index0>strlength(car(sc->args))) { - Error_1(sc, "substring: start out of bounds", cadr(sc->args)); - } - - if(cddr(sc->args)!=sc->NIL) { - index1=ivalue(caddr(sc->args)); - if(index1>strlength(car(sc->args)) || index1args)); - } - } else { - index1=strlength(car(sc->args)); - } - - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0)); - } - - CASE(OP_VECTOR): { /* vector */ - int i; - pointer vec; - int len=list_length(sc,sc->args); - if(len<0) { - Error_1(sc, "vector: not a proper list", sc->args); - } - vec=mk_vector(sc,len); - if(sc->no_memory) { s_return(sc, sc->sink); } - for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { - set_vector_elem(vec,i,car(x)); - } - s_return(sc,vec); - } - - CASE(OP_MKVECTOR): { /* make-vector */ - pointer fill=sc->NIL; - int len; - pointer vec; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=cadr(sc->args); - } - vec=mk_vector(sc,len); - if(sc->no_memory) { s_return(sc, sc->sink); } - if(fill!=sc->NIL) { - fill_vector(vec,fill); - } - s_return(sc,vec); - } - - CASE(OP_VECLEN): /* vector-length */ - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args)))); - - CASE(OP_VECREF): { /* vector-ref */ - int index; - - index=ivalue(cadr(sc->args)); - - if(index >= vector_length(car(sc->args))) { - Error_1(sc, "vector-ref: out of bounds", cadr(sc->args)); - } - - s_return(sc,vector_elem(car(sc->args),index)); - } - - CASE(OP_VECSET): { /* vector-set! */ - int index; - - if(is_immutable(car(sc->args))) { - Error_1(sc, "vector-set!: unable to alter immutable vector", - car(sc->args)); - } - - index=ivalue(cadr(sc->args)); - if(index >= vector_length(car(sc->args))) { - Error_1(sc, "vector-set!: out of bounds", cadr(sc->args)); - } - - set_vector_elem(car(sc->args),index,caddr(sc->args)); - s_return(sc,car(sc->args)); - } - - CASE(OP_NOT): /* not */ - s_retbool(is_false(car(sc->args))); - CASE(OP_BOOLP): /* boolean? */ - s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); - CASE(OP_EOFOBJP): /* boolean? */ - s_retbool(car(sc->args) == sc->EOF_OBJ); - CASE(OP_NULLP): /* null? */ - s_retbool(car(sc->args) == sc->NIL); - CASE(OP_NUMEQ): /* = */ - /* Fallthrough. */ - CASE(OP_LESS): /* < */ - /* Fallthrough. */ - CASE(OP_GRE): /* > */ - /* Fallthrough. */ - CASE(OP_LEQ): /* <= */ - /* Fallthrough. */ - CASE(OP_GEQ): /* >= */ - switch(op) { - case OP_NUMEQ: comp_func=num_eq; break; - case OP_LESS: comp_func=num_lt; break; - case OP_GRE: comp_func=num_gt; break; - case OP_LEQ: comp_func=num_le; break; - case OP_GEQ: comp_func=num_ge; break; - default: assert (! "reached"); - } - x=sc->args; - v=nvalue(car(x)); - x=cdr(x); - - for (; x != sc->NIL; x = cdr(x)) { - if(!comp_func(v,nvalue(car(x)))) { - s_retbool(0); - } - v=nvalue(car(x)); - } - s_retbool(1); - CASE(OP_SYMBOLP): /* symbol? */ - s_retbool(is_symbol(car(sc->args))); - CASE(OP_NUMBERP): /* number? */ - s_retbool(is_number(car(sc->args))); - CASE(OP_STRINGP): /* string? */ - s_retbool(is_string(car(sc->args))); - CASE(OP_INTEGERP): /* integer? */ - s_retbool(is_integer(car(sc->args))); - CASE(OP_REALP): /* real? */ - s_retbool(is_number(car(sc->args))); /* All numbers are real */ - CASE(OP_CHARP): /* char? */ - s_retbool(is_character(car(sc->args))); -#if USE_CHAR_CLASSIFIERS - CASE(OP_CHARAP): /* char-alphabetic? */ - s_retbool(Cisalpha(ivalue(car(sc->args)))); - CASE(OP_CHARNP): /* char-numeric? */ - s_retbool(Cisdigit(ivalue(car(sc->args)))); - CASE(OP_CHARWP): /* char-whitespace? */ - s_retbool(Cisspace(ivalue(car(sc->args)))); - CASE(OP_CHARUP): /* char-upper-case? */ - s_retbool(Cisupper(ivalue(car(sc->args)))); - CASE(OP_CHARLP): /* char-lower-case? */ - s_retbool(Cislower(ivalue(car(sc->args)))); -#endif - CASE(OP_PORTP): /* port? */ - s_retbool(is_port(car(sc->args))); - CASE(OP_INPORTP): /* input-port? */ - s_retbool(is_inport(car(sc->args))); - CASE(OP_OUTPORTP): /* output-port? */ - s_retbool(is_outport(car(sc->args))); - CASE(OP_PROCP): /* procedure? */ - /*-- - * continuation should be procedure by the example - * (call-with-current-continuation procedure?) ==> #t - * in R^3 report sec. 6.9 - */ - s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) - || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); - CASE(OP_PAIRP): /* pair? */ - s_retbool(is_pair(car(sc->args))); - CASE(OP_LISTP): /* list? */ - s_retbool(list_length(sc,car(sc->args)) >= 0); - - CASE(OP_ENVP): /* environment? */ - s_retbool(is_environment(car(sc->args))); - CASE(OP_VECTORP): /* vector? */ - s_retbool(is_vector(car(sc->args))); - CASE(OP_EQ): /* eq? */ - s_retbool(car(sc->args) == cadr(sc->args)); - CASE(OP_EQV): /* eqv? */ - s_retbool(eqv(car(sc->args), cadr(sc->args))); - - CASE(OP_FORCE): /* force */ - sc->code = car(sc->args); - if (is_promise(sc->code)) { - /* Should change type to closure here */ - s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); - sc->args = sc->NIL; - s_thread_to(sc,OP_APPLY); - } else { - s_return(sc,sc->code); - } - - CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */ - copy_value(sc, sc->code, sc->value); - s_return(sc,sc->value); - - CASE(OP_WRITE): /* write */ - /* Fallthrough. */ - CASE(OP_DISPLAY): /* display */ - /* Fallthrough. */ - CASE(OP_WRITE_CHAR): /* write-char */ - if(is_pair(cdr(sc->args))) { - if(cadr(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=cadr(sc->args); - } - } - sc->args = car(sc->args); - if(op==OP_WRITE) { - sc->print_flag = 1; - } else { - sc->print_flag = 0; - } - s_thread_to(sc,OP_P0LIST); - - CASE(OP_NEWLINE): /* newline */ - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=car(sc->args); - } - } - putstr(sc, "\n"); - s_return(sc,sc->T); - - CASE(OP_ERR0): /* error */ - sc->retcode=-1; - if (!is_string(car(sc->args))) { - sc->args=cons(sc,mk_string(sc," -- "),sc->args); - setimmutable(car(sc->args)); - } - putstr(sc, "Error: "); - putstr(sc, strvalue(car(sc->args))); - sc->args = cdr(sc->args); - s_thread_to(sc,OP_ERR1); - - CASE(OP_ERR1): /* error */ - putstr(sc, " "); - if (sc->args != sc->NIL) { - s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - sc->print_flag = 1; - s_thread_to(sc,OP_P0LIST); - } else { - putstr(sc, "\n"); - if(sc->interactive_repl) { - s_thread_to(sc,OP_T0LVL); - } else { - return; - } - } - - CASE(OP_REVERSE): /* reverse */ - s_return(sc,reverse(sc, sc->NIL, car(sc->args))); - - CASE(OP_REVERSE_IN_PLACE): /* reverse! */ - s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args))); - - CASE(OP_LIST_STAR): /* list* */ - s_return(sc,list_star(sc,sc->args)); - - CASE(OP_APPEND): /* append */ - x = sc->NIL; - y = sc->args; - if (y == x) { - s_return(sc, x); - } - - /* cdr() in the while condition is not a typo. If car() */ - /* is used (append '() 'a) will return the wrong result.*/ - while (cdr(y) != sc->NIL) { - x = revappend(sc, x, car(y)); - y = cdr(y); - if (x == sc->F) { - Error_0(sc, "non-list argument to append"); - } - } - - s_return(sc, reverse_in_place(sc, car(y), x)); - -#if USE_PLIST - CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */ - gc_disable(sc, gc_reservations(set_property)); - s_return_enable_gc(sc, - set_property(sc, car(sc->args), - cadr(sc->args), caddr(sc->args))); - - CASE(OP_SYMBOL_PROPERTY): /* symbol-property */ - s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); -#endif /* USE_PLIST */ - - CASE(OP_TAG_VALUE): { /* not exposed */ - /* This tags sc->value with car(sc->args). Useful to tag - * results of opcode evaluations. */ - pointer a, b, c; - free_cons(sc, sc->args, &a, &b); - free_cons(sc, b, &b, &c); - assert(c == sc->NIL); - s_return(sc, mk_tagged_value(sc, sc->value, a, b)); - } - - CASE(OP_MK_TAGGED): /* make-tagged-value */ - if (is_vector(car(sc->args))) - Error_0(sc, "cannot tag vector"); - s_return(sc, mk_tagged_value(sc, car(sc->args), - car(cadr(sc->args)), - cdr(cadr(sc->args)))); - - CASE(OP_GET_TAG): /* get-tag */ - s_return(sc, get_tag(sc, car(sc->args))); - - CASE(OP_QUIT): /* quit */ - if(is_pair(sc->args)) { - sc->retcode=ivalue(car(sc->args)); - } - return; - - CASE(OP_GC): /* gc */ - gc(sc, sc->NIL, sc->NIL); - s_return(sc,sc->T); - - CASE(OP_GCVERB): /* gc-verbose */ - { int was = sc->gc_verbose; - - sc->gc_verbose = (car(sc->args) != sc->F); - s_retbool(was); - } - - CASE(OP_NEWSEGMENT): /* new-segment */ - if (!is_pair(sc->args) || !is_number(car(sc->args))) { - Error_0(sc,"new-segment: argument must be a number"); - } - alloc_cellseg(sc, (int) ivalue(car(sc->args))); - s_return(sc,sc->T); - - CASE(OP_OBLIST): /* oblist */ - s_return(sc, oblist_all_symbols(sc)); - - CASE(OP_CURR_INPORT): /* current-input-port */ - s_return(sc,sc->inport); - - CASE(OP_CURR_OUTPORT): /* current-output-port */ - s_return(sc,sc->outport); - - CASE(OP_OPEN_INFILE): /* open-input-file */ - /* Fallthrough. */ - CASE(OP_OPEN_OUTFILE): /* open-output-file */ - /* Fallthrough. */ - CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ { - int prop=0; - pointer p; - switch(op) { - case OP_OPEN_INFILE: prop=port_input; break; - case OP_OPEN_OUTFILE: prop=port_output; break; - case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; - default: assert (! "reached"); - } - p=port_from_filename(sc,strvalue(car(sc->args)),prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - break; - } - -#if USE_STRING_PORTS - CASE(OP_OPEN_INSTRING): /* open-input-string */ - /* Fallthrough. */ - CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ { - int prop=0; - pointer p; - switch(op) { - case OP_OPEN_INSTRING: prop=port_input; break; - case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; - default: assert (! "reached"); - } - p=port_from_string(sc, strvalue(car(sc->args)), - strvalue(car(sc->args))+strlength(car(sc->args)), prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - } - CASE(OP_OPEN_OUTSTRING): /* open-output-string */ { - pointer p; - if(car(sc->args)==sc->NIL) { - p=port_from_scratch(sc); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - } else { - p=port_from_string(sc, strvalue(car(sc->args)), - strvalue(car(sc->args))+strlength(car(sc->args)), - port_output); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - } - s_return(sc,p); - } - CASE(OP_GET_OUTSTRING): /* get-output-string */ { - port *p; - - if ((p=car(sc->args)->_object._port)->kind&port_string) { - gc_disable(sc, 1); - s_return_enable_gc( - sc, - mk_counted_string(sc, - p->rep.string.start, - p->rep.string.curr - p->rep.string.start)); - } - s_return(sc,sc->F); - } -#endif - - CASE(OP_CLOSE_INPORT): /* close-input-port */ - port_close(sc,car(sc->args),port_input); - s_return(sc,sc->T); - - CASE(OP_CLOSE_OUTPORT): /* close-output-port */ - port_close(sc,car(sc->args),port_output); - s_return(sc,sc->T); - - CASE(OP_INT_ENV): /* interaction-environment */ - s_return(sc,sc->global_env); - - CASE(OP_CURR_ENV): /* current-environment */ - s_return(sc,sc->envir); - - - /* ========== reading part ========== */ - CASE(OP_READ): - if(!is_pair(sc->args)) { - s_thread_to(sc,OP_READ_INTERNAL); - } - if(!is_inport(car(sc->args))) { - Error_1(sc, "read: not an input port", car(sc->args)); - } - if(car(sc->args)==sc->inport) { - s_thread_to(sc,OP_READ_INTERNAL); - } - x=sc->inport; - sc->inport=car(sc->args); - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - s_thread_to(sc,OP_READ_INTERNAL); - - CASE(OP_READ_CHAR): /* read-char */ - /* Fallthrough. */ - CASE(OP_PEEK_CHAR): /* peek-char */ { - int c; - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->inport) { - x=sc->inport; - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - sc->inport=car(sc->args); - } - } - c=inchar(sc); - if(c==EOF) { - s_return(sc,sc->EOF_OBJ); - } - if(op==OP_PEEK_CHAR) { - backchar(sc,c); - } - s_return(sc,mk_character(sc,c)); - } - - CASE(OP_CHAR_READY): /* char-ready? */ { - pointer p=sc->inport; - int res; - if(is_pair(sc->args)) { - p=car(sc->args); - } - res=p->_object._port->kind&port_string; - s_retbool(res); - } - - CASE(OP_SET_INPORT): /* set-input-port */ - sc->inport=car(sc->args); - s_return(sc,sc->value); - - CASE(OP_SET_OUTPORT): /* set-output-port */ - sc->outport=car(sc->args); - s_return(sc,sc->value); - - CASE(OP_RDSEXPR): - switch (sc->tok) { - case TOK_EOF: - s_return(sc,sc->EOF_OBJ); - /* NOTREACHED */ - case TOK_VEC: - s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); - /* fall through */ - case TOK_LPAREN: - sc->tok = token(sc); - if (sc->tok == TOK_RPAREN) { - s_return(sc,sc->NIL); - } else if (sc->tok == TOK_DOT) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { -#if SHOW_ERROR_LINE - pointer filename; - pointer lineno; -#endif - sc->nesting_stack[sc->file_i]++; -#if SHOW_ERROR_LINE - filename = sc->load_stack[sc->file_i].filename; - lineno = sc->load_stack[sc->file_i].curr_line; - - s_save(sc, OP_TAG_VALUE, - cons(sc, filename, cons(sc, lineno, sc->NIL)), - sc->NIL); -#endif - s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); - s_thread_to(sc,OP_RDSEXPR); - } - case TOK_QUOTE: - s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - case TOK_BQUOTE: - sc->tok = token(sc); - if(sc->tok==TOK_VEC) { - s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); - sc->tok=TOK_LPAREN; - s_thread_to(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); - } - s_thread_to(sc,OP_RDSEXPR); - case TOK_COMMA: - s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - case TOK_ATMARK: - s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - case TOK_ATOM: - s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); - case TOK_DQUOTE: - x=readstrexp(sc); - if(x==sc->F) { - Error_0(sc,"Error reading string"); - } - setimmutable(x); - s_return(sc,x); - case TOK_SHARP: { - pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); - if(f==sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - sc->code=cons(sc,slot_value_in_env(f),sc->NIL); - s_thread_to(sc,OP_EVAL); - } - } - case TOK_SHARP_CONST: - if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - s_return(sc,x); - } - default: - Error_0(sc,"syntax error: illegal token"); - } - break; - - CASE(OP_RDLIST): { - gc_disable(sc, 1); - sc->args = cons(sc, sc->value, sc->args); - gc_enable(sc); - sc->tok = token(sc); - if (sc->tok == TOK_EOF) - { s_return(sc,sc->EOF_OBJ); } - else if (sc->tok == TOK_RPAREN) { - int c = inchar(sc); - if (c != '\n') - backchar(sc,c); - else - port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); - } else if (sc->tok == TOK_DOT) { - s_save(sc,OP_RDDOT, sc->args, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDLIST, sc->args, sc->NIL);; - s_thread_to(sc,OP_RDSEXPR); - } - } - - CASE(OP_RDDOT): - if (token(sc) != TOK_RPAREN) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->value, sc->args)); - } - - CASE(OP_RDQUOTE): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->QUOTE, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDQQUOTE): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->QQUOTE, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDQQUOTEVEC): - gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol)); - s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"), - cons(sc, mk_symbol(sc,"vector"), - cons(sc,cons(sc, sc->QQUOTE, - cons(sc,sc->value,sc->NIL)), - sc->NIL)))); - - CASE(OP_RDUNQUOTE): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->UNQUOTE, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDUQTSP): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDVEC): - /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_thread_to(sc,OP_EVAL); Cannot be quoted*/ - /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_return(sc,x); Cannot be part of pairs*/ - /*sc->code=mk_proc(sc,OP_VECTOR); - sc->args=sc->value; - s_thread_to(sc,OP_APPLY);*/ - sc->args=sc->value; - s_thread_to(sc,OP_VECTOR); - - /* ========== printing part ========== */ - CASE(OP_P0LIST): - if(is_vector(sc->args)) { - putstr(sc,"#("); - sc->args=cons(sc,sc->args,mk_integer(sc,0)); - s_thread_to(sc,OP_PVECFROM); - } else if(is_environment(sc->args)) { - putstr(sc,"#"); - s_return(sc,sc->T); - } else if (!is_pair(sc->args)) { - printatom(sc, sc->args, sc->print_flag); - s_return(sc,sc->T); - } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "'"); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "`"); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, ","); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { - putstr(sc, ",@"); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else { - putstr(sc, "("); - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - s_thread_to(sc,OP_P0LIST); - } - - CASE(OP_P1LIST): - if (is_pair(sc->args)) { - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - putstr(sc, " "); - sc->args = car(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if(is_vector(sc->args)) { - s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); - putstr(sc, " . "); - s_thread_to(sc,OP_P0LIST); - } else { - if (sc->args != sc->NIL) { - putstr(sc, " . "); - printatom(sc, sc->args, sc->print_flag); - } - putstr(sc, ")"); - s_return(sc,sc->T); - } - CASE(OP_PVECFROM): { - int i=ivalue_unchecked(cdr(sc->args)); - pointer vec=car(sc->args); - int len = vector_length(vec); - if(i==len) { - putstr(sc,")"); - s_return(sc,sc->T); - } else { - pointer elem=vector_elem(vec,i); - cdr(sc->args) = mk_integer(sc, i + 1); - s_save(sc,OP_PVECFROM, sc->args, sc->NIL); - sc->args=elem; - if (i > 0) - putstr(sc," "); - s_thread_to(sc,OP_P0LIST); - } - } - - CASE(OP_LIST_LENGTH): { /* length */ /* a.k */ - long l = list_length(sc, car(sc->args)); - if(l<0) { - Error_1(sc, "length: not a list", car(sc->args)); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, l)); - } - CASE(OP_ASSQ): /* assq */ /* a.k */ - x = car(sc->args); - for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { - if (!is_pair(car(y))) { - Error_0(sc,"unable to handle non pair element"); - } - if (x == caar(y)) - break; - } - if (is_pair(y)) { - s_return(sc,car(y)); - } else { - s_return(sc,sc->F); - } - - - CASE(OP_GET_CLOSURE): /* get-closure-code */ /* a.k */ - sc->args = car(sc->args); - if (sc->args == sc->NIL) { - s_return(sc,sc->F); - } else if (is_closure(sc->args)) { - gc_disable(sc, 1); - s_return_enable_gc(sc, cons(sc, sc->LAMBDA, - closure_code(sc->value))); - } else if (is_macro(sc->args)) { - gc_disable(sc, 1); - s_return_enable_gc(sc, cons(sc, sc->LAMBDA, - closure_code(sc->value))); - } else { - s_return(sc,sc->F); - } - CASE(OP_CLOSUREP): /* closure? */ - /* - * Note, macro object is also a closure. - * Therefore, (closure? <#MACRO>) ==> #t - */ - s_retbool(is_closure(car(sc->args))); - CASE(OP_MACROP): /* macro? */ - s_retbool(is_macro(car(sc->args))); - CASE(OP_VM_HISTORY): /* *vm-history* */ - s_return(sc, history_flatten(sc)); - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op); - Error_0(sc,sc->strbuff); - } - } -} - -typedef int (*test_predicate)(pointer); - -static int is_any(pointer p) { - (void)p; - return 1; -} - -static int is_nonneg(pointer p) { - return ivalue(p)>=0 && is_integer(p); -} - -/* Correspond carefully with following defines! */ -static const struct { - test_predicate fct; - const char *kind; -} tests[]={ - {0,0}, /* unused */ - {is_any, 0}, - {is_string, "string"}, - {is_symbol, "symbol"}, - {is_port, "port"}, - {is_inport,"input port"}, - {is_outport,"output port"}, - {is_environment, "environment"}, - {is_pair, "pair"}, - {0, "pair or '()"}, - {is_character, "character"}, - {is_vector, "vector"}, - {is_number, "number"}, - {is_integer, "integer"}, - {is_nonneg, "non-negative integer"} -}; - -#define TST_NONE 0 -#define TST_ANY "\001" -#define TST_STRING "\002" -#define TST_SYMBOL "\003" -#define TST_PORT "\004" -#define TST_INPORT "\005" -#define TST_OUTPORT "\006" -#define TST_ENVIRONMENT "\007" -#define TST_PAIR "\010" -#define TST_LIST "\011" -#define TST_CHAR "\012" -#define TST_VECTOR "\013" -#define TST_NUMBER "\014" -#define TST_INTEGER "\015" -#define TST_NATURAL "\016" - -#define INF_ARG 0xff - -static const struct op_code_info dispatch_table[]= { -#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}}, -#include "opdefines.h" -#undef _OP_DEF - {{0},0,0,{0}}, -}; - -static const char *procname(pointer x) { - int n=procnum(x); - const char *name=dispatch_table[n].name; - if (name[0] == 0) { - name="ILLEGAL!"; - } - return name; -} - -static int -check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size) -{ - int ok = 1; - int n = list_length(sc, sc->args); - - /* Check number of arguments */ - if (n < pcd->min_arity) { - ok = 0; - snprintf(msg, msg_size, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity == pcd->max_arity ? "" : " at least", - pcd->min_arity); - } - if (ok && n>pcd->max_arity) { - ok = 0; - snprintf(msg, msg_size, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity == pcd->max_arity ? "" : " at most", - pcd->max_arity); - } - if (ok) { - if (pcd->arg_tests_encoding[0] != 0) { - int i = 0; - int j; - const char *t = pcd->arg_tests_encoding; - pointer arglist = sc->args; - - do { - pointer arg = car(arglist); - j = (int)t[0]; - if (j == TST_LIST[0]) { - if (arg != sc->NIL && !is_pair(arg)) break; - } else { - if (!tests[j].fct(arg)) break; - } - - if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { - /* last test is replicated as necessary */ - t++; - } - arglist = cdr(arglist); - i++; - } while (i < n); - - if (i < n) { - ok = 0; - snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s", - pcd->name, - i + 1, - tests[j].kind, - type_to_string(type(car(arglist)))); - } - } - } - - return ok; -} - -/* ========== Initialization of internal keywords ========== */ - -/* Symbols representing syntax are tagged with (OP . '()). */ -static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) { - pointer x, y; - pointer *slot; - - x = oblist_find_by_name(sc, name, &slot); - assert (x == sc->NIL); - - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL | T_SYNTAX; - setimmutable(car(x)); - y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL); - free_cell(sc, x); - setimmutable(get_tag(sc, y)); - *slot = immutable_cons(sc, y, *slot); -} - -/* Returns the opcode for the syntax represented by P. */ -static int syntaxnum(scheme *sc, pointer p) { - int op = ivalue_unchecked(car(get_tag(sc, p))); - assert (op < OP_MAXDEFINED); - return op; -} - -static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) { - pointer x, y; - - x = mk_symbol(sc, name); - y = mk_proc(sc,op); - new_slot_in_env(sc, x, y); -} - -static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { - pointer y; - - y = get_cell(sc, sc->NIL, sc->NIL); - typeflag(y) = (T_PROC | T_ATOM); - ivalue_unchecked(y) = (long) op; - set_num_integer(y); - return y; -} - -/* initialization of TinyScheme */ -#if USE_INTERFACE -INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { - return cons(sc,a,b); -} -INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { - return immutable_cons(sc,a,b); -} - -static const struct scheme_interface vtbl = { - scheme_define, - s_cons, - s_immutable_cons, - reserve_cells, - mk_integer, - mk_real, - mk_symbol, - gensym, - mk_string, - mk_counted_string, - mk_character, - mk_vector, - mk_foreign_func, - mk_foreign_object, - get_foreign_object_vtable, - get_foreign_object_data, - putstr, - putcharacter, - - is_string, - string_value, - is_number, - nvalue, - ivalue, - rvalue, - is_integer, - is_real, - is_character, - charvalue, - is_list, - is_vector, - list_length, - ivalue, - fill_vector, - vector_elem, - set_vector_elem, - is_port, - is_pair, - pair_car, - pair_cdr, - set_car, - set_cdr, - - is_symbol, - symname, - - is_syntax, - is_proc, - is_foreign, - syntaxname, - is_closure, - is_macro, - closure_code, - closure_env, - - is_continuation, - is_promise, - is_environment, - is_immutable, - setimmutable, - - scheme_load_file, - scheme_load_string, - port_from_file -}; -#endif - -scheme *scheme_init_new() { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init(sc)) { - free(sc); - return 0; - } else { - return sc; - } -} - -scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init_custom_alloc(sc,malloc,free)) { - free(sc); - return 0; - } else { - return sc; - } -} - - -int scheme_init(scheme *sc) { - return scheme_init_custom_alloc(sc,malloc,free); -} - -int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { - int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); - pointer x; - -#if USE_INTERFACE - sc->vptr=&vtbl; -#endif - sc->gensym_cnt=0; - sc->malloc=malloc; - sc->free=free; - sc->sink = &sc->_sink; - sc->NIL = &sc->_NIL; - sc->T = &sc->_HASHT; - sc->F = &sc->_HASHF; - sc->EOF_OBJ=&sc->_EOF_OBJ; - - sc->free_cell = &sc->_NIL; - sc->fcells = 0; - sc->inhibit_gc = GC_ENABLED; - sc->reserved_cells = 0; - sc->reserved_lineno = 0; - sc->no_memory=0; - sc->inport=sc->NIL; - sc->outport=sc->NIL; - sc->save_inport=sc->NIL; - sc->loadport=sc->NIL; - sc->nesting=0; - memset (sc->nesting_stack, 0, sizeof sc->nesting_stack); - sc->interactive_repl=0; - sc->strbuff = sc->malloc(STRBUFFSIZE); - if (sc->strbuff == 0) { - sc->no_memory=1; - return 0; - } - sc->strbuff_size = STRBUFFSIZE; - - sc->cell_segments = NULL; - if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { - sc->no_memory=1; - return 0; - } - sc->gc_verbose = 0; - dump_stack_initialize(sc); - sc->code = sc->NIL; - sc->tracing=0; - sc->flags = 0; - - /* init sc->NIL */ - typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK); - car(sc->NIL) = cdr(sc->NIL) = sc->NIL; - /* init T */ - typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK); - car(sc->T) = cdr(sc->T) = sc->T; - /* init F */ - typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK); - car(sc->F) = cdr(sc->F) = sc->F; - /* init EOF_OBJ */ - typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK); - car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; - /* init sink */ - typeflag(sc->sink) = (T_SINK | T_PAIR | MARK); - car(sc->sink) = cdr(sc->sink) = sc->NIL; - /* init c_nest */ - sc->c_nest = sc->NIL; - - sc->oblist = oblist_initial_value(sc); - /* init global_env */ - new_frame_in_env(sc, sc->NIL); - sc->global_env = sc->envir; - /* init else */ - x = mk_symbol(sc,"else"); - new_slot_in_env(sc, x, sc->T); - - assign_syntax(sc, OP_LAMBDA, "lambda"); - assign_syntax(sc, OP_QUOTE, "quote"); - assign_syntax(sc, OP_DEF0, "define"); - assign_syntax(sc, OP_IF0, "if"); - assign_syntax(sc, OP_BEGIN, "begin"); - assign_syntax(sc, OP_SET0, "set!"); - assign_syntax(sc, OP_LET0, "let"); - assign_syntax(sc, OP_LET0AST, "let*"); - assign_syntax(sc, OP_LET0REC, "letrec"); - assign_syntax(sc, OP_COND0, "cond"); - assign_syntax(sc, OP_DELAY, "delay"); - assign_syntax(sc, OP_AND0, "and"); - assign_syntax(sc, OP_OR0, "or"); - assign_syntax(sc, OP_C0STREAM, "cons-stream"); - assign_syntax(sc, OP_MACRO0, "macro"); - assign_syntax(sc, OP_CASE0, "case"); - - for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); - sc->QUOTE = mk_symbol(sc, "quote"); - sc->QQUOTE = mk_symbol(sc, "quasiquote"); - sc->UNQUOTE = mk_symbol(sc, "unquote"); - sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); - sc->FEED_TO = mk_symbol(sc, "=>"); - sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); - sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); - sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); -#if USE_COMPILE_HOOK - sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); -#endif - - return !sc->no_memory; -} - -void scheme_set_input_port_file(scheme *sc, FILE *fin) { - sc->inport=port_from_file(sc,fin,port_input); -} - -void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { - sc->inport=port_from_string(sc,start,past_the_end,port_input); -} - -void scheme_set_output_port_file(scheme *sc, FILE *fout) { - sc->outport=port_from_file(sc,fout,port_output); -} - -void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { - sc->outport=port_from_string(sc,start,past_the_end,port_output); -} - -void scheme_set_external_data(scheme *sc, void *p) { - sc->ext_data=p; -} - -void scheme_deinit(scheme *sc) { - struct cell_segment *s; - int i; - - sc->oblist=sc->NIL; - sc->global_env=sc->NIL; - dump_stack_free(sc); - sc->envir=sc->NIL; - sc->code=sc->NIL; - history_free(sc); - sc->args=sc->NIL; - sc->value=sc->NIL; - if(is_port(sc->inport)) { - typeflag(sc->inport) = T_ATOM; - } - sc->inport=sc->NIL; - sc->outport=sc->NIL; - if(is_port(sc->save_inport)) { - typeflag(sc->save_inport) = T_ATOM; - } - sc->save_inport=sc->NIL; - if(is_port(sc->loadport)) { - typeflag(sc->loadport) = T_ATOM; - } - sc->loadport=sc->NIL; - - for(i=0; i<=sc->file_i; i++) { - port_clear_location(sc, &sc->load_stack[i]); - } - - sc->gc_verbose=0; - gc(sc,sc->NIL,sc->NIL); - - for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) { - /* nop */ - } - sc->free(sc->strbuff); -} - -void scheme_load_file(scheme *sc, FILE *fin) -{ scheme_load_named_file(sc,fin,0); } - -void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_file; - sc->load_stack[0].rep.stdio.file=fin; - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - if(fin==stdin) { - sc->interactive_repl=1; - } - - port_init_location(sc, &sc->load_stack[0], - (fin != stdin && filename) - ? mk_string(sc, filename) - : NULL); - - sc->inport=sc->loadport; - sc->args = mk_integer(sc,sc->file_i); - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } - - port_clear_location(sc, &sc->load_stack[0]); -} - -void scheme_load_string(scheme *sc, const char *cmd) { - scheme_load_memory(sc, cmd, strlen(cmd), NULL); -} - -void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_string; - sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */ - sc->load_stack[0].rep.string.past_the_end = (char *) buf + len; - sc->load_stack[0].rep.string.curr = (char *) buf; - port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL); - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - sc->interactive_repl=0; - sc->inport=sc->loadport; - sc->args = mk_integer(sc,sc->file_i); - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } - - port_clear_location(sc, &sc->load_stack[0]); -} - -void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { - pointer x; - pointer *sslot; - x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot); - if (x != sc->NIL) { - set_slot_in_env(sc, x, value); - } else { - new_slot_spec_in_env(sc, symbol, value, sslot); - } -} - -#if !STANDALONE -void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) -{ - scheme_define(sc, - sc->global_env, - mk_symbol(sc,sr->name), - mk_foreign_func(sc, sr->f)); -} - -void scheme_register_foreign_func_list(scheme * sc, - scheme_registerable * list, - int count) -{ - int i; - for(i = 0; i < count; i++) - { - scheme_register_foreign_func(sc, list + i); - } -} - -pointer scheme_apply0(scheme *sc, const char *procname) -{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } - -void save_from_C_call(scheme *sc) -{ - pointer saved_data = - cons(sc, - car(sc->sink), - cons(sc, - sc->envir, - sc->dump)); - /* Push */ - sc->c_nest = cons(sc, saved_data, sc->c_nest); - /* Truncate the dump stack so TS will return here when done, not - directly resume pre-C-call operations. */ - dump_stack_reset(sc); -} -void restore_from_C_call(scheme *sc) -{ - car(sc->sink) = caar(sc->c_nest); - sc->envir = cadar(sc->c_nest); - sc->dump = cdr(cdar(sc->c_nest)); - /* Pop */ - sc->c_nest = cdr(sc->c_nest); -} - -/* "func" and "args" are assumed to be already eval'ed. */ -pointer scheme_call(scheme *sc, pointer func, pointer args) -{ - int old_repl = sc->interactive_repl; - sc->interactive_repl = 0; - save_from_C_call(sc); - sc->envir = sc->global_env; - sc->args = args; - sc->code = func; - sc->retcode = 0; - Eval_Cycle(sc, OP_APPLY); - sc->interactive_repl = old_repl; - restore_from_C_call(sc); - return sc->value; -} - -pointer scheme_eval(scheme *sc, pointer obj) -{ - int old_repl = sc->interactive_repl; - sc->interactive_repl = 0; - save_from_C_call(sc); - sc->args = sc->NIL; - sc->code = obj; - sc->retcode = 0; - Eval_Cycle(sc, OP_EVAL); - sc->interactive_repl = old_repl; - restore_from_C_call(sc); - return sc->value; -} - - -#endif - -/* ========== Main ========== */ - -#if STANDALONE - -#if defined(__APPLE__) && !defined (OSX) -int main() -{ - extern MacTS_main(int argc, char **argv); - char** argv; - int argc = ccommand(&argv); - MacTS_main(argc,argv); - return 0; -} -int MacTS_main(int argc, char **argv) { -#else -int main(int argc, char **argv) { -#endif - scheme sc; - FILE *fin; - char *file_name=InitFile; - int retcode; - int isfile=1; - - if(argc==1) { - printf(banner); - } - if(argc==2 && strcmp(argv[1],"-?")==0) { - printf("Usage: tinyscheme -?\n"); - printf("or: tinyscheme [ ...]\n"); - printf("followed by\n"); - printf(" -1 [ ...]\n"); - printf(" -c [ ...]\n"); - printf("assuming that the executable is named tinyscheme.\n"); - printf("Use - as filename for stdin.\n"); - return 1; - } - if(!scheme_init(&sc)) { - fprintf(stderr,"Could not initialize!\n"); - return 2; - } - scheme_set_input_port_file(&sc, stdin); - scheme_set_output_port_file(&sc, stdout); -#if USE_DL - scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); -#endif - argv++; - if(access(file_name,0)!=0) { - char *p=getenv("TINYSCHEMEINIT"); - if(p!=0) { - file_name=p; - } - } - do { - if(strcmp(file_name,"-")==0) { - fin=stdin; - } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { - pointer args=sc.NIL; - isfile=file_name[1]=='1'; - file_name=*argv++; - if(strcmp(file_name,"-")==0) { - fin=stdin; - } else if(isfile) { - fin=fopen(file_name,"r"); - } - for(;*argv;argv++) { - pointer value=mk_string(&sc,*argv); - args=cons(&sc,value,args); - } - args=reverse_in_place(&sc,sc.NIL,args); - scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); - - } else { - fin=fopen(file_name,"r"); - } - if(isfile && fin==0) { - fprintf(stderr,"Could not open file %s\n",file_name); - } else { - if(isfile) { - scheme_load_named_file(&sc,fin,file_name); - } else { - scheme_load_string(&sc,file_name); - } - if(!isfile || fin!=stdin) { - if(sc.retcode!=0) { - fprintf(stderr,"Errors encountered reading %s\n",file_name); - } - if(isfile) { - fclose(fin); - } - } - } - file_name=*argv++; - } while(file_name!=0); - if(argc==1) { - scheme_load_named_file(&sc,stdin,0); - } - retcode=sc.retcode; - scheme_deinit(&sc); - - return retcode; -} - -#endif - -/* -Local variables: -c-file-style: "k&r" -End: -*/ diff --git a/scheme.h b/scheme.h deleted file mode 100644 index 6f917da..0000000 --- a/scheme.h +++ /dev/null @@ -1,290 +0,0 @@ -/* SCHEME.H */ - -#ifndef _SCHEME_H -#define _SCHEME_H - -#include - -#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_COMPILE_HOOK 0 -# define USE_DL 0 -# define USE_PLIST 0 -# define USE_SMALL_INTEGERS 0 -# define USE_HISTORY 0 -#endif - - -#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 - -/* Keep a history of function calls. This enables a feature similar - * to stack traces. */ -#ifndef USE_HISTORY -# define USE_HISTORY 1 -#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 - -/* Compile functions using *compile-hook*. The default hook expands - * macros. */ -#ifndef USE_COMPILE_HOOK -# define USE_COMPILE_HOOK 1 -#endif - -/* Enable faster opcode dispatch. */ -#ifndef USE_THREADED_CODE -# define USE_THREADED_CODE 1 -#endif - -/* Use a static set of cells to represent small numbers. This set - * notably includes all opcodes, and hence saves a cell reservation - * during 's_save'. */ -#ifndef USE_SMALL_INTEGERS -# define USE_SMALL_INTEGERS 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 *); - -/* table of functions required for foreign objects */ -typedef struct foreign_object_vtable { - void (*finalize)(scheme *sc, void *data); - void (*to_string)(scheme *sc, char *out, size_t size, void *data); -} foreign_object_vtable; - -/* 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 void scheme_load_memory(scheme *sc, const char *buf, size_t len, - const char *filename); -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); -pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data); -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); - pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data); - const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p); - void *(*get_foreign_object_data)(pointer p); - 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); - pointer (*mk_port_from_file)(scheme *sc, FILE *f, int kind); -}; -#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: -*/ diff --git a/small-integers.h b/small-integers.h deleted file mode 100644 index 46eda34..0000000 --- a/small-integers.h +++ /dev/null @@ -1,847 +0,0 @@ -/* Constant integer objects for TinySCHEME. - * - * Copyright (C) 2017 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -/* - * Ohne Worte. Generated using: - * - * $ n=0; while read line ; do \ - * echo "DEFINE_INTEGER($n)" ; \ - * n="$(expr $n + 1)" ; \ - * done <./init.scm >> small-integers.h - */ - -DEFINE_INTEGER(0) -DEFINE_INTEGER(1) -DEFINE_INTEGER(2) -DEFINE_INTEGER(3) -DEFINE_INTEGER(4) -DEFINE_INTEGER(5) -DEFINE_INTEGER(6) -DEFINE_INTEGER(7) -DEFINE_INTEGER(8) -DEFINE_INTEGER(9) -DEFINE_INTEGER(10) -DEFINE_INTEGER(11) -DEFINE_INTEGER(12) -DEFINE_INTEGER(13) -DEFINE_INTEGER(14) -DEFINE_INTEGER(15) -DEFINE_INTEGER(16) -DEFINE_INTEGER(17) -DEFINE_INTEGER(18) -DEFINE_INTEGER(19) -DEFINE_INTEGER(20) -DEFINE_INTEGER(21) -DEFINE_INTEGER(22) -DEFINE_INTEGER(23) -DEFINE_INTEGER(24) -DEFINE_INTEGER(25) -DEFINE_INTEGER(26) -DEFINE_INTEGER(27) -DEFINE_INTEGER(28) -DEFINE_INTEGER(29) -DEFINE_INTEGER(30) -DEFINE_INTEGER(31) -DEFINE_INTEGER(32) -DEFINE_INTEGER(33) -DEFINE_INTEGER(34) -DEFINE_INTEGER(35) -DEFINE_INTEGER(36) -DEFINE_INTEGER(37) -DEFINE_INTEGER(38) -DEFINE_INTEGER(39) -DEFINE_INTEGER(40) -DEFINE_INTEGER(41) -DEFINE_INTEGER(42) -DEFINE_INTEGER(43) -DEFINE_INTEGER(44) -DEFINE_INTEGER(45) -DEFINE_INTEGER(46) -DEFINE_INTEGER(47) -DEFINE_INTEGER(48) -DEFINE_INTEGER(49) -DEFINE_INTEGER(50) -DEFINE_INTEGER(51) -DEFINE_INTEGER(52) -DEFINE_INTEGER(53) -DEFINE_INTEGER(54) -DEFINE_INTEGER(55) -DEFINE_INTEGER(56) -DEFINE_INTEGER(57) -DEFINE_INTEGER(58) -DEFINE_INTEGER(59) -DEFINE_INTEGER(60) -DEFINE_INTEGER(61) -DEFINE_INTEGER(62) -DEFINE_INTEGER(63) -DEFINE_INTEGER(64) -DEFINE_INTEGER(65) -DEFINE_INTEGER(66) -DEFINE_INTEGER(67) -DEFINE_INTEGER(68) -DEFINE_INTEGER(69) -DEFINE_INTEGER(70) -DEFINE_INTEGER(71) -DEFINE_INTEGER(72) -DEFINE_INTEGER(73) -DEFINE_INTEGER(74) -DEFINE_INTEGER(75) -DEFINE_INTEGER(76) -DEFINE_INTEGER(77) -DEFINE_INTEGER(78) -DEFINE_INTEGER(79) -DEFINE_INTEGER(80) -DEFINE_INTEGER(81) -DEFINE_INTEGER(82) -DEFINE_INTEGER(83) -DEFINE_INTEGER(84) -DEFINE_INTEGER(85) -DEFINE_INTEGER(86) -DEFINE_INTEGER(87) -DEFINE_INTEGER(88) -DEFINE_INTEGER(89) -DEFINE_INTEGER(90) -DEFINE_INTEGER(91) -DEFINE_INTEGER(92) -DEFINE_INTEGER(93) -DEFINE_INTEGER(94) -DEFINE_INTEGER(95) -DEFINE_INTEGER(96) -DEFINE_INTEGER(97) -DEFINE_INTEGER(98) -DEFINE_INTEGER(99) -DEFINE_INTEGER(100) -DEFINE_INTEGER(101) -DEFINE_INTEGER(102) -DEFINE_INTEGER(103) -DEFINE_INTEGER(104) -DEFINE_INTEGER(105) -DEFINE_INTEGER(106) -DEFINE_INTEGER(107) -DEFINE_INTEGER(108) -DEFINE_INTEGER(109) -DEFINE_INTEGER(110) -DEFINE_INTEGER(111) -DEFINE_INTEGER(112) -DEFINE_INTEGER(113) -DEFINE_INTEGER(114) -DEFINE_INTEGER(115) -DEFINE_INTEGER(116) -DEFINE_INTEGER(117) -DEFINE_INTEGER(118) -DEFINE_INTEGER(119) -DEFINE_INTEGER(120) -DEFINE_INTEGER(121) -DEFINE_INTEGER(122) -DEFINE_INTEGER(123) -DEFINE_INTEGER(124) -DEFINE_INTEGER(125) -DEFINE_INTEGER(126) -DEFINE_INTEGER(127) -DEFINE_INTEGER(128) -DEFINE_INTEGER(129) -DEFINE_INTEGER(130) -DEFINE_INTEGER(131) -DEFINE_INTEGER(132) -DEFINE_INTEGER(133) -DEFINE_INTEGER(134) -DEFINE_INTEGER(135) -DEFINE_INTEGER(136) -DEFINE_INTEGER(137) -DEFINE_INTEGER(138) -DEFINE_INTEGER(139) -DEFINE_INTEGER(140) -DEFINE_INTEGER(141) -DEFINE_INTEGER(142) -DEFINE_INTEGER(143) -DEFINE_INTEGER(144) -DEFINE_INTEGER(145) -DEFINE_INTEGER(146) -DEFINE_INTEGER(147) -DEFINE_INTEGER(148) -DEFINE_INTEGER(149) -DEFINE_INTEGER(150) -DEFINE_INTEGER(151) -DEFINE_INTEGER(152) -DEFINE_INTEGER(153) -DEFINE_INTEGER(154) -DEFINE_INTEGER(155) -DEFINE_INTEGER(156) -DEFINE_INTEGER(157) -DEFINE_INTEGER(158) -DEFINE_INTEGER(159) -DEFINE_INTEGER(160) -DEFINE_INTEGER(161) -DEFINE_INTEGER(162) -DEFINE_INTEGER(163) -DEFINE_INTEGER(164) -DEFINE_INTEGER(165) -DEFINE_INTEGER(166) -DEFINE_INTEGER(167) -DEFINE_INTEGER(168) -DEFINE_INTEGER(169) -DEFINE_INTEGER(170) -DEFINE_INTEGER(171) -DEFINE_INTEGER(172) -DEFINE_INTEGER(173) -DEFINE_INTEGER(174) -DEFINE_INTEGER(175) -DEFINE_INTEGER(176) -DEFINE_INTEGER(177) -DEFINE_INTEGER(178) -DEFINE_INTEGER(179) -DEFINE_INTEGER(180) -DEFINE_INTEGER(181) -DEFINE_INTEGER(182) -DEFINE_INTEGER(183) -DEFINE_INTEGER(184) -DEFINE_INTEGER(185) -DEFINE_INTEGER(186) -DEFINE_INTEGER(187) -DEFINE_INTEGER(188) -DEFINE_INTEGER(189) -DEFINE_INTEGER(190) -DEFINE_INTEGER(191) -DEFINE_INTEGER(192) -DEFINE_INTEGER(193) -DEFINE_INTEGER(194) -DEFINE_INTEGER(195) -DEFINE_INTEGER(196) -DEFINE_INTEGER(197) -DEFINE_INTEGER(198) -DEFINE_INTEGER(199) -DEFINE_INTEGER(200) -DEFINE_INTEGER(201) -DEFINE_INTEGER(202) -DEFINE_INTEGER(203) -DEFINE_INTEGER(204) -DEFINE_INTEGER(205) -DEFINE_INTEGER(206) -DEFINE_INTEGER(207) -DEFINE_INTEGER(208) -DEFINE_INTEGER(209) -DEFINE_INTEGER(210) -DEFINE_INTEGER(211) -DEFINE_INTEGER(212) -DEFINE_INTEGER(213) -DEFINE_INTEGER(214) -DEFINE_INTEGER(215) -DEFINE_INTEGER(216) -DEFINE_INTEGER(217) -DEFINE_INTEGER(218) -DEFINE_INTEGER(219) -DEFINE_INTEGER(220) -DEFINE_INTEGER(221) -DEFINE_INTEGER(222) -DEFINE_INTEGER(223) -DEFINE_INTEGER(224) -DEFINE_INTEGER(225) -DEFINE_INTEGER(226) -DEFINE_INTEGER(227) -DEFINE_INTEGER(228) -DEFINE_INTEGER(229) -DEFINE_INTEGER(230) -DEFINE_INTEGER(231) -DEFINE_INTEGER(232) -DEFINE_INTEGER(233) -DEFINE_INTEGER(234) -DEFINE_INTEGER(235) -DEFINE_INTEGER(236) -DEFINE_INTEGER(237) -DEFINE_INTEGER(238) -DEFINE_INTEGER(239) -DEFINE_INTEGER(240) -DEFINE_INTEGER(241) -DEFINE_INTEGER(242) -DEFINE_INTEGER(243) -DEFINE_INTEGER(244) -DEFINE_INTEGER(245) -DEFINE_INTEGER(246) -DEFINE_INTEGER(247) -DEFINE_INTEGER(248) -DEFINE_INTEGER(249) -DEFINE_INTEGER(250) -DEFINE_INTEGER(251) -DEFINE_INTEGER(252) -DEFINE_INTEGER(253) -DEFINE_INTEGER(254) -DEFINE_INTEGER(255) -DEFINE_INTEGER(256) -DEFINE_INTEGER(257) -DEFINE_INTEGER(258) -DEFINE_INTEGER(259) -DEFINE_INTEGER(260) -DEFINE_INTEGER(261) -DEFINE_INTEGER(262) -DEFINE_INTEGER(263) -DEFINE_INTEGER(264) -DEFINE_INTEGER(265) -DEFINE_INTEGER(266) -DEFINE_INTEGER(267) -DEFINE_INTEGER(268) -DEFINE_INTEGER(269) -DEFINE_INTEGER(270) -DEFINE_INTEGER(271) -DEFINE_INTEGER(272) -DEFINE_INTEGER(273) -DEFINE_INTEGER(274) -DEFINE_INTEGER(275) -DEFINE_INTEGER(276) -DEFINE_INTEGER(277) -DEFINE_INTEGER(278) -DEFINE_INTEGER(279) -DEFINE_INTEGER(280) -DEFINE_INTEGER(281) -DEFINE_INTEGER(282) -DEFINE_INTEGER(283) -DEFINE_INTEGER(284) -DEFINE_INTEGER(285) -DEFINE_INTEGER(286) -DEFINE_INTEGER(287) -DEFINE_INTEGER(288) -DEFINE_INTEGER(289) -DEFINE_INTEGER(290) -DEFINE_INTEGER(291) -DEFINE_INTEGER(292) -DEFINE_INTEGER(293) -DEFINE_INTEGER(294) -DEFINE_INTEGER(295) -DEFINE_INTEGER(296) -DEFINE_INTEGER(297) -DEFINE_INTEGER(298) -DEFINE_INTEGER(299) -DEFINE_INTEGER(300) -DEFINE_INTEGER(301) -DEFINE_INTEGER(302) -DEFINE_INTEGER(303) -DEFINE_INTEGER(304) -DEFINE_INTEGER(305) -DEFINE_INTEGER(306) -DEFINE_INTEGER(307) -DEFINE_INTEGER(308) -DEFINE_INTEGER(309) -DEFINE_INTEGER(310) -DEFINE_INTEGER(311) -DEFINE_INTEGER(312) -DEFINE_INTEGER(313) -DEFINE_INTEGER(314) -DEFINE_INTEGER(315) -DEFINE_INTEGER(316) -DEFINE_INTEGER(317) -DEFINE_INTEGER(318) -DEFINE_INTEGER(319) -DEFINE_INTEGER(320) -DEFINE_INTEGER(321) -DEFINE_INTEGER(322) -DEFINE_INTEGER(323) -DEFINE_INTEGER(324) -DEFINE_INTEGER(325) -DEFINE_INTEGER(326) -DEFINE_INTEGER(327) -DEFINE_INTEGER(328) -DEFINE_INTEGER(329) -DEFINE_INTEGER(330) -DEFINE_INTEGER(331) -DEFINE_INTEGER(332) -DEFINE_INTEGER(333) -DEFINE_INTEGER(334) -DEFINE_INTEGER(335) -DEFINE_INTEGER(336) -DEFINE_INTEGER(337) -DEFINE_INTEGER(338) -DEFINE_INTEGER(339) -DEFINE_INTEGER(340) -DEFINE_INTEGER(341) -DEFINE_INTEGER(342) -DEFINE_INTEGER(343) -DEFINE_INTEGER(344) -DEFINE_INTEGER(345) -DEFINE_INTEGER(346) -DEFINE_INTEGER(347) -DEFINE_INTEGER(348) -DEFINE_INTEGER(349) -DEFINE_INTEGER(350) -DEFINE_INTEGER(351) -DEFINE_INTEGER(352) -DEFINE_INTEGER(353) -DEFINE_INTEGER(354) -DEFINE_INTEGER(355) -DEFINE_INTEGER(356) -DEFINE_INTEGER(357) -DEFINE_INTEGER(358) -DEFINE_INTEGER(359) -DEFINE_INTEGER(360) -DEFINE_INTEGER(361) -DEFINE_INTEGER(362) -DEFINE_INTEGER(363) -DEFINE_INTEGER(364) -DEFINE_INTEGER(365) -DEFINE_INTEGER(366) -DEFINE_INTEGER(367) -DEFINE_INTEGER(368) -DEFINE_INTEGER(369) -DEFINE_INTEGER(370) -DEFINE_INTEGER(371) -DEFINE_INTEGER(372) -DEFINE_INTEGER(373) -DEFINE_INTEGER(374) -DEFINE_INTEGER(375) -DEFINE_INTEGER(376) -DEFINE_INTEGER(377) -DEFINE_INTEGER(378) -DEFINE_INTEGER(379) -DEFINE_INTEGER(380) -DEFINE_INTEGER(381) -DEFINE_INTEGER(382) -DEFINE_INTEGER(383) -DEFINE_INTEGER(384) -DEFINE_INTEGER(385) -DEFINE_INTEGER(386) -DEFINE_INTEGER(387) -DEFINE_INTEGER(388) -DEFINE_INTEGER(389) -DEFINE_INTEGER(390) -DEFINE_INTEGER(391) -DEFINE_INTEGER(392) -DEFINE_INTEGER(393) -DEFINE_INTEGER(394) -DEFINE_INTEGER(395) -DEFINE_INTEGER(396) -DEFINE_INTEGER(397) -DEFINE_INTEGER(398) -DEFINE_INTEGER(399) -DEFINE_INTEGER(400) -DEFINE_INTEGER(401) -DEFINE_INTEGER(402) -DEFINE_INTEGER(403) -DEFINE_INTEGER(404) -DEFINE_INTEGER(405) -DEFINE_INTEGER(406) -DEFINE_INTEGER(407) -DEFINE_INTEGER(408) -DEFINE_INTEGER(409) -DEFINE_INTEGER(410) -DEFINE_INTEGER(411) -DEFINE_INTEGER(412) -DEFINE_INTEGER(413) -DEFINE_INTEGER(414) -DEFINE_INTEGER(415) -DEFINE_INTEGER(416) -DEFINE_INTEGER(417) -DEFINE_INTEGER(418) -DEFINE_INTEGER(419) -DEFINE_INTEGER(420) -DEFINE_INTEGER(421) -DEFINE_INTEGER(422) -DEFINE_INTEGER(423) -DEFINE_INTEGER(424) -DEFINE_INTEGER(425) -DEFINE_INTEGER(426) -DEFINE_INTEGER(427) -DEFINE_INTEGER(428) -DEFINE_INTEGER(429) -DEFINE_INTEGER(430) -DEFINE_INTEGER(431) -DEFINE_INTEGER(432) -DEFINE_INTEGER(433) -DEFINE_INTEGER(434) -DEFINE_INTEGER(435) -DEFINE_INTEGER(436) -DEFINE_INTEGER(437) -DEFINE_INTEGER(438) -DEFINE_INTEGER(439) -DEFINE_INTEGER(440) -DEFINE_INTEGER(441) -DEFINE_INTEGER(442) -DEFINE_INTEGER(443) -DEFINE_INTEGER(444) -DEFINE_INTEGER(445) -DEFINE_INTEGER(446) -DEFINE_INTEGER(447) -DEFINE_INTEGER(448) -DEFINE_INTEGER(449) -DEFINE_INTEGER(450) -DEFINE_INTEGER(451) -DEFINE_INTEGER(452) -DEFINE_INTEGER(453) -DEFINE_INTEGER(454) -DEFINE_INTEGER(455) -DEFINE_INTEGER(456) -DEFINE_INTEGER(457) -DEFINE_INTEGER(458) -DEFINE_INTEGER(459) -DEFINE_INTEGER(460) -DEFINE_INTEGER(461) -DEFINE_INTEGER(462) -DEFINE_INTEGER(463) -DEFINE_INTEGER(464) -DEFINE_INTEGER(465) -DEFINE_INTEGER(466) -DEFINE_INTEGER(467) -DEFINE_INTEGER(468) -DEFINE_INTEGER(469) -DEFINE_INTEGER(470) -DEFINE_INTEGER(471) -DEFINE_INTEGER(472) -DEFINE_INTEGER(473) -DEFINE_INTEGER(474) -DEFINE_INTEGER(475) -DEFINE_INTEGER(476) -DEFINE_INTEGER(477) -DEFINE_INTEGER(478) -DEFINE_INTEGER(479) -DEFINE_INTEGER(480) -DEFINE_INTEGER(481) -DEFINE_INTEGER(482) -DEFINE_INTEGER(483) -DEFINE_INTEGER(484) -DEFINE_INTEGER(485) -DEFINE_INTEGER(486) -DEFINE_INTEGER(487) -DEFINE_INTEGER(488) -DEFINE_INTEGER(489) -DEFINE_INTEGER(490) -DEFINE_INTEGER(491) -DEFINE_INTEGER(492) -DEFINE_INTEGER(493) -DEFINE_INTEGER(494) -DEFINE_INTEGER(495) -DEFINE_INTEGER(496) -DEFINE_INTEGER(497) -DEFINE_INTEGER(498) -DEFINE_INTEGER(499) -DEFINE_INTEGER(500) -DEFINE_INTEGER(501) -DEFINE_INTEGER(502) -DEFINE_INTEGER(503) -DEFINE_INTEGER(504) -DEFINE_INTEGER(505) -DEFINE_INTEGER(506) -DEFINE_INTEGER(507) -DEFINE_INTEGER(508) -DEFINE_INTEGER(509) -DEFINE_INTEGER(510) -DEFINE_INTEGER(511) -DEFINE_INTEGER(512) -DEFINE_INTEGER(513) -DEFINE_INTEGER(514) -DEFINE_INTEGER(515) -DEFINE_INTEGER(516) -DEFINE_INTEGER(517) -DEFINE_INTEGER(518) -DEFINE_INTEGER(519) -DEFINE_INTEGER(520) -DEFINE_INTEGER(521) -DEFINE_INTEGER(522) -DEFINE_INTEGER(523) -DEFINE_INTEGER(524) -DEFINE_INTEGER(525) -DEFINE_INTEGER(526) -DEFINE_INTEGER(527) -DEFINE_INTEGER(528) -DEFINE_INTEGER(529) -DEFINE_INTEGER(530) -DEFINE_INTEGER(531) -DEFINE_INTEGER(532) -DEFINE_INTEGER(533) -DEFINE_INTEGER(534) -DEFINE_INTEGER(535) -DEFINE_INTEGER(536) -DEFINE_INTEGER(537) -DEFINE_INTEGER(538) -DEFINE_INTEGER(539) -DEFINE_INTEGER(540) -DEFINE_INTEGER(541) -DEFINE_INTEGER(542) -DEFINE_INTEGER(543) -DEFINE_INTEGER(544) -DEFINE_INTEGER(545) -DEFINE_INTEGER(546) -DEFINE_INTEGER(547) -DEFINE_INTEGER(548) -DEFINE_INTEGER(549) -DEFINE_INTEGER(550) -DEFINE_INTEGER(551) -DEFINE_INTEGER(552) -DEFINE_INTEGER(553) -DEFINE_INTEGER(554) -DEFINE_INTEGER(555) -DEFINE_INTEGER(556) -DEFINE_INTEGER(557) -DEFINE_INTEGER(558) -DEFINE_INTEGER(559) -DEFINE_INTEGER(560) -DEFINE_INTEGER(561) -DEFINE_INTEGER(562) -DEFINE_INTEGER(563) -DEFINE_INTEGER(564) -DEFINE_INTEGER(565) -DEFINE_INTEGER(566) -DEFINE_INTEGER(567) -DEFINE_INTEGER(568) -DEFINE_INTEGER(569) -DEFINE_INTEGER(570) -DEFINE_INTEGER(571) -DEFINE_INTEGER(572) -DEFINE_INTEGER(573) -DEFINE_INTEGER(574) -DEFINE_INTEGER(575) -DEFINE_INTEGER(576) -DEFINE_INTEGER(577) -DEFINE_INTEGER(578) -DEFINE_INTEGER(579) -DEFINE_INTEGER(580) -DEFINE_INTEGER(581) -DEFINE_INTEGER(582) -DEFINE_INTEGER(583) -DEFINE_INTEGER(584) -DEFINE_INTEGER(585) -DEFINE_INTEGER(586) -DEFINE_INTEGER(587) -DEFINE_INTEGER(588) -DEFINE_INTEGER(589) -DEFINE_INTEGER(590) -DEFINE_INTEGER(591) -DEFINE_INTEGER(592) -DEFINE_INTEGER(593) -DEFINE_INTEGER(594) -DEFINE_INTEGER(595) -DEFINE_INTEGER(596) -DEFINE_INTEGER(597) -DEFINE_INTEGER(598) -DEFINE_INTEGER(599) -DEFINE_INTEGER(600) -DEFINE_INTEGER(601) -DEFINE_INTEGER(602) -DEFINE_INTEGER(603) -DEFINE_INTEGER(604) -DEFINE_INTEGER(605) -DEFINE_INTEGER(606) -DEFINE_INTEGER(607) -DEFINE_INTEGER(608) -DEFINE_INTEGER(609) -DEFINE_INTEGER(610) -DEFINE_INTEGER(611) -DEFINE_INTEGER(612) -DEFINE_INTEGER(613) -DEFINE_INTEGER(614) -DEFINE_INTEGER(615) -DEFINE_INTEGER(616) -DEFINE_INTEGER(617) -DEFINE_INTEGER(618) -DEFINE_INTEGER(619) -DEFINE_INTEGER(620) -DEFINE_INTEGER(621) -DEFINE_INTEGER(622) -DEFINE_INTEGER(623) -DEFINE_INTEGER(624) -DEFINE_INTEGER(625) -DEFINE_INTEGER(626) -DEFINE_INTEGER(627) -DEFINE_INTEGER(628) -DEFINE_INTEGER(629) -DEFINE_INTEGER(630) -DEFINE_INTEGER(631) -DEFINE_INTEGER(632) -DEFINE_INTEGER(633) -DEFINE_INTEGER(634) -DEFINE_INTEGER(635) -DEFINE_INTEGER(636) -DEFINE_INTEGER(637) -DEFINE_INTEGER(638) -DEFINE_INTEGER(639) -DEFINE_INTEGER(640) -DEFINE_INTEGER(641) -DEFINE_INTEGER(642) -DEFINE_INTEGER(643) -DEFINE_INTEGER(644) -DEFINE_INTEGER(645) -DEFINE_INTEGER(646) -DEFINE_INTEGER(647) -DEFINE_INTEGER(648) -DEFINE_INTEGER(649) -DEFINE_INTEGER(650) -DEFINE_INTEGER(651) -DEFINE_INTEGER(652) -DEFINE_INTEGER(653) -DEFINE_INTEGER(654) -DEFINE_INTEGER(655) -DEFINE_INTEGER(656) -DEFINE_INTEGER(657) -DEFINE_INTEGER(658) -DEFINE_INTEGER(659) -DEFINE_INTEGER(660) -DEFINE_INTEGER(661) -DEFINE_INTEGER(662) -DEFINE_INTEGER(663) -DEFINE_INTEGER(664) -DEFINE_INTEGER(665) -DEFINE_INTEGER(666) -DEFINE_INTEGER(667) -DEFINE_INTEGER(668) -DEFINE_INTEGER(669) -DEFINE_INTEGER(670) -DEFINE_INTEGER(671) -DEFINE_INTEGER(672) -DEFINE_INTEGER(673) -DEFINE_INTEGER(674) -DEFINE_INTEGER(675) -DEFINE_INTEGER(676) -DEFINE_INTEGER(677) -DEFINE_INTEGER(678) -DEFINE_INTEGER(679) -DEFINE_INTEGER(680) -DEFINE_INTEGER(681) -DEFINE_INTEGER(682) -DEFINE_INTEGER(683) -DEFINE_INTEGER(684) -DEFINE_INTEGER(685) -DEFINE_INTEGER(686) -DEFINE_INTEGER(687) -DEFINE_INTEGER(688) -DEFINE_INTEGER(689) -DEFINE_INTEGER(690) -DEFINE_INTEGER(691) -DEFINE_INTEGER(692) -DEFINE_INTEGER(693) -DEFINE_INTEGER(694) -DEFINE_INTEGER(695) -DEFINE_INTEGER(696) -DEFINE_INTEGER(697) -DEFINE_INTEGER(698) -DEFINE_INTEGER(699) -DEFINE_INTEGER(700) -DEFINE_INTEGER(701) -DEFINE_INTEGER(702) -DEFINE_INTEGER(703) -DEFINE_INTEGER(704) -DEFINE_INTEGER(705) -DEFINE_INTEGER(706) -DEFINE_INTEGER(707) -DEFINE_INTEGER(708) -DEFINE_INTEGER(709) -DEFINE_INTEGER(710) -DEFINE_INTEGER(711) -DEFINE_INTEGER(712) -DEFINE_INTEGER(713) -DEFINE_INTEGER(714) -DEFINE_INTEGER(715) -DEFINE_INTEGER(716) -DEFINE_INTEGER(717) -DEFINE_INTEGER(718) -DEFINE_INTEGER(719) -DEFINE_INTEGER(720) -DEFINE_INTEGER(721) -DEFINE_INTEGER(722) -DEFINE_INTEGER(723) -DEFINE_INTEGER(724) -DEFINE_INTEGER(725) -DEFINE_INTEGER(726) -DEFINE_INTEGER(727) -DEFINE_INTEGER(728) -DEFINE_INTEGER(729) -DEFINE_INTEGER(730) -DEFINE_INTEGER(731) -DEFINE_INTEGER(732) -DEFINE_INTEGER(733) -DEFINE_INTEGER(734) -DEFINE_INTEGER(735) -DEFINE_INTEGER(736) -DEFINE_INTEGER(737) -DEFINE_INTEGER(738) -DEFINE_INTEGER(739) -DEFINE_INTEGER(740) -DEFINE_INTEGER(741) -DEFINE_INTEGER(742) -DEFINE_INTEGER(743) -DEFINE_INTEGER(744) -DEFINE_INTEGER(745) -DEFINE_INTEGER(746) -DEFINE_INTEGER(747) -DEFINE_INTEGER(748) -DEFINE_INTEGER(749) -DEFINE_INTEGER(750) -DEFINE_INTEGER(751) -DEFINE_INTEGER(752) -DEFINE_INTEGER(753) -DEFINE_INTEGER(754) -DEFINE_INTEGER(755) -DEFINE_INTEGER(756) -DEFINE_INTEGER(757) -DEFINE_INTEGER(758) -DEFINE_INTEGER(759) -DEFINE_INTEGER(760) -DEFINE_INTEGER(761) -DEFINE_INTEGER(762) -DEFINE_INTEGER(763) -DEFINE_INTEGER(764) -DEFINE_INTEGER(765) -DEFINE_INTEGER(766) -DEFINE_INTEGER(767) -DEFINE_INTEGER(768) -DEFINE_INTEGER(769) -DEFINE_INTEGER(770) -DEFINE_INTEGER(771) -DEFINE_INTEGER(772) -DEFINE_INTEGER(773) -DEFINE_INTEGER(774) -DEFINE_INTEGER(775) -DEFINE_INTEGER(776) -DEFINE_INTEGER(777) -DEFINE_INTEGER(778) -DEFINE_INTEGER(779) -DEFINE_INTEGER(780) -DEFINE_INTEGER(781) -DEFINE_INTEGER(782) -DEFINE_INTEGER(783) -DEFINE_INTEGER(784) -DEFINE_INTEGER(785) -DEFINE_INTEGER(786) -DEFINE_INTEGER(787) -DEFINE_INTEGER(788) -DEFINE_INTEGER(789) -DEFINE_INTEGER(790) -DEFINE_INTEGER(791) -DEFINE_INTEGER(792) -DEFINE_INTEGER(793) -DEFINE_INTEGER(794) -DEFINE_INTEGER(795) -DEFINE_INTEGER(796) -DEFINE_INTEGER(797) -DEFINE_INTEGER(798) -DEFINE_INTEGER(799) -DEFINE_INTEGER(800) -DEFINE_INTEGER(801) -DEFINE_INTEGER(802) -DEFINE_INTEGER(803) -DEFINE_INTEGER(804) -DEFINE_INTEGER(805) -DEFINE_INTEGER(806) -DEFINE_INTEGER(807) -DEFINE_INTEGER(808) -DEFINE_INTEGER(809) -DEFINE_INTEGER(810) -DEFINE_INTEGER(811) -DEFINE_INTEGER(812) -DEFINE_INTEGER(813) -DEFINE_INTEGER(814) -DEFINE_INTEGER(815) -DEFINE_INTEGER(816) -DEFINE_INTEGER(817) diff --git a/t-child.c b/t-child.c deleted file mode 100644 index f4e3a04..0000000 --- a/t-child.c +++ /dev/null @@ -1,74 +0,0 @@ -/* Sanity check for the process and IPC primitives. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#include -#include -#include - -#ifdef _WIN32 -# include -# include -#endif - -int -main (int argc, char **argv) -{ - char buffer[4096]; - memset (buffer, 'A', sizeof buffer); -#if _WIN32 - if (! setmode (fileno (stdin), O_BINARY)) - return 23; - if (! setmode (fileno (stdout), O_BINARY)) - return 23; -#endif - - if (argc == 1) - return 2; - else if (strcmp (argv[1], "return0") == 0) - return 0; - else if (strcmp (argv[1], "return1") == 0) - return 1; - else if (strcmp (argv[1], "return77") == 0) - return 77; - else if (strcmp (argv[1], "hello_stdout") == 0) - fprintf (stdout, "hello"); - else if (strcmp (argv[1], "hello_stderr") == 0) - fprintf (stderr, "hello"); - else if (strcmp (argv[1], "stdout4096") == 0) - fwrite (buffer, 1, sizeof buffer, stdout); - else if (strcmp (argv[1], "stdout8192") == 0) - { - fwrite (buffer, 1, sizeof buffer, stdout); - fwrite (buffer, 1, sizeof buffer, stdout); - } - else if (strcmp (argv[1], "cat") == 0) - while (! feof (stdin)) - { - size_t bytes_read; - bytes_read = fread (buffer, 1, sizeof buffer, stdin); - fwrite (buffer, 1, bytes_read, stdout); - } - else - { - fprintf (stderr, "unknown command %s\n", argv[1]); - return 2; - } - return 0; -} diff --git a/t-child.scm b/t-child.scm deleted file mode 100644 index fd1dcc3..0000000 --- a/t-child.scm +++ /dev/null @@ -1,118 +0,0 @@ -;; Tests for the low-level process and IPC primitives. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(echo "Testing process and IPC primitives...") - -(define (qualify executable) - (string-append executable (getenv "EXEEXT"))) - -(define child (qualify "t-child")) - -(assert (= 0 (call `(,(qualify "t-child") "return0")))) -(assert (= 1 (call `(,(qualify "t-child") "return1")))) -(assert (= 77 (call `(,(qualify "t-child") "return77")))) - -(let ((r (call-with-io `(,(qualify "t-child") "return0") ""))) - (assert (= 0 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "return1") ""))) - (assert (= 1 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "return77") ""))) - (assert (= 77 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") ""))) - (assert (= 0 (:retcode r))) - (assert (string=? "hello" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") ""))) - (assert (= 0 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "hello" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "stdout4096") ""))) - (assert (= 0 (:retcode r))) - (assert (= 4096 (string-length (:stdout r)))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "stdout8192") ""))) - (assert (= 0 (:retcode r))) - (assert (= 8192 (string-length (:stdout r)))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello"))) - (assert (= 0 (:retcode r))) - (assert (string=? "hellohello" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(define (spawn what) - (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO)) - -(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) - (pid1 (spawn `(,(qualify "t-child") "return0")))) - (assert (equal? '(0 0) - (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) - -(let ((pid0 (spawn `(,(qualify "t-child") "return1"))) - (pid1 (spawn `(,(qualify "t-child") "return0")))) - (assert (equal? '(1 0) - (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) - -(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) - (pid1 (spawn `(,(qualify "t-child") "return77"))) - (pid2 (spawn `(,(qualify "t-child") "return1")))) - (assert (equal? '(0 77 1) - (wait-processes '("child0" "child1" "child2") - (list pid0 pid1 pid2) #t)))) - -(let* ((p (pipe)) - (pid0 (spawn-process-fd - `(,(qualify "t-child") "hello_stdout") - CLOSED_FD (:write-end p) STDERR_FILENO)) - (_ (close (:write-end p))) - (pid1 (spawn-process-fd - `(,(qualify "t-child") "cat") - (:read-end p) STDOUT_FILENO STDERR_FILENO))) - (close (:read-end p)) - (assert - (equal? '(0 0) - (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) -(echo " world.") - -(tr:do - (tr:pipe-do - (pipe:spawn `(,child stdout4096)) - (pipe:spawn `(,child cat))) - (tr:call-with-content (lambda (c) - (assert (= 4096 (string-length c)))))) -(tr:do - (tr:pipe-do - (pipe:spawn `(,child stdout8192)) - (pipe:spawn `(,child cat))) - (tr:call-with-content (lambda (c) - (assert (= 8192 (string-length c)))))) - -(echo "All good.") diff --git a/tests.scm b/tests.scm deleted file mode 100644 index 5141002..0000000 --- a/tests.scm +++ /dev/null @@ -1,886 +0,0 @@ -;; Common definitions for writing tests. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Reporting. -(define (echo . msg) - (for-each (lambda (x) (display x) (display " ")) msg) - (newline)) - -(define (info . msg) - (apply echo msg) - (flush-stdio)) - -(define (log . msg) - (if (> (*verbose*) 0) - (apply info msg))) - -(define (fail . msg) - (apply info msg) - (exit 1)) - -(define (skip . msg) - (apply info msg) - (exit 77)) - -(define (make-counter) - (let ((c 0)) - (lambda () - (let ((r c)) - (set! c (+ 1 c)) - r)))) - -(define *progress-nesting* 0) - -(define (call-with-progress msg what) - (set! *progress-nesting* (+ 1 *progress-nesting*)) - (if (= 1 *progress-nesting*) - (begin - (info msg) - (display " > ") - (flush-stdio) - (what (lambda (item) - (display item) - (display " ") - (flush-stdio))) - (info "< ")) - (begin - (what (lambda (item) (display ".") (flush-stdio))) - (display " ") - (flush-stdio))) - (set! *progress-nesting* (- *progress-nesting* 1))) - -(define (for-each-p msg proc lst . lsts) - (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts))) - -(define (for-each-p' msg proc fmt lst . lsts) - (call-with-progress - msg - (lambda (progress) - (apply for-each - `(,(lambda args - (progress (apply fmt args)) - (apply proc args)) - ,lst ,@lsts))))) - -;; Process management. -(define CLOSED_FD -1) -(define (call-with-fds what infd outfd errfd) - (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t)) -(define (call what) - (call-with-fds what - CLOSED_FD - (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD) - (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD))) - -;; Accessor functions for the results of 'spawn-process'. -(define :stdin car) -(define :stdout cadr) -(define :stderr caddr) -(define :pid cadddr) - -(define (call-with-io what in) - (let ((h (spawn-process what 0))) - (es-write (:stdin h) in) - (es-fclose (:stdin h)) - (let* ((out (es-read-all (:stdout h))) - (err (es-read-all (:stderr h))) - (result (wait-process (car what) (:pid h) #t))) - (es-fclose (:stdout h)) - (es-fclose (:stderr h)) - (if (> (*verbose*) 2) - (info "Child" (:pid h) "returned:" - `((command ,(stringify what)) - (status ,result) - (stdout ,out) - (stderr ,err)))) - (list result out err)))) - -;; Accessor function for the results of 'call-with-io'. ':stdout' and -;; ':stderr' can also be used. -(define :retcode car) - -(define (call-check what) - (let ((result (call-with-io what ""))) - (if (= 0 (:retcode result)) - (:stdout result) - (throw (string-append (stringify what) " failed") - (:stderr result))))) - -(define (call-popen command input-string) - (let ((result (call-with-io command input-string))) - (if (= 0 (:retcode result)) - (:stdout result) - (throw (:stderr result))))) - -;; -;; estream helpers. -;; - -(define (es-read-all stream) - (let loop - ((acc "")) - (if (es-feof stream) - acc - (loop (string-append acc (es-read stream 4096)))))) - -;; -;; File management. -;; -(define (file-exists? name) - (call-with-input-file name (lambda (port) #t))) - -(define (file=? a b) - (file-equal a b #t)) - -(define (text-file=? a b) - (file-equal a b #f)) - -(define (file-copy from to) - (catch '() (unlink to)) - (letfd ((source (open from (logior O_RDONLY O_BINARY))) - (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600))) - (splice source sink))) - -(define (text-file-copy from to) - (catch '() (unlink to)) - (letfd ((source (open from O_RDONLY)) - (sink (open to (logior O_WRONLY O_CREAT) #o600))) - (splice source sink))) - -(define (path-join . components) - (let loop ((acc #f) (rest (filter (lambda (s) - (not (string=? "" s))) components))) - (if (null? rest) - acc - (loop (if (string? acc) - (string-append acc "/" (car rest)) - (car rest)) - (cdr rest))))) -(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz")) -(assert (string=? (path-join "" "bar" "baz") "bar/baz")) - -;; Is PATH an absolute path? -(define (absolute-path? path) - (or (char=? #\/ (string-ref path 0)) - (and *win32* (char=? #\\ (string-ref path 0))) - (and *win32* - (char-alphabetic? (string-ref path 0)) - (char=? #\: (string-ref path 1)) - (or (char=? #\/ (string-ref path 2)) - (char=? #\\ (string-ref path 2)))))) - -;; Make PATH absolute. -(define (canonical-path path) - (if (absolute-path? path) path (path-join (getcwd) path))) - -(define (in-srcdir . names) - (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names)))) - -;; Split a list of paths. -(define (pathsep-split s) - (string-split s *pathsep*)) - -;; Join a list of paths. -(define (pathsep-join paths) - (foldr (lambda (a b) (string-append a (string *pathsep*) b)) - (car paths) - (cdr paths))) - -;; Try to find NAME in PATHS. Returns the full path name on success, -;; or raises an error. -(define (path-expand name paths) - (let loop ((path paths)) - (if (null? path) - (throw "Could not find" name "in" paths) - (let* ((qualified-name (path-join (car path) name)) - (file-exists (call-with-input-file qualified-name - (lambda (x) #t)))) - (if file-exists - qualified-name - (loop (cdr path))))))) - -;; Expand NAME using the gpgscm load path. Use like this: -;; (load (with-path "library.scm")) -(define (with-path name) - (catch name - (path-expand name (pathsep-split (getenv "GPGSCM_PATH"))))) - -(define (basename path) - (let ((i (string-index path #\/))) - (if (equal? i #f) - path - (basename (substring path (+ 1 i) (string-length path)))))) - -(define (basename-suffix path suffix) - (basename - (if (string-suffix? path suffix) - (substring path 0 (- (string-length path) (string-length suffix))) - path))) - -(define (dirname path) - (let ((i (string-rindex path #\/))) - (if i (substring path 0 i) "."))) -(assert (string=? "foo/bar" (dirname "foo/bar/baz"))) - -;; Helper for (pipe). -(define :read-end car) -(define :write-end cadr) - -;; let-like macro that manages file descriptors. -;; -;; (letfd ) -;; -;; Bind all variables given in and initialize each of them -;; to the given initial value, and close them after evaluating . -(define-macro (letfd bindings . body) - (let bind ((bindings' bindings)) - (if (null? bindings') - `(begin ,@body) - (let* ((binding (car bindings')) - (name (car binding)) - (initializer (cadr binding))) - `(let ((,name ,initializer)) - (finally (close ,name) - ,(bind (cdr bindings')))))))) - -(define-macro (with-working-directory new-directory . expressions) - (let ((new-dir (gensym)) - (old-dir (gensym))) - `(let* ((,new-dir ,new-directory) - (,old-dir (getcwd))) - (dynamic-wind - (lambda () (if ,new-dir (chdir ,new-dir))) - (lambda () ,@expressions) - (lambda () (chdir ,old-dir)))))) - -;; Make a temporary directory. If arguments are given, they are -;; joined using path-join, and must end in a component ending in -;; "XXXXXX". If no arguments are given, a suitable location and -;; generic name is used. Returns an absolute path. -(define (mkdtemp . components) - (canonical-path (_mkdtemp (if (null? components) - (path-join - (get-temp-path) - (string-append "gpgscm-" (get-isotime) "-" - (basename-suffix *scriptname* ".scm") - "-XXXXXX")) - (apply path-join components))))) - -;; Make a temporary directory and remove it at interpreter shutdown. -;; Note that there are macros that limit the lifetime of temporary -;; directories and files to a lexical scope. Use those if possible. -;; Otherwise this works like mkdtemp. -(define (mkdtemp-autoremove . components) - (let ((dir (apply mkdtemp components))) - (atexit (lambda () (unlink-recursively dir))) - dir)) - -(define-macro (with-temporary-working-directory . expressions) - (let ((tmp-sym (gensym))) - `(let* ((,tmp-sym (mkdtemp))) - (finally (unlink-recursively ,tmp-sym) - (with-working-directory ,tmp-sym - ,@expressions))))) - -(define (make-temporary-file . args) - (canonical-path (path-join - (mkdtemp) - (if (null? args) "a" (car args))))) - -(define (remove-temporary-file filename) - (catch '() - (unlink filename)) - (let ((dirname (substring filename 0 (string-rindex filename #\/)))) - (catch (echo "removing temporary directory" dirname "failed") - (rmdir dirname)))) - -;; let-like macro that manages temporary files. -;; -;; (lettmp ) -;; -;; Bind all variables given in , initialize each of them to -;; a string representing an unique path in the filesystem, and delete -;; them after evaluating . -(define-macro (lettmp bindings . body) - (let bind ((bindings' bindings)) - (if (null? bindings') - `(begin ,@body) - (let ((name (car bindings')) - (rest (cdr bindings'))) - `(let ((,name (make-temporary-file ,(symbol->string name)))) - (finally (remove-temporary-file ,name) - ,(bind rest))))))) - -(define (check-execution source transformer) - (lettmp (sink) - (transformer source sink))) - -(define (check-identity source transformer) - (lettmp (sink) - (transformer source sink) - (if (not (file=? source sink)) - (fail "mismatch")))) - -;; -;; Monadic pipe support. -;; - -(define pipeM - (package - (define (new procs source sink producer) - (package - (define (dump) - (write (list procs source sink producer)) - (newline)) - (define (add-proc command pid) - (new (cons (list command pid) procs) source sink producer)) - (define (commands) - (map car procs)) - (define (pids) - (map cadr procs)) - (define (set-source source') - (new procs source' sink producer)) - (define (set-sink sink') - (new procs source sink' producer)) - (define (set-producer producer') - (if producer - (throw "producer already set")) - (new procs source sink producer')))))) - - -(define (pipe:do . commands) - (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands)) - (if (null? cmds) - (begin - (if M::producer (M::producer)) - (if (not (null? M::procs)) - (let* ((retcodes (wait-processes (map stringify (M::commands)) - (M::pids) #t)) - (results (map (lambda (p r) (append p (list r))) - M::procs retcodes)) - (failed (filter (lambda (x) (not (= 0 (caddr x)))) - results))) - (if (not (null? failed)) - (throw failed))))) ; xxx nicer reporting - (if (and (= 2 (length cmds)) (number? (cadr cmds))) - ;; hack: if it's an fd, use it as sink - (let ((M' ((car cmds) (M::set-sink (cadr cmds))))) - (if (> M::source 2) (close M::source)) - (if (> (cadr cmds) 2) (close (cadr cmds))) - (loop M' '())) - (let ((M' ((car cmds) M))) - (if (> M::source 2) (close M::source)) - (loop M' (cdr cmds))))))) - -(define (pipe:open pathname flags) - (lambda (M) - (M::set-source (open pathname flags)))) - -(define (pipe:defer producer) - (lambda (M) - (let* ((p (outbound-pipe)) - (M' (M::set-source (:read-end p)))) - (M'::set-producer (lambda () - (producer (:write-end p)) - (close (:write-end p))))))) -(define (pipe:echo data) - (pipe:defer (lambda (sink) (display data (fdopen sink "wb"))))) - -(define (pipe:spawn command) - (lambda (M) - (define (do-spawn M new-source) - (let ((pid (spawn-process-fd command M::source M::sink - (if (> (*verbose*) 0) - STDERR_FILENO CLOSED_FD))) - (M' (M::set-source new-source))) - (M'::add-proc command pid))) - (if (= CLOSED_FD M::sink) - (let* ((p (pipe)) - (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p)))) - (close (:write-end p)) - (M'::set-sink CLOSED_FD)) - (do-spawn M CLOSED_FD)))) - -(define (pipe:splice sink) - (lambda (M) - (splice M::source sink) - (M::set-source CLOSED_FD))) - -(define (pipe:write-to pathname flags mode) - (open pathname flags mode)) - -;; -;; Monadic transformer support. -;; - -(define (tr:do . commands) - (let loop ((tmpfiles '()) (source #f) (cmds commands)) - (if (null? cmds) - (for-each remove-temporary-file tmpfiles) - (let* ((v ((car cmds) tmpfiles source)) - (tmpfiles' (car v)) - (sink (cadr v)) - (error (caddr v))) - (if error - (begin - (for-each remove-temporary-file tmpfiles') - (apply throw error))) - (loop tmpfiles' sink (cdr cmds)))))) - -(define (tr:open pathname) - (lambda (tmpfiles source) - (list tmpfiles pathname #f))) - -(define (tr:spawn input command) - (lambda (tmpfiles source) - (if (and (member '**in** command) (not source)) - (fail (string-append (stringify cmd) " needs an input"))) - (let* ((t (make-temporary-file)) - (cmd (map (lambda (x) - (cond - ((equal? '**in** x) source) - ((equal? '**out** x) t) - (else x))) command))) - (catch (list (cons t tmpfiles) t *error*) - (call-popen cmd input) - (if (and (member '**out** command) (not (file-exists? t))) - (fail (string-append (stringify cmd) - " did not produce '" t "'."))) - (list (cons t tmpfiles) t #f))))) - -(define (tr:write-to pathname) - (lambda (tmpfiles source) - (rename source pathname) - (list tmpfiles pathname #f))) - -(define (tr:pipe-do . commands) - (lambda (tmpfiles source) - (let ((t (make-temporary-file))) - (apply pipe:do - `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) - ,@commands - ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) - (list (cons t tmpfiles) t #f)))) - -(define (tr:assert-identity reference) - (lambda (tmpfiles source) - (if (not (file=? source reference)) - (fail "mismatch")) - (list tmpfiles source #f))) - -(define (tr:assert-weak-identity reference) - (lambda (tmpfiles source) - (if (not (text-file=? source reference)) - (fail "mismatch")) - (list tmpfiles source #f))) - -(define (tr:call-with-content function . args) - (lambda (tmpfiles source) - (catch (list tmpfiles source *error*) - (apply function `(,(call-with-input-file source read-all) ,@args))) - (list tmpfiles source #f))) - -;; -;; Developing and debugging tests. -;; - -;; Spawn an os shell. -(define (interactive-shell) - (call-with-fds `(,(getenv "SHELL") -i) 0 1 2)) - -;; -;; The main test framework. -;; - -(define semaphore - (package - (define (new n) - (package - (define (acquire!?) - (if (> n 0) - (begin - (set! n (- n 1)) - #t) - #f)) - (define (release!) - (set! n (+ n 1))))))) - -;; A pool of tests. -(define test-pool - (package - (define (new n) - (package - ;; A semaphore to restrict the number of spawned processes. - (define sem (semaphore::new n)) - - ;; A list of enqueued, but not yet run tests. - (define enqueued '()) - - ;; A list of running or finished processes. - (define procs '()) - - (define (add test) - (if (test::started?) - (set! procs (cons test procs)) - (if (sem::acquire!?) - (add (test::run-async)) - (set! enqueued (cons test enqueued)))) - (current-environment)) - - ;; Pop the last of the enqueued tests off the fifo queue. - (define (pop-test!) - (let ((i (length enqueued))) - (assert (> i 0)) - (cond - ((= i 1) - (let ((test (car enqueued))) - (set! enqueued '()) - test)) - (else - (let* ((tail (list-tail enqueued (- i 2))) - (test (cadr tail))) - (set-cdr! tail '()) - (assert (= (length enqueued) (- i 1))) - test))))) - - (define (pid->test pid) - (let ((t (filter (lambda (x) (= pid x::pid)) procs))) - (if (null? t) #f (car t)))) - (define (wait) - (if (null? enqueued) - ;; If no tests are enqueued, we can just block until all - ;; of them finished. - (wait' #t) - ;; Otherwise, we must not block, but give some tests the - ;; chance to finish so that we can start new ones. - (begin - (wait' #f) - (usleep (/ 1000000 10)) - (wait)))) - (define (wait' hang) - (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) - (if (null? unfinished) - (current-environment) - (let ((names (map (lambda (t) t::name) unfinished)) - (pids (map (lambda (t) t::pid) unfinished)) - (any #f)) - (for-each - (lambda (test retcode) - (unless (< retcode 0) - (test::set-end-time!) - (test:::set! 'retcode retcode) - (test::report) - (sem::release!) - (set! any #t))) - (map pid->test pids) - (wait-processes (map stringify names) pids hang)) - - ;; If some processes finished, try to start new ones. - (let loop () - (cond - ((not any) #f) - ((pair? enqueued) - (if (sem::acquire!?) - (let ((test (pop-test!))) - (add (test::run-async)) - (loop))))))))) - (current-environment)) - (define (filter-tests status) - (filter (lambda (p) (eq? status (p::status))) procs)) - (define (report) - (define (print-tests tests message) - (unless (null? tests) - (apply echo (cons message - (map (lambda (t) t::name) tests))))) - - (let ((failed (filter-tests 'FAIL)) - (xfailed (filter-tests 'XFAIL)) - (xpassed (filter-tests 'XPASS)) - (skipped (filter-tests 'SKIP))) - (echo "===================") - (echo (length procs) "tests run," - (length (filter-tests 'PASS)) "succeeded," - (length failed) "failed," - (length xfailed) "failed expectedly," - (length xpassed) "succeeded unexpectedly," - (length skipped) "skipped.") - (print-tests failed "Failed tests:") - (print-tests xfailed "Expectedly failed tests:") - (print-tests xpassed "Unexpectedly passed tests:") - (print-tests skipped "Skipped tests:") - (echo "===================") - (+ (length failed) (length xpassed)))) - - (define (xml) - (xx::document - (xx::tag 'testsuites - `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") - ("xsi:noNamespaceSchemaLocation" - "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd")) - (map (lambda (t) (t::xml)) procs)))))))) - -(define (verbosity n) - (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) - -(define (locate-test path) - (if (absolute-path? path) path (in-srcdir path))) - -;; A single test. -(define test - (begin - - ;; Private definitions. - - (define (isotime->junit t) - "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}" - "20170418T145809" - (string-append (substring t 0 4) - "-" - (substring t 4 6) - "-" - (substring t 6 11) - ":" - (substring t 11 13) - ":" - (substring t 13 15))) - - ;; If a tests name ends with a bang (!), it is expected to fail. - (define (expect-failure? name) - (string-suffix? name "!")) - ;; Strips the bang (if any). - (define (test-name name) - (if (expect-failure? name) - (substring name 0 (- (string-length name) 1)) - name)) - - (package - (define (scm setup name path . args) - ;; Start the process. - (define (spawn-scm args' in out err) - (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) - ,(locate-test (test-name path)) - ,@(if setup (force setup) '()) - ,@args' ,@args) in out err)) - (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name))) - - (define (binary setup name path . args) - ;; Start the process. - (define (spawn-binary args' in out err) - (spawn-process-fd `(,(test-name path) - ,@(if setup (force setup) '()) ,@args' ,@args) - in out err)) - (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name))) - - (define (new name directory spawn pid retcode logfd expect-failure) - (package - - ;; XXX: OO glue. - (define self (current-environment)) - (define (:set! key value) - (eval `(set! ,key ,value) (current-environment)) - (current-environment)) - - ;; The log is written here. - (define log-file-name #f) - - ;; Record time stamps. - (define timestamp #f) - (define start-time 0) - (define end-time 0) - - (define (set-start-time!) - (set! timestamp (isotime->junit (get-isotime))) - (set! start-time (get-time))) - (define (set-end-time!) - (set! end-time (get-time))) - - ;; Has the test been started yet? - (define (started?) - (number? pid)) - - (define (open-log-file) - (unless log-file-name - (set! log-file-name (string-append (basename name) ".log"))) - (catch '() (unlink log-file-name)) - (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) - - (define (run-sync . args) - (set-start-time!) - (letfd ((log (open-log-file))) - (with-working-directory directory - (let* ((p (inbound-pipe)) - (pid' (spawn args 0 (:write-end p) (:write-end p)))) - (close (:write-end p)) - (splice (:read-end p) STDERR_FILENO log) - (close (:read-end p)) - (set! pid pid') - (set! retcode (wait-process name pid' #t))))) - (report) - (current-environment)) - (define (run-sync-quiet . args) - (set-start-time!) - (with-working-directory directory - (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))) - (set! retcode (wait-process name pid #t)) - (set-end-time!) - (current-environment)) - (define (run-async . args) - (set-start-time!) - (let ((log (open-log-file))) - (with-working-directory directory - (set! pid (spawn args CLOSED_FD log log))) - (set! logfd log)) - (current-environment)) - (define (status) - (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))) - (t (if (not t') 'FAIL (cadr t')))) - (if expect-failure - (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t)) - t))) - (define (status-string) - (cadr (assoc (status) '((PASS "PASS") - (SKIP "SKIP") - (ERROR "ERROR") - (FAIL "FAIL") - (XPASS "XPASS") - (XFAIL "XFAIL"))))) - (define (report) - (unless (= logfd CLOSED_FD) - (seek logfd 0 SEEK_SET) - (splice logfd STDERR_FILENO) - (close logfd)) - (echo (string-append (status-string) ":") name)) - - (define (xml) - (xx::tag - 'testsuite - `((name ,name) - (time ,(- end-time start-time)) - (package ,(dirname name)) - (id 0) - (timestamp ,timestamp) - (hostname "unknown") - (tests 1) - (failures ,(if (eq? FAIL (status)) 1 0)) - (errors ,(if (eq? ERROR (status)) 1 0))) - (list - (xx::tag 'properties) - (xx::tag 'testcase - `((name ,(basename name)) - (classname ,(string-translate (dirname name) "/" ".")) - (time ,(- end-time start-time))) - `(,@(case (status) - ((PASS XFAIL) '()) - ((SKIP) (list (xx::tag 'skipped))) - ((ERROR) (list - (xx::tag 'error '((message "Unknown error."))))) - (else - (list (xx::tag 'failure '((message "Unknown error.")))))))) - (xx::tag 'system-out '() - (list (xx::textnode (read-all (open-input-file log-file-name))))) - (xx::tag 'system-err '() (list (xx::textnode ""))))))))))) - -;; Run the setup target to create an environment, then run all given -;; tests in parallel. -(define (run-tests-parallel tests n) - (let loop ((pool (test-pool::new n)) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - ((results::xml) (open-output-file "report.xml")) - (exit (results::report))) - (let ((wd (mkdtemp-autoremove)) - (test (car tests'))) - (test:::set! 'directory wd) - (loop (pool::add test) - (cdr tests')))))) - -;; Run the setup target to create an environment, then run all given -;; tests in sequence. -(define (run-tests-sequential tests) - (let loop ((pool (test-pool::new 1)) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - ((results::xml) (open-output-file "report.xml")) - (exit (results::report))) - (let ((wd (mkdtemp-autoremove)) - (test (car tests'))) - (test:::set! 'directory wd) - (loop (pool::add (test::run-sync)) - (cdr tests')))))) - -;; Run tests either in sequence or in parallel, depending on the -;; number of tests and the command line flags. -(define (run-tests tests) - (let ((parallel (flag "--parallel" *args*)) - (default-parallel-jobs 32)) - (if (and parallel (> (length tests) 1)) - (run-tests-parallel tests (if (and (pair? parallel) - (string->number (car parallel))) - (string->number (car parallel)) - default-parallel-jobs)) - (run-tests-sequential tests)))) - -;; Load all tests from the given path. -(define (load-tests . path) - (load (apply in-srcdir `(,@path "all-tests.scm"))) - all-tests) - -;; Helper to create environment caches from test functions. SETUP -;; must be a test implementing the producer side cache protocol. -;; Returns a promise containing the arguments that must be passed to a -;; test implementing the consumer side of the cache protocol. -(define (make-environment-cache setup) - (delay (with-temporary-working-directory - (let ((tarball (make-temporary-file "environment-cache"))) - (atexit (lambda () (remove-temporary-file tarball))) - (setup::run-sync '--create-tarball tarball) - (if (not (equal? 'PASS (setup::status))) - (fail "Setup failed.")) - `(--unpack-tarball ,tarball))))) - -;; Command line flag handling. Returns the elements following KEY in -;; ARGUMENTS up to the next argument, or #f if KEY is not in -;; ARGUMENTS. If 'KEY=XYZ' is encountered, then the singleton list -;; containing 'XYZ' is returned. -(define (flag key arguments) - (cond - ((null? arguments) - #f) - ((string=? key (car arguments)) - (let loop ((acc '()) - (args (cdr arguments))) - (if (or (null? args) (string-prefix? (car args) "--")) - (reverse acc) - (loop (cons (car args) acc) (cdr args))))) - ((string-prefix? (car arguments) (string-append key "=")) - (list (substring (car arguments) - (+ (string-length key) 1) - (string-length (car arguments))))) - ((string=? "--" (car arguments)) - #f) - (else - (flag key (cdr arguments))))) -(assert (equal? (flag "--xxx" '("--yyy")) #f)) -(assert (equal? (flag "--xxx" '("--xxx")) '())) -(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy"))) -(assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo"))) -(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz"))) -(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz"))) -(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy"))) -(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy"))) diff --git a/time.scm b/time.scm deleted file mode 100644 index a9b06d0..0000000 --- a/time.scm +++ /dev/null @@ -1,42 +0,0 @@ -;; Simple time manipulation library. -;; -;; Copyright (C) 2017 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; This library mimics what GnuPG thinks about expiration times. -;; Granularity is one second. Its focus is not on correctness. - -;; Conversion functions. -(define (minutes->seconds minutes) - (* minutes 60)) -(define (hours->seconds hours) - (* hours 60 60)) -(define (days->seconds days) - (* days 24 60 60)) -(define (weeks->seconds weeks) - (days->seconds (* weeks 7))) -(define (months->seconds months) - (days->seconds (* months 30))) -(define (years->seconds years) - (days->seconds (* years 365))) - -(define (time-matches? a b slack) - (< (abs (- a b)) slack)) -(assert (time-matches? (hours->seconds 1) (hours->seconds 2) (hours->seconds 2))) -(assert (time-matches? (hours->seconds 2) (hours->seconds 1) (hours->seconds 2))) -(assert (not (time-matches? (hours->seconds 4) (hours->seconds 1) (hours->seconds 2)))) -(assert (not (time-matches? (hours->seconds 1) (hours->seconds 4) (hours->seconds 2)))) diff --git a/xml.scm b/xml.scm deleted file mode 100644 index 771ec36..0000000 --- a/xml.scm +++ /dev/null @@ -1,142 +0,0 @@ -;; A tiny XML library. -;; -;; Copyright (C) 2017 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(define xx - (begin - - ;; Private declarations. - (define quote-text - '((#\< "<") - (#\> ">") - (#\& "&"))) - - (define quote-attribute-' - '((#\< "<") - (#\> ">") - (#\& "&") - (#\' "'"))) - - (define quote-attribute-'' - '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """))) - - (define (escape-string quotation string sink) - ;; This implementation is a bit awkward because iteration is so - ;; slow in TinySCHEME. We rely on string-index to skip to the - ;; next character we need to escape. We also avoid allocations - ;; wherever possible. - - ;; Given a list of integers or #f, return the sublist that - ;; starts with the lowest integer. - (define (min* x) - (let loop ((lowest x) (rest x)) - (if (null? rest) - lowest - (loop (if (or (null? lowest) (not (car lowest)) - (and (car rest) (> (car lowest) (car rest)))) rest lowest) - (cdr rest))))) - - (let ((i 0) (start 0) (len (string-length string)) - (indices (map (lambda (x) (string-index string (car x))) quotation)) - (next #f) (c #f)) - - ;; Set 'i' to the index of the next character that needs - ;; escaping, 'c' to the character that needs to be escaped, - ;; and update 'indices'. - (define (skip!) - (set! next (min* indices)) - (set! i (if (null? next) #f (car next))) - (if i - (begin - (set! c (string-ref string i)) - (set-car! next (string-index string c (+ 1 i)))) - (set! i (string-length string)))) - - (let loop () - (skip!) - (if (< i len) - (begin - (display (substring string start i) sink) - (display (cadr (assv c quotation)) sink) - (set! i (+ 1 i)) - (set! start i) - (loop)) - (display (substring string start len) sink))))) - - (let ((escape-string-s (lambda (quotation string) - (let ((sink (open-output-string))) - (escape-string quotation string sink) - (get-output-string sink))))) - (assert (equal? (escape-string-s quote-text "foo") "foo")) - (assert (equal? (escape-string-s quote-text "foo&") "foo&")) - (assert (equal? (escape-string-s quote-text "&foo") "&foo")) - (assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar")) - (assert (equal? (escape-string-s quote-text "foobar") "foo>bar"))) - - (define (escape quotation datum sink) - (cond - ((string? datum) (escape-string quotation datum sink)) - ((symbol? datum) (escape-string quotation (symbol->string datum) sink)) - ((number? datum) (display (number->string datum) sink)) - (else - (throw "Do not know how to encode" datum)))) - - (define (name->string name) - (cond - ((symbol? name) (symbol->string name)) - (else name))) - - (package - - (define (textnode string) - (lambda (sink) - (escape quote-text string sink))) - - (define (tag name . rest) - (let ((attributes (if (null? rest) '() (car rest))) - (children (if (> (length rest) 1) (cadr rest) '()))) - (lambda (sink) - (display "<" sink) - (display (name->string name) sink) - (unless (null? attributes) - (display " " sink) - (for-each (lambda (a) - (display (car a) sink) - (display "=\"" sink) - (escape quote-attribute-'' (cadr a) sink) - (display "\" " sink)) attributes)) - (if (null? children) - (display "/>\n" sink) - (begin - (display ">\n" sink) - (for-each (lambda (c) (c sink)) children) - (display "string name) sink) - (display ">\n" sink)))))) - - (define (document root . rest) - (let ((attributes (if (null? rest) '() (car rest)))) - (lambda (sink) - ;; xxx ignores attributes - (display "\n" sink) - (root sink) - (newline sink))))))) -- cgit v1.2.3