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