From 09984557106ba52ff8889effd811282dca389a99 Mon Sep 17 00:00:00 2001 From: Werner Koch Date: Thu, 5 Oct 2017 17:27:09 +0200 Subject: gpgscm: Move files to a gpgscm subdirectory. -- Note that we used git filter-branch --subdirectory-filter tests/gpgscm in gnupg master to filter out the gpgscm part. This commit merely moves these files to a subdirectory which will be used in libgpg-error for gpgscm. Signed-off-by: Werner Koch --- LICENSE.TinySCHEME | 31 - Makefile.am | 64 - Manual.txt | 444 ---- ffi-private.h | 148 -- ffi.c | 1470 ----------- ffi.h | 30 - ffi.scm | 51 - gnupg.scm | 44 - gpgscm/LICENSE.TinySCHEME | 31 + gpgscm/Makefile.am | 64 + gpgscm/Manual.txt | 444 ++++ gpgscm/ffi-private.h | 148 ++ gpgscm/ffi.c | 1470 +++++++++++ gpgscm/ffi.h | 30 + gpgscm/ffi.scm | 51 + gpgscm/gnupg.scm | 44 + gpgscm/init.scm | 823 +++++++ gpgscm/lib.scm | 307 +++ gpgscm/main.c | 359 +++ gpgscm/makefile.scm | 76 + gpgscm/opdefines.h | 205 ++ gpgscm/private.h | 26 + gpgscm/repl.scm | 69 + gpgscm/scheme-config.h | 32 + gpgscm/scheme-private.h | 274 +++ gpgscm/scheme.c | 6028 +++++++++++++++++++++++++++++++++++++++++++++ gpgscm/scheme.h | 290 +++ gpgscm/small-integers.h | 847 +++++++ gpgscm/t-child.c | 74 + gpgscm/t-child.scm | 118 + gpgscm/tests.scm | 886 +++++++ gpgscm/time.scm | 42 + gpgscm/xml.scm | 142 ++ init.scm | 823 ------- lib.scm | 307 --- main.c | 359 --- makefile.scm | 76 - opdefines.h | 205 -- private.h | 26 - repl.scm | 69 - scheme-config.h | 32 - scheme-private.h | 274 --- scheme.c | 6028 --------------------------------------------- scheme.h | 290 --- small-integers.h | 847 ------- t-child.c | 74 - t-child.scm | 118 - tests.scm | 886 ------- time.scm | 42 - xml.scm | 142 -- 50 files changed, 12880 insertions(+), 12880 deletions(-) delete mode 100644 LICENSE.TinySCHEME delete mode 100644 Makefile.am delete mode 100644 Manual.txt delete mode 100644 ffi-private.h delete mode 100644 ffi.c delete mode 100644 ffi.h delete mode 100644 ffi.scm delete mode 100644 gnupg.scm create mode 100644 gpgscm/LICENSE.TinySCHEME create mode 100644 gpgscm/Makefile.am create mode 100644 gpgscm/Manual.txt create mode 100644 gpgscm/ffi-private.h create mode 100644 gpgscm/ffi.c create mode 100644 gpgscm/ffi.h create mode 100644 gpgscm/ffi.scm create mode 100644 gpgscm/gnupg.scm create mode 100644 gpgscm/init.scm create mode 100644 gpgscm/lib.scm create mode 100644 gpgscm/main.c create mode 100644 gpgscm/makefile.scm create mode 100644 gpgscm/opdefines.h create mode 100644 gpgscm/private.h create mode 100644 gpgscm/repl.scm create mode 100644 gpgscm/scheme-config.h create mode 100644 gpgscm/scheme-private.h create mode 100644 gpgscm/scheme.c create mode 100644 gpgscm/scheme.h create mode 100644 gpgscm/small-integers.h create mode 100644 gpgscm/t-child.c create mode 100644 gpgscm/t-child.scm create mode 100644 gpgscm/tests.scm create mode 100644 gpgscm/time.scm create mode 100644 gpgscm/xml.scm delete mode 100644 init.scm delete mode 100644 lib.scm delete mode 100644 main.c delete mode 100644 makefile.scm delete mode 100644 opdefines.h delete mode 100644 private.h delete mode 100644 repl.scm delete mode 100644 scheme-config.h delete mode 100644 scheme-private.h delete mode 100644 scheme.c delete mode 100644 scheme.h delete mode 100644 small-integers.h delete mode 100644 t-child.c delete mode 100644 t-child.scm delete mode 100644 tests.scm delete mode 100644 time.scm delete mode 100644 xml.scm diff --git a/LICENSE.TinySCHEME b/LICENSE.TinySCHEME deleted file mode 100644 index 23a7e85..0000000 --- a/LICENSE.TinySCHEME +++ /dev/null @@ -1,31 +0,0 @@ - LICENSE TERMS - -Copyright (c) 2000, Dimitrios Souflis -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -Redistributions in binary form must reproduce the above copyright -notice, this list of conditions and the following disclaimer in the -documentation and/or other materials provided with the distribution. - -Neither the name of Dimitrios Souflis nor the names of the -contributors may be used to endorse or promote products derived from -this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR -CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile.am b/Makefile.am deleted file mode 100644 index 44d7b3f..0000000 --- a/Makefile.am +++ /dev/null @@ -1,64 +0,0 @@ -# TinyScheme-based test driver. -# -# Copyright (C) 2016 g10 Code GmbH -# -# This file is part of GnuPG. -# -# GnuPG is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# GnuPG is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, see . - -EXTRA_DIST = \ - LICENSE.TinySCHEME \ - Manual.txt \ - ffi.scm \ - init.scm \ - lib.scm \ - makefile.scm \ - repl.scm \ - t-child.scm \ - xml.scm \ - tests.scm \ - gnupg.scm \ - time.scm - -AM_CPPFLAGS = -I$(top_srcdir)/common -include $(top_srcdir)/am/cmacros.am - -AM_CFLAGS = - -CLEANFILES = - -bin_PROGRAMS = gpgscm -noinst_PROGRAMS = t-child - -common_libs = ../$(libcommon) -commonpth_libs = ../$(libcommonpth) - -gpgscm_CFLAGS = -imacros scheme-config.h \ - $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) -gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ - scheme-config.h scheme.c scheme.h scheme-private.h \ - opdefines.h small-integers.h -gpgscm_LDADD = $(LDADD) $(common_libs) \ - $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \ - $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) - -t_child_SOURCES = t-child.c - -# Make sure that all libs are build before we use them. This is -# important for things like make -j2. -$(PROGRAMS): $(common_libs) - -check-local: gpgscm$(EXEEXT) t-child$(EXEEXT) - EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \ - ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm diff --git a/Manual.txt b/Manual.txt deleted file mode 100644 index b146926..0000000 --- a/Manual.txt +++ /dev/null @@ -1,444 +0,0 @@ - - - TinySCHEME Version 1.41 - - "Safe if used as prescribed" - -- Philip K. Dick, "Ubik" - -This software is open source, covered by a BSD-style license. -Please read accompanying file COPYING. -------------------------------------------------------------------------------- - - This Scheme interpreter is based on MiniSCHEME version 0.85k4 - (see miniscm.tar.gz in the Scheme Repository) - Original credits in file MiniSCHEMETribute.txt. - - D. Souflis (dsouflis@acm.org) - -------------------------------------------------------------------------------- - What is TinyScheme? - ------------------- - - TinyScheme is a lightweight Scheme interpreter that implements as large - a subset of R5RS as was possible without getting very large and - complicated. It is meant to be used as an embedded scripting interpreter - for other programs. As such, it does not offer IDEs or extensive toolkits - although it does sport a small top-level loop, included conditionally. - A lot of functionality in TinyScheme is included conditionally, to allow - developers freedom in balancing features and footprint. - - As an embedded interpreter, it allows multiple interpreter states to - coexist in the same program, without any interference between them. - Programmatically, foreign functions in C can be added and values - can be defined in the Scheme environment. Being a quite small program, - it is easy to comprehend, get to grips with, and use. - - Known bugs - ---------- - - TinyScheme is known to misbehave when memory is exhausted. - - - Things that keep missing, or that need fixing - --------------------------------------------- - - There are no hygienic macros. No rational or - complex numbers. No unwind-protect and call-with-values. - - Maybe (a subset of) SLIB will work with TinySCHEME... - - Decent debugging facilities are missing. Only tracing is supported - natively. - - - Scheme Reference - ---------------- - - If something seems to be missing, please refer to the code and - "init.scm", since some are library functions. Refer to the MiniSCHEME - readme as a last resort. - - Environments - (interaction-environment) - See R5RS. In TinySCHEME, immutable list of association lists. - - (current-environment) - The environment in effect at the time of the call. An example of its - use and its utility can be found in the sample code that implements - packages in "init.scm": - - (macro (package form) - `(apply (lambda () - ,@(cdr form) - (current-environment)))) - - The environment containing the (local) definitions inside the closure - is returned as an immutable value. - - (defined? ) (defined? ) - Checks whether the given symbol is defined in the current (or given) - environment. - - Symbols - (gensym) - Returns a new interned symbol each time. Will probably move to the - library when string->symbol is implemented. - - Directives - (gc) - Performs garbage collection immediately. - - (gc-verbose) (gc-verbose ) - The argument (defaulting to #t) controls whether GC produces - visible outcome. - - (quit) (quit ) - Stops the interpreter and sets the 'retcode' internal field (defaults - to 0). When standalone, 'retcode' is returned as exit code to the OS. - - (tracing ) - 1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1). - - Mathematical functions - Since rationals and complexes are absent, the respective functions - are also missing. - Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling, - trunc, round and also sqrt and expt when USE_MATH=1. - Number-theoretical quotient, remainder and modulo, gcd, lcm. - Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?, - exact->inexact. inexact->exact is a core function. - - Type predicates - boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?, - char?,port?,input-port?,output-port?,procedure?,pair?,environment?', - vector?. Also closure?, macro?. - - Types - Types supported: - - Numbers (integers and reals) - Symbols - Pairs - Strings - Characters - Ports - Eof object - Environments - Vectors - - Literals - String literals can contain escaped quotes \" as usual, but also - \n, \r, \t, \xDD (hex representations) and \DDD (octal representations). - Note also that it is possible to include literal newlines in string - literals, e.g. - - (define s "String with newline here - and here - that can function like a HERE-string") - - Character literals contain #\space and #\newline and are supplemented - with #\return and #\tab, with obvious meanings. Hex character - representations are allowed (e.g. #\x20 is #\space). - When USE_ASCII_NAMES is defined, various control characters can be - referred to by their ASCII name. - 0 #\nul 17 #\dc1 - 1 #\soh 18 #\dc2 - 2 #\stx 19 #\dc3 - 3 #\etx 20 #\dc4 - 4 #\eot 21 #\nak - 5 #\enq 22 #\syn - 6 #\ack 23 #\etv - 7 #\bel 24 #\can - 8 #\bs 25 #\em - 9 #\ht 26 #\sub - 10 #\lf 27 #\esc - 11 #\vt 28 #\fs - 12 #\ff 29 #\gs - 13 #\cr 30 #\rs - 14 #\so 31 #\us - 15 #\si - 16 #\dle 127 #\del - - Numeric literals support #x #o #b and #d. Flonums are currently read only - in decimal notation. Full grammar will be supported soon. - - Quote, quasiquote etc. - As usual. - - Immutable values - Immutable pairs cannot be modified by set-car! and set-cdr!. - Immutable strings cannot be modified via string-set! - - I/O - As per R5RS, plus String Ports (see below). - current-input-port, current-output-port, - close-input-port, close-output-port, input-port?, output-port?, - open-input-file, open-output-file. - read, write, display, newline, write-char, read-char, peek-char. - char-ready? returns #t only for string ports, because there is no - portable way in stdio to determine if a character is available. - Also open-input-output-file, set-input-port, set-output-port (not R5RS) - Library: call-with-input-file, call-with-output-file, - with-input-from-file, with-output-from-file and - with-input-output-from-to-files, close-port and input-output-port? - (not R5RS). - String Ports: open-input-string, open-output-string, get-output-string, - open-input-output-string. Strings can be used with I/O routines. - - Vectors - make-vector, vector, vector-length, vector-ref, vector-set!, list->vector, - vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS) - - Strings - string, make-string, list->string, string-length, string-ref, string-set!, - substring, string->list, string-fill!, string-append, string-copy. - string=?, string?, string>?, string<=?, string>=?. - (No string-ci*? yet). string->number, number->string. Also atom->string, - string->atom (not R5RS). - - Symbols - symbol->string, string->symbol - - Characters - integer->char, char->integer. - char=?, char?, char<=?, char>=?. - (No char-ci*?) - - Pairs & Lists - cons, car, cdr, list, length, map, for-each, foldr, list-tail, - list-ref, last-pair, reverse, append. - Also member, memq, memv, based on generic-member, assoc, assq, assv - based on generic-assoc. - - Streams - head, tail, cons-stream - - Control features - Apart from procedure?, also macro? and closure? - map, for-each, force, delay, call-with-current-continuation (or call/cc), - eval, apply. 'Forcing' a value that is not a promise produces the value. - There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in - the presence of continuations would require support from the abstract - machine itself. - - Property lists - TinyScheme inherited from MiniScheme property lists for symbols. - put, get. - - Dynamically-loaded extensions - (load-extension ) - Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use - of the ld.so.conf file or the LD_RUN_PATH system variable in order to place - the library in a directory other than the current one. Please refer to the - appropriate 'man' page. - - Esoteric procedures - (oblist) - Returns the oblist, an immutable list of all the symbols. - - (macro-expand
) - Returns the expanded form of the macro call denoted by the argument - - (define-with-return ( ...) ) - Like plain 'define', but makes the continuation available as 'return' - inside the procedure. Handy for imperative programs. - - (new-segment ) - Allocates more memory segments. - - defined? - See "Environments" - - (get-closure-code ) - Gets the code as scheme data. - - (make-closure ) - Makes a new closure in the given environment. - - Obsolete procedures - (print-width ) - - Programmer's Reference - ---------------------- - - The interpreter state is initialized with "scheme_init". - Custom memory allocation routines can be installed with an alternate - initialization function: "scheme_init_custom_alloc". - Files can be loaded with "scheme_load_file". Strings containing Scheme - code can be loaded with "scheme_load_string". It is a good idea to - "scheme_load" init.scm before anything else. - - External data for keeping external state (of use to foreign functions) - can be installed with "scheme_set_external_data". - Foreign functions are installed with "assign_foreign". Additional - definitions can be added to the interpreter state, with "scheme_define" - (this is the way HTTP header data and HTML form data are passed to the - Scheme script in the Altera SQL Server). If you wish to define the - foreign function in a specific environment (to enhance modularity), - use "assign_foreign_env". - - The procedure "scheme_apply0" has been added with persistent scripts in - mind. Persistent scripts are loaded once, and every time they are needed - to produce HTTP output, appropriate data are passed through global - definitions and function "main" is called to do the job. One could - add easily "scheme_apply1" etc. - - The interpreter state should be deinitialized with "scheme_deinit". - - DLLs containing foreign functions should define a function named - init_. E.g. foo.dll should define init_foo, and bar.so - should define init_bar. This function should assign_foreign any foreign - function contained in the DLL. - - The first dynamically loaded extension available for TinyScheme is - a regular expression library. Although it's by no means an - established standard, this library is supposed to be installed in - a directory mirroring its name under the TinyScheme location. - - - Foreign Functions - ----------------- - - The user can add foreign functions in C. For example, a function - that squares its argument: - - pointer square(scheme *sc, pointer args) { - if(args!=sc->NIL) { - if(sc->isnumber(sc->pair_car(args))) { - double v=sc->rvalue(sc->pair_car(args)); - return sc->mk_real(sc,v*v); - } - } - return sc->NIL; - } - - Foreign functions are now defined as closures: - - sc->interface->scheme_define( - sc, - sc->global_env, - sc->interface->mk_symbol(sc,"square"), - sc->interface->mk_foreign_func(sc, square)); - - - Foreign functions can use the external data in the "scheme" struct - to implement any kind of external state. - - External data are set with the following function: - void scheme_set_external_data(scheme *sc, void *p); - - As of v.1.17, the canonical way for a foreign function in a DLL to - manipulate Scheme data is using the function pointers in sc->interface. - - Standalone - ---------- - - Usage: tinyscheme -? - or: tinyscheme [ ...] - followed by - -1 [ ...] - -c [ ...] - assuming that the executable is named tinyscheme. - - Use - in the place of a filename to denote stdin. - The -1 flag is meant for #! usage in shell scripts. If you specify - #! /somewhere/tinyscheme -1 - then tinyscheme will be called to process the file. For example, the - following script echoes the Scheme list of its arguments. - - #! /somewhere/tinyscheme -1 - (display *args*) - - The -c flag permits execution of arbitrary Scheme code. - - - Error Handling - -------------- - - Errors are recovered from without damage. The user can install his - own handler for system errors, by defining *error-hook*. Defining - to '() gives the default behavior, which is equivalent to "error". - USE_ERROR_HOOK must be defined. - - A simple exception handling mechanism can be found in "init.scm". - A new syntactic form is introduced: - - (catch - ... ) - - "Catch" establishes a scope spanning multiple call-frames - until another "catch" is encountered. - - Exceptions are thrown with: - - (throw "message") - - If used outside a (catch ...), reverts to (error "message"). - - Example of use: - - (define (foo x) (write x) (newline) (/ x 0)) - - (catch (begin (display "Error!\n") 0) - (write "Before foo ... ") - (foo 5) - (write "After foo")) - - The exception mechanism can be used even by system errors, by - - (define *error-hook* throw) - - which makes use of the error hook described above. - - If necessary, the user can devise his own exception mechanism with - tagged exceptions etc. - - - Reader extensions - ----------------- - - When encountering an unknown character after '#', the user-specified - procedure *sharp-hook* (if any), is called to read the expression. - This can be used to extend the reader to handle user-defined constants - or whatever. It should be a procedure without arguments, reading from - the current input port (which will be the load-port). - - - Colon Qualifiers - Packages - --------------------------- - - When USE_COLON_HOOK=1: - The lexer now recognizes the construction :: and - transforms it in the following manner (T is the transformation function): - - T(::) = (*colon-hook* 'T() ) - - where is a symbol not containing any double-colons. - - As the definition is recursive, qualifiers can be nested. - The user can define his own *colon-hook*, to handle qualified names. - By default, "init.scm" defines *colon-hook* as EVAL. Consequently, - the qualifier must denote a Scheme environment, such as one returned - by (interaction-environment). "Init.scm" defines a new syntantic form, - PACKAGE, as a simple example. It is used like this: - - (define toto - (package - (define foo 1) - (define bar +))) - - foo ==> Error, "foo" undefined - (eval 'foo) ==> Error, "foo" undefined - (eval 'foo toto) ==> 1 - toto::foo ==> 1 - ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 - (toto::bar 2 toto::foo) ==> 3 - (eval (bar 2 foo) toto) ==> 3 - - If the user installs another package infrastructure, he must define - a new 'package' procedure or macro to retain compatibility with supplied - code. - - Note: Older versions used ':' as a qualifier. Unfortunately, the use - of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially - precludes its use as a real qualifier. diff --git a/ffi-private.h b/ffi-private.h deleted file mode 100644 index 037da56..0000000 --- a/ffi-private.h +++ /dev/null @@ -1,148 +0,0 @@ -/* FFI interface for TinySCHEME. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#ifndef GPGSCM_FFI_PRIVATE_H -#define GPGSCM_FFI_PRIVATE_H - -#include -#include "scheme.h" -#include "scheme-private.h" - -#define FFI_PROLOG() \ - unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1; \ - int err GPGRT_ATTR_UNUSED = 0 \ - -int ffi_bool_value (scheme *sc, pointer p); - -#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X) -#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X) -#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X) -#define CONVERSION_list(SC, X) (X) -#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X)) -#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \ - ? (SC)->vptr->string_value \ - : (SC)->vptr->symname) (X)) - -#define IS_A_number(SC, X) (SC)->vptr->is_number (X) -#define IS_A_string(SC, X) (SC)->vptr->is_string (X) -#define IS_A_character(SC, X) (SC)->vptr->is_character (X) -#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X) -#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T) -#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ - || (SC)->vptr->is_symbol (X)) - -#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS) \ - do { \ - if ((ARGS) == (SC)->NIL) \ - return (SC)->vptr->mk_string ((SC), \ - "too few arguments: want " \ - #TARGET "("#WANT"/"#CTYPE")\n"); \ - if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \ - char ffi_error_message[256]; \ - snprintf (ffi_error_message, sizeof ffi_error_message, \ - "argument %d must be: " #WANT "\n", ffi_arg_index); \ - return (SC)->vptr->mk_string ((SC), ffi_error_message); \ - } \ - TARGET = CONVERSION_##WANT (SC, pair_car (ARGS)); \ - ARGS = pair_cdr (ARGS); \ - ffi_arg_index += 1; \ - } while (0) - -#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS) \ - do { \ - if ((ARGS) != (SC)->NIL) \ - return (SC)->vptr->mk_string ((SC), "too many arguments"); \ - } while (0) - -#define FFI_RETURN_ERR(SC, ERR) \ - return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1) - -#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err) - -#define FFI_RETURN_POINTER(SC, X) \ - return _cons ((SC), mk_integer ((SC), err), \ - _cons ((SC), (X), (SC)->NIL, 1), 1) -#define FFI_RETURN_INT(SC, X) \ - FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X))) -#define FFI_RETURN_STRING(SC, X) \ - FFI_RETURN_POINTER ((SC), mk_string ((SC), (X))) - -char *ffi_schemify_name (const char *s, int macro); - -void ffi_scheme_eval (scheme *sc, const char *format, ...) - GPGRT_ATTR_PRINTF (2, 3); -pointer ffi_sprintf (scheme *sc, const char *format, ...) - GPGRT_ATTR_PRINTF (2, 3); - -#define ffi_define_function_name(SC, NAME, F) \ - do { \ - char *_fname = ffi_schemify_name ("__" #F, 0); \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), _fname), \ - mk_foreign_func ((SC), (do_##F))); \ - ffi_scheme_eval ((SC), \ - "(define (%s . a) (ffi-apply \"%s\" %s a))", \ - (NAME), (NAME), _fname); \ - free (_fname); \ - } while (0) - -#define ffi_define_function(SC, F) \ - do { \ - char *_name = ffi_schemify_name (#F, 0); \ - ffi_define_function_name ((SC), _name, F); \ - free (_name); \ - } while (0) - -#define ffi_define_constant(SC, C) \ - do { \ - char *_name = ffi_schemify_name (#C, 1); \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), _name), \ - mk_integer ((SC), (C))); \ - free (_name); \ - } while (0) - -#define ffi_define(SC, SYM, EXP) \ - scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP) - -#define ffi_define_variable_pointer(SC, C, P) \ - do { \ - char *_name = ffi_schemify_name (#C, 0); \ - scheme_define ((SC), \ - (SC)->global_env, \ - mk_symbol ((SC), _name), \ - (P)); \ - free (_name); \ - } while (0) - -#define ffi_define_variable_integer(SC, C) \ - ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C)) - -#define ffi_define_variable_string(SC, C) \ - ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: "")) - -gpg_error_t ffi_list2argv (scheme *sc, pointer list, - char ***argv, size_t *len); -gpg_error_t ffi_list2intv (scheme *sc, pointer list, - int **intv, size_t *len); - -#endif /* GPGSCM_FFI_PRIVATE_H */ diff --git a/ffi.c b/ffi.c deleted file mode 100644 index dde5b52..0000000 --- a/ffi.c +++ /dev/null @@ -1,1470 +0,0 @@ -/* FFI interface for TinySCHEME. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#if HAVE_LIBREADLINE -#define GNUPG_LIBREADLINE_H_INCLUDED -#include -#include -#endif - -#include "../../common/util.h" -#include "../../common/exechelp.h" -#include "../../common/sysutils.h" - -#include "private.h" -#include "ffi.h" -#include "ffi-private.h" - -/* For use in nice error messages. */ -static const char * -ordinal_suffix (int n) -{ - switch (n) - { - case 1: return "st"; - case 2: return "nd"; - case 3: return "rd"; - default: return "th"; - } - assert (! "reached"); -} - - - -int -ffi_bool_value (scheme *sc, pointer p) -{ - return ! (p == sc->F); -} - - - -static pointer -do_logand (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v, acc = ~0; - while (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - acc &= v; - } - FFI_RETURN_INT (sc, acc); -} - -static pointer -do_logior (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v, acc = 0; - while (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - acc |= v; - } - FFI_RETURN_INT (sc, acc); -} - -static pointer -do_logxor (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v, acc = 0; - while (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - acc ^= v; - } - FFI_RETURN_INT (sc, acc); -} - -static pointer -do_lognot (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int v; - FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, ~v); -} - -/* User interface. */ - -static pointer -do_flush_stdio (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - fflush (stdout); - fflush (stderr); - FFI_RETURN (sc); -} - - -int use_libreadline; - -/* Read a string, and return a pointer to it. Returns NULL on EOF. */ -char * -rl_gets (const char *prompt) -{ - static char *line = NULL; - char *p; - xfree (line); - -#if HAVE_LIBREADLINE - { - line = readline (prompt); - if (line && *line) - add_history (line); - } -#else - { - size_t max_size = 0xff; - printf ("%s", prompt); - fflush (stdout); - line = xtrymalloc (max_size); - if (line != NULL) - fgets (line, max_size, stdin); - } -#endif - - /* Strip trailing whitespace. */ - if (line && strlen (line) > 0) - for (p = &line[strlen (line) - 1]; isspace (*p); p--) - *p = 0; - - return line; -} - -static pointer -do_prompt (scheme *sc, pointer args) -{ - FFI_PROLOG (); - const char *prompt; - const char *line; - FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - line = rl_gets (prompt); - if (! line) - FFI_RETURN_POINTER (sc, sc->EOF_OBJ); - - FFI_RETURN_STRING (sc, line); -} - -static pointer -do_sleep (scheme *sc, pointer args) -{ - FFI_PROLOG (); - unsigned int seconds; - FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - sleep (seconds); - FFI_RETURN (sc); -} - -static pointer -do_usleep (scheme *sc, pointer args) -{ - FFI_PROLOG (); - useconds_t microseconds; - FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - usleep (microseconds); - FFI_RETURN (sc); -} - -static pointer -do_chdir (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, path, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (chdir (name)) - FFI_RETURN_ERR (sc, errno); - FFI_RETURN (sc); -} - -static pointer -do_strerror (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int error; - FFI_ARG_OR_RETURN (sc, int, error, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_STRING (sc, gpg_strerror (error)); -} - -static pointer -do_getenv (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - char *value; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - value = getenv (name); - FFI_RETURN_STRING (sc, value ? value : ""); -} - -static pointer -do_setenv (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - char *value; - int overwrite; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARG_OR_RETURN (sc, char *, value, string, args); - FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (gnupg_setenv (name, value, overwrite)) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_exit (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int retcode; - FFI_ARG_OR_RETURN (sc, int, retcode, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - exit (retcode); -} - -/* XXX: use gnupgs variant b/c mode as string */ -static pointer -do_open (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int fd; - char *pathname; - int flags; - mode_t mode = 0; - FFI_ARG_OR_RETURN (sc, char *, pathname, path, args); - FFI_ARG_OR_RETURN (sc, int, flags, number, args); - if (args != sc->NIL) - FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - fd = open (pathname, flags, mode); - if (fd == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN_INT (sc, fd); -} - -static pointer -do_fdopen (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FILE *stream; - int fd; - char *mode; - int kind; - FFI_ARG_OR_RETURN (sc, int, fd, number, args); - FFI_ARG_OR_RETURN (sc, char *, mode, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - stream = fdopen (fd, mode); - if (stream == NULL) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - - if (setvbuf (stream, NULL, _IONBF, 0) != 0) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - - kind = 0; - if (strchr (mode, 'r')) - kind |= port_input; - if (strchr (mode, 'w')) - kind |= port_output; - - FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind)); -} - -static pointer -do_close (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int fd; - FFI_ARG_OR_RETURN (sc, int, fd, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); -} - -static pointer -do_seek (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int fd; - off_t offset; - int whence; - FFI_ARG_OR_RETURN (sc, int, fd, number, args); - FFI_ARG_OR_RETURN (sc, off_t, offset, number, args); - FFI_ARG_OR_RETURN (sc, int, whence, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1 - ? gpg_error_from_syserror () : 0); -} - -static pointer -do_get_temp_path (scheme *sc, pointer args) -{ - FFI_PROLOG (); -#ifdef HAVE_W32_SYSTEM - char buffer[MAX_PATH+1]; -#endif - FFI_ARGS_DONE_OR_RETURN (sc, args); - -#ifdef HAVE_W32_SYSTEM - if (GetTempPath (MAX_PATH+1, buffer) == 0) - FFI_RETURN_STRING (sc, "/temp"); - FFI_RETURN_STRING (sc, buffer); -#else - FFI_RETURN_STRING (sc, "/tmp"); -#endif -} - -static pointer -do_mkdtemp (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *template; -#ifdef PATH_MAX - char buffer[PATH_MAX]; -#else - char buffer[1024]; -#endif - char *name; - FFI_ARG_OR_RETURN (sc, char *, template, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - if (strlen (template) > sizeof buffer - 1) - FFI_RETURN_ERR (sc, EINVAL); - strncpy (buffer, template, sizeof buffer); - - name = gnupg_mkdtemp (buffer); - if (name == NULL) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN_STRING (sc, name); -} - -static pointer -do_unlink (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (unlink (name) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static gpg_error_t -unlink_recursively (const char *name) -{ - gpg_error_t err = 0; - struct stat st; - - if (stat (name, &st) == -1) - return gpg_error_from_syserror (); - - if (S_ISDIR (st.st_mode)) - { - DIR *dir; - struct dirent *dent; - - dir = opendir (name); - if (dir == NULL) - return gpg_error_from_syserror (); - - while ((dent = readdir (dir))) - { - char *child; - - if (strcmp (dent->d_name, ".") == 0 - || strcmp (dent->d_name, "..") == 0) - continue; - - child = xtryasprintf ("%s/%s", name, dent->d_name); - if (child == NULL) - { - err = gpg_error_from_syserror (); - goto leave; - } - - err = unlink_recursively (child); - xfree (child); - if (err == gpg_error_from_errno (ENOENT)) - err = 0; - if (err) - goto leave; - } - - leave: - closedir (dir); - if (! err) - rmdir (name); - return err; - } - else - if (unlink (name) == -1) - return gpg_error_from_syserror (); - return 0; -} - -static pointer -do_unlink_recursively (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = unlink_recursively (name); - FFI_RETURN (sc); -} - -static pointer -do_rename (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *old; - char *new; - FFI_ARG_OR_RETURN (sc, char *, old, string, args); - FFI_ARG_OR_RETURN (sc, char *, new, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (rename (old, new) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_getcwd (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer result; - char *cwd; - FFI_ARGS_DONE_OR_RETURN (sc, args); - cwd = gnupg_getcwd (); - if (cwd == NULL) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - result = sc->vptr->mk_string (sc, cwd); - xfree (cwd); - FFI_RETURN_POINTER (sc, result); -} - -static pointer -do_mkdir (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - char *mode; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARG_OR_RETURN (sc, char *, mode, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (gnupg_mkdir (name, mode) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_rmdir (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *name; - FFI_ARG_OR_RETURN (sc, char *, name, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (rmdir (name) == -1) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - FFI_RETURN (sc); -} - -static pointer -do_get_isotime (scheme *sc, pointer args) -{ - FFI_PROLOG (); - gnupg_isotime_t timebuf; - FFI_ARGS_DONE_OR_RETURN (sc, args); - gnupg_get_isotime (timebuf); - FFI_RETURN_STRING (sc, timebuf); -} - -static pointer -do_get_time (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, gnupg_get_time ()); -} - -static pointer -do_getpid (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, getpid ()); -} - -static pointer -do_srandom (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int seed; - FFI_ARG_OR_RETURN (sc, int, seed, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - srand (seed); - FFI_RETURN (sc); -} - -static int -random_scaled (int scale) -{ - int v; -#ifdef HAVE_RAND - v = rand (); -#else - v = random (); -#endif - -#ifndef RAND_MAX /* for SunOS */ -#define RAND_MAX 32767 -#endif - - return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1); -} - -static pointer -do_random (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int scale; - FFI_ARG_OR_RETURN (sc, int, scale, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, random_scaled (scale)); -} - -static pointer -do_make_random_string (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int size; - pointer chunk; - char *p; - FFI_ARG_OR_RETURN (sc, int, size, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - if (size < 0) - return ffi_sprintf (sc, "size must be positive"); - - chunk = sc->vptr->mk_counted_string (sc, NULL, size); - if (sc->no_memory) - FFI_RETURN_ERR (sc, ENOMEM); - - for (p = sc->vptr->string_value (chunk); size; p++, size--) - *p = (char) random_scaled (256); - FFI_RETURN_POINTER (sc, chunk); -} - - - -/* estream functions. */ - -struct es_object_box -{ - estream_t stream; - int closed; -}; - -static void -es_object_finalize (scheme *sc, void *data) -{ - struct es_object_box *box = data; - (void) sc; - - if (! box->closed) - es_fclose (box->stream); - xfree (box); -} - -static void -es_object_to_string (scheme *sc, char *out, size_t size, void *data) -{ - struct es_object_box *box = data; - (void) sc; - - snprintf (out, size, "#estream %p", box->stream); -} - -static struct foreign_object_vtable es_object_vtable = - { - es_object_finalize, - es_object_to_string, - }; - -static pointer -es_wrap (scheme *sc, estream_t stream) -{ - struct es_object_box *box = xmalloc (sizeof *box); - if (box == NULL) - return sc->NIL; - - box->stream = stream; - box->closed = 0; - return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box); -} - -static struct es_object_box * -es_unwrap (scheme *sc, pointer object) -{ - (void) sc; - - if (! is_foreign_object (object)) - return NULL; - - if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable) - return NULL; - - return sc->vptr->get_foreign_object_data (object); -} - -#define CONVERSION_estream(SC, X) es_unwrap (SC, X) -#define IS_A_estream(SC, X) es_unwrap (SC, X) - -static pointer -do_es_fclose (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = es_fclose (box->stream); - if (! err) - box->closed = 1; - FFI_RETURN (sc); -} - -static pointer -do_es_read (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - size_t bytes_to_read; - - pointer result; - void *buffer; - size_t bytes_read; - - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - buffer = xtrymalloc (bytes_to_read); - if (buffer == NULL) - FFI_RETURN_ERR (sc, ENOMEM); - - err = es_read (box->stream, buffer, bytes_to_read, &bytes_read); - if (err) - FFI_RETURN_ERR (sc, err); - - result = sc->vptr->mk_counted_string (sc, buffer, bytes_read); - xfree (buffer); - FFI_RETURN_POINTER (sc, result); -} - -static pointer -do_es_feof (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F); -} - -static pointer -do_es_write (scheme *sc, pointer args) -{ - FFI_PROLOG (); - struct es_object_box *box; - const char *buffer; - size_t bytes_to_write, bytes_written; - - FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); - /* XXX how to get the length of the string buffer? scheme strings - may contain \0. */ - FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - bytes_to_write = strlen (buffer); - while (bytes_to_write > 0) - { - err = es_write (box->stream, buffer, bytes_to_write, &bytes_written); - if (err) - break; - bytes_to_write -= bytes_written; - buffer += bytes_written; - } - - FFI_RETURN (sc); -} - - - -/* Process handling. */ - -static pointer -do_spawn_process (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer arguments; - char **argv; - size_t len; - unsigned int flags; - - estream_t infp; - estream_t outfp; - estream_t errfp; - pid_t pid; - - FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); - FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - err = ffi_list2argv (sc, arguments, &argv, &len); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%luth element of first argument is " - "neither string nor symbol", - (unsigned long) len); - if (err) - FFI_RETURN_ERR (sc, err); - - if (verbose > 1) - { - char **p; - fprintf (stderr, "Executing:"); - for (p = argv; *p; p++) - fprintf (stderr, " '%s'", *p); - fprintf (stderr, "\n"); - } - - err = gnupg_spawn_process (argv[0], (const char **) &argv[1], - NULL, - NULL, - flags, - &infp, &outfp, &errfp, &pid); - xfree (argv); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) -#define IMS(A, B) \ - _cons (sc, es_wrap (sc, (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMS (infp, - IMS (outfp, - IMS (errfp, - IMC (pid, sc->NIL))))); -#undef IMS -#undef IMC -} - -static pointer -do_spawn_process_fd (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer arguments; - char **argv; - size_t len; - int infd, outfd, errfd; - - pid_t pid; - - FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); - FFI_ARG_OR_RETURN (sc, int, infd, number, args); - FFI_ARG_OR_RETURN (sc, int, outfd, number, args); - FFI_ARG_OR_RETURN (sc, int, errfd, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - err = ffi_list2argv (sc, arguments, &argv, &len); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%luth element of first argument is " - "neither string nor symbol", - (unsigned long) len); - if (err) - FFI_RETURN_ERR (sc, err); - - if (verbose > 1) - { - char **p; - fprintf (stderr, "Executing:"); - for (p = argv; *p; p++) - fprintf (stderr, " '%s'", *p); - fprintf (stderr, "\n"); - } - - err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1], - infd, outfd, errfd, &pid); - xfree (argv); - FFI_RETURN_INT (sc, pid); -} - -static pointer -do_wait_process (scheme *sc, pointer args) -{ - FFI_PROLOG (); - const char *name; - pid_t pid; - int hang; - - int retcode; - - FFI_ARG_OR_RETURN (sc, const char *, name, string, args); - FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args); - FFI_ARG_OR_RETURN (sc, int, hang, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_wait_process (name, pid, hang, &retcode); - if (err == GPG_ERR_GENERAL) - err = 0; /* Let the return code speak for itself. */ - - FFI_RETURN_INT (sc, retcode); -} - - -static pointer -do_wait_processes (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer list_names; - char **names; - pointer list_pids; - size_t i, count; - pid_t *pids; - int hang; - int *retcodes; - pointer retcodes_list = sc->NIL; - - FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args); - FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args); - FFI_ARG_OR_RETURN (sc, int, hang, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - if (sc->vptr->list_length (sc, list_names) - != sc->vptr->list_length (sc, list_pids)) - return - sc->vptr->mk_string (sc, "length of first two arguments must match"); - - err = ffi_list2argv (sc, list_names, &names, &count); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%lu%s element of first argument is " - "neither string nor symbol", - (unsigned long) count, - ordinal_suffix ((int) count)); - if (err) - FFI_RETURN_ERR (sc, err); - - err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); - if (err == gpg_error (GPG_ERR_INV_VALUE)) - return ffi_sprintf (sc, "%lu%s element of second argument is " - "not a number", - (unsigned long) count, - ordinal_suffix ((int) count)); - if (err) - FFI_RETURN_ERR (sc, err); - - retcodes = xtrycalloc (sizeof *retcodes, count); - if (retcodes == NULL) - { - xfree (names); - xfree (pids); - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - } - - err = gnupg_wait_processes ((const char **) names, pids, count, hang, - retcodes); - if (err == GPG_ERR_GENERAL) - err = 0; /* Let the return codes speak. */ - if (err == GPG_ERR_TIMEOUT) - err = 0; /* We may have got some results. */ - - for (i = 0; i < count; i++) - retcodes_list = - (sc->vptr->cons) (sc, - sc->vptr->mk_integer (sc, - (long) retcodes[count-1-i]), - retcodes_list); - - xfree (names); - xfree (pids); - xfree (retcodes); - FFI_RETURN_POINTER (sc, retcodes_list); -} - - -static pointer -do_pipe (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int filedes[2]; - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_create_pipe (filedes); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMC (filedes[0], - IMC (filedes[1], sc->NIL))); -#undef IMC -} - -static pointer -do_inbound_pipe (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int filedes[2]; - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_create_inbound_pipe (filedes, NULL, 0); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMC (filedes[0], - IMC (filedes[1], sc->NIL))); -#undef IMC -} - -static pointer -do_outbound_pipe (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int filedes[2]; - FFI_ARGS_DONE_OR_RETURN (sc, args); - err = gnupg_create_outbound_pipe (filedes, NULL, 0); -#define IMC(A, B) \ - _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) - FFI_RETURN_POINTER (sc, IMC (filedes[0], - IMC (filedes[1], sc->NIL))); -#undef IMC -} - - - -/* Test helper functions. */ -static pointer -do_file_equal (scheme *sc, pointer args) -{ - FFI_PROLOG (); - pointer result = sc->F; - char *a_name, *b_name; - int binary; - const char *mode; - FILE *a_stream = NULL, *b_stream = NULL; - struct stat a_stat, b_stat; -#define BUFFER_SIZE 1024 - char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE]; -#undef BUFFER_SIZE - size_t chunk; - - FFI_ARG_OR_RETURN (sc, char *, a_name, string, args); - FFI_ARG_OR_RETURN (sc, char *, b_name, string, args); - FFI_ARG_OR_RETURN (sc, int, binary, bool, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - mode = binary ? "rb" : "r"; - a_stream = fopen (a_name, mode); - if (a_stream == NULL) - goto errout; - - b_stream = fopen (b_name, mode); - if (b_stream == NULL) - goto errout; - - if (fstat (fileno (a_stream), &a_stat) < 0) - goto errout; - - if (fstat (fileno (b_stream), &b_stat) < 0) - goto errout; - - if (binary && a_stat.st_size != b_stat.st_size) - { - if (verbose) - fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n", - a_name, b_name, (unsigned long) a_stat.st_size, - (unsigned long) b_stat.st_size); - - goto out; - } - - while (! feof (a_stream)) - { - chunk = sizeof a_buf; - - chunk = fread (a_buf, 1, chunk, a_stream); - if (chunk == 0 && ferror (a_stream)) - goto errout; /* some error */ - - if (fread (b_buf, 1, chunk, b_stream) < chunk) - { - if (feof (b_stream)) - goto out; /* short read */ - goto errout; /* some error */ - } - - if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0) - goto out; - } - - fread (b_buf, 1, 1, b_stream); - if (! feof (b_stream)) - goto out; /* b is longer */ - - /* They match. */ - result = sc->T; - - out: - if (a_stream) - fclose (a_stream); - if (b_stream) - fclose (b_stream); - FFI_RETURN_POINTER (sc, result); - errout: - err = gpg_error_from_syserror (); - goto out; -} - -static pointer -do_splice (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int source; - char buffer[1024]; - ssize_t bytes_read; - pointer sinks, sink; - FFI_ARG_OR_RETURN (sc, int, source, number, args); - sinks = args; - if (sinks == sc->NIL) - return ffi_sprintf (sc, "need at least one sink"); - for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++) - if (! sc->vptr->is_number (pair_car (sink))) - return ffi_sprintf (sc, "%d%s argument is not a number", - ffi_arg_index, ordinal_suffix (ffi_arg_index)); - - while (1) - { - bytes_read = read (source, buffer, sizeof buffer); - if (bytes_read == 0) - break; - if (bytes_read < 0) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - - for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink)) - { - int fd = sc->vptr->ivalue (pair_car (sink)); - char *p = buffer; - ssize_t left = bytes_read; - - while (left) - { - ssize_t written = write (fd, p, left); - if (written < 0) - FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); - assert (written <= left); - left -= written; - p += written; - } - } - } - FFI_RETURN (sc); -} - -static pointer -do_string_index (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *haystack; - char needle; - ssize_t offset = 0; - char *position; - FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); - FFI_ARG_OR_RETURN (sc, char, needle, character, args); - if (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); - if (offset < 0) - return ffi_sprintf (sc, "offset must be positive"); - if (offset > strlen (haystack)) - return ffi_sprintf (sc, "offset exceeds haystack"); - } - FFI_ARGS_DONE_OR_RETURN (sc, args); - - position = strchr (haystack+offset, needle); - if (position) - FFI_RETURN_INT (sc, position - haystack); - else - FFI_RETURN_POINTER (sc, sc->F); -} - -static pointer -do_string_rindex (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *haystack; - char needle; - ssize_t offset = 0; - char *position; - FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); - FFI_ARG_OR_RETURN (sc, char, needle, character, args); - if (args != sc->NIL) - { - FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); - if (offset < 0) - return ffi_sprintf (sc, "offset must be positive"); - if (offset > strlen (haystack)) - return ffi_sprintf (sc, "offset exceeds haystack"); - } - FFI_ARGS_DONE_OR_RETURN (sc, args); - - position = strrchr (haystack+offset, needle); - if (position) - FFI_RETURN_INT (sc, position - haystack); - else - FFI_RETURN_POINTER (sc, sc->F); -} - -static pointer -do_string_contains (scheme *sc, pointer args) -{ - FFI_PROLOG (); - char *haystack; - char *needle; - FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); - FFI_ARG_OR_RETURN (sc, char *, needle, string, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); -} - - - -static pointer -do_get_verbose (scheme *sc, pointer args) -{ - FFI_PROLOG (); - FFI_ARGS_DONE_OR_RETURN (sc, args); - FFI_RETURN_INT (sc, verbose); -} - -static pointer -do_set_verbose (scheme *sc, pointer args) -{ - FFI_PROLOG (); - int new_verbosity, old; - FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args); - FFI_ARGS_DONE_OR_RETURN (sc, args); - - old = verbose; - verbose = new_verbosity; - - FFI_RETURN_INT (sc, old); -} - - -gpg_error_t -ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) -{ - int i; - - *len = sc->vptr->list_length (sc, list); - *argv = xtrycalloc (*len + 1, sizeof **argv); - if (*argv == NULL) - return gpg_error_from_syserror (); - - for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) - { - if (sc->vptr->is_string (sc->vptr->pair_car (list))) - (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list)); - else if (sc->vptr->is_symbol (sc->vptr->pair_car (list))) - (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list)); - else - { - xfree (*argv); - *argv = NULL; - *len = i; - return gpg_error (GPG_ERR_INV_VALUE); - } - } - (*argv)[i] = NULL; - return 0; -} - -gpg_error_t -ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) -{ - int i; - - *len = sc->vptr->list_length (sc, list); - *intv = xtrycalloc (*len, sizeof **intv); - if (*intv == NULL) - return gpg_error_from_syserror (); - - for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) - { - if (sc->vptr->is_number (sc->vptr->pair_car (list))) - (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list)); - else - { - xfree (*intv); - *intv = NULL; - *len = i; - return gpg_error (GPG_ERR_INV_VALUE); - } - } - - return 0; -} - - -char * -ffi_schemify_name (const char *s, int macro) -{ - /* Fixme: We should use xtrystrdup and return NULL. However, this - * requires a lot more changes. Simply returning S as done - * originally is not an option. */ - char *n = xstrdup (s), *p; - /* if (n == NULL) */ - /* return s; */ - - for (p = n; *p; p++) - { - *p = (char) tolower (*p); - /* We convert _ to - in identifiers. We allow, however, for - function names to start with a leading _. The functions in - this namespace are not yet finalized and might change or - vanish without warning. Use them with care. */ - if (! macro - && p != n - && *p == '_') - *p = '-'; - } - return n; -} - -pointer -ffi_sprintf (scheme *sc, const char *format, ...) -{ - pointer result; - va_list listp; - char *expression; - int size, written; - - va_start (listp, format); - size = vsnprintf (NULL, 0, format, listp); - va_end (listp); - - expression = xtrymalloc (size + 1); - if (expression == NULL) - return NULL; - - va_start (listp, format); - written = vsnprintf (expression, size + 1, format, listp); - va_end (listp); - - assert (size == written); - - result = sc->vptr->mk_string (sc, expression); - xfree (expression); - return result; -} - -void -ffi_scheme_eval (scheme *sc, const char *format, ...) -{ - va_list listp; - char *expression; - int size, written; - - va_start (listp, format); - size = vsnprintf (NULL, 0, format, listp); - va_end (listp); - - expression = xtrymalloc (size + 1); - if (expression == NULL) - return; - - va_start (listp, format); - written = vsnprintf (expression, size + 1, format, listp); - va_end (listp); - - assert (size == written); - - sc->vptr->load_string (sc, expression); - xfree (expression); -} - -gpg_error_t -ffi_init (scheme *sc, const char *argv0, const char *scriptname, - int argc, const char **argv) -{ - int i; - pointer args = sc->NIL; - - /* bitwise arithmetic */ - ffi_define_function (sc, logand); - ffi_define_function (sc, logior); - ffi_define_function (sc, logxor); - ffi_define_function (sc, lognot); - - /* libc. */ - ffi_define_constant (sc, O_RDONLY); - ffi_define_constant (sc, O_WRONLY); - ffi_define_constant (sc, O_RDWR); - ffi_define_constant (sc, O_CREAT); - ffi_define_constant (sc, O_APPEND); -#ifndef O_BINARY -# define O_BINARY 0 -#endif -#ifndef O_TEXT -# define O_TEXT 0 -#endif - ffi_define_constant (sc, O_BINARY); - ffi_define_constant (sc, O_TEXT); - ffi_define_constant (sc, STDIN_FILENO); - ffi_define_constant (sc, STDOUT_FILENO); - ffi_define_constant (sc, STDERR_FILENO); - ffi_define_constant (sc, SEEK_SET); - ffi_define_constant (sc, SEEK_CUR); - ffi_define_constant (sc, SEEK_END); - - ffi_define_function (sc, sleep); - ffi_define_function (sc, usleep); - ffi_define_function (sc, chdir); - ffi_define_function (sc, strerror); - ffi_define_function (sc, getenv); - ffi_define_function (sc, setenv); - ffi_define_function_name (sc, "_exit", exit); - ffi_define_function (sc, open); - ffi_define_function (sc, fdopen); - ffi_define_function (sc, close); - ffi_define_function (sc, seek); - ffi_define_function (sc, get_temp_path); - ffi_define_function_name (sc, "_mkdtemp", mkdtemp); - ffi_define_function (sc, unlink); - ffi_define_function (sc, unlink_recursively); - ffi_define_function (sc, rename); - ffi_define_function (sc, getcwd); - ffi_define_function (sc, mkdir); - ffi_define_function (sc, rmdir); - ffi_define_function (sc, get_isotime); - ffi_define_function (sc, get_time); - ffi_define_function (sc, getpid); - - /* Random numbers. */ - ffi_define_function (sc, srandom); - ffi_define_function (sc, random); - ffi_define_function (sc, make_random_string); - - /* Process management. */ - ffi_define_function (sc, spawn_process); - ffi_define_function (sc, spawn_process_fd); - ffi_define_function (sc, wait_process); - ffi_define_function (sc, wait_processes); - ffi_define_function (sc, pipe); - ffi_define_function (sc, inbound_pipe); - ffi_define_function (sc, outbound_pipe); - - /* estream functions. */ - ffi_define_function_name (sc, "es-fclose", es_fclose); - ffi_define_function_name (sc, "es-read", es_read); - ffi_define_function_name (sc, "es-feof", es_feof); - ffi_define_function_name (sc, "es-write", es_write); - - /* Test helper functions. */ - ffi_define_function (sc, file_equal); - ffi_define_function (sc, splice); - ffi_define_function (sc, string_index); - ffi_define_function (sc, string_rindex); - ffi_define_function_name (sc, "string-contains?", string_contains); - - /* User interface. */ - ffi_define_function (sc, flush_stdio); - ffi_define_function (sc, prompt); - - /* Configuration. */ - ffi_define_function_name (sc, "*verbose*", get_verbose); - ffi_define_function_name (sc, "*set-verbose!*", set_verbose); - - ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); - ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname)); - for (i = argc - 1; i >= 0; i--) - { - pointer value = sc->vptr->mk_string (sc, argv[i]); - args = (sc->vptr->cons) (sc, value, args); - } - ffi_define (sc, "*args*", args); - -#if _WIN32 - ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';')); -#else - ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); -#endif - - ffi_define (sc, "*win32*", -#if _WIN32 - sc->T -#else - sc->F -#endif - ); - - ffi_define (sc, "*maintainer-mode*", -#if MAINTAINER_MODE - sc->T -#else - sc->F -#endif - ); - - ffi_define (sc, "*run-all-tests*", -#if RUN_ALL_TESTS - sc->T -#else - sc->F -#endif - ); - - - ffi_define (sc, "*stdin*", - sc->vptr->mk_port_from_file (sc, stdin, port_input)); - ffi_define (sc, "*stdout*", - sc->vptr->mk_port_from_file (sc, stdout, port_output)); - ffi_define (sc, "*stderr*", - sc->vptr->mk_port_from_file (sc, stderr, port_output)); - - return 0; -} diff --git a/ffi.h b/ffi.h deleted file mode 100644 index eba6282..0000000 --- a/ffi.h +++ /dev/null @@ -1,30 +0,0 @@ -/* FFI interface for TinySCHEME. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#ifndef GPGSCM_FFI_H -#define GPGSCM_FFI_H - -#include -#include "scheme.h" - -gpg_error_t ffi_init (scheme *sc, const char *argv0, const char *scriptname, - int argc, const char **argv); - -#endif /* GPGSCM_FFI_H */ diff --git a/ffi.scm b/ffi.scm deleted file mode 100644 index 051c2c2..0000000 --- a/ffi.scm +++ /dev/null @@ -1,51 +0,0 @@ -;; FFI interface for TinySCHEME. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Foreign function wrapper. Expects F to return a list with the -;; first element being the `error_t' value returned by the foreign -;; function. The error is thrown, or the cdr of the result is -;; returned. -(define (ffi-apply name f args) - (let ((result (apply f args))) - (cond - ((string? result) - (ffi-fail name args result)) - ((not (= (car result) 0)) - (ffi-fail name args (strerror (car result)))) - ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) - ((= (car result) 0) '()) - (else - (throw (list "Result violates FFI calling convention: " result)))))) - -(define (ffi-fail name args message) - (let ((args' (open-output-string))) - (write (cons (string->symbol name) args) args') - (throw (get-output-string args') message))) - -;; Pseudo-definitions for foreign functions. Evaluates to no code, -;; but serves as documentation. -(macro (ffi-define form)) - -;; Runtime support. - -;; Low-level mechanism to terminate the process. -(ffi-define (_exit status)) - -;; Get the current time in seconds since the epoch. -(ffi-define (get-time)) diff --git a/gnupg.scm b/gnupg.scm deleted file mode 100644 index 5fcf9fd..0000000 --- a/gnupg.scm +++ /dev/null @@ -1,44 +0,0 @@ -;; Common definitions for executing gpg and related tools. -;; -;; Copyright (C) 2016, 2017 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Evaluate a sequence of expressions with the given home directory. -(define-macro (with-home-directory gnupghome . expressions) - (let ((original-home-directory (gensym))) - `(let ((,original-home-directory (getenv "GNUPGHOME"))) - (dynamic-wind - (lambda () (setenv "GNUPGHOME" ,gnupghome #t)) - (lambda () ,@expressions) - (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))) - -;; Evaluate a sequence of expressions with an ephemeral home -;; directory. -(define-macro (with-ephemeral-home-directory setup-fn . expressions) - (let ((original-home-directory (gensym)) - (ephemeral-home-directory (gensym)) - (setup (gensym))) - `(let ((,original-home-directory (getenv "GNUPGHOME")) - (,ephemeral-home-directory (mkdtemp)) - (,setup (delay (,setup-fn)))) - (finally (unlink-recursively ,ephemeral-home-directory) - (dynamic-wind - (lambda () - (setenv "GNUPGHOME" ,ephemeral-home-directory #t) - (with-working-directory ,ephemeral-home-directory (force ,setup))) - (lambda () ,@expressions) - (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))) diff --git a/gpgscm/LICENSE.TinySCHEME b/gpgscm/LICENSE.TinySCHEME new file mode 100644 index 0000000..23a7e85 --- /dev/null +++ b/gpgscm/LICENSE.TinySCHEME @@ -0,0 +1,31 @@ + LICENSE TERMS + +Copyright (c) 2000, Dimitrios Souflis +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of Dimitrios Souflis nor the names of the +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/gpgscm/Makefile.am b/gpgscm/Makefile.am new file mode 100644 index 0000000..44d7b3f --- /dev/null +++ b/gpgscm/Makefile.am @@ -0,0 +1,64 @@ +# TinyScheme-based test driver. +# +# Copyright (C) 2016 g10 Code GmbH +# +# This file is part of GnuPG. +# +# GnuPG is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# GnuPG is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . + +EXTRA_DIST = \ + LICENSE.TinySCHEME \ + Manual.txt \ + ffi.scm \ + init.scm \ + lib.scm \ + makefile.scm \ + repl.scm \ + t-child.scm \ + xml.scm \ + tests.scm \ + gnupg.scm \ + time.scm + +AM_CPPFLAGS = -I$(top_srcdir)/common +include $(top_srcdir)/am/cmacros.am + +AM_CFLAGS = + +CLEANFILES = + +bin_PROGRAMS = gpgscm +noinst_PROGRAMS = t-child + +common_libs = ../$(libcommon) +commonpth_libs = ../$(libcommonpth) + +gpgscm_CFLAGS = -imacros scheme-config.h \ + $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) +gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ + scheme-config.h scheme.c scheme.h scheme-private.h \ + opdefines.h small-integers.h +gpgscm_LDADD = $(LDADD) $(common_libs) \ + $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \ + $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) + +t_child_SOURCES = t-child.c + +# Make sure that all libs are build before we use them. This is +# important for things like make -j2. +$(PROGRAMS): $(common_libs) + +check-local: gpgscm$(EXEEXT) t-child$(EXEEXT) + EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \ + ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm diff --git a/gpgscm/Manual.txt b/gpgscm/Manual.txt new file mode 100644 index 0000000..b146926 --- /dev/null +++ b/gpgscm/Manual.txt @@ -0,0 +1,444 @@ + + + TinySCHEME Version 1.41 + + "Safe if used as prescribed" + -- Philip K. Dick, "Ubik" + +This software is open source, covered by a BSD-style license. +Please read accompanying file COPYING. +------------------------------------------------------------------------------- + + This Scheme interpreter is based on MiniSCHEME version 0.85k4 + (see miniscm.tar.gz in the Scheme Repository) + Original credits in file MiniSCHEMETribute.txt. + + D. Souflis (dsouflis@acm.org) + +------------------------------------------------------------------------------- + What is TinyScheme? + ------------------- + + TinyScheme is a lightweight Scheme interpreter that implements as large + a subset of R5RS as was possible without getting very large and + complicated. It is meant to be used as an embedded scripting interpreter + for other programs. As such, it does not offer IDEs or extensive toolkits + although it does sport a small top-level loop, included conditionally. + A lot of functionality in TinyScheme is included conditionally, to allow + developers freedom in balancing features and footprint. + + As an embedded interpreter, it allows multiple interpreter states to + coexist in the same program, without any interference between them. + Programmatically, foreign functions in C can be added and values + can be defined in the Scheme environment. Being a quite small program, + it is easy to comprehend, get to grips with, and use. + + Known bugs + ---------- + + TinyScheme is known to misbehave when memory is exhausted. + + + Things that keep missing, or that need fixing + --------------------------------------------- + + There are no hygienic macros. No rational or + complex numbers. No unwind-protect and call-with-values. + + Maybe (a subset of) SLIB will work with TinySCHEME... + + Decent debugging facilities are missing. Only tracing is supported + natively. + + + Scheme Reference + ---------------- + + If something seems to be missing, please refer to the code and + "init.scm", since some are library functions. Refer to the MiniSCHEME + readme as a last resort. + + Environments + (interaction-environment) + See R5RS. In TinySCHEME, immutable list of association lists. + + (current-environment) + The environment in effect at the time of the call. An example of its + use and its utility can be found in the sample code that implements + packages in "init.scm": + + (macro (package form) + `(apply (lambda () + ,@(cdr form) + (current-environment)))) + + The environment containing the (local) definitions inside the closure + is returned as an immutable value. + + (defined? ) (defined? ) + Checks whether the given symbol is defined in the current (or given) + environment. + + Symbols + (gensym) + Returns a new interned symbol each time. Will probably move to the + library when string->symbol is implemented. + + Directives + (gc) + Performs garbage collection immediately. + + (gc-verbose) (gc-verbose ) + The argument (defaulting to #t) controls whether GC produces + visible outcome. + + (quit) (quit ) + Stops the interpreter and sets the 'retcode' internal field (defaults + to 0). When standalone, 'retcode' is returned as exit code to the OS. + + (tracing ) + 1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1). + + Mathematical functions + Since rationals and complexes are absent, the respective functions + are also missing. + Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling, + trunc, round and also sqrt and expt when USE_MATH=1. + Number-theoretical quotient, remainder and modulo, gcd, lcm. + Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?, + exact->inexact. inexact->exact is a core function. + + Type predicates + boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?, + char?,port?,input-port?,output-port?,procedure?,pair?,environment?', + vector?. Also closure?, macro?. + + Types + Types supported: + + Numbers (integers and reals) + Symbols + Pairs + Strings + Characters + Ports + Eof object + Environments + Vectors + + Literals + String literals can contain escaped quotes \" as usual, but also + \n, \r, \t, \xDD (hex representations) and \DDD (octal representations). + Note also that it is possible to include literal newlines in string + literals, e.g. + + (define s "String with newline here + and here + that can function like a HERE-string") + + Character literals contain #\space and #\newline and are supplemented + with #\return and #\tab, with obvious meanings. Hex character + representations are allowed (e.g. #\x20 is #\space). + When USE_ASCII_NAMES is defined, various control characters can be + referred to by their ASCII name. + 0 #\nul 17 #\dc1 + 1 #\soh 18 #\dc2 + 2 #\stx 19 #\dc3 + 3 #\etx 20 #\dc4 + 4 #\eot 21 #\nak + 5 #\enq 22 #\syn + 6 #\ack 23 #\etv + 7 #\bel 24 #\can + 8 #\bs 25 #\em + 9 #\ht 26 #\sub + 10 #\lf 27 #\esc + 11 #\vt 28 #\fs + 12 #\ff 29 #\gs + 13 #\cr 30 #\rs + 14 #\so 31 #\us + 15 #\si + 16 #\dle 127 #\del + + Numeric literals support #x #o #b and #d. Flonums are currently read only + in decimal notation. Full grammar will be supported soon. + + Quote, quasiquote etc. + As usual. + + Immutable values + Immutable pairs cannot be modified by set-car! and set-cdr!. + Immutable strings cannot be modified via string-set! + + I/O + As per R5RS, plus String Ports (see below). + current-input-port, current-output-port, + close-input-port, close-output-port, input-port?, output-port?, + open-input-file, open-output-file. + read, write, display, newline, write-char, read-char, peek-char. + char-ready? returns #t only for string ports, because there is no + portable way in stdio to determine if a character is available. + Also open-input-output-file, set-input-port, set-output-port (not R5RS) + Library: call-with-input-file, call-with-output-file, + with-input-from-file, with-output-from-file and + with-input-output-from-to-files, close-port and input-output-port? + (not R5RS). + String Ports: open-input-string, open-output-string, get-output-string, + open-input-output-string. Strings can be used with I/O routines. + + Vectors + make-vector, vector, vector-length, vector-ref, vector-set!, list->vector, + vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS) + + Strings + string, make-string, list->string, string-length, string-ref, string-set!, + substring, string->list, string-fill!, string-append, string-copy. + string=?, string?, string>?, string<=?, string>=?. + (No string-ci*? yet). string->number, number->string. Also atom->string, + string->atom (not R5RS). + + Symbols + symbol->string, string->symbol + + Characters + integer->char, char->integer. + char=?, char?, char<=?, char>=?. + (No char-ci*?) + + Pairs & Lists + cons, car, cdr, list, length, map, for-each, foldr, list-tail, + list-ref, last-pair, reverse, append. + Also member, memq, memv, based on generic-member, assoc, assq, assv + based on generic-assoc. + + Streams + head, tail, cons-stream + + Control features + Apart from procedure?, also macro? and closure? + map, for-each, force, delay, call-with-current-continuation (or call/cc), + eval, apply. 'Forcing' a value that is not a promise produces the value. + There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in + the presence of continuations would require support from the abstract + machine itself. + + Property lists + TinyScheme inherited from MiniScheme property lists for symbols. + put, get. + + Dynamically-loaded extensions + (load-extension ) + Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use + of the ld.so.conf file or the LD_RUN_PATH system variable in order to place + the library in a directory other than the current one. Please refer to the + appropriate 'man' page. + + Esoteric procedures + (oblist) + Returns the oblist, an immutable list of all the symbols. + + (macro-expand ) + Returns the expanded form of the macro call denoted by the argument + + (define-with-return ( ...) ) + Like plain 'define', but makes the continuation available as 'return' + inside the procedure. Handy for imperative programs. + + (new-segment ) + Allocates more memory segments. + + defined? + See "Environments" + + (get-closure-code ) + Gets the code as scheme data. + + (make-closure ) + Makes a new closure in the given environment. + + Obsolete procedures + (print-width ) + + Programmer's Reference + ---------------------- + + The interpreter state is initialized with "scheme_init". + Custom memory allocation routines can be installed with an alternate + initialization function: "scheme_init_custom_alloc". + Files can be loaded with "scheme_load_file". Strings containing Scheme + code can be loaded with "scheme_load_string". It is a good idea to + "scheme_load" init.scm before anything else. + + External data for keeping external state (of use to foreign functions) + can be installed with "scheme_set_external_data". + Foreign functions are installed with "assign_foreign". Additional + definitions can be added to the interpreter state, with "scheme_define" + (this is the way HTTP header data and HTML form data are passed to the + Scheme script in the Altera SQL Server). If you wish to define the + foreign function in a specific environment (to enhance modularity), + use "assign_foreign_env". + + The procedure "scheme_apply0" has been added with persistent scripts in + mind. Persistent scripts are loaded once, and every time they are needed + to produce HTTP output, appropriate data are passed through global + definitions and function "main" is called to do the job. One could + add easily "scheme_apply1" etc. + + The interpreter state should be deinitialized with "scheme_deinit". + + DLLs containing foreign functions should define a function named + init_. E.g. foo.dll should define init_foo, and bar.so + should define init_bar. This function should assign_foreign any foreign + function contained in the DLL. + + The first dynamically loaded extension available for TinyScheme is + a regular expression library. Although it's by no means an + established standard, this library is supposed to be installed in + a directory mirroring its name under the TinyScheme location. + + + Foreign Functions + ----------------- + + The user can add foreign functions in C. For example, a function + that squares its argument: + + pointer square(scheme *sc, pointer args) { + if(args!=sc->NIL) { + if(sc->isnumber(sc->pair_car(args))) { + double v=sc->rvalue(sc->pair_car(args)); + return sc->mk_real(sc,v*v); + } + } + return sc->NIL; + } + + Foreign functions are now defined as closures: + + sc->interface->scheme_define( + sc, + sc->global_env, + sc->interface->mk_symbol(sc,"square"), + sc->interface->mk_foreign_func(sc, square)); + + + Foreign functions can use the external data in the "scheme" struct + to implement any kind of external state. + + External data are set with the following function: + void scheme_set_external_data(scheme *sc, void *p); + + As of v.1.17, the canonical way for a foreign function in a DLL to + manipulate Scheme data is using the function pointers in sc->interface. + + Standalone + ---------- + + Usage: tinyscheme -? + or: tinyscheme [ ...] + followed by + -1 [ ...] + -c [ ...] + assuming that the executable is named tinyscheme. + + Use - in the place of a filename to denote stdin. + The -1 flag is meant for #! usage in shell scripts. If you specify + #! /somewhere/tinyscheme -1 + then tinyscheme will be called to process the file. For example, the + following script echoes the Scheme list of its arguments. + + #! /somewhere/tinyscheme -1 + (display *args*) + + The -c flag permits execution of arbitrary Scheme code. + + + Error Handling + -------------- + + Errors are recovered from without damage. The user can install his + own handler for system errors, by defining *error-hook*. Defining + to '() gives the default behavior, which is equivalent to "error". + USE_ERROR_HOOK must be defined. + + A simple exception handling mechanism can be found in "init.scm". + A new syntactic form is introduced: + + (catch + ... ) + + "Catch" establishes a scope spanning multiple call-frames + until another "catch" is encountered. + + Exceptions are thrown with: + + (throw "message") + + If used outside a (catch ...), reverts to (error "message"). + + Example of use: + + (define (foo x) (write x) (newline) (/ x 0)) + + (catch (begin (display "Error!\n") 0) + (write "Before foo ... ") + (foo 5) + (write "After foo")) + + The exception mechanism can be used even by system errors, by + + (define *error-hook* throw) + + which makes use of the error hook described above. + + If necessary, the user can devise his own exception mechanism with + tagged exceptions etc. + + + Reader extensions + ----------------- + + When encountering an unknown character after '#', the user-specified + procedure *sharp-hook* (if any), is called to read the expression. + This can be used to extend the reader to handle user-defined constants + or whatever. It should be a procedure without arguments, reading from + the current input port (which will be the load-port). + + + Colon Qualifiers - Packages + --------------------------- + + When USE_COLON_HOOK=1: + The lexer now recognizes the construction :: and + transforms it in the following manner (T is the transformation function): + + T(::) = (*colon-hook* 'T() ) + + where is a symbol not containing any double-colons. + + As the definition is recursive, qualifiers can be nested. + The user can define his own *colon-hook*, to handle qualified names. + By default, "init.scm" defines *colon-hook* as EVAL. Consequently, + the qualifier must denote a Scheme environment, such as one returned + by (interaction-environment). "Init.scm" defines a new syntantic form, + PACKAGE, as a simple example. It is used like this: + + (define toto + (package + (define foo 1) + (define bar +))) + + foo ==> Error, "foo" undefined + (eval 'foo) ==> Error, "foo" undefined + (eval 'foo toto) ==> 1 + toto::foo ==> 1 + ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 + (toto::bar 2 toto::foo) ==> 3 + (eval (bar 2 foo) toto) ==> 3 + + If the user installs another package infrastructure, he must define + a new 'package' procedure or macro to retain compatibility with supplied + code. + + Note: Older versions used ':' as a qualifier. Unfortunately, the use + of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially + precludes its use as a real qualifier. diff --git a/gpgscm/ffi-private.h b/gpgscm/ffi-private.h new file mode 100644 index 0000000..037da56 --- /dev/null +++ b/gpgscm/ffi-private.h @@ -0,0 +1,148 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef GPGSCM_FFI_PRIVATE_H +#define GPGSCM_FFI_PRIVATE_H + +#include +#include "scheme.h" +#include "scheme-private.h" + +#define FFI_PROLOG() \ + unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1; \ + int err GPGRT_ATTR_UNUSED = 0 \ + +int ffi_bool_value (scheme *sc, pointer p); + +#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X) +#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X) +#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X) +#define CONVERSION_list(SC, X) (X) +#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X)) +#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \ + ? (SC)->vptr->string_value \ + : (SC)->vptr->symname) (X)) + +#define IS_A_number(SC, X) (SC)->vptr->is_number (X) +#define IS_A_string(SC, X) (SC)->vptr->is_string (X) +#define IS_A_character(SC, X) (SC)->vptr->is_character (X) +#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X) +#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T) +#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ + || (SC)->vptr->is_symbol (X)) + +#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS) \ + do { \ + if ((ARGS) == (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), \ + "too few arguments: want " \ + #TARGET "("#WANT"/"#CTYPE")\n"); \ + if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \ + char ffi_error_message[256]; \ + snprintf (ffi_error_message, sizeof ffi_error_message, \ + "argument %d must be: " #WANT "\n", ffi_arg_index); \ + return (SC)->vptr->mk_string ((SC), ffi_error_message); \ + } \ + TARGET = CONVERSION_##WANT (SC, pair_car (ARGS)); \ + ARGS = pair_cdr (ARGS); \ + ffi_arg_index += 1; \ + } while (0) + +#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS) \ + do { \ + if ((ARGS) != (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), "too many arguments"); \ + } while (0) + +#define FFI_RETURN_ERR(SC, ERR) \ + return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1) + +#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err) + +#define FFI_RETURN_POINTER(SC, X) \ + return _cons ((SC), mk_integer ((SC), err), \ + _cons ((SC), (X), (SC)->NIL, 1), 1) +#define FFI_RETURN_INT(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X))) +#define FFI_RETURN_STRING(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_string ((SC), (X))) + +char *ffi_schemify_name (const char *s, int macro); + +void ffi_scheme_eval (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); +pointer ffi_sprintf (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); + +#define ffi_define_function_name(SC, NAME, F) \ + do { \ + char *_fname = ffi_schemify_name ("__" #F, 0); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _fname), \ + mk_foreign_func ((SC), (do_##F))); \ + ffi_scheme_eval ((SC), \ + "(define (%s . a) (ffi-apply \"%s\" %s a))", \ + (NAME), (NAME), _fname); \ + free (_fname); \ + } while (0) + +#define ffi_define_function(SC, F) \ + do { \ + char *_name = ffi_schemify_name (#F, 0); \ + ffi_define_function_name ((SC), _name, F); \ + free (_name); \ + } while (0) + +#define ffi_define_constant(SC, C) \ + do { \ + char *_name = ffi_schemify_name (#C, 1); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + mk_integer ((SC), (C))); \ + free (_name); \ + } while (0) + +#define ffi_define(SC, SYM, EXP) \ + scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP) + +#define ffi_define_variable_pointer(SC, C, P) \ + do { \ + char *_name = ffi_schemify_name (#C, 0); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + (P)); \ + free (_name); \ + } while (0) + +#define ffi_define_variable_integer(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C)) + +#define ffi_define_variable_string(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: "")) + +gpg_error_t ffi_list2argv (scheme *sc, pointer list, + char ***argv, size_t *len); +gpg_error_t ffi_list2intv (scheme *sc, pointer list, + int **intv, size_t *len); + +#endif /* GPGSCM_FFI_PRIVATE_H */ diff --git a/gpgscm/ffi.c b/gpgscm/ffi.c new file mode 100644 index 0000000..dde5b52 --- /dev/null +++ b/gpgscm/ffi.c @@ -0,0 +1,1470 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#if HAVE_LIBREADLINE +#define GNUPG_LIBREADLINE_H_INCLUDED +#include +#include +#endif + +#include "../../common/util.h" +#include "../../common/exechelp.h" +#include "../../common/sysutils.h" + +#include "private.h" +#include "ffi.h" +#include "ffi-private.h" + +/* For use in nice error messages. */ +static const char * +ordinal_suffix (int n) +{ + switch (n) + { + case 1: return "st"; + case 2: return "nd"; + case 3: return "rd"; + default: return "th"; + } + assert (! "reached"); +} + + + +int +ffi_bool_value (scheme *sc, pointer p) +{ + return ! (p == sc->F); +} + + + +static pointer +do_logand (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = ~0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc &= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logior (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc |= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logxor (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc ^= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_lognot (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v; + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, ~v); +} + +/* User interface. */ + +static pointer +do_flush_stdio (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + fflush (stdout); + fflush (stderr); + FFI_RETURN (sc); +} + + +int use_libreadline; + +/* Read a string, and return a pointer to it. Returns NULL on EOF. */ +char * +rl_gets (const char *prompt) +{ + static char *line = NULL; + char *p; + xfree (line); + +#if HAVE_LIBREADLINE + { + line = readline (prompt); + if (line && *line) + add_history (line); + } +#else + { + size_t max_size = 0xff; + printf ("%s", prompt); + fflush (stdout); + line = xtrymalloc (max_size); + if (line != NULL) + fgets (line, max_size, stdin); + } +#endif + + /* Strip trailing whitespace. */ + if (line && strlen (line) > 0) + for (p = &line[strlen (line) - 1]; isspace (*p); p--) + *p = 0; + + return line; +} + +static pointer +do_prompt (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *prompt; + const char *line; + FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + line = rl_gets (prompt); + if (! line) + FFI_RETURN_POINTER (sc, sc->EOF_OBJ); + + FFI_RETURN_STRING (sc, line); +} + +static pointer +do_sleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int seconds; + FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + sleep (seconds); + FFI_RETURN (sc); +} + +static pointer +do_usleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + useconds_t microseconds; + FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + usleep (microseconds); + FFI_RETURN (sc); +} + +static pointer +do_chdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, path, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (chdir (name)) + FFI_RETURN_ERR (sc, errno); + FFI_RETURN (sc); +} + +static pointer +do_strerror (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int error; + FFI_ARG_OR_RETURN (sc, int, error, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_STRING (sc, gpg_strerror (error)); +} + +static pointer +do_getenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *value; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + value = getenv (name); + FFI_RETURN_STRING (sc, value ? value : ""); +} + +static pointer +do_setenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *value; + int overwrite; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, value, string, args); + FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (gnupg_setenv (name, value, overwrite)) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_exit (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int retcode; + FFI_ARG_OR_RETURN (sc, int, retcode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + exit (retcode); +} + +/* XXX: use gnupgs variant b/c mode as string */ +static pointer +do_open (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + char *pathname; + int flags; + mode_t mode = 0; + FFI_ARG_OR_RETURN (sc, char *, pathname, path, args); + FFI_ARG_OR_RETURN (sc, int, flags, number, args); + if (args != sc->NIL) + FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + fd = open (pathname, flags, mode); + if (fd == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_INT (sc, fd); +} + +static pointer +do_fdopen (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FILE *stream; + int fd; + char *mode; + int kind; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + stream = fdopen (fd, mode); + if (stream == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + if (setvbuf (stream, NULL, _IONBF, 0) != 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + kind = 0; + if (strchr (mode, 'r')) + kind |= port_input; + if (strchr (mode, 'w')) + kind |= port_output; + + FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind)); +} + +static pointer +do_close (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); +} + +static pointer +do_seek (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + off_t offset; + int whence; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARG_OR_RETURN (sc, off_t, offset, number, args); + FFI_ARG_OR_RETURN (sc, int, whence, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1 + ? gpg_error_from_syserror () : 0); +} + +static pointer +do_get_temp_path (scheme *sc, pointer args) +{ + FFI_PROLOG (); +#ifdef HAVE_W32_SYSTEM + char buffer[MAX_PATH+1]; +#endif + FFI_ARGS_DONE_OR_RETURN (sc, args); + +#ifdef HAVE_W32_SYSTEM + if (GetTempPath (MAX_PATH+1, buffer) == 0) + FFI_RETURN_STRING (sc, "/temp"); + FFI_RETURN_STRING (sc, buffer); +#else + FFI_RETURN_STRING (sc, "/tmp"); +#endif +} + +static pointer +do_mkdtemp (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *template; +#ifdef PATH_MAX + char buffer[PATH_MAX]; +#else + char buffer[1024]; +#endif + char *name; + FFI_ARG_OR_RETURN (sc, char *, template, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (strlen (template) > sizeof buffer - 1) + FFI_RETURN_ERR (sc, EINVAL); + strncpy (buffer, template, sizeof buffer); + + name = gnupg_mkdtemp (buffer); + if (name == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_STRING (sc, name); +} + +static pointer +do_unlink (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (unlink (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static gpg_error_t +unlink_recursively (const char *name) +{ + gpg_error_t err = 0; + struct stat st; + + if (stat (name, &st) == -1) + return gpg_error_from_syserror (); + + if (S_ISDIR (st.st_mode)) + { + DIR *dir; + struct dirent *dent; + + dir = opendir (name); + if (dir == NULL) + return gpg_error_from_syserror (); + + while ((dent = readdir (dir))) + { + char *child; + + if (strcmp (dent->d_name, ".") == 0 + || strcmp (dent->d_name, "..") == 0) + continue; + + child = xtryasprintf ("%s/%s", name, dent->d_name); + if (child == NULL) + { + err = gpg_error_from_syserror (); + goto leave; + } + + err = unlink_recursively (child); + xfree (child); + if (err == gpg_error_from_errno (ENOENT)) + err = 0; + if (err) + goto leave; + } + + leave: + closedir (dir); + if (! err) + rmdir (name); + return err; + } + else + if (unlink (name) == -1) + return gpg_error_from_syserror (); + return 0; +} + +static pointer +do_unlink_recursively (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = unlink_recursively (name); + FFI_RETURN (sc); +} + +static pointer +do_rename (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *old; + char *new; + FFI_ARG_OR_RETURN (sc, char *, old, string, args); + FFI_ARG_OR_RETURN (sc, char *, new, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rename (old, new) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_getcwd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result; + char *cwd; + FFI_ARGS_DONE_OR_RETURN (sc, args); + cwd = gnupg_getcwd (); + if (cwd == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + result = sc->vptr->mk_string (sc, cwd); + xfree (cwd); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_mkdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *mode; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (gnupg_mkdir (name, mode) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_rmdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rmdir (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_get_isotime (scheme *sc, pointer args) +{ + FFI_PROLOG (); + gnupg_isotime_t timebuf; + FFI_ARGS_DONE_OR_RETURN (sc, args); + gnupg_get_isotime (timebuf); + FFI_RETURN_STRING (sc, timebuf); +} + +static pointer +do_get_time (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, gnupg_get_time ()); +} + +static pointer +do_getpid (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, getpid ()); +} + +static pointer +do_srandom (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int seed; + FFI_ARG_OR_RETURN (sc, int, seed, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + srand (seed); + FFI_RETURN (sc); +} + +static int +random_scaled (int scale) +{ + int v; +#ifdef HAVE_RAND + v = rand (); +#else + v = random (); +#endif + +#ifndef RAND_MAX /* for SunOS */ +#define RAND_MAX 32767 +#endif + + return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1); +} + +static pointer +do_random (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int scale; + FFI_ARG_OR_RETURN (sc, int, scale, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, random_scaled (scale)); +} + +static pointer +do_make_random_string (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int size; + pointer chunk; + char *p; + FFI_ARG_OR_RETURN (sc, int, size, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (size < 0) + return ffi_sprintf (sc, "size must be positive"); + + chunk = sc->vptr->mk_counted_string (sc, NULL, size); + if (sc->no_memory) + FFI_RETURN_ERR (sc, ENOMEM); + + for (p = sc->vptr->string_value (chunk); size; p++, size--) + *p = (char) random_scaled (256); + FFI_RETURN_POINTER (sc, chunk); +} + + + +/* estream functions. */ + +struct es_object_box +{ + estream_t stream; + int closed; +}; + +static void +es_object_finalize (scheme *sc, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + if (! box->closed) + es_fclose (box->stream); + xfree (box); +} + +static void +es_object_to_string (scheme *sc, char *out, size_t size, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + snprintf (out, size, "#estream %p", box->stream); +} + +static struct foreign_object_vtable es_object_vtable = + { + es_object_finalize, + es_object_to_string, + }; + +static pointer +es_wrap (scheme *sc, estream_t stream) +{ + struct es_object_box *box = xmalloc (sizeof *box); + if (box == NULL) + return sc->NIL; + + box->stream = stream; + box->closed = 0; + return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box); +} + +static struct es_object_box * +es_unwrap (scheme *sc, pointer object) +{ + (void) sc; + + if (! is_foreign_object (object)) + return NULL; + + if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable) + return NULL; + + return sc->vptr->get_foreign_object_data (object); +} + +#define CONVERSION_estream(SC, X) es_unwrap (SC, X) +#define IS_A_estream(SC, X) es_unwrap (SC, X) + +static pointer +do_es_fclose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = es_fclose (box->stream); + if (! err) + box->closed = 1; + FFI_RETURN (sc); +} + +static pointer +do_es_read (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + size_t bytes_to_read; + + pointer result; + void *buffer; + size_t bytes_read; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + buffer = xtrymalloc (bytes_to_read); + if (buffer == NULL) + FFI_RETURN_ERR (sc, ENOMEM); + + err = es_read (box->stream, buffer, bytes_to_read, &bytes_read); + if (err) + FFI_RETURN_ERR (sc, err); + + result = sc->vptr->mk_counted_string (sc, buffer, bytes_read); + xfree (buffer); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_es_feof (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F); +} + +static pointer +do_es_write (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + const char *buffer; + size_t bytes_to_write, bytes_written; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + /* XXX how to get the length of the string buffer? scheme strings + may contain \0. */ + FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + bytes_to_write = strlen (buffer); + while (bytes_to_write > 0) + { + err = es_write (box->stream, buffer, bytes_to_write, &bytes_written); + if (err) + break; + bytes_to_write -= bytes_written; + buffer += bytes_written; + } + + FFI_RETURN (sc); +} + + + +/* Process handling. */ + +static pointer +do_spawn_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + unsigned int flags; + + estream_t infp; + estream_t outfp; + estream_t errfp; + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process (argv[0], (const char **) &argv[1], + NULL, + NULL, + flags, + &infp, &outfp, &errfp, &pid); + xfree (argv); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) +#define IMS(A, B) \ + _cons (sc, es_wrap (sc, (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMS (infp, + IMS (outfp, + IMS (errfp, + IMC (pid, sc->NIL))))); +#undef IMS +#undef IMC +} + +static pointer +do_spawn_process_fd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + int infd, outfd, errfd; + + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, int, infd, number, args); + FFI_ARG_OR_RETURN (sc, int, outfd, number, args); + FFI_ARG_OR_RETURN (sc, int, errfd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1], + infd, outfd, errfd, &pid); + xfree (argv); + FFI_RETURN_INT (sc, pid); +} + +static pointer +do_wait_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *name; + pid_t pid; + int hang; + + int retcode; + + FFI_ARG_OR_RETURN (sc, const char *, name, string, args); + FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_wait_process (name, pid, hang, &retcode); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return code speak for itself. */ + + FFI_RETURN_INT (sc, retcode); +} + + +static pointer +do_wait_processes (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer list_names; + char **names; + pointer list_pids; + size_t i, count; + pid_t *pids; + int hang; + int *retcodes; + pointer retcodes_list = sc->NIL; + + FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args); + FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (sc->vptr->list_length (sc, list_names) + != sc->vptr->list_length (sc, list_pids)) + return + sc->vptr->mk_string (sc, "length of first two arguments must match"); + + err = ffi_list2argv (sc, list_names, &names, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%lu%s element of first argument is " + "neither string nor symbol", + (unsigned long) count, + ordinal_suffix ((int) count)); + if (err) + FFI_RETURN_ERR (sc, err); + + err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%lu%s element of second argument is " + "not a number", + (unsigned long) count, + ordinal_suffix ((int) count)); + if (err) + FFI_RETURN_ERR (sc, err); + + retcodes = xtrycalloc (sizeof *retcodes, count); + if (retcodes == NULL) + { + xfree (names); + xfree (pids); + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + } + + err = gnupg_wait_processes ((const char **) names, pids, count, hang, + retcodes); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return codes speak. */ + if (err == GPG_ERR_TIMEOUT) + err = 0; /* We may have got some results. */ + + for (i = 0; i < count; i++) + retcodes_list = + (sc->vptr->cons) (sc, + sc->vptr->mk_integer (sc, + (long) retcodes[count-1-i]), + retcodes_list); + + xfree (names); + xfree (pids); + xfree (retcodes); + FFI_RETURN_POINTER (sc, retcodes_list); +} + + +static pointer +do_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_pipe (filedes); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_inbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_inbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_outbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_outbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + + + +/* Test helper functions. */ +static pointer +do_file_equal (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result = sc->F; + char *a_name, *b_name; + int binary; + const char *mode; + FILE *a_stream = NULL, *b_stream = NULL; + struct stat a_stat, b_stat; +#define BUFFER_SIZE 1024 + char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE]; +#undef BUFFER_SIZE + size_t chunk; + + FFI_ARG_OR_RETURN (sc, char *, a_name, string, args); + FFI_ARG_OR_RETURN (sc, char *, b_name, string, args); + FFI_ARG_OR_RETURN (sc, int, binary, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + mode = binary ? "rb" : "r"; + a_stream = fopen (a_name, mode); + if (a_stream == NULL) + goto errout; + + b_stream = fopen (b_name, mode); + if (b_stream == NULL) + goto errout; + + if (fstat (fileno (a_stream), &a_stat) < 0) + goto errout; + + if (fstat (fileno (b_stream), &b_stat) < 0) + goto errout; + + if (binary && a_stat.st_size != b_stat.st_size) + { + if (verbose) + fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n", + a_name, b_name, (unsigned long) a_stat.st_size, + (unsigned long) b_stat.st_size); + + goto out; + } + + while (! feof (a_stream)) + { + chunk = sizeof a_buf; + + chunk = fread (a_buf, 1, chunk, a_stream); + if (chunk == 0 && ferror (a_stream)) + goto errout; /* some error */ + + if (fread (b_buf, 1, chunk, b_stream) < chunk) + { + if (feof (b_stream)) + goto out; /* short read */ + goto errout; /* some error */ + } + + if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0) + goto out; + } + + fread (b_buf, 1, 1, b_stream); + if (! feof (b_stream)) + goto out; /* b is longer */ + + /* They match. */ + result = sc->T; + + out: + if (a_stream) + fclose (a_stream); + if (b_stream) + fclose (b_stream); + FFI_RETURN_POINTER (sc, result); + errout: + err = gpg_error_from_syserror (); + goto out; +} + +static pointer +do_splice (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int source; + char buffer[1024]; + ssize_t bytes_read; + pointer sinks, sink; + FFI_ARG_OR_RETURN (sc, int, source, number, args); + sinks = args; + if (sinks == sc->NIL) + return ffi_sprintf (sc, "need at least one sink"); + for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++) + if (! sc->vptr->is_number (pair_car (sink))) + return ffi_sprintf (sc, "%d%s argument is not a number", + ffi_arg_index, ordinal_suffix (ffi_arg_index)); + + while (1) + { + bytes_read = read (source, buffer, sizeof buffer); + if (bytes_read == 0) + break; + if (bytes_read < 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink)) + { + int fd = sc->vptr->ivalue (pair_car (sink)); + char *p = buffer; + ssize_t left = bytes_read; + + while (left) + { + ssize_t written = write (fd, p, left); + if (written < 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + assert (written <= left); + left -= written; + p += written; + } + } + } + FFI_RETURN (sc); +} + +static pointer +do_string_index (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_rindex (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strrchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_contains (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char *needle; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char *, needle, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); +} + + + +static pointer +do_get_verbose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, verbose); +} + +static pointer +do_set_verbose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int new_verbosity, old; + FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + old = verbose; + verbose = new_verbosity; + + FFI_RETURN_INT (sc, old); +} + + +gpg_error_t +ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *argv = xtrycalloc (*len + 1, sizeof **argv); + if (*argv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_string (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list)); + else if (sc->vptr->is_symbol (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list)); + else + { + xfree (*argv); + *argv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + (*argv)[i] = NULL; + return 0; +} + +gpg_error_t +ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *intv = xtrycalloc (*len, sizeof **intv); + if (*intv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_number (sc->vptr->pair_car (list))) + (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list)); + else + { + xfree (*intv); + *intv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + + return 0; +} + + +char * +ffi_schemify_name (const char *s, int macro) +{ + /* Fixme: We should use xtrystrdup and return NULL. However, this + * requires a lot more changes. Simply returning S as done + * originally is not an option. */ + char *n = xstrdup (s), *p; + /* if (n == NULL) */ + /* return s; */ + + for (p = n; *p; p++) + { + *p = (char) tolower (*p); + /* We convert _ to - in identifiers. We allow, however, for + function names to start with a leading _. The functions in + this namespace are not yet finalized and might change or + vanish without warning. Use them with care. */ + if (! macro + && p != n + && *p == '_') + *p = '-'; + } + return n; +} + +pointer +ffi_sprintf (scheme *sc, const char *format, ...) +{ + pointer result; + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return NULL; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + result = sc->vptr->mk_string (sc, expression); + xfree (expression); + return result; +} + +void +ffi_scheme_eval (scheme *sc, const char *format, ...) +{ + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + sc->vptr->load_string (sc, expression); + xfree (expression); +} + +gpg_error_t +ffi_init (scheme *sc, const char *argv0, const char *scriptname, + int argc, const char **argv) +{ + int i; + pointer args = sc->NIL; + + /* bitwise arithmetic */ + ffi_define_function (sc, logand); + ffi_define_function (sc, logior); + ffi_define_function (sc, logxor); + ffi_define_function (sc, lognot); + + /* libc. */ + ffi_define_constant (sc, O_RDONLY); + ffi_define_constant (sc, O_WRONLY); + ffi_define_constant (sc, O_RDWR); + ffi_define_constant (sc, O_CREAT); + ffi_define_constant (sc, O_APPEND); +#ifndef O_BINARY +# define O_BINARY 0 +#endif +#ifndef O_TEXT +# define O_TEXT 0 +#endif + ffi_define_constant (sc, O_BINARY); + ffi_define_constant (sc, O_TEXT); + ffi_define_constant (sc, STDIN_FILENO); + ffi_define_constant (sc, STDOUT_FILENO); + ffi_define_constant (sc, STDERR_FILENO); + ffi_define_constant (sc, SEEK_SET); + ffi_define_constant (sc, SEEK_CUR); + ffi_define_constant (sc, SEEK_END); + + ffi_define_function (sc, sleep); + ffi_define_function (sc, usleep); + ffi_define_function (sc, chdir); + ffi_define_function (sc, strerror); + ffi_define_function (sc, getenv); + ffi_define_function (sc, setenv); + ffi_define_function_name (sc, "_exit", exit); + ffi_define_function (sc, open); + ffi_define_function (sc, fdopen); + ffi_define_function (sc, close); + ffi_define_function (sc, seek); + ffi_define_function (sc, get_temp_path); + ffi_define_function_name (sc, "_mkdtemp", mkdtemp); + ffi_define_function (sc, unlink); + ffi_define_function (sc, unlink_recursively); + ffi_define_function (sc, rename); + ffi_define_function (sc, getcwd); + ffi_define_function (sc, mkdir); + ffi_define_function (sc, rmdir); + ffi_define_function (sc, get_isotime); + ffi_define_function (sc, get_time); + ffi_define_function (sc, getpid); + + /* Random numbers. */ + ffi_define_function (sc, srandom); + ffi_define_function (sc, random); + ffi_define_function (sc, make_random_string); + + /* Process management. */ + ffi_define_function (sc, spawn_process); + ffi_define_function (sc, spawn_process_fd); + ffi_define_function (sc, wait_process); + ffi_define_function (sc, wait_processes); + ffi_define_function (sc, pipe); + ffi_define_function (sc, inbound_pipe); + ffi_define_function (sc, outbound_pipe); + + /* estream functions. */ + ffi_define_function_name (sc, "es-fclose", es_fclose); + ffi_define_function_name (sc, "es-read", es_read); + ffi_define_function_name (sc, "es-feof", es_feof); + ffi_define_function_name (sc, "es-write", es_write); + + /* Test helper functions. */ + ffi_define_function (sc, file_equal); + ffi_define_function (sc, splice); + ffi_define_function (sc, string_index); + ffi_define_function (sc, string_rindex); + ffi_define_function_name (sc, "string-contains?", string_contains); + + /* User interface. */ + ffi_define_function (sc, flush_stdio); + ffi_define_function (sc, prompt); + + /* Configuration. */ + ffi_define_function_name (sc, "*verbose*", get_verbose); + ffi_define_function_name (sc, "*set-verbose!*", set_verbose); + + ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); + ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname)); + for (i = argc - 1; i >= 0; i--) + { + pointer value = sc->vptr->mk_string (sc, argv[i]); + args = (sc->vptr->cons) (sc, value, args); + } + ffi_define (sc, "*args*", args); + +#if _WIN32 + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';')); +#else + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); +#endif + + ffi_define (sc, "*win32*", +#if _WIN32 + sc->T +#else + sc->F +#endif + ); + + ffi_define (sc, "*maintainer-mode*", +#if MAINTAINER_MODE + sc->T +#else + sc->F +#endif + ); + + ffi_define (sc, "*run-all-tests*", +#if RUN_ALL_TESTS + sc->T +#else + sc->F +#endif + ); + + + ffi_define (sc, "*stdin*", + sc->vptr->mk_port_from_file (sc, stdin, port_input)); + ffi_define (sc, "*stdout*", + sc->vptr->mk_port_from_file (sc, stdout, port_output)); + ffi_define (sc, "*stderr*", + sc->vptr->mk_port_from_file (sc, stderr, port_output)); + + return 0; +} diff --git a/gpgscm/ffi.h b/gpgscm/ffi.h new file mode 100644 index 0000000..eba6282 --- /dev/null +++ b/gpgscm/ffi.h @@ -0,0 +1,30 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef GPGSCM_FFI_H +#define GPGSCM_FFI_H + +#include +#include "scheme.h" + +gpg_error_t ffi_init (scheme *sc, const char *argv0, const char *scriptname, + int argc, const char **argv); + +#endif /* GPGSCM_FFI_H */ diff --git a/gpgscm/ffi.scm b/gpgscm/ffi.scm new file mode 100644 index 0000000..051c2c2 --- /dev/null +++ b/gpgscm/ffi.scm @@ -0,0 +1,51 @@ +;; FFI interface for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Foreign function wrapper. Expects F to return a list with the +;; first element being the `error_t' value returned by the foreign +;; function. The error is thrown, or the cdr of the result is +;; returned. +(define (ffi-apply name f args) + (let ((result (apply f args))) + (cond + ((string? result) + (ffi-fail name args result)) + ((not (= (car result) 0)) + (ffi-fail name args (strerror (car result)))) + ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) + ((= (car result) 0) '()) + (else + (throw (list "Result violates FFI calling convention: " result)))))) + +(define (ffi-fail name args message) + (let ((args' (open-output-string))) + (write (cons (string->symbol name) args) args') + (throw (get-output-string args') message))) + +;; Pseudo-definitions for foreign functions. Evaluates to no code, +;; but serves as documentation. +(macro (ffi-define form)) + +;; Runtime support. + +;; Low-level mechanism to terminate the process. +(ffi-define (_exit status)) + +;; Get the current time in seconds since the epoch. +(ffi-define (get-time)) diff --git a/gpgscm/gnupg.scm b/gpgscm/gnupg.scm new file mode 100644 index 0000000..5fcf9fd --- /dev/null +++ b/gpgscm/gnupg.scm @@ -0,0 +1,44 @@ +;; Common definitions for executing gpg and related tools. +;; +;; Copyright (C) 2016, 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Evaluate a sequence of expressions with the given home directory. +(define-macro (with-home-directory gnupghome . expressions) + (let ((original-home-directory (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME"))) + (dynamic-wind + (lambda () (setenv "GNUPGHOME" ,gnupghome #t)) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))) + +;; Evaluate a sequence of expressions with an ephemeral home +;; directory. +(define-macro (with-ephemeral-home-directory setup-fn . expressions) + (let ((original-home-directory (gensym)) + (ephemeral-home-directory (gensym)) + (setup (gensym))) + `(let ((,original-home-directory (getenv "GNUPGHOME")) + (,ephemeral-home-directory (mkdtemp)) + (,setup (delay (,setup-fn)))) + (finally (unlink-recursively ,ephemeral-home-directory) + (dynamic-wind + (lambda () + (setenv "GNUPGHOME" ,ephemeral-home-directory #t) + (with-working-directory ,ephemeral-home-directory (force ,setup))) + (lambda () ,@expressions) + (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))) diff --git a/gpgscm/init.scm b/gpgscm/init.scm new file mode 100644 index 0000000..66bec0f --- /dev/null +++ b/gpgscm/init.scm @@ -0,0 +1,823 @@ +; Initialization file for TinySCHEME 1.41 + +; Per R5RS, up to four deep compositions should be defined +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +;;;; Utility to ease macro creation +(define (macro-expand form) + ((eval (get-closure-code (eval (car form)))) form)) + +(define (macro-expand-all form) + (if (macro? form) + (macro-expand-all (macro-expand form)) + form)) + +(define *compile-hook* macro-expand-all) + + +(macro (unless form) + `(if (not ,(cadr form)) (begin ,@(cddr form)))) + +(macro (when form) + `(if ,(cadr form) (begin ,@(cddr form)))) + +; DEFINE-MACRO Contributed by Andy Gaynor +(macro (define-macro dform) + (if (symbol? (cadr dform)) + `(macro ,@(cdr dform)) + (let ((form (gensym))) + `(macro (,(caadr dform) ,form) + (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) + +; Utilities for math. Notice that inexact->exact is primitive, +; but exact->inexact is not. +(define exact? integer?) +(define (inexact? x) (and (real? x) (not (integer? x)))) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (not (= (remainder n 2) 0))) +(define (zero? n) (= n 0)) +(define (positive? n) (> n 0)) +(define (negative? n) (< n 0)) +(define complex? number?) +(define rational? real?) +(define (abs n) (if (>= n 0) n (- n))) +(define (exact->inexact n) (* n 1.0)) +(define (<> n1 n2) (not (= n1 n2))) + +; min and max must return inexact if any arg is inexact; use (+ n 0.0) +(define (max . lst) + (foldr (lambda (a b) + (if (> a b) + (if (exact? b) a (+ a 0.0)) + (if (exact? a) b (+ b 0.0)))) + (car lst) (cdr lst))) +(define (min . lst) + (foldr (lambda (a b) + (if (< a b) + (if (exact? b) a (+ a 0.0)) + (if (exact? a) b (+ b 0.0)))) + (car lst) (cdr lst))) + +(define (succ x) (+ x 1)) +(define (pred x) (- x 1)) +(define gcd + (lambda a + (if (null? a) + 0 + (let ((aa (abs (car a))) + (bb (abs (cadr a)))) + (if (= bb 0) + aa + (gcd bb (remainder aa bb))))))) +(define lcm + (lambda a + (if (null? a) + 1 + (let ((aa (abs (car a))) + (bb (abs (cadr a)))) + (if (or (= aa 0) (= bb 0)) + 0 + (abs (* (quotient aa (gcd aa bb)) bb))))))) + + +(define (string . charlist) + (list->string charlist)) + +(define (list->string charlist) + (let* ((len (length charlist)) + (newstr (make-string len)) + (fill-string! + (lambda (str i len charlist) + (if (= i len) + str + (begin (string-set! str i (car charlist)) + (fill-string! str (+ i 1) len (cdr charlist))))))) + (fill-string! newstr 0 len charlist))) + +(define (string-fill! s e) + (let ((n (string-length s))) + (let loop ((i 0)) + (if (= i n) + s + (begin (string-set! s i e) (loop (succ i))))))) + +(define (string->list s) + (let loop ((n (pred (string-length s))) (l '())) + (if (= n -1) + l + (loop (pred n) (cons (string-ref s n) l))))) + +(define (string-copy str) + (string-append str)) + +(define (string->anyatom str pred) + (let* ((a (string->atom str))) + (if (pred a) a + (error "string->xxx: not a xxx" a)))) + +(define (string->number str . base) + (let ((n (string->atom str (if (null? base) 10 (car base))))) + (if (number? n) n #f))) + +(define (anyatom->string n pred) + (if (pred n) + (atom->string n) + (error "xxx->string: not a xxx" n))) + +(define (number->string n . base) + (atom->string n (if (null? base) 10 (car base)))) + + +(define (char-cmp? cmp a b) + (cmp (char->integer a) (char->integer b))) +(define (char-ci-cmp? cmp a b) + (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + +(define (char=? a b) (char-cmp? = a b)) +(define (char? a b) (char-cmp? > a b)) +(define (char<=? a b) (char-cmp? <= a b)) +(define (char>=? a b) (char-cmp? >= a b)) + +(define (char-ci=? a b) (char-ci-cmp? = a b)) +(define (char-ci? a b) (char-ci-cmp? > a b)) +(define (char-ci<=? a b) (char-ci-cmp? <= a b)) +(define (char-ci>=? a b) (char-ci-cmp? >= a b)) + +; Note the trick of returning (cmp x y) +(define (string-cmp? chcmp cmp a b) + (let ((na (string-length a)) (nb (string-length b))) + (let loop ((i 0)) + (cond + ((= i na) + (if (= i nb) (cmp 0 0) (cmp 0 1))) + ((= i nb) + (cmp 1 0)) + ((chcmp = (string-ref a i) (string-ref b i)) + (loop (succ i))) + (else + (chcmp cmp (string-ref a i) (string-ref b i))))))) + + +(define (string=? a b) (string-cmp? char-cmp? = a b)) +(define (string? a b) (string-cmp? char-cmp? > a b)) +(define (string<=? a b) (string-cmp? char-cmp? <= a b)) +(define (string>=? a b) (string-cmp? char-cmp? >= a b)) + +(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b)) +(define (string-ci? a b) (string-cmp? char-ci-cmp? > a b)) +(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b)) +(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b)) + +(define (list . x) x) + +(define (foldr f x lst) + (if (null? lst) + x + (foldr f (f x (car lst)) (cdr lst)))) + +(define (unzip1-with-cdr . lists) + (unzip1-with-cdr-iterative lists '() '())) + +(define (unzip1-with-cdr-iterative lists cars cdrs) + (if (null? lists) + (cons cars cdrs) + (let ((car1 (caar lists)) + (cdr1 (cdar lists))) + (unzip1-with-cdr-iterative + (cdr lists) + (append cars (list car1)) + (append cdrs (list cdr1)))))) + +(define (map proc . lists) + (if (null? lists) + (apply proc) + (if (null? (car lists)) + '() + (let* ((unz (apply unzip1-with-cdr lists)) + (cars (car unz)) + (cdrs (cdr unz))) + (cons (apply proc cars) (apply map (cons proc cdrs))))))) + +(define (for-each proc . lists) + (if (null? lists) + (apply proc) + (if (null? (car lists)) + #t + (let* ((unz (apply unzip1-with-cdr lists)) + (cars (car unz)) + (cdrs (cdr unz))) + (apply proc cars) (apply map (cons proc cdrs)))))) + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1)))) + +(define (list-ref x k) + (car (list-tail x k))) + +(define (last-pair x) + (if (pair? (cdr x)) + (last-pair (cdr x)) + x)) + +(define (head stream) (car stream)) + +(define (tail stream) (force (cdr stream))) + +(define (vector-equal? x y) + (and (vector? x) (vector? y) (= (vector-length x) (vector-length y)) + (let ((n (vector-length x))) + (let loop ((i 0)) + (if (= i n) + #t + (and (equal? (vector-ref x i) (vector-ref y i)) + (loop (succ i)))))))) + +(define (list->vector x) + (apply vector x)) + +(define (vector-fill! v e) + (let ((n (vector-length v))) + (let loop ((i 0)) + (if (= i n) + v + (begin (vector-set! v i e) (loop (succ i))))))) + +(define (vector->list v) + (let loop ((n (pred (vector-length v))) (l '())) + (if (= n -1) + l + (loop (pred n) (cons (vector-ref v n) l))))) + +;; The following quasiquote macro is due to Eric S. Tiedemann. +;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. +;; +;; Subsequently modified to handle vectors: D. Souflis + +(macro + quasiquote + (lambda (l) + (define (mcons f l r) + (if (and (pair? r) + (eq? (car r) 'quote) + (eq? (car (cdr r)) (cdr f)) + (pair? l) + (eq? (car l) 'quote) + (eq? (car (cdr l)) (car f))) + (if (or (procedure? f) (number? f) (string? f)) + f + (list 'quote f)) + (if (eqv? l vector) + (apply l (eval r)) + (list 'cons l r) + ))) + (define (mappend f l r) + (if (or (null? (cdr f)) + (and (pair? r) + (eq? (car r) 'quote) + (eq? (car (cdr r)) '()))) + l + (list 'append l r))) + (define (foo level form) + (cond ((not (pair? form)) + (if (or (procedure? form) (number? form) (string? form)) + form + (list 'quote form)) + ) + ((eq? 'quasiquote (car form)) + (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) + (#t (if (zero? level) + (cond ((eq? (car form) 'unquote) (car (cdr form))) + ((eq? (car form) 'unquote-splicing) + (error "Unquote-splicing wasn't in a list:" + form)) + ((and (pair? (car form)) + (eq? (car (car form)) 'unquote-splicing)) + (mappend form (car (cdr (car form))) + (foo level (cdr form)))) + (#t (mcons form (foo level (car form)) + (foo level (cdr form))))) + (cond ((eq? (car form) 'unquote) + (mcons form ''unquote (foo (- level 1) + (cdr form)))) + ((eq? (car form) 'unquote-splicing) + (mcons form ''unquote-splicing + (foo (- level 1) (cdr form)))) + (#t (mcons form (foo level (car form)) + (foo level (cdr form))))))))) + (foo 0 (car (cdr l))))) + +;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom) +(define (shared-tail x y) + (let ((len-x (length x)) + (len-y (length y))) + (define (shared-tail-helper x y) + (if + (eq? x y) + x + (shared-tail-helper (cdr x) (cdr y)))) + + (cond + ((> len-x len-y) + (shared-tail-helper + (list-tail x (- len-x len-y)) + y)) + ((< len-x len-y) + (shared-tail-helper + x + (list-tail y (- len-y len-x)))) + (#t (shared-tail-helper x y))))) + +;;;;;Dynamic-wind by Tom Breton (Tehom) + +;;Guarded because we must only eval this once, because doing so +;;redefines call/cc in terms of old call/cc +(unless (defined? 'dynamic-wind) + (let + ;;These functions are defined in the context of a private list of + ;;pairs of before/after procs. + ( (*active-windings* '()) + ;;We'll define some functions into the larger environment, so + ;;we need to know it. + (outer-env (current-environment))) + + ;;Poor-man's structure operations + (define before-func car) + (define after-func cdr) + (define make-winding cons) + + ;;Manage active windings + (define (activate-winding! new) + ((before-func new)) + (set! *active-windings* (cons new *active-windings*))) + (define (deactivate-top-winding!) + (let ((old-top (car *active-windings*))) + ;;Remove it from the list first so it's not active during its + ;;own exit. + (set! *active-windings* (cdr *active-windings*)) + ((after-func old-top)))) + + (define (set-active-windings! new-ws) + (unless (eq? new-ws *active-windings*) + (let ((shared (shared-tail new-ws *active-windings*))) + + ;;Define the looping functions. + ;;Exit the old list. Do deeper ones last. Don't do + ;;any shared ones. + (define (pop-many) + (unless (eq? *active-windings* shared) + (deactivate-top-winding!) + (pop-many))) + ;;Enter the new list. Do deeper ones first so that the + ;;deeper windings will already be active. Don't do any + ;;shared ones. + (define (push-many new-ws) + (unless (eq? new-ws shared) + (push-many (cdr new-ws)) + (activate-winding! (car new-ws)))) + + ;;Do it. + (pop-many) + (push-many new-ws)))) + + ;;The definitions themselves. + (eval + `(define call-with-current-continuation + ;;It internally uses the built-in call/cc, so capture it. + ,(let ((old-c/cc call-with-current-continuation)) + (lambda (func) + ;;Use old call/cc to get the continuation. + (old-c/cc + (lambda (continuation) + ;;Call func with not the continuation itself + ;;but a procedure that adjusts the active + ;;windings to what they were when we made + ;;this, and only then calls the + ;;continuation. + (func + (let ((current-ws *active-windings*)) + (lambda (x) + (set-active-windings! current-ws) + (continuation x))))))))) + outer-env) + ;;We can't just say "define (dynamic-wind before thunk after)" + ;;because the lambda it's defined to lives in this environment, + ;;not in the global environment. + (eval + `(define dynamic-wind + ,(lambda (before thunk after) + ;;Make a new winding + (activate-winding! (make-winding before after)) + (let ((result (thunk))) + ;;Get rid of the new winding. + (deactivate-top-winding!) + ;;The return value is that of thunk. + result))) + outer-env))) + +(define call/cc call-with-current-continuation) + + +;;;;; atom? and equal? written by a.k + +;;;; atom? +(define (atom? x) + (not (pair? x))) + +;;;; equal? +(define (equal? x y) + (cond + ((pair? x) + (and (pair? y) + (equal? (car x) (car y)) + (equal? (cdr x) (cdr y)))) + ((vector? x) + (and (vector? y) (vector-equal? x y))) + ((string? x) + (and (string? y) (string=? x y))) + (else (eqv? x y)))) + +;;;; (do ((var init inc) ...) (endtest result ...) body ...) +;; +(macro do + (lambda (do-macro) + (apply (lambda (do vars endtest . body) + (let ((do-loop (gensym))) + `(letrec ((,do-loop + (lambda ,(map (lambda (x) + (if (pair? x) (car x) x)) + `,vars) + (if ,(car endtest) + (begin ,@(cdr endtest)) + (begin + ,@body + (,do-loop + ,@(map (lambda (x) + (cond + ((not (pair? x)) x) + ((< (length x) 3) (car x)) + (else (car (cdr (cdr x)))))) + `,vars))))))) + (,do-loop + ,@(map (lambda (x) + (if (and (pair? x) (cdr x)) + (car (cdr x)) + '())) + `,vars))))) + do-macro))) + +;;;; generic-member +(define (generic-member cmp obj lst) + (cond + ((null? lst) #f) + ((cmp obj (car lst)) lst) + (else (generic-member cmp obj (cdr lst))))) + +(define (memq obj lst) + (generic-member eq? obj lst)) +(define (memv obj lst) + (generic-member eqv? obj lst)) +(define (member obj lst) + (generic-member equal? obj lst)) + +;;;; generic-assoc +(define (generic-assoc cmp obj alst) + (cond + ((null? alst) #f) + ((cmp obj (caar alst)) (car alst)) + (else (generic-assoc cmp obj (cdr alst))))) + +(define (assq obj alst) + (generic-assoc eq? obj alst)) +(define (assv obj alst) + (generic-assoc eqv? obj alst)) +(define (assoc obj alst) + (generic-assoc equal? obj alst)) + +(define (acons x y z) (cons (cons x y) z)) + +;;;; Handy for imperative programs +;;;; Used as: (define-with-return (foo x y) .... (return z) ...) +(macro (define-with-return form) + `(define ,(cadr form) + (call/cc (lambda (return) ,@(cddr form))))) + +;; Print the given history. +(define (vm-history-print history) + (let loop ((n 0) (skip 0) (frames history)) + (cond + ((null? frames) + #t) + ((> skip 0) + (loop 0 (- skip 1) (cdr frames))) + (else + (let ((f (car frames))) + (display n) + (display ": ") + (let ((tag (get-tag f))) + (when (and (pair? tag) (string? (car tag)) (number? (cdr tag))) + (display (basename (car tag))) + (display ":") + (display (+ 1 (cdr tag))) + (display ": "))) + (write f)) + (newline) + (loop (+ n 1) skip (cdr frames)))))) + +;;;; Simple exception handling +; +; Exceptions are caught as follows: +; +; (catch (do-something to-recover and-return meaningful-value) +; (if-something goes-wrong) +; (with-these calls)) +; +; "Catch" establishes a scope spanning multiple call-frames until +; another "catch" is encountered. Within the recovery expression +; the thrown exception is bound to *error*. Errors can be rethrown +; using (rethrow *error*). +; +; Finalization can be expressed using "finally": +; +; (finally (finalize-something called-purely-for side-effects) +; (whether-or-not something goes-wrong) +; (with-these calls)) +; +; The final expression is executed purely for its side-effects, +; both when the function exits successfully, and when an exception +; is thrown. +; +; Exceptions are thrown with: +; +; (throw "message") +; +; If used outside a (catch ...), reverts to (error "message") + +(define *handlers* (list)) + +(define (push-handler proc) + (set! *handlers* (cons proc *handlers*))) + +(define (pop-handler) + (let ((h (car *handlers*))) + (set! *handlers* (cdr *handlers*)) + h)) + +(define (more-handlers?) + (pair? *handlers*)) + +;; This throws an exception. +(define (throw message . args) + (throw' message args (cdr (*vm-history*)))) + +;; This is used by the vm to throw exceptions. +(define (throw' message args history) + (cond + ((and args (list? args) (= 2 (length args)) + (equal? *interpreter-exit* (car args))) + (*run-atexit-handlers*) + (quit (cadr args))) + ((more-handlers?) + ((pop-handler) message args history)) + (else + (display message) + (when (and args (not (null? args))) + (display ": ") + (if (and (pair? args) (string? (car args))) + (begin (display (car args)) + (unless (null? (cdr args)) + (newline) + (write (cdr args)))) + (write args))) + (newline) + (vm-history-print history) + (quit 1)))) + +;; Convenience function to rethrow the error. +(define (rethrow e) + (apply throw' e)) + +(macro (catch form) + (let ((label (gensym))) + `(call/cc (lambda (**exit**) + (push-handler (lambda *error* (**exit** ,(cadr form)))) + (let ((,label (begin ,@(cddr form)))) + (pop-handler) + ,label))))) + +(define-macro (finally final-expression . expressions) + (let ((result (gensym))) + `(let ((,result (catch (begin ,final-expression (rethrow *error*)) + ,@expressions))) + ,final-expression + ,result))) + +;; Make the vm use throw'. +(define *error-hook* throw') + + + +;; High-level mechanism to terminate the process is to throw an error +;; of the form (*interpreter-exit* status). This gives automatic +;; resource management a chance to clean up. +(define *interpreter-exit* (gensym)) + +;; Terminate the process returning STATUS to the parent. +(define (exit status) + (throw "interpreter exit" *interpreter-exit* status)) + +;; A list of functions run at interpreter shutdown. +(define *atexit-handlers* (list)) + +;; Execute all these functions. +(define (*run-atexit-handlers*) + (unless (null? *atexit-handlers*) + (let ((proc (car *atexit-handlers*))) + ;; Drop proc from the list so that it will not get + ;; executed again even if it raises an exception. + (set! *atexit-handlers* (cdr *atexit-handlers*)) + (proc) + (*run-atexit-handlers*)))) + +;; Register a function to be run at interpreter shutdown. +(define (atexit proc) + (set! *atexit-handlers* (cons proc *atexit-handlers*))) + + + +;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL + +(macro (make-environment form) + `(apply (lambda () + ,@(cdr form) + (current-environment)))) + +(define-macro (eval-polymorphic x . envl) + (display envl) + (let* ((env (if (null? envl) (current-environment) (eval (car envl)))) + (xval (eval x env))) + (if (closure? xval) + (make-closure (get-closure-code xval) env) + xval))) + +; Redefine this if you install another package infrastructure +; Also redefine 'package' +(define *colon-hook* eval) + +(macro (package form) + `(apply (lambda () + ,@(cdr form) + (current-environment)))) + +(define-macro (export name . expressions) + `(define ,name + (begin + ,@expressions))) + +;;;;; I/O + +(define (input-output-port? p) + (and (input-port? p) (output-port? p))) + +(define (close-port p) + (cond + ((input-output-port? p) (close-input-port p) (close-output-port p)) + ((input-port? p) (close-input-port p)) + ((output-port? p) (close-output-port p)) + (else (throw "Not a port" p)))) + +(define (call-with-input-file s p) + (let ((inport (open-input-file s))) + (if (eq? inport #f) + #f + (let ((res (p inport))) + (close-input-port inport) + res)))) + +(define (call-with-output-file s p) + (let ((outport (open-output-file s))) + (if (eq? outport #f) + #f + (let ((res (p outport))) + (close-output-port outport) + res)))) + +(define (with-input-from-file s p) + (let ((inport (open-input-file s))) + (if (eq? inport #f) + #f + (let ((prev-inport (current-input-port))) + (set-input-port inport) + (let ((res (p))) + (close-input-port inport) + (set-input-port prev-inport) + res))))) + +(define (with-output-to-file s p) + (let ((outport (open-output-file s))) + (if (eq? outport #f) + #f + (let ((prev-outport (current-output-port))) + (set-output-port outport) + (let ((res (p))) + (close-output-port outport) + (set-output-port prev-outport) + res))))) + +(define (with-input-output-from-to-files si so p) + (let ((inport (open-input-file si)) + (outport (open-input-file so))) + (if (not (and inport outport)) + (begin + (close-input-port inport) + (close-output-port outport) + #f) + (let ((prev-inport (current-input-port)) + (prev-outport (current-output-port))) + (set-input-port inport) + (set-output-port outport) + (let ((res (p))) + (close-input-port inport) + (close-output-port outport) + (set-input-port prev-inport) + (set-output-port prev-outport) + res))))) + +; Random number generator (maximum cycle) +(define *seed* 1) +(define (random-next) + (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a))) + (set! *seed* + (- (* a (- *seed* + (* (quotient *seed* q) q))) + (* (quotient *seed* q) r))) + (if (< *seed* 0) (set! *seed* (+ *seed* m))) + *seed*)) +;; SRFI-0 +;; COND-EXPAND +;; Implemented as a macro +(define *features* '(srfi-0 tinyscheme)) + +(define-macro (cond-expand . cond-action-list) + (cond-expand-runtime cond-action-list)) + +(define (cond-expand-runtime cond-action-list) + (if (null? cond-action-list) + #t + (if (cond-eval (caar cond-action-list)) + `(begin ,@(cdar cond-action-list)) + (cond-expand-runtime (cdr cond-action-list))))) + +(define (cond-eval-and cond-list) + (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list)) + +(define (cond-eval-or cond-list) + (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list)) + +(define (cond-eval condition) + (cond + ((symbol? condition) + (if (member condition *features*) #t #f)) + ((eq? condition #t) #t) + ((eq? condition #f) #f) + (else (case (car condition) + ((and) (cond-eval-and (cdr condition))) + ((or) (cond-eval-or (cdr condition))) + ((not) (if (not (null? (cddr condition))) + (error "cond-expand : 'not' takes 1 argument") + (not (cond-eval (cadr condition))))) + (else (error "cond-expand : unknown operator" (car condition))))))) + +(gc-verbose #f) diff --git a/gpgscm/lib.scm b/gpgscm/lib.scm new file mode 100644 index 0000000..258f692 --- /dev/null +++ b/gpgscm/lib.scm @@ -0,0 +1,307 @@ +;; Additional library functions for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(macro (assert form) + (let ((tag (get-tag form))) + `(if (not ,(cadr form)) + (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag))) + `(string-append ,(car tag) ":" + ,(number->string (+ 1 (cdr tag))) + ": Assertion failed: ") + "Assertion failed: ") + (quote ,(cadr form)))))) +(assert #t) +(assert (not #f)) + +;; Trace displays and returns the given value. A debugging aid. +(define (trace x) + (display x) + (newline) + x) + +;; Stringification. +(define (stringify expression) + (let ((p (open-output-string))) + (write expression p) + (get-output-string p))) + +(define (filter pred lst) + (cond ((null? lst) '()) + ((pred (car lst)) + (cons (car lst) (filter pred (cdr lst)))) + (else (filter pred (cdr lst))))) + +(define (any p l) + (cond ((null? l) #f) + ((p (car l)) #t) + (else (any p (cdr l))))) + +(define (all p l) + (cond ((null? l) #t) + ((not (p (car l))) #f) + (else (all p (cdr l))))) + +;; Return the first element of a list. +(define first car) + +;; Return the last element of a list. +(define (last lst) + (if (null? (cdr lst)) + (car lst) + (last (cdr lst)))) + +;; Compute the powerset of a list. +(define (powerset set) + (if (null? set) + '(()) + (let ((rst (powerset (cdr set)))) + (append (map (lambda (x) (cons (car set) x)) + rst) + rst)))) + +;; Is PREFIX a prefix of S? +(define (string-prefix? s prefix) + (and (>= (string-length s) (string-length prefix)) + (string=? prefix (substring s 0 (string-length prefix))))) +(assert (string-prefix? "Scheme" "Sch")) + +;; Is SUFFIX a suffix of S? +(define (string-suffix? s suffix) + (and (>= (string-length s) (string-length suffix)) + (string=? suffix (substring s (- (string-length s) + (string-length suffix)) + (string-length s))))) +(assert (string-suffix? "Scheme" "eme")) + +;; Locate the first occurrence of needle in haystack starting at offset. +(ffi-define (string-index haystack needle [offset])) +(assert (= 2 (string-index "Hallo" #\l))) +(assert (= 3 (string-index "Hallo" #\l 3))) +(assert (equal? #f (string-index "Hallo" #\.))) + +;; Locate the last occurrence of needle in haystack starting at offset. +(ffi-define (string-rindex haystack needle [offset])) +(assert (= 3 (string-rindex "Hallo" #\l))) +(assert (equal? #f (string-rindex "Hallo" #\a 2))) +(assert (equal? #f (string-rindex "Hallo" #\.))) + +;; Split HAYSTACK at each character that makes PREDICATE true at most +;; N times. +(define (string-split-pln haystack predicate lookahead n) + (let ((length (string-length haystack))) + (define (split acc offset n) + (if (>= offset length) + (reverse! acc) + (let ((i (lookahead haystack offset))) + (if (or (eq? i #f) (= 0 n)) + (reverse! (cons (substring haystack offset length) acc)) + (split (cons (substring haystack offset i) acc) + (+ i 1) (- n 1)))))) + (split '() 0 n))) + +(define (string-indexp haystack offset predicate) + (cond + ((= (string-length haystack) offset) + #f) + ((predicate (string-ref haystack offset)) + offset) + (else + (string-indexp haystack (+ 1 offset) predicate)))) + +;; Split HAYSTACK at each character that makes PREDICATE true at most +;; N times. +(define (string-splitp haystack predicate n) + (string-split-pln haystack predicate + (lambda (haystack offset) + (string-indexp haystack offset predicate)) + n)) +(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1))) +(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1))) +(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1))) + +;; Split haystack at delimiter at most n times. +(define (string-splitn haystack delimiter n) + (string-split-pln haystack + (lambda (c) (char=? c delimiter)) + (lambda (haystack offset) + (string-index haystack delimiter offset)) + n)) +(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1)))) + +;; Split haystack at delimiter. +(define (string-split haystack delimiter) + (string-splitn haystack delimiter -1)) +(assert (= 3 (length (string-split "foo:bar:baz" #\:)))) +(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:)))) +(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:)))) +(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:)))) + +;; Split haystack at newlines. +(define (string-split-newlines haystack) + (if *win32* + (map (lambda (line) (if (string-suffix? line "\r") + (substring line 0 (- (string-length line) 1)) + line)) + (string-split haystack #\newline)) + (string-split haystack #\newline))) + +;; Trim the prefix of S containing only characters that make PREDICATE +;; true. +(define (string-ltrim predicate s) + (if (string=? s "") + "" + (let loop ((s' (string->list s))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string s'))))) +(assert (string=? "" (string-ltrim char-whitespace? ""))) +(assert (string=? "foo" (string-ltrim char-whitespace? " foo"))) + +;; Trim the suffix of S containing only characters that make PREDICATE +;; true. +(define (string-rtrim predicate s) + (if (string=? s "") + "" + (let loop ((s' (reverse! (string->list s)))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string (reverse! s')))))) +(assert (string=? "" (string-rtrim char-whitespace? ""))) +(assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) + +;; Trim both the prefix and suffix of S containing only characters +;; that make PREDICATE true. +(define (string-trim predicate s) + (string-ltrim predicate (string-rtrim predicate s))) +(assert (string=? "" (string-trim char-whitespace? ""))) +(assert (string=? "foo" (string-trim char-whitespace? " foo "))) + +;; Check if needle is contained in haystack. +(ffi-define (string-contains? haystack needle)) +(assert (string-contains? "Hallo" "llo")) +(assert (not (string-contains? "Hallo" "olla"))) + +;; Translate characters. +(define (string-translate s from to) + (list->string (map (lambda (c) + (let ((i (string-index from c))) + (if i (string-ref to i) c))) (string->list s)))) +(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar")) + +;; Read a word from port P. +(define (read-word . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char-alphabetic? c) + (apply read-char p) + (cons c (f))) + (else + (apply read-char p) + '())))))) + +(define (list->string-reversed lst) + (let* ((len (length lst)) + (str (make-string len))) + (let loop ((i (- len 1)) + (l lst)) + (if (< i 0) + (begin + (assert (null? l)) + str) + (begin + (string-set! str i (car l)) + (loop (- i 1) (cdr l))))))) + +;; Read a line from port P. +(define (read-line . p) + (let loop ((acc '())) + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) + (if (null? acc) + c ;; #eof + (list->string-reversed acc))) + ((char=? c #\newline) + (apply read-char p) + (list->string-reversed acc)) + (else + (apply read-char p) + (loop (cons c acc))))))) + +;; Read everything from port P. +(define (read-all . p) + (let loop ((acc (open-output-string))) + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) (get-output-string acc)) + (else + (write-char (apply read-char p) acc) + (loop acc)))))) + +;; +;; Windows support. +;; + +;; Like call-with-input-file but opens the file in 'binary' mode. +(define (call-with-binary-input-file filename proc) + (letfd ((fd (open filename (logior O_RDONLY O_BINARY)))) + (proc (fdopen fd "rb")))) + +;; Like call-with-output-file but opens the file in 'binary' mode. +(define (call-with-binary-output-file filename proc) + (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (proc (fdopen fd "wb")))) + +;; +;; Libc functions. +;; + +;; Change the read/write offset. +(ffi-define (seek fd offset whence)) + +;; Constants for WHENCE. +(ffi-define SEEK_SET) +(ffi-define SEEK_CUR) +(ffi-define SEEK_END) + +;; Get our process id. +(ffi-define (getpid)) + +;; Copy data from file descriptor SOURCE to every file descriptor in +;; SINKS. +(ffi-define (splice source . sinks)) + +;; +;; Random numbers. +;; + +;; Seed the random number generator. +(ffi-define (srandom seed)) + +;; Get a pseudo-random number between 0 (inclusive) and SCALE +;; (exclusive). +(ffi-define (random scale)) + +;; Create a string of the given SIZE containing pseudo-random data. +(ffi-define (make-random-string size)) diff --git a/gpgscm/main.c b/gpgscm/main.c new file mode 100644 index 0000000..5540ac3 --- /dev/null +++ b/gpgscm/main.c @@ -0,0 +1,359 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#if HAVE_MMAP +#include +#endif + +#include "private.h" +#include "scheme.h" +#include "scheme-private.h" +#include "ffi.h" +#include "../common/i18n.h" +#include "../../common/argparse.h" +#include "../../common/init.h" +#include "../../common/logging.h" +#include "../../common/strlist.h" +#include "../../common/sysutils.h" +#include "../../common/util.h" + +/* The TinyScheme banner. Unfortunately, it isn't in the header + file. */ +#define ts_banner "TinyScheme 1.41" + +int verbose; + + + +/* Constants to identify the commands and options. */ +enum cmd_and_opt_values + { + aNull = 0, + oVerbose = 'v', + }; + +/* The list of commands and options. */ +static ARGPARSE_OPTS opts[] = + { + ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")), + ARGPARSE_end (), + }; + +char *scmpath = ""; +size_t scmpath_len = 0; + +/* Command line parsing. */ +static void +parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) +{ + int no_more_options = 0; + + while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts)) + { + switch (pargs->r_opt) + { + case oVerbose: + verbose++; + break; + + default: + pargs->err = 2; + break; + } + } +} + +/* Print usage information and provide strings for help. */ +static const char * +my_strusage( int level ) +{ + const char *p; + + switch (level) + { + case 11: p = "gpgscm (@GNUPG@)"; + break; + case 13: p = VERSION; break; + case 17: p = PRINTABLE_OS_NAME; break; + case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break; + + case 1: + case 40: + p = _("Usage: gpgscm [options] [file] (-h for help)"); + break; + case 41: + p = _("Syntax: gpgscm [options] [file]\n" + "Execute the given Scheme program, or spawn interactive shell.\n"); + break; + + default: p = NULL; break; + } + return p; +} + + + +static int +path_absolute_p (const char *p) +{ +#if _WIN32 + return ((strlen (p) > 2 && p[1] == ':' && (p[2] == '\\' || p[2] == '/')) + || p[0] == '\\' || p[0] == '/'); +#else + return p[0] == '/'; +#endif +} + + +/* Load the Scheme program from FILE_NAME. If FILE_NAME is not an + absolute path, and LOOKUP_IN_PATH is given, then it is qualified + with the values in scmpath until the file is found. */ +static gpg_error_t +load (scheme *sc, char *file_name, + int lookup_in_cwd, int lookup_in_path) +{ + gpg_error_t err = 0; + size_t n; + const char *directory; + char *qualified_name = file_name; + int use_path; + FILE *h = NULL; + + use_path = + lookup_in_path && ! (path_absolute_p (file_name) || scmpath_len == 0); + + if (path_absolute_p (file_name) || lookup_in_cwd || scmpath_len == 0) + { + h = fopen (file_name, "r"); + if (! h) + err = gpg_error_from_syserror (); + } + + if (h == NULL && use_path) + for (directory = scmpath, n = scmpath_len; n; + directory += strlen (directory) + 1, n--) + { + if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0) + return gpg_error_from_syserror (); + + h = fopen (qualified_name, "r"); + if (h) + { + err = 0; + break; + } + + if (n > 1) + { + free (qualified_name); + continue; /* Try again! */ + } + + err = gpg_error_from_syserror (); + } + + if (h == NULL) + { + /* Failed and no more elements in scmpath to try. */ + fprintf (stderr, "Could not read %s: %s.\n", + qualified_name, gpg_strerror (err)); + if (lookup_in_path) + fprintf (stderr, + "Consider using GPGSCM_PATH to specify the location " + "of the Scheme library.\n"); + goto leave; + } + if (verbose > 2) + fprintf (stderr, "Loading %s...\n", qualified_name); + +#if HAVE_MMAP + /* Always try to mmap the file. This allows the pages to be shared + * between processes. If anything fails, we fall back to using + * buffered streams. */ + if (1) + { + struct stat st; + void *map; + size_t len; + int fd = fileno (h); + + if (fd < 0) + goto fallback; + + if (fstat (fd, &st)) + goto fallback; + + len = (size_t) st.st_size; + if ((off_t) len != st.st_size) + goto fallback; /* Truncated. */ + + map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0); + if (map == MAP_FAILED) + goto fallback; + + scheme_load_memory (sc, map, len, qualified_name); + munmap (map, len); + } + else + fallback: +#endif + scheme_load_named_file (sc, h, qualified_name); + fclose (h); + + if (sc->retcode && sc->nesting) + { + fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); + err = gpg_error (GPG_ERR_GENERAL); + } + + leave: + if (file_name != qualified_name) + free (qualified_name); + return err; +} + + + +int +main (int argc, char **argv) +{ + int retcode; + gpg_error_t err; + char *argv0; + ARGPARSE_ARGS pargs; + scheme *sc; + char *p; +#if _WIN32 + char pathsep = ';'; +#else + char pathsep = ':'; +#endif + char *script = NULL; + + /* Save argv[0] so that we can re-exec. */ + argv0 = argv[0]; + + /* Parse path. */ + if (getenv ("GPGSCM_PATH")) + scmpath = getenv ("GPGSCM_PATH"); + + p = scmpath = strdup (scmpath); + if (p == NULL) + return 2; + + if (*p) + scmpath_len++; + for (; *p; p++) + if (*p == pathsep) + *p = 0, scmpath_len++; + + set_strusage (my_strusage); + log_set_prefix ("gpgscm", GPGRT_LOG_WITH_PREFIX); + + /* Make sure that our subsystems are ready. */ + i18n_init (); + init_common_subsystems (&argc, &argv); + + if (!gcry_check_version (NEED_LIBGCRYPT_VERSION)) + { + fputs ("libgcrypt version mismatch\n", stderr); + exit (2); + } + + /* Parse the command line. */ + pargs.argc = &argc; + pargs.argv = &argv; + pargs.flags = 0; + parse_arguments (&pargs, opts); + + if (log_get_errorcount (0)) + exit (2); + + sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free); + if (! sc) { + fprintf (stderr, "Could not initialize TinyScheme!\n"); + return 2; + } + scheme_set_input_port_file (sc, stdin); + scheme_set_output_port_file (sc, stderr); + + if (argc) + { + script = argv[0]; + argc--, argv++; + } + + err = load (sc, "init.scm", 0, 1); + if (! err) + err = load (sc, "ffi.scm", 0, 1); + if (! err) + err = ffi_init (sc, argv0, script ? script : "interactive", + argc, (const char **) argv); + if (! err) + err = load (sc, "lib.scm", 0, 1); + if (! err) + err = load (sc, "repl.scm", 0, 1); + if (! err) + err = load (sc, "xml.scm", 0, 1); + if (! err) + err = load (sc, "tests.scm", 0, 1); + if (! err) + err = load (sc, "gnupg.scm", 0, 1); + if (err) + { + fprintf (stderr, "Error initializing gpgscm: %s.\n", + gpg_strerror (err)); + exit (2); + } + + if (script == NULL) + { + /* Interactive shell. */ + fprintf (stderr, "gpgscm/"ts_banner".\n"); + scheme_load_string (sc, "(interactive-repl)"); + } + else + { + err = load (sc, script, 1, 1); + if (err) + log_fatal ("%s: %s", script, gpg_strerror (err)); + } + + retcode = sc->retcode; + scheme_load_string (sc, "(*run-atexit-handlers*)"); + scheme_deinit (sc); + xfree (sc); + return retcode; +} diff --git a/gpgscm/makefile.scm b/gpgscm/makefile.scm new file mode 100644 index 0000000..32fae3a --- /dev/null +++ b/gpgscm/makefile.scm @@ -0,0 +1,76 @@ +;; Support for parsing Makefiles +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(define (parse-makefile port key) + (define (is-continuation? tokens) + (string=? (last tokens) "\\")) + (define (valid-token? s) + (< 0 (string-length s))) + (define (drop-continuations tokens) + (let loop ((acc '()) (tks tokens)) + (if (null? tks) + (reverse acc) + (loop (if (string=? "\\" (car tks)) + acc + (cons (car tks) acc)) (cdr tks))))) + (let next ((acc '()) (found #f)) + (let ((line (read-line port))) + (if (eof-object? line) + acc + (let ((tokens (filter valid-token? + (string-splitp (string-trim char-whitespace? + line) + char-whitespace? -1)))) + (cond + ((or (null? tokens) + (string-prefix? (car tokens) "#") + (and (not found) (not (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))))) + (next acc found)) + ((not found) + (assert (and (string=? key (car tokens)) + (string=? "=" (cadr tokens)))) + (if (is-continuation? tokens) + (next (drop-continuations (cddr tokens)) #t) + (drop-continuations (cddr tokens)))) + (else + (assert found) + (if (is-continuation? tokens) + (next (append acc (drop-continuations tokens)) found) + (append acc (drop-continuations tokens)))))))))) + +(define (parse-makefile-expand filename expand key) + (define (variable? v) + (and (string-prefix? v "$(") (string-suffix? v ")"))) + + (let expand-all ((values (parse-makefile (open-input-file filename) key))) + (if (any variable? values) + (expand-all + (let expand-one ((acc '()) (v values)) + (cond + ((null? v) + acc) + ((variable? (car v)) + (let ((makefile (open-input-file filename)) + (key (substring (car v) 2 (- (string-length (car v)) 1)))) + (expand-one (append acc (expand filename makefile key)) + (cdr v)))) + (else + (expand-one (append acc (list (car v))) (cdr v)))))) + values))) diff --git a/gpgscm/opdefines.h b/gpgscm/opdefines.h new file mode 100644 index 0000000..61f7971 --- /dev/null +++ b/gpgscm/opdefines.h @@ -0,0 +1,205 @@ +_OP_DEF("load", 1, 1, TST_STRING, OP_LOAD ) +_OP_DEF(0, 0, 0, 0, OP_T0LVL ) +_OP_DEF(0, 0, 0, 0, OP_T1LVL ) +_OP_DEF(0, 0, 0, 0, OP_READ_INTERNAL ) +_OP_DEF("gensym", 0, 0, 0, OP_GENSYM ) +_OP_DEF(0, 0, 0, 0, OP_VALUEPRINT ) +_OP_DEF(0, 0, 0, 0, OP_EVAL ) +#if USE_TRACING +_OP_DEF(0, 0, 0, 0, OP_REAL_EVAL ) +#endif +_OP_DEF(0, 0, 0, 0, OP_E0ARGS ) +_OP_DEF(0, 0, 0, 0, OP_E1ARGS ) +#if USE_HISTORY +_OP_DEF(0, 0, 0, 0, OP_CALLSTACK_POP ) +#endif +_OP_DEF(0, 0, 0, 0, OP_APPLY_CODE ) +_OP_DEF(0, 0, 0, 0, OP_APPLY ) +#if USE_TRACING +_OP_DEF(0, 0, 0, 0, OP_REAL_APPLY ) +_OP_DEF("tracing", 1, 1, TST_NATURAL, OP_TRACING ) +#endif +_OP_DEF(0, 0, 0, 0, OP_DOMACRO ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA ) +_OP_DEF(0, 0, 0, 0, OP_LAMBDA1 ) +_OP_DEF("make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) +_OP_DEF(0, 0, 0, 0, OP_QUOTE ) +_OP_DEF(0, 0, 0, 0, OP_DEF0 ) +_OP_DEF(0, 0, 0, 0, OP_DEF1 ) +_OP_DEF("defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) +_OP_DEF(0, 0, 0, 0, OP_BEGIN ) +_OP_DEF(0, 0, 0, 0, OP_IF0 ) +_OP_DEF(0, 0, 0, 0, OP_IF1 ) +_OP_DEF(0, 0, 0, 0, OP_SET0 ) +_OP_DEF(0, 0, 0, 0, OP_SET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET0 ) +_OP_DEF(0, 0, 0, 0, OP_LET1 ) +_OP_DEF(0, 0, 0, 0, OP_LET2 ) +_OP_DEF(0, 0, 0, 0, OP_LET0AST ) +_OP_DEF(0, 0, 0, 0, OP_LET1AST ) +_OP_DEF(0, 0, 0, 0, OP_LET2AST ) +_OP_DEF(0, 0, 0, 0, OP_LET0REC ) +_OP_DEF(0, 0, 0, 0, OP_LET1REC ) +_OP_DEF(0, 0, 0, 0, OP_LET2REC ) +_OP_DEF(0, 0, 0, 0, OP_COND0 ) +_OP_DEF(0, 0, 0, 0, OP_COND1 ) +_OP_DEF(0, 0, 0, 0, OP_DELAY ) +_OP_DEF(0, 0, 0, 0, OP_AND0 ) +_OP_DEF(0, 0, 0, 0, OP_AND1 ) +_OP_DEF(0, 0, 0, 0, OP_OR0 ) +_OP_DEF(0, 0, 0, 0, OP_OR1 ) +_OP_DEF(0, 0, 0, 0, OP_C0STREAM ) +_OP_DEF(0, 0, 0, 0, OP_C1STREAM ) +_OP_DEF(0, 0, 0, 0, OP_MACRO0 ) +_OP_DEF(0, 0, 0, 0, OP_MACRO1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE0 ) +_OP_DEF(0, 0, 0, 0, OP_CASE1 ) +_OP_DEF(0, 0, 0, 0, OP_CASE2 ) +_OP_DEF("eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) +_OP_DEF("apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) +_OP_DEF("call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) +#if USE_MATH +_OP_DEF("inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) +_OP_DEF("exp", 1, 1, TST_NUMBER, OP_EXP ) +_OP_DEF("log", 1, 1, TST_NUMBER, OP_LOG ) +_OP_DEF("sin", 1, 1, TST_NUMBER, OP_SIN ) +_OP_DEF("cos", 1, 1, TST_NUMBER, OP_COS ) +_OP_DEF("tan", 1, 1, TST_NUMBER, OP_TAN ) +_OP_DEF("asin", 1, 1, TST_NUMBER, OP_ASIN ) +_OP_DEF("acos", 1, 1, TST_NUMBER, OP_ACOS ) +_OP_DEF("atan", 1, 2, TST_NUMBER, OP_ATAN ) +_OP_DEF("sqrt", 1, 1, TST_NUMBER, OP_SQRT ) +_OP_DEF("expt", 2, 2, TST_NUMBER, OP_EXPT ) +_OP_DEF("floor", 1, 1, TST_NUMBER, OP_FLOOR ) +_OP_DEF("ceiling", 1, 1, TST_NUMBER, OP_CEILING ) +_OP_DEF("truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) +_OP_DEF("round", 1, 1, TST_NUMBER, OP_ROUND ) +#endif +_OP_DEF("+", 0, INF_ARG, TST_NUMBER, OP_ADD ) +_OP_DEF("-", 1, INF_ARG, TST_NUMBER, OP_SUB ) +_OP_DEF("*", 0, INF_ARG, TST_NUMBER, OP_MUL ) +_OP_DEF("/", 1, INF_ARG, TST_NUMBER, OP_DIV ) +_OP_DEF("quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) +_OP_DEF("remainder", 2, 2, TST_INTEGER, OP_REM ) +_OP_DEF("modulo", 2, 2, TST_INTEGER, OP_MOD ) +_OP_DEF("car", 1, 1, TST_PAIR, OP_CAR ) +_OP_DEF("cdr", 1, 1, TST_PAIR, OP_CDR ) +_OP_DEF("cons", 2, 2, TST_NONE, OP_CONS ) +_OP_DEF("set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) +_OP_DEF("set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) +_OP_DEF("char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) +_OP_DEF("integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) +_OP_DEF("char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) +_OP_DEF("char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) +_OP_DEF("symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) +_OP_DEF("atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) +_OP_DEF("string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) +_OP_DEF("string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) +_OP_DEF("make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) +_OP_DEF("string-length", 1, 1, TST_STRING, OP_STRLEN ) +_OP_DEF("string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) +_OP_DEF("string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) +_OP_DEF("string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) +_OP_DEF("substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) +_OP_DEF("vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) +_OP_DEF("make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) +_OP_DEF("vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) +_OP_DEF("vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) +_OP_DEF("vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) +_OP_DEF("not", 1, 1, TST_NONE, OP_NOT ) +_OP_DEF("boolean?", 1, 1, TST_NONE, OP_BOOLP ) +_OP_DEF("eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) +_OP_DEF("null?", 1, 1, TST_NONE, OP_NULLP ) +_OP_DEF("=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) +_OP_DEF("<", 2, INF_ARG, TST_NUMBER, OP_LESS ) +_OP_DEF(">", 2, INF_ARG, TST_NUMBER, OP_GRE ) +_OP_DEF("<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) +_OP_DEF(">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) +_OP_DEF("symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) +_OP_DEF("number?", 1, 1, TST_ANY, OP_NUMBERP ) +_OP_DEF("string?", 1, 1, TST_ANY, OP_STRINGP ) +_OP_DEF("integer?", 1, 1, TST_ANY, OP_INTEGERP ) +_OP_DEF("real?", 1, 1, TST_ANY, OP_REALP ) +_OP_DEF("char?", 1, 1, TST_ANY, OP_CHARP ) +#if USE_CHAR_CLASSIFIERS +_OP_DEF("char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) +_OP_DEF("char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) +_OP_DEF("char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) +_OP_DEF("char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) +_OP_DEF("char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) +#endif +_OP_DEF("port?", 1, 1, TST_ANY, OP_PORTP ) +_OP_DEF("input-port?", 1, 1, TST_ANY, OP_INPORTP ) +_OP_DEF("output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) +_OP_DEF("procedure?", 1, 1, TST_ANY, OP_PROCP ) +_OP_DEF("pair?", 1, 1, TST_ANY, OP_PAIRP ) +_OP_DEF("list?", 1, 1, TST_ANY, OP_LISTP ) +_OP_DEF("environment?", 1, 1, TST_ANY, OP_ENVP ) +_OP_DEF("vector?", 1, 1, TST_ANY, OP_VECTORP ) +_OP_DEF("eq?", 2, 2, TST_ANY, OP_EQ ) +_OP_DEF("eqv?", 2, 2, TST_ANY, OP_EQV ) +_OP_DEF("force", 1, 1, TST_ANY, OP_FORCE ) +_OP_DEF(0, 0, 0, 0, OP_SAVE_FORCED ) +_OP_DEF("write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) +_OP_DEF("write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) +_OP_DEF("display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) +_OP_DEF("newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) +_OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 ) +_OP_DEF(0, 0, 0, 0, OP_ERR1 ) +_OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE ) +_OP_DEF("reverse!", 1, 1, TST_LIST, OP_REVERSE_IN_PLACE ) +_OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) +_OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND ) +#if USE_PLIST +_OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) +_OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) +#endif +_OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE ) +_OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) +_OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) +_OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT ) +_OP_DEF("gc", 0, 0, 0, OP_GC ) +_OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) +_OP_DEF("new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) +_OP_DEF("oblist", 0, 0, 0, OP_OBLIST ) +_OP_DEF("current-input-port", 0, 0, 0, OP_CURR_INPORT ) +_OP_DEF("current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) +_OP_DEF("open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) +_OP_DEF("open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) +_OP_DEF("open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) +#if USE_STRING_PORTS +_OP_DEF("open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) +_OP_DEF("open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) +_OP_DEF("open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) +_OP_DEF("get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) +#endif +_OP_DEF("close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) +_OP_DEF("close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) +_OP_DEF("interaction-environment", 0, 0, 0, OP_INT_ENV ) +_OP_DEF("current-environment", 0, 0, 0, OP_CURR_ENV ) +_OP_DEF("read", 0, 1, TST_INPORT, OP_READ ) +_OP_DEF("read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) +_OP_DEF("peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) +_OP_DEF("char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) +_OP_DEF("set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) +_OP_DEF("set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) +_OP_DEF(0, 0, 0, 0, OP_RDSEXPR ) +_OP_DEF(0, 0, 0, 0, OP_RDLIST ) +_OP_DEF(0, 0, 0, 0, OP_RDDOT ) +_OP_DEF(0, 0, 0, 0, OP_RDQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDQQUOTEVEC ) +_OP_DEF(0, 0, 0, 0, OP_RDUNQUOTE ) +_OP_DEF(0, 0, 0, 0, OP_RDUQTSP ) +_OP_DEF(0, 0, 0, 0, OP_RDVEC ) +_OP_DEF(0, 0, 0, 0, OP_P0LIST ) +_OP_DEF(0, 0, 0, 0, OP_P1LIST ) +_OP_DEF(0, 0, 0, 0, OP_PVECFROM ) +_OP_DEF("length", 1, 1, TST_LIST, OP_LIST_LENGTH ) +_OP_DEF("assq", 2, 2, TST_NONE, OP_ASSQ ) +_OP_DEF("get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) +_OP_DEF("closure?", 1, 1, TST_NONE, OP_CLOSUREP ) +_OP_DEF("macro?", 1, 1, TST_NONE, OP_MACROP ) +_OP_DEF("*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) + +#undef _OP_DEF diff --git a/gpgscm/private.h b/gpgscm/private.h new file mode 100644 index 0000000..6e330e0 --- /dev/null +++ b/gpgscm/private.h @@ -0,0 +1,26 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#ifndef __GPGSCM_PRIVATE_H__ +#define __GPGSCM_PRIVATE_H__ + +extern int verbose; + +#endif /* __GPGSCM_PRIVATE_H__ */ diff --git a/gpgscm/repl.scm b/gpgscm/repl.scm new file mode 100644 index 0000000..833ec0d --- /dev/null +++ b/gpgscm/repl.scm @@ -0,0 +1,69 @@ +;; A read-evaluate-print-loop for gpgscm. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Interactive repl using 'prompt' function. P must be a function +;; that given the current entered prefix returns the prompt to +;; display. +(define (repl p environment) + (call/cc + (lambda (exit) + (let loop ((prefix "")) + (let ((line (prompt (p prefix)))) + (if (and (not (eof-object? line)) (= 0 (string-length line))) + (exit (loop prefix))) + (if (not (eof-object? line)) + (let* ((next (string-append prefix line)) + (c (catch (begin (echo "Parse error:" *error*) + (loop prefix)) + (read (open-input-string next))))) + (if (not (eof-object? c)) + (begin + (catch (begin + (display (car *error*)) + (when (and (cadr *error*) + (not (null? (cadr *error*)))) + (display ": ") + (write (cadr *error*))) + (newline) + (vm-history-print (caddr *error*))) + (echo " ===>" (eval c environment))) + (exit (loop "")))) + (exit (loop next))))))))) + +(define (prompt-append-prefix prompt prefix) + (string-append prompt (if (> (string-length prefix) 0) + (string-append prefix "...") + "> "))) + +;; Default repl run by main.c. +(define (interactive-repl . environment) + (repl (lambda (p) (prompt-append-prefix "gpgscm " p)) + (if (null? environment) (interaction-environment) (car environment)))) + +;; Ask a yes/no question. +(define (prompt-yes-no? question default) + (let ((answer (prompt (string-append question "? [" + (if default "Y/n" "y/N") "] ")))) + (cond + ((= 0 (string-length answer)) + default) + ((or (equal? "y" answer) (equal? "Y" answer)) + #t) + (else + #f)))) diff --git a/gpgscm/scheme-config.h b/gpgscm/scheme-config.h new file mode 100644 index 0000000..15ca969 --- /dev/null +++ b/gpgscm/scheme-config.h @@ -0,0 +1,32 @@ +/* TinyScheme configuration. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#define STANDALONE 0 +#define USE_MATH 0 +#define USE_CHAR_CLASSIFIERS 1 +#define USE_ASCII_NAMES 1 +#define USE_STRING_PORTS 1 +#define USE_ERROR_HOOK 1 +#define USE_TRACING 1 +#define USE_COLON_HOOK 1 +#define USE_DL 0 +#define USE_PLIST 0 +#define USE_INTERFACE 1 +#define SHOW_ERROR_LINE 1 diff --git a/gpgscm/scheme-private.h b/gpgscm/scheme-private.h new file mode 100644 index 0000000..7f92bda --- /dev/null +++ b/gpgscm/scheme-private.h @@ -0,0 +1,274 @@ +/* scheme-private.h */ + +#ifndef _SCHEME_PRIVATE_H +#define _SCHEME_PRIVATE_H + +#include +#include "scheme.h" +/*------------------ Ugly internals -----------------------------------*/ +/*------------------ Of interest only to FFI users --------------------*/ + +#ifdef __cplusplus +extern "C" { +#endif + +enum scheme_port_kind { + port_free=0, + port_file=1, + port_string=2, + port_srfi6=4, + port_input=16, + port_output=32, + port_saw_EOF=64 +}; + +typedef struct port { + unsigned char kind; + union { + struct { + FILE *file; + int closeit; + } stdio; + struct { + char *start; + char *past_the_end; + char *curr; + } string; + } rep; +#if SHOW_ERROR_LINE + pointer curr_line; + pointer filename; +#endif +} port; + +/* cell structure */ +struct cell { + uintptr_t _flag; + union { + num _number; + struct { + char *_svalue; + int _length; + } _string; + port *_port; + foreign_func _ff; + struct { + struct cell *_car; + struct cell *_cdr; + } _cons; + struct { + size_t _length; + pointer _elements[0]; + } _vector; + struct { + char *_data; + const foreign_object_vtable *_vtable; + } _foreign_object; + } _object; +}; + +#if USE_HISTORY +/* The history is a two-dimensional ring buffer. A donut-shaped data + * structure. This data structure is inspired by MIT/GNU Scheme. */ +struct history { + /* Number of calls to store. Must be a power of two. */ + size_t N; + + /* Number of tail-calls to store in each call frame. Must be a + * power of two. */ + size_t M; + + /* Masks for fast index calculations. */ + size_t mask_N; + size_t mask_M; + + /* A vector of size N containing calls. */ + pointer callstack; + + /* A vector of size N containing vectors of size M containing tail + * calls. */ + pointer tailstacks; + + /* Our current position. */ + size_t n; + size_t *m; +}; +#endif + +struct scheme { +/* arrays for segments */ +func_alloc malloc; +func_dealloc free; + +/* return code */ +int retcode; +int tracing; + + +#ifndef CELL_SEGSIZE +#define CELL_SEGSIZE 5000 /* # of cells in one segment */ +#endif + +/* If less than # of cells are recovered in a garbage collector run, + * allocate a new cell segment to avoid fruitless collection cycles in + * the near future. */ +#ifndef CELL_MINRECOVER +#define CELL_MINRECOVER (CELL_SEGSIZE >> 2) +#endif +struct cell_segment *cell_segments; + +/* We use 4 registers. */ +pointer args; /* register for arguments of function */ +pointer envir; /* stack register for current environment */ +pointer code; /* register for current code */ +pointer dump; /* stack register for next evaluation */ +pointer frame_freelist; + +#if USE_HISTORY +struct history history; /* we keep track of the call history for + * error messages */ +#endif + +int interactive_repl; /* are we in an interactive REPL? */ + +struct cell _sink; +pointer sink; /* when mem. alloc. fails */ +struct cell _NIL; +pointer NIL; /* special cell representing empty cell */ +struct cell _HASHT; +pointer T; /* special cell representing #t */ +struct cell _HASHF; +pointer F; /* special cell representing #f */ +struct cell _EOF_OBJ; +pointer EOF_OBJ; /* special cell representing end-of-file object */ +pointer oblist; /* pointer to symbol table */ +pointer global_env; /* pointer to global environment */ +pointer c_nest; /* stack for nested calls from C */ + +/* global pointers to special symbols */ +pointer LAMBDA; /* pointer to syntax lambda */ +pointer QUOTE; /* pointer to syntax quote */ + +pointer QQUOTE; /* pointer to symbol quasiquote */ +pointer UNQUOTE; /* pointer to symbol unquote */ +pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ +pointer FEED_TO; /* => */ +pointer COLON_HOOK; /* *colon-hook* */ +pointer ERROR_HOOK; /* *error-hook* */ +pointer SHARP_HOOK; /* *sharp-hook* */ +#if USE_COMPILE_HOOK +pointer COMPILE_HOOK; /* *compile-hook* */ +#endif + +pointer free_cell; /* pointer to top of free cells */ +long fcells; /* # of free cells */ +size_t inhibit_gc; /* nesting of gc_disable */ +size_t reserved_cells; /* # of reserved cells */ +#ifndef NDEBUG +int reserved_lineno; /* location of last reservation */ +#endif + +pointer inport; +pointer outport; +pointer save_inport; +pointer loadport; + +#ifndef MAXFIL +#define MAXFIL 64 +#endif +port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ +int nesting_stack[MAXFIL]; +int file_i; +int nesting; + +char gc_verbose; /* if gc_verbose is not zero, print gc status */ +char no_memory; /* Whether mem. alloc. has failed */ + +#ifndef LINESIZE +#define LINESIZE 1024 +#endif +char linebuff[LINESIZE]; +#ifndef STRBUFFSIZE +#define STRBUFFSIZE 256 +#endif +char *strbuff; +size_t strbuff_size; +FILE *tmpfp; +int tok; +int print_flag; +pointer value; +unsigned int flags; + +void *ext_data; /* For the benefit of foreign functions */ +long gensym_cnt; + +const struct scheme_interface *vptr; +}; + +/* operator code */ +enum scheme_opcodes { +#define _OP_DEF(A,B,C,D,OP) OP, +#include "opdefines.h" + OP_MAXDEFINED +}; + + +#define cons(sc,a,b) _cons(sc,a,b,0) +#define immutable_cons(sc,a,b) _cons(sc,a,b,1) + +int is_string(pointer p); +char *string_value(pointer p); +int is_number(pointer p); +num nvalue(pointer p); +long ivalue(pointer p); +double rvalue(pointer p); +int is_integer(pointer p); +int is_real(pointer p); +int is_character(pointer p); +long charvalue(pointer p); +int is_vector(pointer p); + +int is_port(pointer p); + +int is_pair(pointer p); +pointer pair_car(pointer p); +pointer pair_cdr(pointer p); +pointer set_car(pointer p, pointer q); +pointer set_cdr(pointer p, pointer q); + +int is_symbol(pointer p); +char *symname(pointer p); +int hasprop(pointer p); + +int is_syntax(pointer p); +int is_proc(pointer p); +int is_foreign(pointer p); +char *syntaxname(pointer p); +int is_closure(pointer p); +#ifdef USE_MACRO +int is_macro(pointer p); +#endif +pointer closure_code(pointer p); +pointer closure_env(pointer p); + +int is_continuation(pointer p); +int is_promise(pointer p); +int is_environment(pointer p); +int is_immutable(pointer p); +void setimmutable(pointer p); + +int is_foreign_object(pointer p); +const foreign_object_vtable *get_foreign_object_vtable(pointer p); +void *get_foreign_object_data(pointer p); + +#ifdef __cplusplus +} +#endif + +#endif + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/gpgscm/scheme.c b/gpgscm/scheme.c new file mode 100644 index 0000000..4384841 --- /dev/null +++ b/gpgscm/scheme.c @@ -0,0 +1,6028 @@ +/* T I N Y S C H E M E 1 . 4 1 + * Dimitrios Souflis (dsouflis@acm.org) + * Based on MiniScheme (original credits follow) + * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) + * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp + * (MINISCM) This version has been modified by R.C. Secrist. + * (MINISCM) + * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. + * (MINISCM) + * (MINISCM) This is a revised and modified version by Akira KIDA. + * (MINISCM) current version is 0.85k4 (15 May 1994) + * + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#define _SCHEME_SOURCE +#include "scheme-private.h" +#ifndef WIN32 +# include +#endif +#ifdef WIN32 +#define snprintf _snprintf +#endif +#if USE_DL +# include "dynload.h" +#endif +#if USE_MATH +# include +#endif + +#include +#include +#include +#include +#include + +#if USE_STRCASECMP +#include +# ifndef __APPLE__ +# define stricmp strcasecmp +# endif +#endif + +/* Used for documentation purposes, to signal functions in 'interface' */ +#define INTERFACE + +#define TOK_EOF (-1) +#define TOK_LPAREN 0 +#define TOK_RPAREN 1 +#define TOK_DOT 2 +#define TOK_ATOM 3 +#define TOK_QUOTE 4 +#define TOK_COMMENT 5 +#define TOK_DQUOTE 6 +#define TOK_BQUOTE 7 +#define TOK_COMMA 8 +#define TOK_ATMARK 9 +#define TOK_SHARP 10 +#define TOK_SHARP_CONST 11 +#define TOK_VEC 12 + +#define BACKQUOTE '`' +#define DELIMITERS "()\";\f\t\v\n\r " + +/* + * Basic memory allocation units + */ + +#define banner "TinyScheme 1.41" + +#include +#include +#include + +#ifdef __APPLE__ +static int stricmp(const char *s1, const char *s2) +{ + unsigned char c1, c2; + do { + c1 = tolower(*s1); + c2 = tolower(*s2); + if (c1 < c2) + return -1; + else if (c1 > c2) + return 1; + s1++, s2++; + } while (c1 != 0); + return 0; +} +#endif /* __APPLE__ */ + +#if USE_STRLWR && !defined(HAVE_STRLWR) +static const char *strlwr(char *s) { + const char *p=s; + while(*s) { + *s=tolower(*s); + s++; + } + return p; +} +#endif + +#ifndef prompt +# define prompt "ts> " +#endif + +#ifndef InitFile +# define InitFile "init.scm" +#endif + +#ifndef FIRST_CELLSEGS +# define FIRST_CELLSEGS 3 +#endif + + + +/* All types have the LSB set. The garbage collector takes advantage + * of that to identify types. */ +enum scheme_types { + T_STRING = 1 << 1 | 1, + T_NUMBER = 2 << 1 | 1, + T_SYMBOL = 3 << 1 | 1, + T_PROC = 4 << 1 | 1, + T_PAIR = 5 << 1 | 1, + T_CLOSURE = 6 << 1 | 1, + T_CONTINUATION = 7 << 1 | 1, + T_FOREIGN = 8 << 1 | 1, + T_CHARACTER = 9 << 1 | 1, + T_PORT = 10 << 1 | 1, + T_VECTOR = 11 << 1 | 1, + T_MACRO = 12 << 1 | 1, + T_PROMISE = 13 << 1 | 1, + T_ENVIRONMENT = 14 << 1 | 1, + T_FOREIGN_OBJECT = 15 << 1 | 1, + T_BOOLEAN = 16 << 1 | 1, + T_NIL = 17 << 1 | 1, + T_EOF_OBJ = 18 << 1 | 1, + T_SINK = 19 << 1 | 1, + T_FRAME = 20 << 1 | 1, + T_LAST_SYSTEM_TYPE = 20 << 1 | 1 +}; + +static const char * +type_to_string (enum scheme_types typ) +{ + switch (typ) + { + case T_STRING: return "string"; + case T_NUMBER: return "number"; + case T_SYMBOL: return "symbol"; + case T_PROC: return "proc"; + case T_PAIR: return "pair"; + case T_CLOSURE: return "closure"; + case T_CONTINUATION: return "continuation"; + case T_FOREIGN: return "foreign"; + case T_CHARACTER: return "character"; + case T_PORT: return "port"; + case T_VECTOR: return "vector"; + case T_MACRO: return "macro"; + case T_PROMISE: return "promise"; + case T_ENVIRONMENT: return "environment"; + case T_FOREIGN_OBJECT: return "foreign object"; + case T_BOOLEAN: return "boolean"; + case T_NIL: return "nil"; + case T_EOF_OBJ: return "eof object"; + case T_SINK: return "sink"; + case T_FRAME: return "frame"; + } + assert (! "not reached"); +} + +/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ +#define TYPE_BITS 6 +#define ADJ (1 << TYPE_BITS) +#define T_MASKTYPE (ADJ - 1) + /* 0000000000111111 */ +#define T_TAGGED 1024 /* 0000010000000000 */ +#define T_FINALIZE 2048 /* 0000100000000000 */ +#define T_SYNTAX 4096 /* 0001000000000000 */ +#define T_IMMUTABLE 8192 /* 0010000000000000 */ +#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ +#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ +#define MARK 32768 /* 1000000000000000 */ +#define UNMARK 32767 /* 0111111111111111 */ + + +static num num_add(num a, num b); +static num num_mul(num a, num b); +static num num_div(num a, num b); +static num num_intdiv(num a, num b); +static num num_sub(num a, num b); +static num num_rem(num a, num b); +static num num_mod(num a, num b); +static int num_eq(num a, num b); +static int num_gt(num a, num b); +static int num_ge(num a, num b); +static int num_lt(num a, num b); +static int num_le(num a, num b); + +#if USE_MATH +static double round_per_R5RS(double x); +#endif +static int is_zero_double(double x); +static INLINE int num_is_integer(pointer p) { + return ((p)->_object._number.is_fixnum); +} + +static const struct num num_zero = { 1, {0} }; +static const struct num num_one = { 1, {1} }; + +/* macros for cell operations */ +#define typeflag(p) ((p)->_flag) +#define type(p) (typeflag(p)&T_MASKTYPE) +#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ)) + +INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } +#define strvalue(p) ((p)->_object._string._svalue) +#define strlength(p) ((p)->_object._string._length) + +INTERFACE static int is_list(scheme *sc, pointer p); +INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } +/* Given a vector, return it's length. */ +#define vector_length(v) (v)->_object._vector._length +/* Given a vector length, compute the amount of cells required to + * represent it. */ +#define vector_size(len) (1 + ((len) - 1 + 2) / 3) +INTERFACE static void fill_vector(pointer vec, pointer obj); +INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem); +INTERFACE static pointer vector_elem(pointer vec, int ielem); +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); +INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } +INTERFACE INLINE int is_integer(pointer p) { + if (!is_number(p)) + return 0; + if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) + return 1; + return 0; +} + +INTERFACE INLINE int is_real(pointer p) { + return is_number(p) && (!(p)->_object._number.is_fixnum); +} + +INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } +INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } +INLINE num nvalue(pointer p) { return ((p)->_object._number); } +INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } +INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } +#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) +#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) +#define set_num_integer(p) (p)->_object._number.is_fixnum=1; +#define set_num_real(p) (p)->_object._number.is_fixnum=0; +INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } + +INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } +INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } +INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } + +INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } +#define car(p) ((p)->_object._cons._car) +#define cdr(p) ((p)->_object._cons._cdr) +INTERFACE pointer pair_car(pointer p) { return car(p); } +INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } +INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } +INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } + +INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } +INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } +#if USE_PLIST +SCHEME_EXPORT INLINE int hasprop(pointer p) { return (is_symbol(p)); } +#define symprop(p) cdr(p) +#endif + +INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } +INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } +INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } +INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } +#define procnum(p) ivalue_unchecked(p) +static const char *procname(pointer x); + +INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } +INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } +INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } +INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } + +INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } +#define cont_dump(p) cdr(p) + +INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); } +INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) { + return p->_object._foreign_object._vtable; +} +INTERFACE void *get_foreign_object_data(pointer p) { + return p->_object._foreign_object._data; +} + +/* To do: promise should be forced ONCE only */ +INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } + +INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } +#define setenvironment(p) typeflag(p) = T_ENVIRONMENT + +INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); } +#define setframe(p) settype(p, T_FRAME) + +#define is_atom(p) (typeflag(p)&T_ATOM) +#define setatom(p) typeflag(p) |= T_ATOM +#define clratom(p) typeflag(p) &= CLRATOM + +#define is_mark(p) (typeflag(p)&MARK) +#define setmark(p) typeflag(p) |= MARK +#define clrmark(p) typeflag(p) &= UNMARK + +INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } +/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ +INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } + +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define cdar(p) cdr(car(p)) +#define cddr(p) cdr(cdr(p)) +#define cadar(p) car(cdr(car(p))) +#define caddr(p) car(cdr(cdr(p))) +#define cdaar(p) cdr(car(car(p))) +#define cadaar(p) car(cdr(car(car(p)))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define cddddr(p) cdr(cdr(cdr(cdr(p)))) + +#if USE_HISTORY +static pointer history_flatten(scheme *sc); +static void history_mark(scheme *sc); +#else +# define history_mark(SC) (void) 0 +# define history_flatten(SC) (SC)->NIL +#endif + +#if USE_CHAR_CLASSIFIERS +static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } +static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } +static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } +static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } +static INLINE int Cislower(int c) { return isascii(c) && islower(c); } +#endif + +#if USE_ASCII_NAMES +static const char charnames[32][3]={ + "nul", + "soh", + "stx", + "etx", + "eot", + "enq", + "ack", + "bel", + "bs", + "ht", + "lf", + "vt", + "ff", + "cr", + "so", + "si", + "dle", + "dc1", + "dc2", + "dc3", + "dc4", + "nak", + "syn", + "etb", + "can", + "em", + "sub", + "esc", + "fs", + "gs", + "rs", + "us" +}; + +static int is_ascii_name(const char *name, int *pc) { + int i; + for(i=0; i<32; i++) { + if (strncasecmp(name, charnames[i], 3) == 0) { + *pc=i; + return 1; + } + } + if (strcasecmp(name, "del") == 0) { + *pc=127; + return 1; + } + return 0; +} + +#endif + +static int file_push(scheme *sc, pointer fname); +static void file_pop(scheme *sc); +static int file_interactive(scheme *sc); +static INLINE int is_one_of(char *s, int c); +static int alloc_cellseg(scheme *sc, int n); +static long binary_decode(const char *s); +static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); +static pointer _get_cell(scheme *sc, pointer a, pointer b); +static pointer reserve_cells(scheme *sc, int n); +static pointer get_consecutive_cells(scheme *sc, int n); +static pointer find_consecutive_cells(scheme *sc, int n); +static int finalize_cell(scheme *sc, pointer a); +static int count_consecutive_cells(pointer x, int needed); +static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); +static pointer mk_number(scheme *sc, num n); +static char *store_string(scheme *sc, int len, const char *str, char fill); +static pointer mk_vector(scheme *sc, int len); +static pointer mk_atom(scheme *sc, char *q); +static pointer mk_sharp_const(scheme *sc, char *name); +static pointer mk_port(scheme *sc, port *p); +static pointer port_from_filename(scheme *sc, const char *fn, int prop); +static pointer port_from_file(scheme *sc, FILE *, int prop); +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); +static port *port_rep_from_file(scheme *sc, FILE *, int prop); +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static void port_close(scheme *sc, pointer p, int flag); +static void mark(pointer a); +static void gc(scheme *sc, pointer a, pointer b); +static int basic_inchar(port *pt); +static int inchar(scheme *sc); +static void backchar(scheme *sc, int c); +static char *readstr_upto(scheme *sc, char *delim); +static pointer readstrexp(scheme *sc); +static INLINE int skipspace(scheme *sc); +static int token(scheme *sc); +static void printslashstring(scheme *sc, char *s, int len); +static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); +static void printatom(scheme *sc, pointer l, int f); +static pointer mk_proc(scheme *sc, enum scheme_opcodes op); +static pointer mk_closure(scheme *sc, pointer c, pointer e); +static pointer mk_continuation(scheme *sc, pointer d); +static pointer reverse(scheme *sc, pointer term, pointer list); +static pointer reverse_in_place(scheme *sc, pointer term, pointer list); +static pointer revappend(scheme *sc, pointer a, pointer b); +static void dump_stack_preallocate_frame(scheme *sc); +static void dump_stack_mark(scheme *); +struct op_code_info { + char name[31]; /* strlen ("call-with-current-continuation") + 1 */ + unsigned char min_arity; + unsigned char max_arity; + char arg_tests_encoding[3]; +}; +static const struct op_code_info dispatch_table[]; +static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size); +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name); +static int syntaxnum(scheme *sc, pointer p); +static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name); + +#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) +#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) + +static num num_add(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue+b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)+num_rvalue(b); + } + return ret; +} + +static num num_mul(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue*b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)*num_rvalue(b); + } + return ret; +} + +static num num_div(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_intdiv(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_sub(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue-b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)-num_rvalue(b); + } + return ret; +} + +static num num_rem(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* remainder should have same sign as second operand */ + if (res > 0) { + if (e1 < 0) { + res -= labs(e2); + } + } else if (res < 0) { + if (e1 > 0) { + res += labs(e2); + } + } + ret.value.ivalue=res; + return ret; +} + +static num num_mod(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* modulo should have same sign as second operand */ + if (res * e2 < 0) { + res += e2; + } + ret.value.ivalue=res; + return ret; +} + +static int num_eq(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue==b.value.ivalue; + } else { + ret=num_rvalue(a)==num_rvalue(b); + } + return ret; +} + + +static int num_gt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue>b.value.ivalue; + } else { + ret=num_rvalue(a)>num_rvalue(b); + } + return ret; +} + +static int num_ge(num a, num b) { + return !num_lt(a,b); +} + +static int num_lt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivaluedce) { + return ce; + } else if(dfl-DBL_MIN; +} + +static long binary_decode(const char *s) { + long x=0; + + while(*s!=0 && (*s=='1' || *s=='0')) { + x<<=1; + x+=*s-'0'; + s++; + } + + return x; +} + + + +/* + * Copying values. + * + * Occasionally, we need to copy a value from one location in the + * storage to another. Scheme objects are fine. Some primitive + * objects, however, require finalization, usually to free resources. + * + * For these values, we either make a copy or acquire a reference. + */ + +/* + * Copy SRC to DST. + * + * Copies the representation of SRC to DST. This makes SRC + * indistinguishable from DST from the perspective of a Scheme + * expression modulo the fact that they reside at a different location + * in the store. + * + * Conditions: + * + * - SRC must not be a vector. + * - Caller must ensure that any resources associated with the + * value currently stored in DST is accounted for. + */ +static void +copy_value(scheme *sc, pointer dst, pointer src) +{ + memcpy(dst, src, sizeof *src); + + /* We may need to make a copy or acquire a reference. */ + if (typeflag(dst) & T_FINALIZE) + switch (type(dst)) { + case T_STRING: + strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0); + break; + case T_PORT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_FOREIGN_OBJECT: + /* XXX acquire reference */ + assert (!"implemented"); + break; + case T_VECTOR: + assert (!"vectors cannot be copied"); + } +} + + + +/* Tags are like property lists, but can be attached to arbitrary + * values. */ + +static pointer +mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) +{ + pointer r, t; + + assert(! is_vector(v)); + + r = get_consecutive_cells(sc, 2); + if (r == sc->sink) + return sc->sink; + + copy_value(sc, r, v); + typeflag(r) |= T_TAGGED; + + t = r + 1; + typeflag(t) = T_PAIR; + car(t) = tag_car; + cdr(t) = tag_cdr; + + return r; +} + +static INLINE int +has_tag(pointer v) +{ + return !! (typeflag(v) & T_TAGGED); +} + +static INLINE pointer +get_tag(scheme *sc, pointer v) +{ + if (has_tag(v)) + return v + 1; + return sc->NIL; +} + + + +/* Low-level allocator. + * + * Memory is allocated in segments. Every segment holds a fixed + * number of cells. Segments are linked into a list, sorted in + * reverse address order (i.e. those with a higher address first). + * This is used in the garbage collector to build the freelist in + * address order. + */ + +struct cell_segment +{ + struct cell_segment *next; + void *alloc; + pointer cells; + size_t cells_len; +}; + +/* Allocate a new cell segment but do not make it available yet. */ +static int +_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment) +{ + int adj = ADJ; + void *cp; + + if (adj < sizeof(struct cell)) + adj = sizeof(struct cell); + + /* The segment header is conveniently allocated with the cells. */ + cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj); + if (cp == NULL) + return 1; + + *segment = cp; + (*segment)->next = NULL; + (*segment)->alloc = cp; + cp = (void *) ((uintptr_t) cp + sizeof **segment); + + /* adjust in TYPE_BITS-bit boundary */ + if (((uintptr_t) cp) % adj != 0) + cp = (void *) (adj * ((uintptr_t) cp / adj + 1)); + + (*segment)->cells = cp; + (*segment)->cells_len = len; + return 0; +} + +/* Deallocate a cell segment. Returns the next cell segment. + * Convenient for deallocation in a loop. */ +static struct cell_segment * +_dealloc_cellseg(scheme *sc, struct cell_segment *segment) +{ + + struct cell_segment *next; + + if (segment == NULL) + return NULL; + + next = segment->next; + sc->free(segment->alloc); + return next; +} + +/* allocate new cell segment */ +static int alloc_cellseg(scheme *sc, int n) { + pointer last; + pointer p; + int k; + + for (k = 0; k < n; k++) { + struct cell_segment *new, **s; + if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) { + return k; + } + /* insert new segment in reverse address order */ + for (s = &sc->cell_segments; + *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc; + s = &(*s)->next) { + /* walk */ + } + new->next = *s; + *s = new; + + sc->fcells += new->cells_len; + last = new->cells + new->cells_len - 1; + for (p = new->cells; p <= last; p++) { + typeflag(p) = 0; + cdr(p) = p + 1; + car(p) = sc->NIL; + } + /* insert new cells in address order on free list */ + if (sc->free_cell == sc->NIL || p < sc->free_cell) { + cdr(last) = sc->free_cell; + sc->free_cell = new->cells; + } else { + p = sc->free_cell; + while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p)) + p = cdr(p); + cdr(last) = cdr(p); + cdr(p) = new->cells; + } + } + return n; +} + + + +/* Controlling the garbage collector. + * + * Every time a cell is allocated, the interpreter may run out of free + * cells and do a garbage collection. This is problematic because it + * might garbage collect objects that have been allocated, but are not + * yet made available to the interpreter. + * + * Previously, we would plug such newly allocated cells into the list + * of newly allocated objects rooted at car(sc->sink), but that + * requires allocating yet another cell increasing pressure on the + * memory management system. + * + * A faster alternative is to preallocate the cells needed for an + * operation and make sure the garbage collection is not run until all + * allocated objects are plugged in. This can be done with gc_disable + * and gc_enable. + */ + +/* The garbage collector is enabled if the inhibit counter is + * zero. */ +#define GC_ENABLED 0 + +/* For now we provide a way to disable this optimization for + * benchmarking and because it produces slightly smaller code. */ +#ifndef USE_GC_LOCKING +# define USE_GC_LOCKING 1 +#endif + +/* To facilitate nested calls to gc_disable, functions that allocate + * more than one cell may define a macro, e.g. foo_allocates. This + * macro can be used to compute the amount of preallocation at the + * call site with the help of this macro. */ +#define gc_reservations(fn) fn ## _allocates + +#if USE_GC_LOCKING + +/* Report a shortage in reserved cells, and terminate the program. */ +static void +gc_reservation_failure(struct scheme *sc) +{ +#ifdef NDEBUG + fprintf(stderr, + "insufficient reservation\n") +#else + fprintf(stderr, + "insufficient %s reservation in line %d\n", + sc->frame_freelist == sc->NIL ? "frame" : "cell", + sc->reserved_lineno); +#endif + abort(); +} + +/* Disable the garbage collection and reserve the given number of + * cells. gc_disable may be nested, but the enclosing reservation + * must include the reservations of all nested calls. Note: You must + * re-enable the gc before calling Error_X. */ +static void +_gc_disable(struct scheme *sc, size_t reserve, int lineno) +{ + if (sc->inhibit_gc == 0) { + reserve_cells(sc, (reserve)); + sc->reserved_cells = (reserve); +#ifdef NDEBUG + (void) lineno; +#else + sc->reserved_lineno = lineno; +#endif + } else if (sc->reserved_cells < (reserve)) + gc_reservation_failure (sc); + sc->inhibit_gc += 1; +} +#define gc_disable(sc, reserve) \ + do { \ + if (sc->frame_freelist == sc->NIL) { \ + if (gc_enabled(sc)) \ + dump_stack_preallocate_frame(sc); \ + else \ + gc_reservation_failure(sc); \ + } \ + _gc_disable (sc, reserve, __LINE__); \ + } while (0) + +/* Enable the garbage collector. */ +#define gc_enable(sc) \ + do { \ + assert(sc->inhibit_gc); \ + sc->inhibit_gc -= 1; \ + } while (0) + +/* Test whether the garbage collector is enabled. */ +#define gc_enabled(sc) \ + (sc->inhibit_gc == GC_ENABLED) + +/* Consume a reserved cell. */ +#define gc_consume(sc) \ + do { \ + assert(! gc_enabled (sc)); \ + if (sc->reserved_cells == 0) \ + gc_reservation_failure (sc); \ + sc->reserved_cells -= 1; \ + } while (0) + +#else /* USE_GC_LOCKING */ + +#define gc_reservation_failure(sc) (void) 0 +#define gc_disable(sc, reserve) \ + do { \ + if (sc->frame_freelist == sc->NIL) \ + dump_stack_preallocate_frame(sc); \ + } while (0) +#define gc_enable(sc) (void) 0 +#define gc_enabled(sc) 1 +#define gc_consume(sc) (void) 0 + +#endif /* USE_GC_LOCKING */ + +static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { + if (! gc_enabled (sc) || sc->free_cell != sc->NIL) { + pointer x = sc->free_cell; + if (! gc_enabled (sc)) + gc_consume (sc); + sc->free_cell = cdr(x); + --sc->fcells; + return (x); + } + assert (gc_enabled (sc)); + return _get_cell (sc, a, b); +} + + +/* get new cell. parameter a, b is marked by gc. */ +static pointer _get_cell(scheme *sc, pointer a, pointer b) { + pointer x; + + if(sc->no_memory) { + return sc->sink; + } + + assert (gc_enabled (sc)); + if (sc->free_cell == sc->NIL) { + gc(sc,a, b); + if (sc->free_cell == sc->NIL) { + sc->no_memory=1; + return sc->sink; + } + } + x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); +} + +/* make sure that there is a given number of cells free */ +static pointer reserve_cells(scheme *sc, int n) { + if(sc->no_memory) { + return sc->NIL; + } + + /* Are there enough cells available? */ + if (sc->fcells < n) { + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + if (sc->fcells < n) { + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) { + sc->no_memory=1; + return sc->NIL; + } + } + if (sc->fcells < n) { + /* If all fail, report failure */ + sc->no_memory=1; + return sc->NIL; + } + } + return (sc->T); +} + +static pointer get_consecutive_cells(scheme *sc, int n) { + pointer x; + + if(sc->no_memory) { return sc->sink; } + + /* Are there any cells available? */ + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) + { + sc->no_memory=1; + return sc->sink; + } + + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If all fail, report failure */ + sc->no_memory=1; + return sc->sink; +} + +static int count_consecutive_cells(pointer x, int needed) { + int n=1; + while(cdr(x)==x+1) { + x=cdr(x); + n++; + if(n>needed) return n; + } + return n; +} + +static pointer find_consecutive_cells(scheme *sc, int n) { + pointer *pp; + int cnt; + + pp=&sc->free_cell; + while(*pp!=sc->NIL) { + cnt=count_consecutive_cells(*pp,n); + if(cnt>=n) { + pointer x=*pp; + *pp=cdr(*pp+n-1); + sc->fcells -= n; + return x; + } + pp=&cdr(*pp+cnt-1); + } + return sc->NIL; +} + +/* Free a cell. This is dangerous. Only free cells that are not + * referenced. */ +static INLINE void +free_cell(scheme *sc, pointer a) +{ + cdr(a) = sc->free_cell; + sc->free_cell = a; + sc->fcells += 1; +} + +/* Free a cell and retrieve its content. This is dangerous. Only + * free cells that are not referenced. */ +static INLINE void +free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr) +{ + *r_car = car(a); + *r_cdr = cdr(a); + free_cell(sc, a); +} + +/* To retain recent allocs before interpreter knows about them - + Tehom */ + +static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) +{ + pointer holder = get_cell_x(sc, recent, extra); + typeflag(holder) = T_PAIR | T_IMMUTABLE; + car(holder) = recent; + cdr(holder) = car(sc->sink); + car(sc->sink) = holder; +} + +static INLINE void ok_to_freely_gc(scheme *sc) +{ + pointer a = car(sc->sink), next; + car(sc->sink) = sc->NIL; + while (a != sc->NIL) + { + next = cdr(a); + free_cell(sc, a); + a = next; + } +} + +static pointer get_cell(scheme *sc, pointer a, pointer b) +{ + pointer cell = get_cell_x(sc, a, b); + /* For right now, include "a" and "b" in "cell" so that gc doesn't + think they are garbage. */ + /* Tentatively record it as a pair so gc understands it. */ + typeflag(cell) = T_PAIR; + car(cell) = a; + cdr(cell) = b; + if (gc_enabled (sc)) + push_recent_alloc(sc, cell, sc->NIL); + return cell; +} + +static pointer get_vector_object(scheme *sc, int len, pointer init) +{ + pointer cells = get_consecutive_cells(sc, vector_size(len)); + int i; + int alloc_len = 1 + 3 * (vector_size(len) - 1); + if(sc->no_memory) { return sc->sink; } + /* Record it as a vector so that gc understands it. */ + typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE); + vector_length(cells) = len; + fill_vector(cells,init); + + /* Initialize the unused slots at the end. */ + assert (alloc_len - len < 3); + for (i = len; i < alloc_len; i++) + cells->_object._vector._elements[i] = sc->NIL; + + if (gc_enabled (sc)) + push_recent_alloc(sc, cells, sc->NIL); + return cells; +} + +/* Medium level cell allocation */ + +/* get new cons cell */ +pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { + pointer x = get_cell(sc,a, b); + + typeflag(x) = T_PAIR; + if(immutable) { + setimmutable(x); + } + car(x) = a; + cdr(x) = b; + return (x); +} + + +/* ========== oblist implementation ========== */ + +#ifndef USE_OBJECT_LIST + +static int hash_fn(const char *key, int table_size); + +static pointer oblist_initial_value(scheme *sc) +{ + /* There are about 768 symbols used after loading the + * interpreter. */ + return mk_vector(sc, 1009); +} + +/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not + * exist. In that case, SLOT points to the point where the new symbol + * is to be inserted. */ +static INLINE pointer +oblist_find_by_name(scheme *sc, const char *name, pointer **slot) +{ + int location; + pointer x; + char *s; + int d; + + location = hash_fn(name, vector_length(sc->oblist)); + for (*slot = vector_elem_slot(sc->oblist, location), x = **slot; + x != sc->NIL; *slot = &cdr(x), x = **slot) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + d = stricmp(name, s); + if (d == 0) + return car(x); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + return sc->NIL; +} + +static pointer oblist_all_symbols(scheme *sc) +{ + int i; + pointer x; + pointer ob_list = sc->NIL; + + for (i = 0; i < vector_length(sc->oblist); i++) { + for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { + ob_list = cons(sc, x, ob_list); + } + } + return ob_list; +} + +#else + +static pointer oblist_initial_value(scheme *sc) +{ + return sc->NIL; +} + +/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not + * exist. In that case, SLOT points to the point where the new symbol + * is to be inserted. */ +static INLINE pointer +oblist_find_by_name(scheme *sc, const char *name, pointer **slot) +{ + pointer x; + char *s; + int d; + + for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + d = stricmp(name, s); + if (d == 0) + return car(x); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + return sc->NIL; +} + +static pointer oblist_all_symbols(scheme *sc) +{ + return sc->oblist; +} + +#endif + +/* Add a new symbol NAME at SLOT. SLOT must be obtained using + * oblist_find_by_name, and no insertion must be done between + * obtaining the SLOT and calling this function. Returns the new + * symbol. */ +static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) +{ +#define oblist_add_by_name_allocates 3 + pointer x; + + gc_disable(sc, gc_reservations (oblist_add_by_name)); + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + *slot = immutable_cons(sc, x, *slot); + gc_enable(sc); + return x; +} + + + +static pointer mk_port(scheme *sc, port *p) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = T_PORT|T_ATOM|T_FINALIZE; + x->_object._port=p; + return (x); +} + +pointer mk_foreign_func(scheme *sc, foreign_func f) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN | T_ATOM); + x->_object._ff=f; + return (x); +} + +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE); + x->_object._foreign_object._vtable=vtable; + x->_object._foreign_object._data = data; + return (x); +} + +INTERFACE pointer mk_character(scheme *sc, int c) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_CHARACTER | T_ATOM); + ivalue_unchecked(x)= c; + set_num_integer(x); + return (x); +} + + + +#if USE_SMALL_INTEGERS + +static const struct cell small_integers[] = { +#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}}, +#include "small-integers.h" +#undef DEFINE_INTEGER + {0} +}; + +#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1) + +static INLINE pointer +mk_small_integer(scheme *sc, long n) +{ +#define mk_small_integer_allocates 0 + (void) sc; + assert(0 <= n && n < MAX_SMALL_INTEGER); + return (pointer) &small_integers[n]; +} +#else + +#define mk_small_integer_allocates 1 +#define mk_small_integer mk_integer + +#endif + +/* get number atom (integer) */ +INTERFACE pointer mk_integer(scheme *sc, long n) { + pointer x; + +#if USE_SMALL_INTEGERS + if (0 <= n && n < MAX_SMALL_INTEGER) + return mk_small_integer(sc, n); +#endif + + x = get_cell(sc,sc->NIL, sc->NIL); + typeflag(x) = (T_NUMBER | T_ATOM); + ivalue_unchecked(x)= n; + set_num_integer(x); + return (x); +} + + + +INTERFACE pointer mk_real(scheme *sc, double n) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + rvalue_unchecked(x)= n; + set_num_real(x); + return (x); +} + +static pointer mk_number(scheme *sc, num n) { + if(n.is_fixnum) { + return mk_integer(sc,n.value.ivalue); + } else { + return mk_real(sc,n.value.rvalue); + } +} + +/* allocate name to string area */ +static char *store_string(scheme *sc, int len_str, const char *str, char fill) { + char *q; + + q=(char*)sc->malloc(len_str+1); + if(q==0) { + sc->no_memory=1; + return sc->strbuff; + } + if(str!=0) { + memcpy (q, str, len_str); + q[len_str]=0; + } else { + memset(q, fill, len_str); + q[len_str]=0; + } + return (q); +} + +/* get new string */ +INTERFACE pointer mk_string(scheme *sc, const char *str) { + return mk_counted_string(sc,str,strlen(str)); +} + +INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); + strvalue(x) = store_string(sc,len,str,0); + strlength(x) = len; + return (x); +} + +INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); + strvalue(x) = store_string(sc,len,0,fill); + strlength(x) = len; + return (x); +} + +INTERFACE static pointer mk_vector(scheme *sc, int len) +{ return get_vector_object(sc,len,sc->NIL); } + +INTERFACE static void fill_vector(pointer vec, pointer obj) { + size_t i; + assert (is_vector (vec)); + for(i = 0; i < vector_length(vec); i++) { + vec->_object._vector._elements[i] = obj; + } +} + +INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) { + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + return &vec->_object._vector._elements[ielem]; +} + +INTERFACE static pointer vector_elem(pointer vec, int ielem) { + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + return vec->_object._vector._elements[ielem]; +} + +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { + assert (is_vector (vec)); + assert (ielem < vector_length(vec)); + vec->_object._vector._elements[ielem] = a; + return a; +} + +/* get new symbol */ +INTERFACE pointer mk_symbol(scheme *sc, const char *name) { +#define mk_symbol_allocates oblist_add_by_name_allocates + pointer x; + pointer *slot; + + /* first check oblist */ + x = oblist_find_by_name(sc, name, &slot); + if (x != sc->NIL) { + return (x); + } else { + x = oblist_add_by_name(sc, name, slot); + return (x); + } +} + +INTERFACE pointer gensym(scheme *sc) { + pointer x; + pointer *slot; + char name[40]; + + for(; sc->gensym_cntgensym_cnt++) { + snprintf(name,40,"gensym-%ld",sc->gensym_cnt); + + /* first check oblist */ + x = oblist_find_by_name(sc, name, &slot); + + if (x != sc->NIL) { + continue; + } else { + x = oblist_add_by_name(sc, name, slot); + return (x); + } + } + + return sc->NIL; +} + +/* double the size of the string buffer */ +static int expand_strbuff(scheme *sc) { + size_t new_size = sc->strbuff_size * 2; + char *new_buffer = sc->malloc(new_size); + if (new_buffer == 0) { + sc->no_memory = 1; + return 1; + } + memcpy(new_buffer, sc->strbuff, sc->strbuff_size); + sc->free(sc->strbuff); + sc->strbuff = new_buffer; + sc->strbuff_size = new_size; + return 0; +} + +/* make symbol or number atom from string */ +static pointer mk_atom(scheme *sc, char *q) { + char c, *p; + int has_dec_point=0; + int has_fp_exp = 0; + +#if USE_COLON_HOOK + char *next; + next = p = q; + while ((next = strstr(next, "::")) != 0) { + /* Keep looking for the last occurrence. */ + p = next; + next = next + 2; + } + + if (p != q) { + *p=0; + return cons(sc, sc->COLON_HOOK, + cons(sc, + cons(sc, + sc->QUOTE, + cons(sc, mk_symbol(sc, strlwr(p + 2)), + sc->NIL)), + cons(sc, mk_atom(sc, q), sc->NIL))); + } +#endif + + p = q; + c = *p++; + if ((c == '+') || (c == '-')) { + c = *p++; + if (c == '.') { + has_dec_point=1; + c = *p++; + } + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (c == '.') { + has_dec_point=1; + c = *p++; + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + + for ( ; (c = *p) != 0; ++p) { + if (!isdigit(c)) { + if(c=='.') { + if(!has_dec_point) { + has_dec_point=1; + continue; + } + } + else if ((c == 'e') || (c == 'E')) { + if(!has_fp_exp) { + has_dec_point = 1; /* decimal point illegal + from now on */ + p++; + if ((*p == '-') || (*p == '+') || isdigit(*p)) { + continue; + } + } + } + return (mk_symbol(sc, strlwr(q))); + } + } + if(has_dec_point) { + return mk_real(sc,atof(q)); + } + return (mk_integer(sc, atol(q))); +} + +/* make constant */ +static pointer mk_sharp_const(scheme *sc, char *name) { + long x; + char tmp[STRBUFFSIZE]; + + if (!strcmp(name, "t")) + return (sc->T); + else if (!strcmp(name, "f")) + return (sc->F); + else if (*name == 'o') {/* #o (octal) */ + snprintf(tmp, STRBUFFSIZE, "0%s", name+1); + sscanf(tmp, "%lo", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'd') { /* #d (decimal) */ + sscanf(name+1, "%ld", (long int *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'x') { /* #x (hex) */ + snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); + sscanf(tmp, "%lx", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'b') { /* #b (binary) */ + x = binary_decode(name+1); + return (mk_integer(sc, x)); + } else if (*name == '\\') { /* #\w (character) */ + int c=0; + if(stricmp(name+1,"space")==0) { + c=' '; + } else if(stricmp(name+1,"newline")==0) { + c='\n'; + } else if(stricmp(name+1,"return")==0) { + c='\r'; + } else if(stricmp(name+1,"tab")==0) { + c='\t'; + } else if(name[1]=='x' && name[2]!=0) { + int c1=0; + if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { + c=c1; + } else { + return sc->NIL; + } +#if USE_ASCII_NAMES + } else if(is_ascii_name(name+1,&c)) { + /* nothing */ +#endif + } else if(name[2]==0) { + c=name[1]; + } else { + return sc->NIL; + } + return mk_character(sc,c); + } else + return (sc->NIL); +} + +/* ========== garbage collector ========== */ + +const int frame_length; +static void dump_stack_deallocate_frame(scheme *sc, pointer frame); + +/*-- + * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, + * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, + * for marking. + */ +static void mark(pointer a) { + pointer t, q, p; + + t = (pointer) 0; + p = a; +E2: if (! is_mark(p)) + setmark(p); + if (is_vector(p) || is_frame(p)) { + int i; + int len = is_vector(p) ? vector_length(p) : frame_length; + for (i = 0; i < len; i++) { + mark(p->_object._vector._elements[i]); + } + } +#if SHOW_ERROR_LINE + else if (is_port(p)) { + port *pt = p->_object._port; + mark(pt->curr_line); + mark(pt->filename); + } +#endif + /* Mark tag if p has one. */ + if (has_tag(p)) + mark(p + 1); + if (is_atom(p)) + goto E6; + /* E4: down car */ + q = car(p); + if (q && !is_mark(q)) { + setatom(p); /* a note that we have moved car */ + car(p) = t; + t = p; + p = q; + goto E2; + } +E5: q = cdr(p); /* down cdr */ + if (q && !is_mark(q)) { + cdr(p) = t; + t = p; + p = q; + goto E2; + } +E6: /* up. Undo the link switching from steps E4 and E5. */ + if (!t) + return; + q = t; + if (is_atom(q)) { + clratom(q); + t = car(q); + car(q) = p; + p = q; + goto E5; + } else { + t = cdr(q); + cdr(q) = p; + p = q; + goto E6; + } +} + +/* garbage collection. parameter a, b is marked. */ +static void gc(scheme *sc, pointer a, pointer b) { + pointer p; + struct cell_segment *s; + int i; + + assert (gc_enabled (sc)); + + if(sc->gc_verbose) { + putstr(sc, "gc..."); + } + + /* mark system globals */ + mark(sc->oblist); + mark(sc->global_env); + + /* mark current registers */ + mark(sc->args); + mark(sc->envir); + mark(sc->code); + history_mark(sc); + dump_stack_mark(sc); + mark(sc->value); + mark(sc->inport); + mark(sc->save_inport); + mark(sc->outport); + mark(sc->loadport); + for (i = 0; i <= sc->file_i; i++) { + mark(sc->load_stack[i].filename); + mark(sc->load_stack[i].curr_line); + } + + /* Mark recent objects the interpreter doesn't know about yet. */ + mark(car(sc->sink)); + /* Mark any older stuff above nested C calls */ + mark(sc->c_nest); + + /* mark variables a, b */ + mark(a); + mark(b); + + /* garbage collect */ + clrmark(sc->NIL); + sc->fcells = 0; + sc->free_cell = sc->NIL; + /* free-list is kept sorted by address so as to maintain consecutive + ranges, if possible, for use with vectors. Here we scan the cells + (which are also kept sorted by address) downwards to build the + free-list in sorted order. + */ + for (s = sc->cell_segments; s; s = s->next) { + p = s->cells + s->cells_len; + while (--p >= s->cells) { + if ((typeflag(p) & 1) == 0) + /* All types have the LSB set. This is not a typeflag. */ + continue; + if (is_mark(p)) { + clrmark(p); + } else { + /* reclaim cell */ + if ((typeflag(p) & T_FINALIZE) == 0 + || finalize_cell(sc, p)) { + /* Reclaim cell. */ + ++sc->fcells; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + } + } + } + } + + if (sc->gc_verbose) { + char msg[80]; + snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); + putstr(sc,msg); + } + + /* if only a few recovered, get more to avoid fruitless gc's */ + if (sc->fcells < CELL_MINRECOVER + && alloc_cellseg(sc, 1) == 0) + sc->no_memory = 1; +} + +/* Finalize A. Returns true if a can be added to the list of free + * cells. */ +static int +finalize_cell(scheme *sc, pointer a) +{ + switch (type(a)) { + case T_STRING: + sc->free(strvalue(a)); + break; + + case T_PORT: + if(a->_object._port->kind&port_file + && a->_object._port->rep.stdio.closeit) { + port_close(sc,a,port_input|port_output); + } else if (a->_object._port->kind & port_srfi6) { + sc->free(a->_object._port->rep.string.start); + } + sc->free(a->_object._port); + break; + + case T_FOREIGN_OBJECT: + a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); + break; + + case T_VECTOR: + do { + int i; + for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { + pointer p = a + i; + typeflag(p) = 0; + car(p) = sc->NIL; + cdr(p) = sc->free_cell; + sc->free_cell = p; + sc->fcells += 1; + } + } while (0); + break; + + case T_FRAME: + dump_stack_deallocate_frame(sc, a); + return 0; /* Do not free cell. */ + } + + return 1; /* Free cell. */ +} + +#if SHOW_ERROR_LINE +static void +port_clear_location (scheme *sc, port *p) +{ + p->curr_line = sc->NIL; + p->filename = sc->NIL; +} + +static void +port_increment_current_line (scheme *sc, port *p, long delta) +{ + if (delta == 0) + return; + + p->curr_line = + mk_integer(sc, ivalue_unchecked(p->curr_line) + delta); +} + +static void +port_init_location (scheme *sc, port *p, pointer name) +{ + p->curr_line = mk_integer(sc, 0); + p->filename = name ? name : mk_string(sc, ""); +} + +#else + +static void +port_clear_location (scheme *sc, port *p) +{ +} + +static void +port_increment_current_line (scheme *sc, port *p, long delta) +{ +} + +static void +port_init_location (scheme *sc, port *p, pointer name) +{ +} + +#endif + +/* ========== Routines for Reading ========== */ + +static int file_push(scheme *sc, pointer fname) { + FILE *fin = NULL; + + if (sc->file_i == MAXFIL-1) + return 0; + fin = fopen(string_value(fname), "r"); + if(fin!=0) { + sc->file_i++; + sc->load_stack[sc->file_i].kind=port_file|port_input; + sc->load_stack[sc->file_i].rep.stdio.file=fin; + sc->load_stack[sc->file_i].rep.stdio.closeit=1; + sc->nesting_stack[sc->file_i]=0; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + port_init_location(sc, &sc->load_stack[sc->file_i], fname); + } + return fin!=0; +} + +static void file_pop(scheme *sc) { + if(sc->file_i != 0) { + sc->nesting=sc->nesting_stack[sc->file_i]; + port_close(sc,sc->loadport,port_input); + port_clear_location(sc, &sc->load_stack[sc->file_i]); + sc->file_i--; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + } +} + +static int file_interactive(scheme *sc) { + return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin + && sc->inport->_object._port->kind&port_file; +} + +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { + FILE *f; + char *rw; + port *pt; + if(prop==(port_input|port_output)) { + rw="a+"; + } else if(prop==port_output) { + rw="w"; + } else { + rw="r"; + } + f=fopen(fn,rw); + if(f==0) { + return 0; + } + pt=port_rep_from_file(sc,f,prop); + pt->rep.stdio.closeit=1; + port_init_location(sc, pt, mk_string(sc, fn)); + return pt; +} + +static pointer port_from_filename(scheme *sc, const char *fn, int prop) { + port *pt; + pt=port_rep_from_filename(sc,fn,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_file(scheme *sc, FILE *f, int prop) +{ + port *pt; + + pt = (port *)sc->malloc(sizeof *pt); + if (pt == NULL) { + return NULL; + } + pt->kind = port_file | prop; + pt->rep.stdio.file = f; + pt->rep.stdio.closeit = 0; + port_init_location(sc, pt, NULL); + return pt; +} + +static pointer port_from_file(scheme *sc, FILE *f, int prop) { + port *pt; + pt=port_rep_from_file(sc,f,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + pt->kind=port_string|prop; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=past_the_end; + port_init_location(sc, pt, NULL); + return pt; +} + +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=port_rep_from_string(sc,start,past_the_end,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +#define BLOCK_SIZE 256 + +static port *port_rep_from_scratch(scheme *sc) { + port *pt; + char *start; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + start=sc->malloc(BLOCK_SIZE); + if(start==0) { + return 0; + } + memset(start,' ',BLOCK_SIZE-1); + start[BLOCK_SIZE-1]='\0'; + pt->kind=port_string|port_output|port_srfi6; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=start+BLOCK_SIZE-1; + port_init_location(sc, pt, NULL); + return pt; +} + +static pointer port_from_scratch(scheme *sc) { + port *pt; + pt=port_rep_from_scratch(sc); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static void port_close(scheme *sc, pointer p, int flag) { + port *pt=p->_object._port; + pt->kind&=~flag; + if((pt->kind & (port_input|port_output))==0) { + /* Cleanup is here so (close-*-port) functions could work too */ + port_clear_location(sc, pt); + if(pt->kind&port_file) { + fclose(pt->rep.stdio.file); + } + pt->kind=port_free; + } +} + +/* get new character from input file */ +static int inchar(scheme *sc) { + int c; + port *pt; + + pt = sc->inport->_object._port; + if(pt->kind & port_saw_EOF) + { return EOF; } + c = basic_inchar(pt); + if(c == EOF && sc->inport == sc->loadport) { + /* Instead, set port_saw_EOF */ + pt->kind |= port_saw_EOF; + + /* file_pop(sc); */ + return EOF; + /* NOTREACHED */ + } + return c; +} + +static int basic_inchar(port *pt) { + if(pt->kind & port_file) { + return fgetc(pt->rep.stdio.file); + } else { + if(*pt->rep.string.curr == 0 || + pt->rep.string.curr == pt->rep.string.past_the_end) { + return EOF; + } else { + return *pt->rep.string.curr++; + } + } +} + +/* back character to input buffer */ +static void backchar(scheme *sc, int c) { + port *pt; + if(c==EOF) return; + pt=sc->inport->_object._port; + if(pt->kind&port_file) { + ungetc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.start) { + --pt->rep.string.curr; + } + } +} + +static int realloc_port_string(scheme *sc, port *p) +{ + char *start=p->rep.string.start; + size_t old_size = p->rep.string.past_the_end - start; + size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; + char *str=sc->malloc(new_size); + if(str) { + memset(str,' ',new_size-1); + str[new_size-1]='\0'; + memcpy(str, start, old_size); + p->rep.string.start=str; + p->rep.string.past_the_end=str+new_size-1; + p->rep.string.curr-=start-str; + sc->free(start); + return 1; + } else { + return 0; + } +} + +INTERFACE void putstr(scheme *sc, const char *s) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputs(s,pt->rep.stdio.file); + } else { + for(;*s;s++) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s; + } + } + } +} + +static void putchars(scheme *sc, const char *s, int len) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fwrite(s,1,len,pt->rep.stdio.file); + } else { + for(;len;len--) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s++; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s++; + } + } + } +} + +INTERFACE void putcharacter(scheme *sc, int c) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=c; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=c; + } + } +} + +/* read characters up to delimiter, but cater to character constants */ +static char *readstr_upto(scheme *sc, char *delim) { + char *p = sc->strbuff; + + while ((p - sc->strbuff < sc->strbuff_size) && + !is_one_of(delim, (*p++ = inchar(sc)))); + + if(p == sc->strbuff+2 && p[-2] == '\\') { + *p=0; + } else { + backchar(sc,p[-1]); + *--p = '\0'; + } + return sc->strbuff; +} + +/* read string expression "xxx...xxx" */ +static pointer readstrexp(scheme *sc) { + char *p = sc->strbuff; + int c; + int c1=0; + enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; + + for (;;) { + c=inchar(sc); + if(c == EOF) { + return sc->F; + } + if(p-sc->strbuff > (sc->strbuff_size)-1) { + ptrdiff_t offset = p - sc->strbuff; + if (expand_strbuff(sc) != 0) { + return sc->F; + } + p = sc->strbuff + offset; + } + switch(state) { + case st_ok: + switch(c) { + case '\\': + state=st_bsl; + break; + case '"': + *p=0; + return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); + default: + *p++=c; + break; + } + break; + case st_bsl: + switch(c) { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + state=st_oct1; + c1=c-'0'; + break; + case 'x': + case 'X': + state=st_x1; + c1=0; + break; + case 'n': + *p++='\n'; + state=st_ok; + break; + case 't': + *p++='\t'; + state=st_ok; + break; + case 'r': + *p++='\r'; + state=st_ok; + break; + case '"': + *p++='"'; + state=st_ok; + break; + default: + *p++=c; + state=st_ok; + break; + } + break; + case st_x1: + case st_x2: + c=toupper(c); + if(c>='0' && c<='F') { + if(c<='9') { + c1=(c1<<4)+c-'0'; + } else { + c1=(c1<<4)+c-'A'+10; + } + if(state==st_x1) { + state=st_x2; + } else { + *p++=c1; + state=st_ok; + } + } else { + return sc->F; + } + break; + case st_oct1: + case st_oct2: + if (c < '0' || c > '7') + { + *p++=c1; + backchar(sc, c); + state=st_ok; + } + else + { + if (state==st_oct2 && c1 >= 32) + return sc->F; + + c1=(c1<<3)+(c-'0'); + + if (state == st_oct1) + state=st_oct2; + else + { + *p++=c1; + state=st_ok; + } + } + break; + + } + } +} + +/* check c is in chars */ +static INLINE int is_one_of(char *s, int c) { + if(c==EOF) return 1; + while (*s) + if (*s++ == c) + return (1); + return (0); +} + +/* skip white characters */ +static INLINE int skipspace(scheme *sc) { + int c = 0, curr_line = 0; + + do { + c=inchar(sc); +#if SHOW_ERROR_LINE + if(c=='\n') + curr_line++; +#endif + } while (isspace(c)); + + /* record it */ + port_increment_current_line(sc, &sc->load_stack[sc->file_i], curr_line); + + if(c!=EOF) { + backchar(sc,c); + return 1; + } + else + { return EOF; } +} + +/* get token */ +static int token(scheme *sc) { + int c; + c = skipspace(sc); + if(c == EOF) { return (TOK_EOF); } + switch (c=inchar(sc)) { + case EOF: + return (TOK_EOF); + case '(': + return (TOK_LPAREN); + case ')': + return (TOK_RPAREN); + case '.': + c=inchar(sc); + if(is_one_of(" \n\t",c)) { + return (TOK_DOT); + } else { + backchar(sc,c); + backchar(sc,'.'); + return TOK_ATOM; + } + case '\'': + return (TOK_QUOTE); + case ';': + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + + if(c == '\n') + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + case '"': + return (TOK_DQUOTE); + case BACKQUOTE: + return (TOK_BQUOTE); + case ',': + if ((c=inchar(sc)) == '@') { + return (TOK_ATMARK); + } else { + backchar(sc,c); + return (TOK_COMMA); + } + case '#': + c=inchar(sc); + if (c == '(') { + return (TOK_VEC); + } else if(c == '!') { + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + + if(c == '\n') + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + } else { + backchar(sc,c); + if(is_one_of(" tfodxb\\",c)) { + return TOK_SHARP_CONST; + } else { + return (TOK_SHARP); + } + } + default: + backchar(sc,c); + return (TOK_ATOM); + } +} + +/* ========== Routines for Printing ========== */ +#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) + +static void printslashstring(scheme *sc, char *p, int len) { + int i; + unsigned char *s=(unsigned char*)p; + putcharacter(sc,'"'); + for ( i=0; iNIL) { + p = "()"; + } else if (l == sc->T) { + p = "#t"; + } else if (l == sc->F) { + p = "#f"; + } else if (l == sc->EOF_OBJ) { + p = "#"; + } else if (is_port(l)) { + p = "#"; + } else if (is_number(l)) { + p = sc->strbuff; + if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { + if(num_is_integer(l)) { + snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); + } else { + snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); + /* r5rs says there must be a '.' (unless 'e'?) */ + f = strcspn(p, ".e"); + if (p[f] == 0) { + p[f] = '.'; /* not found, so add '.0' at the end */ + p[f+1] = '0'; + p[f+2] = 0; + } + } + } else { + long v = ivalue(l); + if (f == 16) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lx", v); + else + snprintf(p, STRBUFFSIZE, "-%lx", -v); + } else if (f == 8) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lo", v); + else + snprintf(p, STRBUFFSIZE, "-%lo", -v); + } else if (f == 2) { + unsigned long b = (v < 0) ? -v : v; + p = &p[STRBUFFSIZE-1]; + *p = 0; + do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); + if (v < 0) *--p = '-'; + } + } + } else if (is_string(l)) { + if (!f) { + *pp = strvalue(l); + *plen = strlength(l); + return; + } else { /* Hack, uses the fact that printing is needed */ + *pp=sc->strbuff; + *plen=0; + printslashstring(sc, strvalue(l), strlength(l)); + return; + } + } else if (is_character(l)) { + int c=charvalue(l); + p = sc->strbuff; + if (!f) { + p[0]=c; + p[1]=0; + } else { + switch(c) { + case ' ': + p = "#\\space"; + break; + case '\n': + p = "#\\newline"; + break; + case '\r': + p = "#\\return"; + break; + case '\t': + p = "#\\tab"; + break; + default: +#if USE_ASCII_NAMES + if(c==127) { + p = "#\\del"; + break; + } else if(c<32) { + snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]); + break; + } +#else + if(c<32) { + snprintf(p,STRBUFFSIZE,"#\\x%x",c); + break; + } +#endif + snprintf(p,STRBUFFSIZE,"#\\%c",c); + break; + } + } + } else if (is_symbol(l)) { + p = symname(l); + } else if (is_proc(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); + } else if (is_macro(l)) { + p = "#"; + } else if (is_closure(l)) { + p = "#"; + } else if (is_promise(l)) { + p = "#"; + } else if (is_foreign(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#", procnum(l)); + } else if (is_continuation(l)) { + p = "#"; + } else if (is_foreign_object(l)) { + p = sc->strbuff; + l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data); + } else { + p = "#"; + } + *pp=p; + *plen=strlen(p); +} +/* ========== Routines for Evaluation Cycle ========== */ + +/* make closure. c is code. e is environment */ +static pointer mk_closure(scheme *sc, pointer c, pointer e) { + pointer x = get_cell(sc, c, e); + + typeflag(x) = T_CLOSURE; + car(x) = c; + cdr(x) = e; + return (x); +} + +/* make continuation. */ +static pointer mk_continuation(scheme *sc, pointer d) { + pointer x = get_cell(sc, sc->NIL, d); + + typeflag(x) = T_CONTINUATION; + cont_dump(x) = d; + return (x); +} + +static pointer list_star(scheme *sc, pointer d) { + pointer p, q; + if(cdr(d)==sc->NIL) { + return car(d); + } + p=cons(sc,car(d),cdr(d)); + q=p; + while(cdr(cdr(p))!=sc->NIL) { + d=cons(sc,car(p),cdr(p)); + if(cdr(cdr(p))!=sc->NIL) { + p=cdr(d); + } + } + cdr(p)=car(cdr(p)); + return q; +} + +/* reverse list -- produce new list */ +static pointer reverse(scheme *sc, pointer term, pointer list) { +/* a must be checked by gc */ + pointer a = list, p = term; + + for ( ; is_pair(a); a = cdr(a)) { + p = cons(sc, car(a), p); + } + return (p); +} + +/* reverse list --- in-place */ +static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { + pointer p = list, result = term, q; + + while (p != sc->NIL) { + q = cdr(p); + cdr(p) = result; + result = p; + p = q; + } + return (result); +} + +/* append list -- produce new list (in reverse order) */ +static pointer revappend(scheme *sc, pointer a, pointer b) { + pointer result = a; + pointer p = b; + + while (is_pair(p)) { + result = cons(sc, car(p), result); + p = cdr(p); + } + + if (p == sc->NIL) { + return result; + } + + return sc->F; /* signal an error */ +} + +/* equivalence of atoms */ +int eqv(pointer a, pointer b) { + if (is_string(a)) { + if (is_string(b)) + return (strvalue(a) == strvalue(b)); + else + return (0); + } else if (is_number(a)) { + if (is_number(b)) { + if (num_is_integer(a) == num_is_integer(b)) + return num_eq(nvalue(a),nvalue(b)); + } + return (0); + } else if (is_character(a)) { + if (is_character(b)) + return charvalue(a)==charvalue(b); + else + return (0); + } else if (is_port(a)) { + if (is_port(b)) + return a==b; + else + return (0); + } else if (is_proc(a)) { + if (is_proc(b)) + return procnum(a)==procnum(b); + else + return (0); + } else { + return (a == b); + } +} + +/* true or false value macro */ +/* () is #t in R5RS */ +#define is_true(p) ((p) != sc->F) +#define is_false(p) ((p) == sc->F) + + +/* ========== Environment implementation ========== */ + +#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) + +static int hash_fn(const char *key, int table_size) +{ + unsigned int hashed = 0; + const char *c; + int bits_per_int = sizeof(unsigned int)*8; + + for (c = key; *c; c++) { + /* letters have about 5 bits in them */ + hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); + hashed ^= *c; + } + return hashed % table_size; +} +#endif + +/* Compares A and B. Returns an integer less than, equal to, or + * greater than zero if A is stored at a memory location that is + * numerical less than, equal to, or greater than that of B. */ +static int +pointercmp(pointer a, pointer b) +{ + uintptr_t a_n = (uintptr_t) a; + uintptr_t b_n = (uintptr_t) b; + + if (a_n < b_n) + return -1; + if (a_n > b_n) + return 1; + return 0; +} + +#ifndef USE_ALIST_ENV + +/* + * In this implementation, each frame of the environment may be + * a hash table: a vector of alists hashed by variable name. + * In practice, we use a vector only for the initial frame; + * subsequent frames are too small and transient for the lookup + * speed to out-weigh the cost of making a new vector. + */ + +static void new_frame_in_env(scheme *sc, pointer old_env) +{ + pointer new_frame; + + /* The interaction-environment has about 480 variables in it. */ + if (old_env == sc->NIL) { + new_frame = mk_vector(sc, 751); + } else { + new_frame = sc->NIL; + } + + gc_disable(sc, 1); + sc->envir = immutable_cons(sc, new_frame, old_env); + gc_enable(sc); + setenvironment(sc->envir); +} + +/* Find the slot in ENV under the key HDL. If ALL is given, look in + * all environments enclosing ENV. If the lookup fails, and SSLOT is + * given, the position where the new slot has to be inserted is stored + * at SSLOT. */ +static pointer +find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) +{ + pointer x,y; + int location; + pointer *sl; + int d; + assert(is_symbol(hdl)); + + for (x = env; x != sc->NIL; x = cdr(x)) { + if (is_vector(car(x))) { + location = hash_fn(symname(hdl), vector_length(car(x))); + sl = vector_elem_slot(car(x), location); + } else { + sl = &car(x); + } + for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) { + d = pointercmp(caar(y), hdl); + if (d == 0) + return car(y); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + + if (x == env && sslot) + *sslot = sl; /* Insert here. */ + + if (!all) + return sc->NIL; /* Miss, and stop looking. */ + } + + return sc->NIL; /* Not found in any environment. */ +} + +#else /* USE_ALIST_ENV */ + +static INLINE void new_frame_in_env(scheme *sc, pointer old_env) +{ + sc->envir = immutable_cons(sc, sc->NIL, old_env); + setenvironment(sc->envir); +} + +/* Find the slot in ENV under the key HDL. If ALL is given, look in + * all environments enclosing ENV. If the lookup fails, and SSLOT is + * given, the position where the new slot has to be inserted is stored + * at SSLOT. */ +static pointer +find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) +{ + pointer x,y; + pointer *sl; + int d; + assert(is_symbol(hdl)); + + for (x = env; x != sc->NIL; x = cdr(x)) { + for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) { + d = pointercmp(caar(y), hdl); + if (d == 0) + return car(y); /* Hit. */ + else if (d > 0) + break; /* Miss. */ + } + + if (x == env && sslot) + *sslot = sl; /* Insert here. */ + + if (!all) + return sc->NIL; /* Miss, and stop looking. */ + } + + return sc->NIL; /* Not found in any environment. */ +} + +#endif /* USE_ALIST_ENV else */ + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + return find_slot_spec_in_env(sc, env, hdl, all, NULL); +} + +/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using + * find_slot_spec_in_env, and no insertion must be done between + * obtaining SSLOT and the call to this function. */ +static INLINE void new_slot_spec_in_env(scheme *sc, + pointer variable, pointer value, + pointer *sslot) +{ +#define new_slot_spec_in_env_allocates 2 + pointer slot; + gc_disable(sc, gc_reservations (new_slot_spec_in_env)); + slot = immutable_cons(sc, variable, value); + *sslot = immutable_cons(sc, slot, *sslot); + gc_enable(sc); +} + +static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) +{ +#define new_slot_in_env_allocates new_slot_spec_in_env_allocates + pointer slot; + pointer *sslot; + assert(is_symbol(variable)); + slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot); + assert(slot == sc->NIL); + new_slot_spec_in_env(sc, variable, value, sslot); +} + +static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) +{ + (void)sc; + cdr(slot) = value; +} + +static INLINE pointer slot_value_in_env(pointer slot) +{ + return cdr(slot); +} + + +/* ========== Evaluation Cycle ========== */ + + +static enum scheme_opcodes +_Error_1(scheme *sc, const char *s, pointer a) { + const char *str = s; + pointer history; +#if USE_ERROR_HOOK + pointer x; + pointer hdl=sc->ERROR_HOOK; +#endif + +#if SHOW_ERROR_LINE + char sbuf[STRBUFFSIZE]; +#endif + + history = history_flatten(sc); + +#if SHOW_ERROR_LINE + /* make sure error is not in REPL */ + if (((sc->load_stack[sc->file_i].kind & port_file) == 0 + || sc->load_stack[sc->file_i].rep.stdio.file != stdin)) { + pointer tag; + const char *fname; + int ln; + + if (history != sc->NIL && has_tag(car(history)) + && (tag = get_tag(sc, car(history))) + && is_string(car(tag)) && is_integer(cdr(tag))) { + fname = string_value(car(tag)); + ln = ivalue_unchecked(cdr(tag)); + } else { + fname = string_value(sc->load_stack[sc->file_i].filename); + ln = ivalue_unchecked(sc->load_stack[sc->file_i].curr_line); + } + + /* should never happen */ + if(!fname) fname = ""; + + /* we started from 0 */ + ln++; + snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s); + + str = (const char*)sbuf; + } +#endif + +#if USE_ERROR_HOOK + x=find_slot_in_env(sc,sc->envir,hdl,1); + if (x != sc->NIL) { + sc->code = cons(sc, cons(sc, sc->QUOTE, + cons(sc, history, sc->NIL)), + sc->NIL); + if(a!=0) { + sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)), + sc->code); + } else { + sc->code = cons(sc, sc->F, sc->code); + } + sc->code = cons(sc, mk_string(sc, str), sc->code); + setimmutable(car(sc->code)); + sc->code = cons(sc, slot_value_in_env(x), sc->code); + return OP_EVAL; + } +#endif + + if(a!=0) { + sc->args = cons(sc, (a), sc->NIL); + } else { + sc->args = sc->NIL; + } + sc->args = cons(sc, mk_string(sc, str), sc->args); + setimmutable(car(sc->args)); + return OP_ERR0; +} +#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; } +#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; } + +/* Too small to turn into function */ +# define BEGIN do { +# define END } while (0) + + + +/* Flags. The interpreter has a flags field. When the interpreter + * pushes a frame to the dump stack, it is encoded with the opcode. + * Therefore, we do not use the least significant byte. */ + +/* Masks used to encode and decode opcode and flags. */ +#define S_OP_MASK 0x000000ff +#define S_FLAG_MASK 0xffffff00 + +/* Set if the interpreter evaluates an expression in a tail context + * (see R5RS, section 3.5). If a function, procedure, or continuation + * is invoked while this flag is set, the call is recorded as tail + * call in the history buffer. */ +#define S_FLAG_TAIL_CONTEXT 0x00000100 + +/* Set flag F. */ +#define s_set_flag(sc, f) \ + BEGIN \ + (sc)->flags |= S_FLAG_ ## f; \ + END + +/* Clear flag F. */ +#define s_clear_flag(sc, f) \ + BEGIN \ + (sc)->flags &= ~ S_FLAG_ ## f; \ + END + +/* Check if flag F is set. */ +#define s_get_flag(sc, f) \ + !!((sc)->flags & S_FLAG_ ## f) + + + +/* Bounce back to Eval_Cycle and execute A. */ +#define s_goto(sc, a) { op = (a); goto dispatch; } + +#if USE_THREADED_CODE + +/* Do not bounce back to Eval_Cycle but execute A by jumping directly + * to it. */ +#define s_thread_to(sc, a) \ + BEGIN \ + op = (a); \ + goto a; \ + END + +/* Define a label OP and emit a case statement for OP. For use in the + * dispatch function. The slightly peculiar goto that is never + * executed avoids warnings about unused labels. */ +#define CASE(OP) case OP: if (0) goto OP; OP + +#else /* USE_THREADED_CODE */ +#define s_thread_to(sc, a) s_goto(sc, a) +#define CASE(OP) case OP +#endif /* USE_THREADED_CODE */ + +/* Return to the previous frame on the dump stack, setting the current + * value to A. */ +#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0)) + +/* Return to the previous frame on the dump stack, setting the current + * value to A, and re-enable the garbage collector. */ +#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1)) + +static INLINE void dump_stack_reset(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + dump_stack_reset(sc); + sc->frame_freelist = sc->NIL; +} + +static void dump_stack_free(scheme *sc) +{ + dump_stack_initialize(sc); +} + +const int frame_length = 4; + +static pointer +dump_stack_make_frame(scheme *sc) +{ + pointer frame; + + frame = mk_vector(sc, frame_length); + if (! sc->no_memory) + setframe(frame); + + return frame; +} + +static INLINE pointer * +frame_slots(pointer frame) +{ + return &frame->_object._vector._elements[0]; +} + +#define frame_payload vector_length + +static pointer +dump_stack_allocate_frame(scheme *sc) +{ + pointer frame = sc->frame_freelist; + if (frame == sc->NIL) { + if (gc_enabled(sc)) + frame = dump_stack_make_frame(sc); + else + gc_reservation_failure(sc); + } else + sc->frame_freelist = *frame_slots(frame); + return frame; +} + +static void +dump_stack_deallocate_frame(scheme *sc, pointer frame) +{ + pointer *p = frame_slots(frame); + *p++ = sc->frame_freelist; + *p++ = sc->NIL; + *p++ = sc->NIL; + *p++ = sc->NIL; + sc->frame_freelist = frame; +} + +static void +dump_stack_preallocate_frame(scheme *sc) +{ + pointer frame = dump_stack_make_frame(sc); + if (! sc->no_memory) + dump_stack_deallocate_frame(sc, frame); +} + +static enum scheme_opcodes +_s_return(scheme *sc, pointer a, int enable_gc) { + pointer dump = sc->dump; + pointer *p; + unsigned long v; + enum scheme_opcodes next_op; + sc->value = (a); + if (enable_gc) + gc_enable(sc); + if (dump == sc->NIL) + return OP_QUIT; + v = frame_payload(dump); + next_op = (int) (v & S_OP_MASK); + sc->flags = v & S_FLAG_MASK; + p = frame_slots(dump); + sc->args = *p++; + sc->envir = *p++; + sc->code = *p++; + sc->dump = *p++; + dump_stack_deallocate_frame(sc, dump); + return next_op; +} + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { +#define s_save_allocates 0 + pointer dump; + pointer *p; + gc_disable(sc, gc_reservations (s_save)); + dump = dump_stack_allocate_frame(sc); + frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op); + p = frame_slots(dump); + *p++ = args; + *p++ = sc->envir; + *p++ = code; + *p++ = sc->dump; + sc->dump = dump; + gc_enable(sc); +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + mark(sc->dump); + mark(sc->frame_freelist); +} + + + +#if USE_HISTORY + +static void +history_free(scheme *sc) +{ + sc->free(sc->history.m); + sc->history.tailstacks = sc->NIL; + sc->history.callstack = sc->NIL; +} + +static pointer +history_init(scheme *sc, size_t N, size_t M) +{ + size_t i; + struct history *h = &sc->history; + + h->N = N; + h->mask_N = N - 1; + h->n = N - 1; + assert ((N & h->mask_N) == 0); + + h->M = M; + h->mask_M = M - 1; + assert ((M & h->mask_M) == 0); + + h->callstack = mk_vector(sc, N); + if (h->callstack == sc->sink) + goto fail; + + h->tailstacks = mk_vector(sc, N); + for (i = 0; i < N; i++) { + pointer tailstack = mk_vector(sc, M); + if (tailstack == sc->sink) + goto fail; + set_vector_elem(h->tailstacks, i, tailstack); + } + + h->m = sc->malloc(N * sizeof *h->m); + if (h->m == NULL) + goto fail; + + for (i = 0; i < N; i++) + h->m[i] = 0; + + return sc->T; + +fail: + history_free(sc); + return sc->F; +} + +static void +history_mark(scheme *sc) +{ + struct history *h = &sc->history; + mark(h->callstack); + mark(h->tailstacks); +} + +#define add_mod(a, b, mask) (((a) + (b)) & (mask)) +#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask) + +static INLINE void +tailstack_clear(scheme *sc, pointer v) +{ + assert(is_vector(v)); + /* XXX optimize */ + fill_vector(v, sc->NIL); +} + +static pointer +callstack_pop(scheme *sc) +{ + struct history *h = &sc->history; + size_t n = h->n; + pointer item; + + if (h->callstack == sc->NIL) + return sc->NIL; + + item = vector_elem(h->callstack, n); + /* Clear our frame so that it can be gc'ed and we don't run into it + * when walking the history. */ + set_vector_elem(h->callstack, n, sc->NIL); + tailstack_clear(sc, vector_elem(h->tailstacks, n)); + + /* Exit from the frame. */ + h->n = sub_mod(h->n, 1, h->mask_N); + + return item; +} + +static void +callstack_push(scheme *sc, pointer item) +{ + struct history *h = &sc->history; + size_t n = h->n; + + if (h->callstack == sc->NIL) + return; + + /* Enter a new frame. */ + n = h->n = add_mod(n, 1, h->mask_N); + + /* Initialize tail stack. */ + tailstack_clear(sc, vector_elem(h->tailstacks, n)); + h->m[n] = h->mask_M; + + set_vector_elem(h->callstack, n, item); +} + +static void +tailstack_push(scheme *sc, pointer item) +{ + struct history *h = &sc->history; + size_t n = h->n; + size_t m = h->m[n]; + + if (h->callstack == sc->NIL) + return; + + /* Enter a new tail frame. */ + m = h->m[n] = add_mod(m, 1, h->mask_M); + set_vector_elem(vector_elem(h->tailstacks, n), m, item); +} + +static pointer +tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n, + pointer acc) +{ + struct history *h = &sc->history; + pointer frame; + + assert(i <= h->M); + assert(n < h->M); + + if (acc == sc->sink) + return sc->sink; + + if (i == 0) { + /* We reached the end, but we did not see a unused frame. Signal + this using '... . */ + return cons(sc, mk_symbol(sc, "..."), acc); + } + + frame = vector_elem(tailstack, n); + if (frame == sc->NIL) { + /* A unused frame. We reached the end of the history. */ + return acc; + } + + /* Add us. */ + acc = cons(sc, frame, acc); + + return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M), + acc); +} + +static pointer +callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc) +{ + struct history *h = &sc->history; + pointer frame; + + assert(i <= h->N); + assert(n < h->N); + + if (acc == sc->sink) + return sc->sink; + + if (i == 0) { + /* We reached the end, but we did not see a unused frame. Signal + this using '... . */ + return cons(sc, mk_symbol(sc, "..."), acc); + } + + frame = vector_elem(h->callstack, n); + if (frame == sc->NIL) { + /* A unused frame. We reached the end of the history. */ + return acc; + } + + /* First, emit the tail calls. */ + acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n], + acc); + + /* Then us. */ + acc = cons(sc, frame, acc); + + return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc); +} + +static pointer +history_flatten(scheme *sc) +{ + struct history *h = &sc->history; + pointer history; + + if (h->callstack == sc->NIL) + return sc->NIL; + + history = callstack_flatten(sc, h->N, h->n, sc->NIL); + if (history == sc->sink) + return sc->sink; + + return reverse_in_place(sc, sc->NIL, history); +} + +#undef add_mod +#undef sub_mod + +#else /* USE_HISTORY */ + +#define history_init(SC, A, B) (void) 0 +#define history_free(SC) (void) 0 +#define callstack_pop(SC) (void) 0 +#define callstack_push(SC, X) (void) 0 +#define tailstack_push(SC, X) (void) 0 + +#endif /* USE_HISTORY */ + + + +#if USE_PLIST +static pointer +get_property(scheme *sc, pointer obj, pointer key) +{ + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + return cdar(x); + + return sc->NIL; +} + +static pointer +set_property(scheme *sc, pointer obj, pointer key, pointer value) +{ +#define set_property_allocates 2 + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + cdar(x) = value; + else { + gc_disable(sc, gc_reservations(set_property)); + symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); + gc_enable(sc); + } + + return sc->T; +} +#endif + + + +static int is_list(scheme *sc, pointer a) +{ return list_length(sc,a) >= 0; } + +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +int list_length(scheme *sc, pointer a) { + int i=0; + pointer slow, fast; + + slow = fast = a; + while (1) + { + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + fast = cdr(fast); + ++i; + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + ++i; + fast = cdr(fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr(slow); + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + + + +#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) + +/* kernel of this interpreter */ +static void +Eval_Cycle(scheme *sc, enum scheme_opcodes op) { + for (;;) { + pointer x, y; + pointer callsite; + num v; +#if USE_MATH + double dd; +#endif + int (*comp_func)(num, num) = NULL; + const struct op_code_info *pcd; + + dispatch: + pcd = &dispatch_table[op]; + if (pcd->name[0] != 0) { /* if built-in function, check arguments */ + char msg[STRBUFFSIZE]; + if (! check_arguments (sc, pcd, msg, sizeof msg)) { + s_goto(sc, _Error_1(sc, msg, 0)); + } + } + + if(sc->no_memory) { + fprintf(stderr,"No memory!\n"); + exit(1); + } + ok_to_freely_gc(sc); + + switch (op) { + CASE(OP_LOAD): /* load */ + if(file_interactive(sc)) { + fprintf(sc->outport->_object._port->rep.stdio.file, + "Loading %s\n", strvalue(car(sc->args))); + } + if (!file_push(sc, car(sc->args))) { + Error_1(sc,"unable to open", car(sc->args)); + } + else + { + sc->args = mk_integer(sc,sc->file_i); + s_thread_to(sc,OP_T0LVL); + } + + CASE(OP_T0LVL): /* top level */ + /* If we reached the end of file, this loop is done. */ + if(sc->loadport->_object._port->kind & port_saw_EOF) + { + if(sc->file_i == 0) + { + sc->args=sc->NIL; + sc->nesting = sc->nesting_stack[0]; + s_thread_to(sc,OP_QUIT); + } + else + { + file_pop(sc); + s_return(sc,sc->value); + } + /* NOTREACHED */ + } + + /* If interactive, be nice to user. */ + if(file_interactive(sc)) + { + sc->envir = sc->global_env; + dump_stack_reset(sc); + putstr(sc,"\n"); + putstr(sc,prompt); + } + + /* Set up another iteration of REPL */ + sc->nesting=0; + sc->save_inport=sc->inport; + sc->inport = sc->loadport; + s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); + s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); + s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); + s_thread_to(sc,OP_READ_INTERNAL); + + CASE(OP_T1LVL): /* top level */ + sc->code = sc->value; + sc->inport=sc->save_inport; + s_thread_to(sc,OP_EVAL); + + CASE(OP_READ_INTERNAL): /* internal read */ + sc->tok = token(sc); + if(sc->tok==TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + s_thread_to(sc,OP_RDSEXPR); + + CASE(OP_GENSYM): + s_return(sc, gensym(sc)); + + CASE(OP_VALUEPRINT): /* print evaluation result */ + /* OP_VALUEPRINT is always pushed, because when changing from + non-interactive to interactive mode, it needs to be + already on the stack */ + if(sc->tracing) { + putstr(sc,"\nGives: "); + } + if(file_interactive(sc)) { + sc->print_flag = 1; + sc->args = sc->value; + s_thread_to(sc,OP_P0LIST); + } else { + s_return(sc,sc->value); + } + + CASE(OP_EVAL): /* main part of evaluation */ +#if USE_TRACING + if(sc->tracing) { + /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ + s_save(sc,OP_REAL_EVAL,sc->args,sc->code); + sc->args=sc->code; + putstr(sc,"\nEval: "); + s_thread_to(sc,OP_P0LIST); + } + /* fall through */ + CASE(OP_REAL_EVAL): +#endif + if (is_symbol(sc->code)) { /* symbol */ + x=find_slot_in_env(sc,sc->envir,sc->code,1); + if (x != sc->NIL) { + s_return(sc,slot_value_in_env(x)); + } else { + Error_1(sc, "eval: unbound variable", sc->code); + } + } else if (is_pair(sc->code)) { + if (is_syntax(x = car(sc->code))) { /* SYNTAX */ + sc->code = cdr(sc->code); + s_goto(sc, syntaxnum(sc, x)); + } else {/* first, eval top element and eval arguments */ + s_save(sc,OP_E0ARGS, sc->NIL, sc->code); + /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ + sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } + } else { + s_return(sc,sc->code); + } + + CASE(OP_E0ARGS): /* eval arguments */ + if (is_macro(sc->value)) { /* macro expansion */ + gc_disable(sc, 1 + gc_reservations (s_save)); + s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); + sc->args = cons(sc,sc->code, sc->NIL); + gc_enable(sc); + sc->code = sc->value; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_APPLY); + } else { + gc_disable(sc, 1); + sc->args = cons(sc, sc->code, sc->NIL); + gc_enable(sc); + sc->code = cdr(sc->code); + s_thread_to(sc,OP_E1ARGS); + } + + CASE(OP_E1ARGS): /* eval arguments */ + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); + sc->code = car(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + s_thread_to(sc,OP_APPLY_CODE); + } + +#if USE_TRACING + CASE(OP_TRACING): { + int tr=sc->tracing; + sc->tracing=ivalue(car(sc->args)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, tr)); + } +#endif + +#if USE_HISTORY + CASE(OP_CALLSTACK_POP): /* pop the call stack */ + callstack_pop(sc); + s_return(sc, sc->value); +#endif + + CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)', + * record in the history as invoked from + * 'car(args)' */ + free_cons(sc, sc->args, &callsite, &sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + /* Fallthrough. */ + + CASE(OP_APPLY): /* apply 'code' to 'args' */ +#if USE_TRACING + if(sc->tracing) { + s_save(sc,OP_REAL_APPLY,sc->args,sc->code); + sc->print_flag = 1; + /* sc->args=cons(sc,sc->code,sc->args);*/ + putstr(sc,"\nApply to: "); + s_thread_to(sc,OP_P0LIST); + } + /* fall through */ + CASE(OP_REAL_APPLY): +#endif +#if USE_HISTORY + if (op != OP_APPLY_CODE) + callsite = sc->code; + if (s_get_flag(sc, TAIL_CONTEXT)) { + /* We are evaluating a tail call. */ + tailstack_push(sc, callsite); + } else { + callstack_push(sc, callsite); + s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL); + } +#endif + + if (is_proc(sc->code)) { + s_goto(sc,procnum(sc->code)); /* PROCEDURE */ + } else if (is_foreign(sc->code)) + { + /* Keep nested calls from GC'ing the arglist */ + push_recent_alloc(sc,sc->args,sc->NIL); + x=sc->code->_object._ff(sc,sc->args); + s_return(sc,x); + } else if (is_closure(sc->code) || is_macro(sc->code) + || is_promise(sc->code)) { /* CLOSURE */ + /* Should not accept promise */ + /* make environment */ + new_frame_in_env(sc, closure_env(sc->code)); + for (x = car(closure_code(sc->code)), y = sc->args; + is_pair(x); x = cdr(x), y = cdr(y)) { + if (y == sc->NIL) { + Error_1(sc, "not enough arguments, missing", x); + } else if (is_symbol(car(x))) { + new_slot_in_env(sc, car(x), car(y)); + } else { + Error_1(sc, "syntax error in closure: not a symbol", car(x)); + } + } + + if (x == sc->NIL) { + if (y != sc->NIL) { + Error_0(sc, "too many arguments"); + } + } else if (is_symbol(x)) + new_slot_in_env(sc, x, y); + else { + Error_1(sc, "syntax error in closure: not a symbol", x); + } + sc->code = cdr(closure_code(sc->code)); + sc->args = sc->NIL; + s_set_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_BEGIN); + } else if (is_continuation(sc->code)) { /* CONTINUATION */ + sc->dump = cont_dump(sc->code); + s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); + } else { + Error_1(sc,"illegal function",sc->code); + } + + CASE(OP_DOMACRO): /* do macro */ + sc->code = sc->value; + s_thread_to(sc,OP_EVAL); + +#if USE_COMPILE_HOOK + CASE(OP_LAMBDA): /* lambda */ + /* If the hook is defined, apply it to sc->code, otherwise + set sc->value fall through */ + { + pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); + if(f==sc->NIL) { + sc->value = sc->code; + /* Fallthru */ + } else { + gc_disable(sc, 1 + gc_reservations (s_save)); + s_save(sc,OP_LAMBDA1,sc->args,sc->code); + sc->args=cons(sc,sc->code,sc->NIL); + gc_enable(sc); + sc->code=slot_value_in_env(f); + s_thread_to(sc,OP_APPLY); + } + } + /* Fallthrough. */ +#else + CASE(OP_LAMBDA): /* lambda */ + sc->value = sc->code; + /* Fallthrough. */ +#endif + + CASE(OP_LAMBDA1): + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); + + + CASE(OP_MKCLOSURE): /* make-closure */ + x=car(sc->args); + if(car(x)==sc->LAMBDA) { + x=cdr(x); + } + if(cdr(sc->args)==sc->NIL) { + y=sc->envir; + } else { + y=cadr(sc->args); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, x, y)); + + CASE(OP_QUOTE): /* quote */ + s_return(sc,car(sc->code)); + + CASE(OP_DEF0): /* define */ + if(is_immutable(car(sc->code))) + Error_1(sc,"define: unable to alter immutable", car(sc->code)); + + if (is_pair(car(sc->code))) { + x = caar(sc->code); + gc_disable(sc, 2); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_DEF1, sc->NIL, x); + s_thread_to(sc,OP_EVAL); + + CASE(OP_DEF1): { /* define */ + pointer *sslot; + x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_spec_in_env(sc, sc->code, sc->value, sslot); + } + s_return(sc,sc->code); + } + + CASE(OP_DEFP): /* defined? */ + x=sc->envir; + if(cdr(sc->args)!=sc->NIL) { + x=cadr(sc->args); + } + s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); + + CASE(OP_SET0): /* set! */ + if(is_immutable(car(sc->code))) + Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); + s_save(sc,OP_SET1, sc->NIL, car(sc->code)); + sc->code = cadr(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_SET1): /* set! */ + y=find_slot_in_env(sc,sc->envir,sc->code,1); + if (y != sc->NIL) { + set_slot_in_env(sc, y, sc->value); + s_return(sc,sc->value); + } else { + Error_1(sc, "set!: unbound variable", sc->code); + } + + + CASE(OP_BEGIN): /* begin */ + { + int last; + + if (!is_pair(sc->code)) { + s_return(sc,sc->code); + } + + last = cdr(sc->code) == sc->NIL; + if (!last) { + s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); + } + sc->code = car(sc->code); + if (! last) + /* This is not the end of the list. This is not a tail + * position. */ + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } + + CASE(OP_IF0): /* if */ + s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_IF1): /* if */ + if (is_true(sc->value)) + sc->code = car(sc->code); + else + sc->code = cadr(sc->code); /* (if #f 1) ==> () because + * car(sc->NIL) = sc->NIL */ + s_thread_to(sc,OP_EVAL); + + CASE(OP_LET0): /* let */ + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); + s_thread_to(sc,OP_LET1); + + CASE(OP_LET1): /* let (calculate parameters) */ + gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0)); + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + gc_enable(sc); + Error_1(sc, "Bad syntax of binding spec in let", + car(sc->code)); + } + s_save(sc,OP_LET1, sc->args, cdr(sc->code)); + gc_enable(sc); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + gc_enable(sc); + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_thread_to(sc,OP_LET2); + } + + CASE(OP_LET2): /* let */ + new_frame_in_env(sc, sc->envir); + for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; + y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + if (is_symbol(car(sc->code))) { /* named let */ + for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { + if (!is_pair(x)) + Error_1(sc, "Bad syntax of binding in let", x); + if (!is_list(sc, car(x))) + Error_1(sc, "Bad syntax of binding in let", car(x)); + gc_disable(sc, 1); + sc->args = cons(sc, caar(x), sc->args); + gc_enable(sc); + } + gc_disable(sc, 2 + gc_reservations (new_slot_in_env)); + x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); + new_slot_in_env(sc, car(sc->code), x); + gc_enable(sc); + sc->code = cddr(sc->code); + sc->args = sc->NIL; + } else { + sc->code = cdr(sc->code); + sc->args = sc->NIL; + } + s_thread_to(sc,OP_BEGIN); + + CASE(OP_LET0AST): /* let* */ + if (car(sc->code) == sc->NIL) { + new_frame_in_env(sc, sc->envir); + sc->code = cdr(sc->code); + s_thread_to(sc,OP_BEGIN); + } + if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code)); + } + s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); + sc->code = cadaar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_LET1AST): /* let* (make new frame) */ + new_frame_in_env(sc, sc->envir); + s_thread_to(sc,OP_LET2AST); + + CASE(OP_LET2AST): /* let* (calculate parameters) */ + new_slot_in_env(sc, caar(sc->code), sc->value); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_LET2AST, sc->args, sc->code); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + sc->code = sc->args; + sc->args = sc->NIL; + s_thread_to(sc,OP_BEGIN); + } + + CASE(OP_LET0REC): /* letrec */ + new_frame_in_env(sc, sc->envir); + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = car(sc->code); + s_thread_to(sc,OP_LET1REC); + + CASE(OP_LET1REC): /* letrec (calculate parameters) */ + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in letrec", + car(sc->code)); + } + s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_thread_to(sc,OP_LET2REC); + } + + CASE(OP_LET2REC): /* letrec */ + for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + sc->code = cdr(sc->code); + sc->args = sc->NIL; + s_thread_to(sc,OP_BEGIN); + + CASE(OP_COND0): /* cond */ + if (!is_pair(sc->code)) { + Error_0(sc,"syntax error in cond"); + } + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_COND1): /* cond */ + if (is_true(sc->value)) { + if ((sc->code = cdar(sc->code)) == sc->NIL) { + s_return(sc,sc->value); + } + if(!sc->code || car(sc->code)==sc->FEED_TO) { + if(!is_pair(cdr(sc->code))) { + Error_0(sc,"syntax error in cond"); + } + gc_disable(sc, 4); + x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); + sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); + gc_enable(sc); + s_thread_to(sc,OP_EVAL); + } + s_thread_to(sc,OP_BEGIN); + } else { + if ((sc->code = cdr(sc->code)) == sc->NIL) { + s_return(sc,sc->NIL); + } else { + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + } + } + + CASE(OP_DELAY): /* delay */ + gc_disable(sc, 2); + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return_enable_gc(sc,x); + + CASE(OP_AND0): /* and */ + if (sc->code == sc->NIL) { + s_return(sc,sc->T); + } + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_AND1): /* and */ + if (is_false(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + } + + CASE(OP_OR0): /* or */ + if (sc->code == sc->NIL) { + s_return(sc,sc->F); + } + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_OR1): /* or */ + if (is_true(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + if (cdr(sc->code) != sc->NIL) + s_clear_flag(sc, TAIL_CONTEXT); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + } + + CASE(OP_C0STREAM): /* cons-stream */ + s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_thread_to(sc,OP_EVAL); + + CASE(OP_C1STREAM): /* cons-stream */ + sc->args = sc->value; /* save sc->value to register sc->args for gc */ + gc_disable(sc, 3); + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return_enable_gc(sc, cons(sc, sc->args, x)); + + CASE(OP_MACRO0): /* macro */ + if (is_pair(car(sc->code))) { + x = caar(sc->code); + gc_disable(sc, 2); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_MACRO1, sc->NIL, x); + s_thread_to(sc,OP_EVAL); + + CASE(OP_MACRO1): { /* macro */ + pointer *sslot; + typeflag(sc->value) = T_MACRO; + x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_spec_in_env(sc, sc->code, sc->value, sslot); + } + s_return(sc,sc->code); + } + + CASE(OP_CASE0): /* case */ + s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_clear_flag(sc, TAIL_CONTEXT); + s_thread_to(sc,OP_EVAL); + + CASE(OP_CASE1): /* case */ + for (x = sc->code; x != sc->NIL; x = cdr(x)) { + if (!is_pair(y = caar(x))) { + break; + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (eqv(car(y), sc->value)) { + break; + } + } + if (y != sc->NIL) { + break; + } + } + if (x != sc->NIL) { + if (is_pair(caar(x))) { + sc->code = cdar(x); + s_thread_to(sc,OP_BEGIN); + } else {/* else */ + s_save(sc,OP_CASE2, sc->NIL, cdar(x)); + sc->code = caar(x); + s_thread_to(sc,OP_EVAL); + } + } else { + s_return(sc,sc->NIL); + } + + CASE(OP_CASE2): /* case */ + if (is_true(sc->value)) { + s_thread_to(sc,OP_BEGIN); + } else { + s_return(sc,sc->NIL); + } + + CASE(OP_PAPPLY): /* apply */ + sc->code = car(sc->args); + sc->args = list_star(sc,cdr(sc->args)); + /*sc->args = cadr(sc->args);*/ + s_thread_to(sc,OP_APPLY); + + CASE(OP_PEVAL): /* eval */ + if(cdr(sc->args)!=sc->NIL) { + sc->envir=cadr(sc->args); + } + sc->code = car(sc->args); + s_thread_to(sc,OP_EVAL); + + CASE(OP_CONTINUATION): /* call-with-current-continuation */ + sc->code = car(sc->args); + gc_disable(sc, 2); + sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); + gc_enable(sc); + s_thread_to(sc,OP_APPLY); + +#if USE_MATH + CASE(OP_INEX2EX): /* inexact->exact */ + x=car(sc->args); + if(num_is_integer(x)) { + s_return(sc,x); + } else if(modf(rvalue_unchecked(x),&dd)==0.0) { + s_return(sc,mk_integer(sc,ivalue(x))); + } else { + Error_1(sc, "inexact->exact: not integral", x); + } + + CASE(OP_EXP): + x=car(sc->args); + s_return(sc, mk_real(sc, exp(rvalue(x)))); + + CASE(OP_LOG): + x=car(sc->args); + s_return(sc, mk_real(sc, log(rvalue(x)))); + + CASE(OP_SIN): + x=car(sc->args); + s_return(sc, mk_real(sc, sin(rvalue(x)))); + + CASE(OP_COS): + x=car(sc->args); + s_return(sc, mk_real(sc, cos(rvalue(x)))); + + CASE(OP_TAN): + x=car(sc->args); + s_return(sc, mk_real(sc, tan(rvalue(x)))); + + CASE(OP_ASIN): + x=car(sc->args); + s_return(sc, mk_real(sc, asin(rvalue(x)))); + + CASE(OP_ACOS): + x=car(sc->args); + s_return(sc, mk_real(sc, acos(rvalue(x)))); + + CASE(OP_ATAN): + x=car(sc->args); + if(cdr(sc->args)==sc->NIL) { + s_return(sc, mk_real(sc, atan(rvalue(x)))); + } else { + pointer y=cadr(sc->args); + s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); + } + + CASE(OP_SQRT): + x=car(sc->args); + s_return(sc, mk_real(sc, sqrt(rvalue(x)))); + + CASE(OP_EXPT): { + double result; + int real_result=1; + pointer y=cadr(sc->args); + x=car(sc->args); + if (num_is_integer(x) && num_is_integer(y)) + real_result=0; + /* This 'if' is an R5RS compatibility fix. */ + /* NOTE: Remove this 'if' fix for R6RS. */ + if (rvalue(x) == 0 && rvalue(y) < 0) { + result = 0.0; + } else { + result = pow(rvalue(x),rvalue(y)); + } + /* Before returning integer result make sure we can. */ + /* If the test fails, result is too big for integer. */ + if (!real_result) + { + long result_as_long = (long)result; + if (result != (double)result_as_long) + real_result = 1; + } + if (real_result) { + s_return(sc, mk_real(sc, result)); + } else { + s_return(sc, mk_integer(sc, result)); + } + } + + CASE(OP_FLOOR): + x=car(sc->args); + s_return(sc, mk_real(sc, floor(rvalue(x)))); + + CASE(OP_CEILING): + x=car(sc->args); + s_return(sc, mk_real(sc, ceil(rvalue(x)))); + + CASE(OP_TRUNCATE ): { + double rvalue_of_x ; + x=car(sc->args); + rvalue_of_x = rvalue(x) ; + if (rvalue_of_x > 0) { + s_return(sc, mk_real(sc, floor(rvalue_of_x))); + } else { + s_return(sc, mk_real(sc, ceil(rvalue_of_x))); + } + } + + CASE(OP_ROUND): + x=car(sc->args); + if (num_is_integer(x)) + s_return(sc, x); + s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); +#endif + + CASE(OP_ADD): /* + */ + v=num_zero; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_add(v,nvalue(car(x))); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_MUL): /* * */ + v=num_one; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_mul(v,nvalue(car(x))); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_SUB): /* - */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_zero; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + v=num_sub(v,nvalue(car(x))); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_DIV): /* / */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (!is_zero_double(rvalue(car(x)))) + v=num_div(v,nvalue(car(x))); + else { + Error_0(sc,"/: division by zero"); + } + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_INTDIV): /* quotient */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (ivalue(car(x)) != 0) + v=num_intdiv(v,nvalue(car(x))); + else { + Error_0(sc,"quotient: division by zero"); + } + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_REM): /* remainder */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_rem(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"remainder: division by zero"); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_MOD): /* modulo */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_mod(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"modulo: division by zero"); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); + + CASE(OP_CAR): /* car */ + s_return(sc,caar(sc->args)); + + CASE(OP_CDR): /* cdr */ + s_return(sc,cdar(sc->args)); + + CASE(OP_CONS): /* cons */ + cdr(sc->args) = cadr(sc->args); + s_return(sc,sc->args); + + CASE(OP_SETCAR): /* set-car! */ + if(!is_immutable(car(sc->args))) { + caar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-car!: unable to alter immutable pair"); + } + + CASE(OP_SETCDR): /* set-cdr! */ + if(!is_immutable(car(sc->args))) { + cdar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-cdr!: unable to alter immutable pair"); + } + + CASE(OP_CHAR2INT): { /* char->integer */ + char c; + c=(char)ivalue(car(sc->args)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c)); + } + + CASE(OP_INT2CHAR): { /* integer->char */ + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); + } + + CASE(OP_CHARUPCASE): { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=toupper(c); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); + } + + CASE(OP_CHARDNCASE): { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=tolower(c); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); + } + + CASE(OP_STR2SYM): /* string->symbol */ + gc_disable(sc, gc_reservations (mk_symbol)); + s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args)))); + + CASE(OP_STR2ATOM): /* string->atom */ { + char *s=strvalue(car(sc->args)); + long pf = 0; + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "string->atom: bad base", cadr(sc->args)); + } else if(*s=='#') /* no use of base! */ { + s_return(sc, mk_sharp_const(sc, s+1)); + } else { + if (pf == 0 || pf == 10) { + s_return(sc, mk_atom(sc, s)); + } + else { + char *ep; + long iv = strtol(s,&ep,(int )pf); + if (*ep == 0) { + s_return(sc, mk_integer(sc, iv)); + } + else { + s_return(sc, sc->F); + } + } + } + } + + CASE(OP_SYM2STR): /* symbol->string */ + gc_disable(sc, 1); + x=mk_string(sc,symname(car(sc->args))); + setimmutable(x); + s_return_enable_gc(sc, x); + + CASE(OP_ATOM2STR): /* atom->string */ { + long pf = 0; + x=car(sc->args); + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "atom->string: bad base", cadr(sc->args)); + } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { + char *p; + int len; + atom2str(sc,x,(int )pf,&p,&len); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_counted_string(sc, p, len)); + } else { + Error_1(sc, "atom->string: not an atom", x); + } + } + + CASE(OP_MKSTRING): { /* make-string */ + int fill=' '; + int len; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=charvalue(cadr(sc->args)); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill)); + } + + CASE(OP_STRLEN): /* string-length */ + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args)))); + + CASE(OP_STRREF): { /* string-ref */ + char *str; + int index; + + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + + if(index>=strlength(car(sc->args))) { + Error_1(sc, "string-ref: out of bounds", cadr(sc->args)); + } + + gc_disable(sc, 1); + s_return_enable_gc(sc, + mk_character(sc, ((unsigned char*) str)[index])); + } + + CASE(OP_STRSET): { /* string-set! */ + char *str; + int index; + int c; + + if(is_immutable(car(sc->args))) { + Error_1(sc, "string-set!: unable to alter immutable string", + car(sc->args)); + } + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + if(index>=strlength(car(sc->args))) { + Error_1(sc, "string-set!: out of bounds", cadr(sc->args)); + } + + c=charvalue(caddr(sc->args)); + + str[index]=(char)c; + s_return(sc,car(sc->args)); + } + + CASE(OP_STRAPPEND): { /* string-append */ + /* in 1.29 string-append was in Scheme in init.scm but was too slow */ + int len = 0; + pointer newstr; + char *pos; + + /* compute needed length for new string */ + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + len += strlength(car(x)); + } + gc_disable(sc, 1); + newstr = mk_empty_string(sc, len, ' '); + /* store the contents of the argument strings into the new string */ + for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; + pos += strlength(car(x)), x = cdr(x)) { + memcpy(pos, strvalue(car(x)), strlength(car(x))); + } + s_return_enable_gc(sc, newstr); + } + + CASE(OP_SUBSTR): { /* substring */ + char *str; + int index0; + int index1; + + str=strvalue(car(sc->args)); + + index0=ivalue(cadr(sc->args)); + + if(index0>strlength(car(sc->args))) { + Error_1(sc, "substring: start out of bounds", cadr(sc->args)); + } + + if(cddr(sc->args)!=sc->NIL) { + index1=ivalue(caddr(sc->args)); + if(index1>strlength(car(sc->args)) || index1args)); + } + } else { + index1=strlength(car(sc->args)); + } + + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0)); + } + + CASE(OP_VECTOR): { /* vector */ + int i; + pointer vec; + int len=list_length(sc,sc->args); + if(len<0) { + Error_1(sc, "vector: not a proper list", sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { + set_vector_elem(vec,i,car(x)); + } + s_return(sc,vec); + } + + CASE(OP_MKVECTOR): { /* make-vector */ + pointer fill=sc->NIL; + int len; + pointer vec; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=cadr(sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + if(fill!=sc->NIL) { + fill_vector(vec,fill); + } + s_return(sc,vec); + } + + CASE(OP_VECLEN): /* vector-length */ + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args)))); + + CASE(OP_VECREF): { /* vector-ref */ + int index; + + index=ivalue(cadr(sc->args)); + + if(index >= vector_length(car(sc->args))) { + Error_1(sc, "vector-ref: out of bounds", cadr(sc->args)); + } + + s_return(sc,vector_elem(car(sc->args),index)); + } + + CASE(OP_VECSET): { /* vector-set! */ + int index; + + if(is_immutable(car(sc->args))) { + Error_1(sc, "vector-set!: unable to alter immutable vector", + car(sc->args)); + } + + index=ivalue(cadr(sc->args)); + if(index >= vector_length(car(sc->args))) { + Error_1(sc, "vector-set!: out of bounds", cadr(sc->args)); + } + + set_vector_elem(car(sc->args),index,caddr(sc->args)); + s_return(sc,car(sc->args)); + } + + CASE(OP_NOT): /* not */ + s_retbool(is_false(car(sc->args))); + CASE(OP_BOOLP): /* boolean? */ + s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); + CASE(OP_EOFOBJP): /* boolean? */ + s_retbool(car(sc->args) == sc->EOF_OBJ); + CASE(OP_NULLP): /* null? */ + s_retbool(car(sc->args) == sc->NIL); + CASE(OP_NUMEQ): /* = */ + /* Fallthrough. */ + CASE(OP_LESS): /* < */ + /* Fallthrough. */ + CASE(OP_GRE): /* > */ + /* Fallthrough. */ + CASE(OP_LEQ): /* <= */ + /* Fallthrough. */ + CASE(OP_GEQ): /* >= */ + switch(op) { + case OP_NUMEQ: comp_func=num_eq; break; + case OP_LESS: comp_func=num_lt; break; + case OP_GRE: comp_func=num_gt; break; + case OP_LEQ: comp_func=num_le; break; + case OP_GEQ: comp_func=num_ge; break; + default: assert (! "reached"); + } + x=sc->args; + v=nvalue(car(x)); + x=cdr(x); + + for (; x != sc->NIL; x = cdr(x)) { + if(!comp_func(v,nvalue(car(x)))) { + s_retbool(0); + } + v=nvalue(car(x)); + } + s_retbool(1); + CASE(OP_SYMBOLP): /* symbol? */ + s_retbool(is_symbol(car(sc->args))); + CASE(OP_NUMBERP): /* number? */ + s_retbool(is_number(car(sc->args))); + CASE(OP_STRINGP): /* string? */ + s_retbool(is_string(car(sc->args))); + CASE(OP_INTEGERP): /* integer? */ + s_retbool(is_integer(car(sc->args))); + CASE(OP_REALP): /* real? */ + s_retbool(is_number(car(sc->args))); /* All numbers are real */ + CASE(OP_CHARP): /* char? */ + s_retbool(is_character(car(sc->args))); +#if USE_CHAR_CLASSIFIERS + CASE(OP_CHARAP): /* char-alphabetic? */ + s_retbool(Cisalpha(ivalue(car(sc->args)))); + CASE(OP_CHARNP): /* char-numeric? */ + s_retbool(Cisdigit(ivalue(car(sc->args)))); + CASE(OP_CHARWP): /* char-whitespace? */ + s_retbool(Cisspace(ivalue(car(sc->args)))); + CASE(OP_CHARUP): /* char-upper-case? */ + s_retbool(Cisupper(ivalue(car(sc->args)))); + CASE(OP_CHARLP): /* char-lower-case? */ + s_retbool(Cislower(ivalue(car(sc->args)))); +#endif + CASE(OP_PORTP): /* port? */ + s_retbool(is_port(car(sc->args))); + CASE(OP_INPORTP): /* input-port? */ + s_retbool(is_inport(car(sc->args))); + CASE(OP_OUTPORTP): /* output-port? */ + s_retbool(is_outport(car(sc->args))); + CASE(OP_PROCP): /* procedure? */ + /*-- + * continuation should be procedure by the example + * (call-with-current-continuation procedure?) ==> #t + * in R^3 report sec. 6.9 + */ + s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) + || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); + CASE(OP_PAIRP): /* pair? */ + s_retbool(is_pair(car(sc->args))); + CASE(OP_LISTP): /* list? */ + s_retbool(list_length(sc,car(sc->args)) >= 0); + + CASE(OP_ENVP): /* environment? */ + s_retbool(is_environment(car(sc->args))); + CASE(OP_VECTORP): /* vector? */ + s_retbool(is_vector(car(sc->args))); + CASE(OP_EQ): /* eq? */ + s_retbool(car(sc->args) == cadr(sc->args)); + CASE(OP_EQV): /* eqv? */ + s_retbool(eqv(car(sc->args), cadr(sc->args))); + + CASE(OP_FORCE): /* force */ + sc->code = car(sc->args); + if (is_promise(sc->code)) { + /* Should change type to closure here */ + s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); + sc->args = sc->NIL; + s_thread_to(sc,OP_APPLY); + } else { + s_return(sc,sc->code); + } + + CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */ + copy_value(sc, sc->code, sc->value); + s_return(sc,sc->value); + + CASE(OP_WRITE): /* write */ + /* Fallthrough. */ + CASE(OP_DISPLAY): /* display */ + /* Fallthrough. */ + CASE(OP_WRITE_CHAR): /* write-char */ + if(is_pair(cdr(sc->args))) { + if(cadr(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=cadr(sc->args); + } + } + sc->args = car(sc->args); + if(op==OP_WRITE) { + sc->print_flag = 1; + } else { + sc->print_flag = 0; + } + s_thread_to(sc,OP_P0LIST); + + CASE(OP_NEWLINE): /* newline */ + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=car(sc->args); + } + } + putstr(sc, "\n"); + s_return(sc,sc->T); + + CASE(OP_ERR0): /* error */ + sc->retcode=-1; + if (!is_string(car(sc->args))) { + sc->args=cons(sc,mk_string(sc," -- "),sc->args); + setimmutable(car(sc->args)); + } + putstr(sc, "Error: "); + putstr(sc, strvalue(car(sc->args))); + sc->args = cdr(sc->args); + s_thread_to(sc,OP_ERR1); + + CASE(OP_ERR1): /* error */ + putstr(sc, " "); + if (sc->args != sc->NIL) { + s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + sc->print_flag = 1; + s_thread_to(sc,OP_P0LIST); + } else { + putstr(sc, "\n"); + if(sc->interactive_repl) { + s_thread_to(sc,OP_T0LVL); + } else { + return; + } + } + + CASE(OP_REVERSE): /* reverse */ + s_return(sc,reverse(sc, sc->NIL, car(sc->args))); + + CASE(OP_REVERSE_IN_PLACE): /* reverse! */ + s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args))); + + CASE(OP_LIST_STAR): /* list* */ + s_return(sc,list_star(sc,sc->args)); + + CASE(OP_APPEND): /* append */ + x = sc->NIL; + y = sc->args; + if (y == x) { + s_return(sc, x); + } + + /* cdr() in the while condition is not a typo. If car() */ + /* is used (append '() 'a) will return the wrong result.*/ + while (cdr(y) != sc->NIL) { + x = revappend(sc, x, car(y)); + y = cdr(y); + if (x == sc->F) { + Error_0(sc, "non-list argument to append"); + } + } + + s_return(sc, reverse_in_place(sc, car(y), x)); + +#if USE_PLIST + CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */ + gc_disable(sc, gc_reservations(set_property)); + s_return_enable_gc(sc, + set_property(sc, car(sc->args), + cadr(sc->args), caddr(sc->args))); + + CASE(OP_SYMBOL_PROPERTY): /* symbol-property */ + s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); +#endif /* USE_PLIST */ + + CASE(OP_TAG_VALUE): { /* not exposed */ + /* This tags sc->value with car(sc->args). Useful to tag + * results of opcode evaluations. */ + pointer a, b, c; + free_cons(sc, sc->args, &a, &b); + free_cons(sc, b, &b, &c); + assert(c == sc->NIL); + s_return(sc, mk_tagged_value(sc, sc->value, a, b)); + } + + CASE(OP_MK_TAGGED): /* make-tagged-value */ + if (is_vector(car(sc->args))) + Error_0(sc, "cannot tag vector"); + s_return(sc, mk_tagged_value(sc, car(sc->args), + car(cadr(sc->args)), + cdr(cadr(sc->args)))); + + CASE(OP_GET_TAG): /* get-tag */ + s_return(sc, get_tag(sc, car(sc->args))); + + CASE(OP_QUIT): /* quit */ + if(is_pair(sc->args)) { + sc->retcode=ivalue(car(sc->args)); + } + return; + + CASE(OP_GC): /* gc */ + gc(sc, sc->NIL, sc->NIL); + s_return(sc,sc->T); + + CASE(OP_GCVERB): /* gc-verbose */ + { int was = sc->gc_verbose; + + sc->gc_verbose = (car(sc->args) != sc->F); + s_retbool(was); + } + + CASE(OP_NEWSEGMENT): /* new-segment */ + if (!is_pair(sc->args) || !is_number(car(sc->args))) { + Error_0(sc,"new-segment: argument must be a number"); + } + alloc_cellseg(sc, (int) ivalue(car(sc->args))); + s_return(sc,sc->T); + + CASE(OP_OBLIST): /* oblist */ + s_return(sc, oblist_all_symbols(sc)); + + CASE(OP_CURR_INPORT): /* current-input-port */ + s_return(sc,sc->inport); + + CASE(OP_CURR_OUTPORT): /* current-output-port */ + s_return(sc,sc->outport); + + CASE(OP_OPEN_INFILE): /* open-input-file */ + /* Fallthrough. */ + CASE(OP_OPEN_OUTFILE): /* open-output-file */ + /* Fallthrough. */ + CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INFILE: prop=port_input; break; + case OP_OPEN_OUTFILE: prop=port_output; break; + case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; + default: assert (! "reached"); + } + p=port_from_filename(sc,strvalue(car(sc->args)),prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + break; + } + +#if USE_STRING_PORTS + CASE(OP_OPEN_INSTRING): /* open-input-string */ + /* Fallthrough. */ + CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INSTRING: prop=port_input; break; + case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; + default: assert (! "reached"); + } + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + } + CASE(OP_OPEN_OUTSTRING): /* open-output-string */ { + pointer p; + if(car(sc->args)==sc->NIL) { + p=port_from_scratch(sc); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } else { + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), + port_output); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } + s_return(sc,p); + } + CASE(OP_GET_OUTSTRING): /* get-output-string */ { + port *p; + + if ((p=car(sc->args)->_object._port)->kind&port_string) { + gc_disable(sc, 1); + s_return_enable_gc( + sc, + mk_counted_string(sc, + p->rep.string.start, + p->rep.string.curr - p->rep.string.start)); + } + s_return(sc,sc->F); + } +#endif + + CASE(OP_CLOSE_INPORT): /* close-input-port */ + port_close(sc,car(sc->args),port_input); + s_return(sc,sc->T); + + CASE(OP_CLOSE_OUTPORT): /* close-output-port */ + port_close(sc,car(sc->args),port_output); + s_return(sc,sc->T); + + CASE(OP_INT_ENV): /* interaction-environment */ + s_return(sc,sc->global_env); + + CASE(OP_CURR_ENV): /* current-environment */ + s_return(sc,sc->envir); + + + /* ========== reading part ========== */ + CASE(OP_READ): + if(!is_pair(sc->args)) { + s_thread_to(sc,OP_READ_INTERNAL); + } + if(!is_inport(car(sc->args))) { + Error_1(sc, "read: not an input port", car(sc->args)); + } + if(car(sc->args)==sc->inport) { + s_thread_to(sc,OP_READ_INTERNAL); + } + x=sc->inport; + sc->inport=car(sc->args); + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + s_thread_to(sc,OP_READ_INTERNAL); + + CASE(OP_READ_CHAR): /* read-char */ + /* Fallthrough. */ + CASE(OP_PEEK_CHAR): /* peek-char */ { + int c; + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->inport) { + x=sc->inport; + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + sc->inport=car(sc->args); + } + } + c=inchar(sc); + if(c==EOF) { + s_return(sc,sc->EOF_OBJ); + } + if(op==OP_PEEK_CHAR) { + backchar(sc,c); + } + s_return(sc,mk_character(sc,c)); + } + + CASE(OP_CHAR_READY): /* char-ready? */ { + pointer p=sc->inport; + int res; + if(is_pair(sc->args)) { + p=car(sc->args); + } + res=p->_object._port->kind&port_string; + s_retbool(res); + } + + CASE(OP_SET_INPORT): /* set-input-port */ + sc->inport=car(sc->args); + s_return(sc,sc->value); + + CASE(OP_SET_OUTPORT): /* set-output-port */ + sc->outport=car(sc->args); + s_return(sc,sc->value); + + CASE(OP_RDSEXPR): + switch (sc->tok) { + case TOK_EOF: + s_return(sc,sc->EOF_OBJ); + /* NOTREACHED */ + case TOK_VEC: + s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); + /* fall through */ + case TOK_LPAREN: + sc->tok = token(sc); + if (sc->tok == TOK_RPAREN) { + s_return(sc,sc->NIL); + } else if (sc->tok == TOK_DOT) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { +#if SHOW_ERROR_LINE + pointer filename; + pointer lineno; +#endif + sc->nesting_stack[sc->file_i]++; +#if SHOW_ERROR_LINE + filename = sc->load_stack[sc->file_i].filename; + lineno = sc->load_stack[sc->file_i].curr_line; + + s_save(sc, OP_TAG_VALUE, + cons(sc, filename, cons(sc, lineno, sc->NIL)), + sc->NIL); +#endif + s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); + s_thread_to(sc,OP_RDSEXPR); + } + case TOK_QUOTE: + s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + case TOK_BQUOTE: + sc->tok = token(sc); + if(sc->tok==TOK_VEC) { + s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); + sc->tok=TOK_LPAREN; + s_thread_to(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); + } + s_thread_to(sc,OP_RDSEXPR); + case TOK_COMMA: + s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + case TOK_ATMARK: + s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + case TOK_ATOM: + s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); + case TOK_DQUOTE: + x=readstrexp(sc); + if(x==sc->F) { + Error_0(sc,"Error reading string"); + } + setimmutable(x); + s_return(sc,x); + case TOK_SHARP: { + pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); + if(f==sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + sc->code=cons(sc,slot_value_in_env(f),sc->NIL); + s_thread_to(sc,OP_EVAL); + } + } + case TOK_SHARP_CONST: + if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + s_return(sc,x); + } + default: + Error_0(sc,"syntax error: illegal token"); + } + break; + + CASE(OP_RDLIST): { + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); + sc->tok = token(sc); + if (sc->tok == TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + else if (sc->tok == TOK_RPAREN) { + int c = inchar(sc); + if (c != '\n') + backchar(sc,c); + else + port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); + } else if (sc->tok == TOK_DOT) { + s_save(sc,OP_RDDOT, sc->args, sc->NIL); + sc->tok = token(sc); + s_thread_to(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDLIST, sc->args, sc->NIL);; + s_thread_to(sc,OP_RDSEXPR); + } + } + + CASE(OP_RDDOT): + if (token(sc) != TOK_RPAREN) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->value, sc->args)); + } + + CASE(OP_RDQUOTE): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QUOTE, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDQQUOTE): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QQUOTE, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDQQUOTEVEC): + gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol)); + s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"), + cons(sc, mk_symbol(sc,"vector"), + cons(sc,cons(sc, sc->QQUOTE, + cons(sc,sc->value,sc->NIL)), + sc->NIL)))); + + CASE(OP_RDUNQUOTE): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTE, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDUQTSP): + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP, + cons(sc, sc->value, sc->NIL))); + + CASE(OP_RDVEC): + /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_thread_to(sc,OP_EVAL); Cannot be quoted*/ + /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_return(sc,x); Cannot be part of pairs*/ + /*sc->code=mk_proc(sc,OP_VECTOR); + sc->args=sc->value; + s_thread_to(sc,OP_APPLY);*/ + sc->args=sc->value; + s_thread_to(sc,OP_VECTOR); + + /* ========== printing part ========== */ + CASE(OP_P0LIST): + if(is_vector(sc->args)) { + putstr(sc,"#("); + sc->args=cons(sc,sc->args,mk_integer(sc,0)); + s_thread_to(sc,OP_PVECFROM); + } else if(is_environment(sc->args)) { + putstr(sc,"#"); + s_return(sc,sc->T); + } else if (!is_pair(sc->args)) { + printatom(sc, sc->args, sc->print_flag); + s_return(sc,sc->T); + } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "'"); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "`"); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, ","); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { + putstr(sc, ",@"); + sc->args = cadr(sc->args); + s_thread_to(sc,OP_P0LIST); + } else { + putstr(sc, "("); + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + s_thread_to(sc,OP_P0LIST); + } + + CASE(OP_P1LIST): + if (is_pair(sc->args)) { + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + putstr(sc, " "); + sc->args = car(sc->args); + s_thread_to(sc,OP_P0LIST); + } else if(is_vector(sc->args)) { + s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); + putstr(sc, " . "); + s_thread_to(sc,OP_P0LIST); + } else { + if (sc->args != sc->NIL) { + putstr(sc, " . "); + printatom(sc, sc->args, sc->print_flag); + } + putstr(sc, ")"); + s_return(sc,sc->T); + } + CASE(OP_PVECFROM): { + int i=ivalue_unchecked(cdr(sc->args)); + pointer vec=car(sc->args); + int len = vector_length(vec); + if(i==len) { + putstr(sc,")"); + s_return(sc,sc->T); + } else { + pointer elem=vector_elem(vec,i); + cdr(sc->args) = mk_integer(sc, i + 1); + s_save(sc,OP_PVECFROM, sc->args, sc->NIL); + sc->args=elem; + if (i > 0) + putstr(sc," "); + s_thread_to(sc,OP_P0LIST); + } + } + + CASE(OP_LIST_LENGTH): { /* length */ /* a.k */ + long l = list_length(sc, car(sc->args)); + if(l<0) { + Error_1(sc, "length: not a list", car(sc->args)); + } + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, l)); + } + CASE(OP_ASSQ): /* assq */ /* a.k */ + x = car(sc->args); + for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { + if (!is_pair(car(y))) { + Error_0(sc,"unable to handle non pair element"); + } + if (x == caar(y)) + break; + } + if (is_pair(y)) { + s_return(sc,car(y)); + } else { + s_return(sc,sc->F); + } + + + CASE(OP_GET_CLOSURE): /* get-closure-code */ /* a.k */ + sc->args = car(sc->args); + if (sc->args == sc->NIL) { + s_return(sc,sc->F); + } else if (is_closure(sc->args)) { + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); + } else if (is_macro(sc->args)) { + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); + } else { + s_return(sc,sc->F); + } + CASE(OP_CLOSUREP): /* closure? */ + /* + * Note, macro object is also a closure. + * Therefore, (closure? <#MACRO>) ==> #t + */ + s_retbool(is_closure(car(sc->args))); + CASE(OP_MACROP): /* macro? */ + s_retbool(is_macro(car(sc->args))); + CASE(OP_VM_HISTORY): /* *vm-history* */ + s_return(sc, history_flatten(sc)); + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op); + Error_0(sc,sc->strbuff); + } + } +} + +typedef int (*test_predicate)(pointer); + +static int is_any(pointer p) { + (void)p; + return 1; +} + +static int is_nonneg(pointer p) { + return ivalue(p)>=0 && is_integer(p); +} + +/* Correspond carefully with following defines! */ +static const struct { + test_predicate fct; + const char *kind; +} tests[]={ + {0,0}, /* unused */ + {is_any, 0}, + {is_string, "string"}, + {is_symbol, "symbol"}, + {is_port, "port"}, + {is_inport,"input port"}, + {is_outport,"output port"}, + {is_environment, "environment"}, + {is_pair, "pair"}, + {0, "pair or '()"}, + {is_character, "character"}, + {is_vector, "vector"}, + {is_number, "number"}, + {is_integer, "integer"}, + {is_nonneg, "non-negative integer"} +}; + +#define TST_NONE 0 +#define TST_ANY "\001" +#define TST_STRING "\002" +#define TST_SYMBOL "\003" +#define TST_PORT "\004" +#define TST_INPORT "\005" +#define TST_OUTPORT "\006" +#define TST_ENVIRONMENT "\007" +#define TST_PAIR "\010" +#define TST_LIST "\011" +#define TST_CHAR "\012" +#define TST_VECTOR "\013" +#define TST_NUMBER "\014" +#define TST_INTEGER "\015" +#define TST_NATURAL "\016" + +#define INF_ARG 0xff + +static const struct op_code_info dispatch_table[]= { +#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}}, +#include "opdefines.h" +#undef _OP_DEF + {{0},0,0,{0}}, +}; + +static const char *procname(pointer x) { + int n=procnum(x); + const char *name=dispatch_table[n].name; + if (name[0] == 0) { + name="ILLEGAL!"; + } + return name; +} + +static int +check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size) +{ + int ok = 1; + int n = list_length(sc, sc->args); + + /* Check number of arguments */ + if (n < pcd->min_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at least", + pcd->min_arity); + } + if (ok && n>pcd->max_arity) { + ok = 0; + snprintf(msg, msg_size, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity == pcd->max_arity ? "" : " at most", + pcd->max_arity); + } + if (ok) { + if (pcd->arg_tests_encoding[0] != 0) { + int i = 0; + int j; + const char *t = pcd->arg_tests_encoding; + pointer arglist = sc->args; + + do { + pointer arg = car(arglist); + j = (int)t[0]; + if (j == TST_LIST[0]) { + if (arg != sc->NIL && !is_pair(arg)) break; + } else { + if (!tests[j].fct(arg)) break; + } + + if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { + /* last test is replicated as necessary */ + t++; + } + arglist = cdr(arglist); + i++; + } while (i < n); + + if (i < n) { + ok = 0; + snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s", + pcd->name, + i + 1, + tests[j].kind, + type_to_string(type(car(arglist)))); + } + } + } + + return ok; +} + +/* ========== Initialization of internal keywords ========== */ + +/* Symbols representing syntax are tagged with (OP . '()). */ +static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) { + pointer x, y; + pointer *slot; + + x = oblist_find_by_name(sc, name, &slot); + assert (x == sc->NIL); + + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL | T_SYNTAX; + setimmutable(car(x)); + y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL); + free_cell(sc, x); + setimmutable(get_tag(sc, y)); + *slot = immutable_cons(sc, y, *slot); +} + +/* Returns the opcode for the syntax represented by P. */ +static int syntaxnum(scheme *sc, pointer p) { + int op = ivalue_unchecked(car(get_tag(sc, p))); + assert (op < OP_MAXDEFINED); + return op; +} + +static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) { + pointer x, y; + + x = mk_symbol(sc, name); + y = mk_proc(sc,op); + new_slot_in_env(sc, x, y); +} + +static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { + pointer y; + + y = get_cell(sc, sc->NIL, sc->NIL); + typeflag(y) = (T_PROC | T_ATOM); + ivalue_unchecked(y) = (long) op; + set_num_integer(y); + return y; +} + +/* initialization of TinyScheme */ +#if USE_INTERFACE +INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { + return cons(sc,a,b); +} +INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { + return immutable_cons(sc,a,b); +} + +static const struct scheme_interface vtbl = { + scheme_define, + s_cons, + s_immutable_cons, + reserve_cells, + mk_integer, + mk_real, + mk_symbol, + gensym, + mk_string, + mk_counted_string, + mk_character, + mk_vector, + mk_foreign_func, + mk_foreign_object, + get_foreign_object_vtable, + get_foreign_object_data, + putstr, + putcharacter, + + is_string, + string_value, + is_number, + nvalue, + ivalue, + rvalue, + is_integer, + is_real, + is_character, + charvalue, + is_list, + is_vector, + list_length, + ivalue, + fill_vector, + vector_elem, + set_vector_elem, + is_port, + is_pair, + pair_car, + pair_cdr, + set_car, + set_cdr, + + is_symbol, + symname, + + is_syntax, + is_proc, + is_foreign, + syntaxname, + is_closure, + is_macro, + closure_code, + closure_env, + + is_continuation, + is_promise, + is_environment, + is_immutable, + setimmutable, + + scheme_load_file, + scheme_load_string, + port_from_file +}; +#endif + +scheme *scheme_init_new() { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init(sc)) { + free(sc); + return 0; + } else { + return sc; + } +} + +scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init_custom_alloc(sc,malloc,free)) { + free(sc); + return 0; + } else { + return sc; + } +} + + +int scheme_init(scheme *sc) { + return scheme_init_custom_alloc(sc,malloc,free); +} + +int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { + int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); + pointer x; + +#if USE_INTERFACE + sc->vptr=&vtbl; +#endif + sc->gensym_cnt=0; + sc->malloc=malloc; + sc->free=free; + sc->sink = &sc->_sink; + sc->NIL = &sc->_NIL; + sc->T = &sc->_HASHT; + sc->F = &sc->_HASHF; + sc->EOF_OBJ=&sc->_EOF_OBJ; + + sc->free_cell = &sc->_NIL; + sc->fcells = 0; + sc->inhibit_gc = GC_ENABLED; + sc->reserved_cells = 0; + sc->reserved_lineno = 0; + sc->no_memory=0; + sc->inport=sc->NIL; + sc->outport=sc->NIL; + sc->save_inport=sc->NIL; + sc->loadport=sc->NIL; + sc->nesting=0; + memset (sc->nesting_stack, 0, sizeof sc->nesting_stack); + sc->interactive_repl=0; + sc->strbuff = sc->malloc(STRBUFFSIZE); + if (sc->strbuff == 0) { + sc->no_memory=1; + return 0; + } + sc->strbuff_size = STRBUFFSIZE; + + sc->cell_segments = NULL; + if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { + sc->no_memory=1; + return 0; + } + sc->gc_verbose = 0; + dump_stack_initialize(sc); + sc->code = sc->NIL; + sc->tracing=0; + sc->flags = 0; + + /* init sc->NIL */ + typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK); + car(sc->NIL) = cdr(sc->NIL) = sc->NIL; + /* init T */ + typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK); + car(sc->T) = cdr(sc->T) = sc->T; + /* init F */ + typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK); + car(sc->F) = cdr(sc->F) = sc->F; + /* init EOF_OBJ */ + typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK); + car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; + /* init sink */ + typeflag(sc->sink) = (T_SINK | T_PAIR | MARK); + car(sc->sink) = cdr(sc->sink) = sc->NIL; + /* init c_nest */ + sc->c_nest = sc->NIL; + + sc->oblist = oblist_initial_value(sc); + /* init global_env */ + new_frame_in_env(sc, sc->NIL); + sc->global_env = sc->envir; + /* init else */ + x = mk_symbol(sc,"else"); + new_slot_in_env(sc, x, sc->T); + + assign_syntax(sc, OP_LAMBDA, "lambda"); + assign_syntax(sc, OP_QUOTE, "quote"); + assign_syntax(sc, OP_DEF0, "define"); + assign_syntax(sc, OP_IF0, "if"); + assign_syntax(sc, OP_BEGIN, "begin"); + assign_syntax(sc, OP_SET0, "set!"); + assign_syntax(sc, OP_LET0, "let"); + assign_syntax(sc, OP_LET0AST, "let*"); + assign_syntax(sc, OP_LET0REC, "letrec"); + assign_syntax(sc, OP_COND0, "cond"); + assign_syntax(sc, OP_DELAY, "delay"); + assign_syntax(sc, OP_AND0, "and"); + assign_syntax(sc, OP_OR0, "or"); + assign_syntax(sc, OP_C0STREAM, "cons-stream"); + assign_syntax(sc, OP_MACRO0, "macro"); + assign_syntax(sc, OP_CASE0, "case"); + + for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); + sc->QUOTE = mk_symbol(sc, "quote"); + sc->QQUOTE = mk_symbol(sc, "quasiquote"); + sc->UNQUOTE = mk_symbol(sc, "unquote"); + sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); + sc->FEED_TO = mk_symbol(sc, "=>"); + sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); + sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); + sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); +#if USE_COMPILE_HOOK + sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); +#endif + + return !sc->no_memory; +} + +void scheme_set_input_port_file(scheme *sc, FILE *fin) { + sc->inport=port_from_file(sc,fin,port_input); +} + +void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { + sc->inport=port_from_string(sc,start,past_the_end,port_input); +} + +void scheme_set_output_port_file(scheme *sc, FILE *fout) { + sc->outport=port_from_file(sc,fout,port_output); +} + +void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { + sc->outport=port_from_string(sc,start,past_the_end,port_output); +} + +void scheme_set_external_data(scheme *sc, void *p) { + sc->ext_data=p; +} + +void scheme_deinit(scheme *sc) { + struct cell_segment *s; + int i; + + sc->oblist=sc->NIL; + sc->global_env=sc->NIL; + dump_stack_free(sc); + sc->envir=sc->NIL; + sc->code=sc->NIL; + history_free(sc); + sc->args=sc->NIL; + sc->value=sc->NIL; + if(is_port(sc->inport)) { + typeflag(sc->inport) = T_ATOM; + } + sc->inport=sc->NIL; + sc->outport=sc->NIL; + if(is_port(sc->save_inport)) { + typeflag(sc->save_inport) = T_ATOM; + } + sc->save_inport=sc->NIL; + if(is_port(sc->loadport)) { + typeflag(sc->loadport) = T_ATOM; + } + sc->loadport=sc->NIL; + + for(i=0; i<=sc->file_i; i++) { + port_clear_location(sc, &sc->load_stack[i]); + } + + sc->gc_verbose=0; + gc(sc,sc->NIL,sc->NIL); + + for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) { + /* nop */ + } + sc->free(sc->strbuff); +} + +void scheme_load_file(scheme *sc, FILE *fin) +{ scheme_load_named_file(sc,fin,0); } + +void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_file; + sc->load_stack[0].rep.stdio.file=fin; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + if(fin==stdin) { + sc->interactive_repl=1; + } + + port_init_location(sc, &sc->load_stack[0], + (fin != stdin && filename) + ? mk_string(sc, filename) + : NULL); + + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } + + port_clear_location(sc, &sc->load_stack[0]); +} + +void scheme_load_string(scheme *sc, const char *cmd) { + scheme_load_memory(sc, cmd, strlen(cmd), NULL); +} + +void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_string; + sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */ + sc->load_stack[0].rep.string.past_the_end = (char *) buf + len; + sc->load_stack[0].rep.string.curr = (char *) buf; + port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL); + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + sc->interactive_repl=0; + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } + + port_clear_location(sc, &sc->load_stack[0]); +} + +void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { + pointer x; + pointer *sslot; + x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot); + if (x != sc->NIL) { + set_slot_in_env(sc, x, value); + } else { + new_slot_spec_in_env(sc, symbol, value, sslot); + } +} + +#if !STANDALONE +void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) +{ + scheme_define(sc, + sc->global_env, + mk_symbol(sc,sr->name), + mk_foreign_func(sc, sr->f)); +} + +void scheme_register_foreign_func_list(scheme * sc, + scheme_registerable * list, + int count) +{ + int i; + for(i = 0; i < count; i++) + { + scheme_register_foreign_func(sc, list + i); + } +} + +pointer scheme_apply0(scheme *sc, const char *procname) +{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } + +void save_from_C_call(scheme *sc) +{ + pointer saved_data = + cons(sc, + car(sc->sink), + cons(sc, + sc->envir, + sc->dump)); + /* Push */ + sc->c_nest = cons(sc, saved_data, sc->c_nest); + /* Truncate the dump stack so TS will return here when done, not + directly resume pre-C-call operations. */ + dump_stack_reset(sc); +} +void restore_from_C_call(scheme *sc) +{ + car(sc->sink) = caar(sc->c_nest); + sc->envir = cadar(sc->c_nest); + sc->dump = cdr(cdar(sc->c_nest)); + /* Pop */ + sc->c_nest = cdr(sc->c_nest); +} + +/* "func" and "args" are assumed to be already eval'ed. */ +pointer scheme_call(scheme *sc, pointer func, pointer args) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->envir = sc->global_env; + sc->args = args; + sc->code = func; + sc->retcode = 0; + Eval_Cycle(sc, OP_APPLY); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + +pointer scheme_eval(scheme *sc, pointer obj) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->args = sc->NIL; + sc->code = obj; + sc->retcode = 0; + Eval_Cycle(sc, OP_EVAL); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + + +#endif + +/* ========== Main ========== */ + +#if STANDALONE + +#if defined(__APPLE__) && !defined (OSX) +int main() +{ + extern MacTS_main(int argc, char **argv); + char** argv; + int argc = ccommand(&argv); + MacTS_main(argc,argv); + return 0; +} +int MacTS_main(int argc, char **argv) { +#else +int main(int argc, char **argv) { +#endif + scheme sc; + FILE *fin; + char *file_name=InitFile; + int retcode; + int isfile=1; + + if(argc==1) { + printf(banner); + } + if(argc==2 && strcmp(argv[1],"-?")==0) { + printf("Usage: tinyscheme -?\n"); + printf("or: tinyscheme [ ...]\n"); + printf("followed by\n"); + printf(" -1 [ ...]\n"); + printf(" -c [ ...]\n"); + printf("assuming that the executable is named tinyscheme.\n"); + printf("Use - as filename for stdin.\n"); + return 1; + } + if(!scheme_init(&sc)) { + fprintf(stderr,"Could not initialize!\n"); + return 2; + } + scheme_set_input_port_file(&sc, stdin); + scheme_set_output_port_file(&sc, stdout); +#if USE_DL + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); +#endif + argv++; + if(access(file_name,0)!=0) { + char *p=getenv("TINYSCHEMEINIT"); + if(p!=0) { + file_name=p; + } + } + do { + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { + pointer args=sc.NIL; + isfile=file_name[1]=='1'; + file_name=*argv++; + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(isfile) { + fin=fopen(file_name,"r"); + } + for(;*argv;argv++) { + pointer value=mk_string(&sc,*argv); + args=cons(&sc,value,args); + } + args=reverse_in_place(&sc,sc.NIL,args); + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); + + } else { + fin=fopen(file_name,"r"); + } + if(isfile && fin==0) { + fprintf(stderr,"Could not open file %s\n",file_name); + } else { + if(isfile) { + scheme_load_named_file(&sc,fin,file_name); + } else { + scheme_load_string(&sc,file_name); + } + if(!isfile || fin!=stdin) { + if(sc.retcode!=0) { + fprintf(stderr,"Errors encountered reading %s\n",file_name); + } + if(isfile) { + fclose(fin); + } + } + } + file_name=*argv++; + } while(file_name!=0); + if(argc==1) { + scheme_load_named_file(&sc,stdin,0); + } + retcode=sc.retcode; + scheme_deinit(&sc); + + return retcode; +} + +#endif + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/gpgscm/scheme.h b/gpgscm/scheme.h new file mode 100644 index 0000000..6f917da --- /dev/null +++ b/gpgscm/scheme.h @@ -0,0 +1,290 @@ +/* SCHEME.H */ + +#ifndef _SCHEME_H +#define _SCHEME_H + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Default values for #define'd symbols + */ +#ifndef STANDALONE /* If used as standalone interpreter */ +# define STANDALONE 1 +#endif + +#ifndef _MSC_VER +# define USE_STRCASECMP 1 +# ifndef USE_STRLWR +# define USE_STRLWR 1 +# endif +# define SCHEME_EXPORT +#else +# define USE_STRCASECMP 0 +# define USE_STRLWR 0 +# ifdef _SCHEME_SOURCE +# define SCHEME_EXPORT __declspec(dllexport) +# else +# define SCHEME_EXPORT __declspec(dllimport) +# endif +#endif + +#if USE_NO_FEATURES +# define USE_MATH 0 +# define USE_CHAR_CLASSIFIERS 0 +# define USE_ASCII_NAMES 0 +# define USE_STRING_PORTS 0 +# define USE_ERROR_HOOK 0 +# define USE_TRACING 0 +# define USE_COLON_HOOK 0 +# define USE_COMPILE_HOOK 0 +# define USE_DL 0 +# define USE_PLIST 0 +# define USE_SMALL_INTEGERS 0 +# define USE_HISTORY 0 +#endif + + +#if USE_DL +# define USE_INTERFACE 1 +#endif + + +#ifndef USE_MATH /* If math support is needed */ +# define USE_MATH 1 +#endif + +#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ +# define USE_CHAR_CLASSIFIERS 1 +#endif + +#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ +# define USE_ASCII_NAMES 1 +#endif + +#ifndef USE_STRING_PORTS /* Enable string ports */ +# define USE_STRING_PORTS 1 +#endif + +#ifndef USE_TRACING +# define USE_TRACING 1 +#endif + +#ifndef USE_PLIST +# define USE_PLIST 0 +#endif + +/* Keep a history of function calls. This enables a feature similar + * to stack traces. */ +#ifndef USE_HISTORY +# define USE_HISTORY 1 +#endif + +/* To force system errors through user-defined error handling (see *error-hook*) */ +#ifndef USE_ERROR_HOOK +# define USE_ERROR_HOOK 1 +#endif + +#ifndef USE_COLON_HOOK /* Enable qualified qualifier */ +# define USE_COLON_HOOK 1 +#endif + +/* Compile functions using *compile-hook*. The default hook expands + * macros. */ +#ifndef USE_COMPILE_HOOK +# define USE_COMPILE_HOOK 1 +#endif + +/* Enable faster opcode dispatch. */ +#ifndef USE_THREADED_CODE +# define USE_THREADED_CODE 1 +#endif + +/* Use a static set of cells to represent small numbers. This set + * notably includes all opcodes, and hence saves a cell reservation + * during 's_save'. */ +#ifndef USE_SMALL_INTEGERS +# define USE_SMALL_INTEGERS 1 +#endif + +#ifndef USE_STRCASECMP /* stricmp for Unix */ +# define USE_STRCASECMP 0 +#endif + +#ifndef USE_STRLWR +# define USE_STRLWR 1 +#endif + +#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ +# define STDIO_ADDS_CR 0 +#endif + +#ifndef INLINE +# define INLINE +#endif + +#ifndef USE_INTERFACE +# define USE_INTERFACE 0 +#endif + +#ifndef SHOW_ERROR_LINE /* Show error line in file */ +# define SHOW_ERROR_LINE 1 +#endif + +typedef struct scheme scheme; +typedef struct cell *pointer; + +typedef void * (*func_alloc)(size_t); +typedef void (*func_dealloc)(void *); + +/* table of functions required for foreign objects */ +typedef struct foreign_object_vtable { + void (*finalize)(scheme *sc, void *data); + void (*to_string)(scheme *sc, char *out, size_t size, void *data); +} foreign_object_vtable; + +/* num, for generic arithmetic */ +typedef struct num { + char is_fixnum; + union { + long ivalue; + double rvalue; + } value; +} num; + +SCHEME_EXPORT scheme *scheme_init_new(void); +SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); +SCHEME_EXPORT int scheme_init(scheme *sc); +SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); +SCHEME_EXPORT void scheme_deinit(scheme *sc); +void scheme_set_input_port_file(scheme *sc, FILE *fin); +void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); +SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); +void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); +SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); +SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); +SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); +SCHEME_EXPORT void scheme_load_memory(scheme *sc, const char *buf, size_t len, + const char *filename); +SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); +SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); +SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); +void scheme_set_external_data(scheme *sc, void *p); +SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); + +typedef pointer (*foreign_func)(scheme *, pointer); + +pointer _cons(scheme *sc, pointer a, pointer b, int immutable); +pointer mk_integer(scheme *sc, long num); +pointer mk_real(scheme *sc, double num); +pointer mk_symbol(scheme *sc, const char *name); +pointer gensym(scheme *sc); +pointer mk_string(scheme *sc, const char *str); +pointer mk_counted_string(scheme *sc, const char *str, int len); +pointer mk_empty_string(scheme *sc, int len, char fill); +pointer mk_character(scheme *sc, int c); +pointer mk_foreign_func(scheme *sc, foreign_func f); +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data); +void putstr(scheme *sc, const char *s); +int list_length(scheme *sc, pointer a); +int eqv(pointer a, pointer b); + + +#if USE_INTERFACE +struct scheme_interface { + void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); + pointer (*cons)(scheme *sc, pointer a, pointer b); + pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); + pointer (*reserve_cells)(scheme *sc, int n); + pointer (*mk_integer)(scheme *sc, long num); + pointer (*mk_real)(scheme *sc, double num); + pointer (*mk_symbol)(scheme *sc, const char *name); + pointer (*gensym)(scheme *sc); + pointer (*mk_string)(scheme *sc, const char *str); + pointer (*mk_counted_string)(scheme *sc, const char *str, int len); + pointer (*mk_character)(scheme *sc, int c); + pointer (*mk_vector)(scheme *sc, int len); + pointer (*mk_foreign_func)(scheme *sc, foreign_func f); + pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data); + const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p); + void *(*get_foreign_object_data)(pointer p); + void (*putstr)(scheme *sc, const char *s); + void (*putcharacter)(scheme *sc, int c); + + int (*is_string)(pointer p); + char *(*string_value)(pointer p); + int (*is_number)(pointer p); + num (*nvalue)(pointer p); + long (*ivalue)(pointer p); + double (*rvalue)(pointer p); + int (*is_integer)(pointer p); + int (*is_real)(pointer p); + int (*is_character)(pointer p); + long (*charvalue)(pointer p); + int (*is_list)(scheme *sc, pointer p); + int (*is_vector)(pointer p); + int (*list_length)(scheme *sc, pointer vec); + long (*vector_length)(pointer vec); + void (*fill_vector)(pointer vec, pointer elem); + pointer (*vector_elem)(pointer vec, int ielem); + pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); + int (*is_port)(pointer p); + + int (*is_pair)(pointer p); + pointer (*pair_car)(pointer p); + pointer (*pair_cdr)(pointer p); + pointer (*set_car)(pointer p, pointer q); + pointer (*set_cdr)(pointer p, pointer q); + + int (*is_symbol)(pointer p); + char *(*symname)(pointer p); + + int (*is_syntax)(pointer p); + int (*is_proc)(pointer p); + int (*is_foreign)(pointer p); + char *(*syntaxname)(pointer p); + int (*is_closure)(pointer p); + int (*is_macro)(pointer p); + pointer (*closure_code)(pointer p); + pointer (*closure_env)(pointer p); + + int (*is_continuation)(pointer p); + int (*is_promise)(pointer p); + int (*is_environment)(pointer p); + int (*is_immutable)(pointer p); + void (*setimmutable)(pointer p); + void (*load_file)(scheme *sc, FILE *fin); + void (*load_string)(scheme *sc, const char *input); + pointer (*mk_port_from_file)(scheme *sc, FILE *f, int kind); +}; +#endif + +#if !STANDALONE +typedef struct scheme_registerable +{ + foreign_func f; + const char * name; +} +scheme_registerable; + +void scheme_register_foreign_func_list(scheme * sc, + scheme_registerable * list, + int n); + +#endif /* !STANDALONE */ + +#ifdef __cplusplus +} +#endif + +#endif + + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/gpgscm/small-integers.h b/gpgscm/small-integers.h new file mode 100644 index 0000000..46eda34 --- /dev/null +++ b/gpgscm/small-integers.h @@ -0,0 +1,847 @@ +/* Constant integer objects for TinySCHEME. + * + * Copyright (C) 2017 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +/* + * Ohne Worte. Generated using: + * + * $ n=0; while read line ; do \ + * echo "DEFINE_INTEGER($n)" ; \ + * n="$(expr $n + 1)" ; \ + * done <./init.scm >> small-integers.h + */ + +DEFINE_INTEGER(0) +DEFINE_INTEGER(1) +DEFINE_INTEGER(2) +DEFINE_INTEGER(3) +DEFINE_INTEGER(4) +DEFINE_INTEGER(5) +DEFINE_INTEGER(6) +DEFINE_INTEGER(7) +DEFINE_INTEGER(8) +DEFINE_INTEGER(9) +DEFINE_INTEGER(10) +DEFINE_INTEGER(11) +DEFINE_INTEGER(12) +DEFINE_INTEGER(13) +DEFINE_INTEGER(14) +DEFINE_INTEGER(15) +DEFINE_INTEGER(16) +DEFINE_INTEGER(17) +DEFINE_INTEGER(18) +DEFINE_INTEGER(19) +DEFINE_INTEGER(20) +DEFINE_INTEGER(21) +DEFINE_INTEGER(22) +DEFINE_INTEGER(23) +DEFINE_INTEGER(24) +DEFINE_INTEGER(25) +DEFINE_INTEGER(26) +DEFINE_INTEGER(27) +DEFINE_INTEGER(28) +DEFINE_INTEGER(29) +DEFINE_INTEGER(30) +DEFINE_INTEGER(31) +DEFINE_INTEGER(32) +DEFINE_INTEGER(33) +DEFINE_INTEGER(34) +DEFINE_INTEGER(35) +DEFINE_INTEGER(36) +DEFINE_INTEGER(37) +DEFINE_INTEGER(38) +DEFINE_INTEGER(39) +DEFINE_INTEGER(40) +DEFINE_INTEGER(41) +DEFINE_INTEGER(42) +DEFINE_INTEGER(43) +DEFINE_INTEGER(44) +DEFINE_INTEGER(45) +DEFINE_INTEGER(46) +DEFINE_INTEGER(47) +DEFINE_INTEGER(48) +DEFINE_INTEGER(49) +DEFINE_INTEGER(50) +DEFINE_INTEGER(51) +DEFINE_INTEGER(52) +DEFINE_INTEGER(53) +DEFINE_INTEGER(54) +DEFINE_INTEGER(55) +DEFINE_INTEGER(56) +DEFINE_INTEGER(57) +DEFINE_INTEGER(58) +DEFINE_INTEGER(59) +DEFINE_INTEGER(60) +DEFINE_INTEGER(61) +DEFINE_INTEGER(62) +DEFINE_INTEGER(63) +DEFINE_INTEGER(64) +DEFINE_INTEGER(65) +DEFINE_INTEGER(66) +DEFINE_INTEGER(67) +DEFINE_INTEGER(68) +DEFINE_INTEGER(69) +DEFINE_INTEGER(70) +DEFINE_INTEGER(71) +DEFINE_INTEGER(72) +DEFINE_INTEGER(73) +DEFINE_INTEGER(74) +DEFINE_INTEGER(75) +DEFINE_INTEGER(76) +DEFINE_INTEGER(77) +DEFINE_INTEGER(78) +DEFINE_INTEGER(79) +DEFINE_INTEGER(80) +DEFINE_INTEGER(81) +DEFINE_INTEGER(82) +DEFINE_INTEGER(83) +DEFINE_INTEGER(84) +DEFINE_INTEGER(85) +DEFINE_INTEGER(86) +DEFINE_INTEGER(87) +DEFINE_INTEGER(88) +DEFINE_INTEGER(89) +DEFINE_INTEGER(90) +DEFINE_INTEGER(91) +DEFINE_INTEGER(92) +DEFINE_INTEGER(93) +DEFINE_INTEGER(94) +DEFINE_INTEGER(95) +DEFINE_INTEGER(96) +DEFINE_INTEGER(97) +DEFINE_INTEGER(98) +DEFINE_INTEGER(99) +DEFINE_INTEGER(100) +DEFINE_INTEGER(101) +DEFINE_INTEGER(102) +DEFINE_INTEGER(103) +DEFINE_INTEGER(104) +DEFINE_INTEGER(105) +DEFINE_INTEGER(106) +DEFINE_INTEGER(107) +DEFINE_INTEGER(108) +DEFINE_INTEGER(109) +DEFINE_INTEGER(110) +DEFINE_INTEGER(111) +DEFINE_INTEGER(112) +DEFINE_INTEGER(113) +DEFINE_INTEGER(114) +DEFINE_INTEGER(115) +DEFINE_INTEGER(116) +DEFINE_INTEGER(117) +DEFINE_INTEGER(118) +DEFINE_INTEGER(119) +DEFINE_INTEGER(120) +DEFINE_INTEGER(121) +DEFINE_INTEGER(122) +DEFINE_INTEGER(123) +DEFINE_INTEGER(124) +DEFINE_INTEGER(125) +DEFINE_INTEGER(126) +DEFINE_INTEGER(127) +DEFINE_INTEGER(128) +DEFINE_INTEGER(129) +DEFINE_INTEGER(130) +DEFINE_INTEGER(131) +DEFINE_INTEGER(132) +DEFINE_INTEGER(133) +DEFINE_INTEGER(134) +DEFINE_INTEGER(135) +DEFINE_INTEGER(136) +DEFINE_INTEGER(137) +DEFINE_INTEGER(138) +DEFINE_INTEGER(139) +DEFINE_INTEGER(140) +DEFINE_INTEGER(141) +DEFINE_INTEGER(142) +DEFINE_INTEGER(143) +DEFINE_INTEGER(144) +DEFINE_INTEGER(145) +DEFINE_INTEGER(146) +DEFINE_INTEGER(147) +DEFINE_INTEGER(148) +DEFINE_INTEGER(149) +DEFINE_INTEGER(150) +DEFINE_INTEGER(151) +DEFINE_INTEGER(152) +DEFINE_INTEGER(153) +DEFINE_INTEGER(154) +DEFINE_INTEGER(155) +DEFINE_INTEGER(156) +DEFINE_INTEGER(157) +DEFINE_INTEGER(158) +DEFINE_INTEGER(159) +DEFINE_INTEGER(160) +DEFINE_INTEGER(161) +DEFINE_INTEGER(162) +DEFINE_INTEGER(163) +DEFINE_INTEGER(164) +DEFINE_INTEGER(165) +DEFINE_INTEGER(166) +DEFINE_INTEGER(167) +DEFINE_INTEGER(168) +DEFINE_INTEGER(169) +DEFINE_INTEGER(170) +DEFINE_INTEGER(171) +DEFINE_INTEGER(172) +DEFINE_INTEGER(173) +DEFINE_INTEGER(174) +DEFINE_INTEGER(175) +DEFINE_INTEGER(176) +DEFINE_INTEGER(177) +DEFINE_INTEGER(178) +DEFINE_INTEGER(179) +DEFINE_INTEGER(180) +DEFINE_INTEGER(181) +DEFINE_INTEGER(182) +DEFINE_INTEGER(183) +DEFINE_INTEGER(184) +DEFINE_INTEGER(185) +DEFINE_INTEGER(186) +DEFINE_INTEGER(187) +DEFINE_INTEGER(188) +DEFINE_INTEGER(189) +DEFINE_INTEGER(190) +DEFINE_INTEGER(191) +DEFINE_INTEGER(192) +DEFINE_INTEGER(193) +DEFINE_INTEGER(194) +DEFINE_INTEGER(195) +DEFINE_INTEGER(196) +DEFINE_INTEGER(197) +DEFINE_INTEGER(198) +DEFINE_INTEGER(199) +DEFINE_INTEGER(200) +DEFINE_INTEGER(201) +DEFINE_INTEGER(202) +DEFINE_INTEGER(203) +DEFINE_INTEGER(204) +DEFINE_INTEGER(205) +DEFINE_INTEGER(206) +DEFINE_INTEGER(207) +DEFINE_INTEGER(208) +DEFINE_INTEGER(209) +DEFINE_INTEGER(210) +DEFINE_INTEGER(211) +DEFINE_INTEGER(212) +DEFINE_INTEGER(213) +DEFINE_INTEGER(214) +DEFINE_INTEGER(215) +DEFINE_INTEGER(216) +DEFINE_INTEGER(217) +DEFINE_INTEGER(218) +DEFINE_INTEGER(219) +DEFINE_INTEGER(220) +DEFINE_INTEGER(221) +DEFINE_INTEGER(222) +DEFINE_INTEGER(223) +DEFINE_INTEGER(224) +DEFINE_INTEGER(225) +DEFINE_INTEGER(226) +DEFINE_INTEGER(227) +DEFINE_INTEGER(228) +DEFINE_INTEGER(229) +DEFINE_INTEGER(230) +DEFINE_INTEGER(231) +DEFINE_INTEGER(232) +DEFINE_INTEGER(233) +DEFINE_INTEGER(234) +DEFINE_INTEGER(235) +DEFINE_INTEGER(236) +DEFINE_INTEGER(237) +DEFINE_INTEGER(238) +DEFINE_INTEGER(239) +DEFINE_INTEGER(240) +DEFINE_INTEGER(241) +DEFINE_INTEGER(242) +DEFINE_INTEGER(243) +DEFINE_INTEGER(244) +DEFINE_INTEGER(245) +DEFINE_INTEGER(246) +DEFINE_INTEGER(247) +DEFINE_INTEGER(248) +DEFINE_INTEGER(249) +DEFINE_INTEGER(250) +DEFINE_INTEGER(251) +DEFINE_INTEGER(252) +DEFINE_INTEGER(253) +DEFINE_INTEGER(254) +DEFINE_INTEGER(255) +DEFINE_INTEGER(256) +DEFINE_INTEGER(257) +DEFINE_INTEGER(258) +DEFINE_INTEGER(259) +DEFINE_INTEGER(260) +DEFINE_INTEGER(261) +DEFINE_INTEGER(262) +DEFINE_INTEGER(263) +DEFINE_INTEGER(264) +DEFINE_INTEGER(265) +DEFINE_INTEGER(266) +DEFINE_INTEGER(267) +DEFINE_INTEGER(268) +DEFINE_INTEGER(269) +DEFINE_INTEGER(270) +DEFINE_INTEGER(271) +DEFINE_INTEGER(272) +DEFINE_INTEGER(273) +DEFINE_INTEGER(274) +DEFINE_INTEGER(275) +DEFINE_INTEGER(276) +DEFINE_INTEGER(277) +DEFINE_INTEGER(278) +DEFINE_INTEGER(279) +DEFINE_INTEGER(280) +DEFINE_INTEGER(281) +DEFINE_INTEGER(282) +DEFINE_INTEGER(283) +DEFINE_INTEGER(284) +DEFINE_INTEGER(285) +DEFINE_INTEGER(286) +DEFINE_INTEGER(287) +DEFINE_INTEGER(288) +DEFINE_INTEGER(289) +DEFINE_INTEGER(290) +DEFINE_INTEGER(291) +DEFINE_INTEGER(292) +DEFINE_INTEGER(293) +DEFINE_INTEGER(294) +DEFINE_INTEGER(295) +DEFINE_INTEGER(296) +DEFINE_INTEGER(297) +DEFINE_INTEGER(298) +DEFINE_INTEGER(299) +DEFINE_INTEGER(300) +DEFINE_INTEGER(301) +DEFINE_INTEGER(302) +DEFINE_INTEGER(303) +DEFINE_INTEGER(304) +DEFINE_INTEGER(305) +DEFINE_INTEGER(306) +DEFINE_INTEGER(307) +DEFINE_INTEGER(308) +DEFINE_INTEGER(309) +DEFINE_INTEGER(310) +DEFINE_INTEGER(311) +DEFINE_INTEGER(312) +DEFINE_INTEGER(313) +DEFINE_INTEGER(314) +DEFINE_INTEGER(315) +DEFINE_INTEGER(316) +DEFINE_INTEGER(317) +DEFINE_INTEGER(318) +DEFINE_INTEGER(319) +DEFINE_INTEGER(320) +DEFINE_INTEGER(321) +DEFINE_INTEGER(322) +DEFINE_INTEGER(323) +DEFINE_INTEGER(324) +DEFINE_INTEGER(325) +DEFINE_INTEGER(326) +DEFINE_INTEGER(327) +DEFINE_INTEGER(328) +DEFINE_INTEGER(329) +DEFINE_INTEGER(330) +DEFINE_INTEGER(331) +DEFINE_INTEGER(332) +DEFINE_INTEGER(333) +DEFINE_INTEGER(334) +DEFINE_INTEGER(335) +DEFINE_INTEGER(336) +DEFINE_INTEGER(337) +DEFINE_INTEGER(338) +DEFINE_INTEGER(339) +DEFINE_INTEGER(340) +DEFINE_INTEGER(341) +DEFINE_INTEGER(342) +DEFINE_INTEGER(343) +DEFINE_INTEGER(344) +DEFINE_INTEGER(345) +DEFINE_INTEGER(346) +DEFINE_INTEGER(347) +DEFINE_INTEGER(348) +DEFINE_INTEGER(349) +DEFINE_INTEGER(350) +DEFINE_INTEGER(351) +DEFINE_INTEGER(352) +DEFINE_INTEGER(353) +DEFINE_INTEGER(354) +DEFINE_INTEGER(355) +DEFINE_INTEGER(356) +DEFINE_INTEGER(357) +DEFINE_INTEGER(358) +DEFINE_INTEGER(359) +DEFINE_INTEGER(360) +DEFINE_INTEGER(361) +DEFINE_INTEGER(362) +DEFINE_INTEGER(363) +DEFINE_INTEGER(364) +DEFINE_INTEGER(365) +DEFINE_INTEGER(366) +DEFINE_INTEGER(367) +DEFINE_INTEGER(368) +DEFINE_INTEGER(369) +DEFINE_INTEGER(370) +DEFINE_INTEGER(371) +DEFINE_INTEGER(372) +DEFINE_INTEGER(373) +DEFINE_INTEGER(374) +DEFINE_INTEGER(375) +DEFINE_INTEGER(376) +DEFINE_INTEGER(377) +DEFINE_INTEGER(378) +DEFINE_INTEGER(379) +DEFINE_INTEGER(380) +DEFINE_INTEGER(381) +DEFINE_INTEGER(382) +DEFINE_INTEGER(383) +DEFINE_INTEGER(384) +DEFINE_INTEGER(385) +DEFINE_INTEGER(386) +DEFINE_INTEGER(387) +DEFINE_INTEGER(388) +DEFINE_INTEGER(389) +DEFINE_INTEGER(390) +DEFINE_INTEGER(391) +DEFINE_INTEGER(392) +DEFINE_INTEGER(393) +DEFINE_INTEGER(394) +DEFINE_INTEGER(395) +DEFINE_INTEGER(396) +DEFINE_INTEGER(397) +DEFINE_INTEGER(398) +DEFINE_INTEGER(399) +DEFINE_INTEGER(400) +DEFINE_INTEGER(401) +DEFINE_INTEGER(402) +DEFINE_INTEGER(403) +DEFINE_INTEGER(404) +DEFINE_INTEGER(405) +DEFINE_INTEGER(406) +DEFINE_INTEGER(407) +DEFINE_INTEGER(408) +DEFINE_INTEGER(409) +DEFINE_INTEGER(410) +DEFINE_INTEGER(411) +DEFINE_INTEGER(412) +DEFINE_INTEGER(413) +DEFINE_INTEGER(414) +DEFINE_INTEGER(415) +DEFINE_INTEGER(416) +DEFINE_INTEGER(417) +DEFINE_INTEGER(418) +DEFINE_INTEGER(419) +DEFINE_INTEGER(420) +DEFINE_INTEGER(421) +DEFINE_INTEGER(422) +DEFINE_INTEGER(423) +DEFINE_INTEGER(424) +DEFINE_INTEGER(425) +DEFINE_INTEGER(426) +DEFINE_INTEGER(427) +DEFINE_INTEGER(428) +DEFINE_INTEGER(429) +DEFINE_INTEGER(430) +DEFINE_INTEGER(431) +DEFINE_INTEGER(432) +DEFINE_INTEGER(433) +DEFINE_INTEGER(434) +DEFINE_INTEGER(435) +DEFINE_INTEGER(436) +DEFINE_INTEGER(437) +DEFINE_INTEGER(438) +DEFINE_INTEGER(439) +DEFINE_INTEGER(440) +DEFINE_INTEGER(441) +DEFINE_INTEGER(442) +DEFINE_INTEGER(443) +DEFINE_INTEGER(444) +DEFINE_INTEGER(445) +DEFINE_INTEGER(446) +DEFINE_INTEGER(447) +DEFINE_INTEGER(448) +DEFINE_INTEGER(449) +DEFINE_INTEGER(450) +DEFINE_INTEGER(451) +DEFINE_INTEGER(452) +DEFINE_INTEGER(453) +DEFINE_INTEGER(454) +DEFINE_INTEGER(455) +DEFINE_INTEGER(456) +DEFINE_INTEGER(457) +DEFINE_INTEGER(458) +DEFINE_INTEGER(459) +DEFINE_INTEGER(460) +DEFINE_INTEGER(461) +DEFINE_INTEGER(462) +DEFINE_INTEGER(463) +DEFINE_INTEGER(464) +DEFINE_INTEGER(465) +DEFINE_INTEGER(466) +DEFINE_INTEGER(467) +DEFINE_INTEGER(468) +DEFINE_INTEGER(469) +DEFINE_INTEGER(470) +DEFINE_INTEGER(471) +DEFINE_INTEGER(472) +DEFINE_INTEGER(473) +DEFINE_INTEGER(474) +DEFINE_INTEGER(475) +DEFINE_INTEGER(476) +DEFINE_INTEGER(477) +DEFINE_INTEGER(478) +DEFINE_INTEGER(479) +DEFINE_INTEGER(480) +DEFINE_INTEGER(481) +DEFINE_INTEGER(482) +DEFINE_INTEGER(483) +DEFINE_INTEGER(484) +DEFINE_INTEGER(485) +DEFINE_INTEGER(486) +DEFINE_INTEGER(487) +DEFINE_INTEGER(488) +DEFINE_INTEGER(489) +DEFINE_INTEGER(490) +DEFINE_INTEGER(491) +DEFINE_INTEGER(492) +DEFINE_INTEGER(493) +DEFINE_INTEGER(494) +DEFINE_INTEGER(495) +DEFINE_INTEGER(496) +DEFINE_INTEGER(497) +DEFINE_INTEGER(498) +DEFINE_INTEGER(499) +DEFINE_INTEGER(500) +DEFINE_INTEGER(501) +DEFINE_INTEGER(502) +DEFINE_INTEGER(503) +DEFINE_INTEGER(504) +DEFINE_INTEGER(505) +DEFINE_INTEGER(506) +DEFINE_INTEGER(507) +DEFINE_INTEGER(508) +DEFINE_INTEGER(509) +DEFINE_INTEGER(510) +DEFINE_INTEGER(511) +DEFINE_INTEGER(512) +DEFINE_INTEGER(513) +DEFINE_INTEGER(514) +DEFINE_INTEGER(515) +DEFINE_INTEGER(516) +DEFINE_INTEGER(517) +DEFINE_INTEGER(518) +DEFINE_INTEGER(519) +DEFINE_INTEGER(520) +DEFINE_INTEGER(521) +DEFINE_INTEGER(522) +DEFINE_INTEGER(523) +DEFINE_INTEGER(524) +DEFINE_INTEGER(525) +DEFINE_INTEGER(526) +DEFINE_INTEGER(527) +DEFINE_INTEGER(528) +DEFINE_INTEGER(529) +DEFINE_INTEGER(530) +DEFINE_INTEGER(531) +DEFINE_INTEGER(532) +DEFINE_INTEGER(533) +DEFINE_INTEGER(534) +DEFINE_INTEGER(535) +DEFINE_INTEGER(536) +DEFINE_INTEGER(537) +DEFINE_INTEGER(538) +DEFINE_INTEGER(539) +DEFINE_INTEGER(540) +DEFINE_INTEGER(541) +DEFINE_INTEGER(542) +DEFINE_INTEGER(543) +DEFINE_INTEGER(544) +DEFINE_INTEGER(545) +DEFINE_INTEGER(546) +DEFINE_INTEGER(547) +DEFINE_INTEGER(548) +DEFINE_INTEGER(549) +DEFINE_INTEGER(550) +DEFINE_INTEGER(551) +DEFINE_INTEGER(552) +DEFINE_INTEGER(553) +DEFINE_INTEGER(554) +DEFINE_INTEGER(555) +DEFINE_INTEGER(556) +DEFINE_INTEGER(557) +DEFINE_INTEGER(558) +DEFINE_INTEGER(559) +DEFINE_INTEGER(560) +DEFINE_INTEGER(561) +DEFINE_INTEGER(562) +DEFINE_INTEGER(563) +DEFINE_INTEGER(564) +DEFINE_INTEGER(565) +DEFINE_INTEGER(566) +DEFINE_INTEGER(567) +DEFINE_INTEGER(568) +DEFINE_INTEGER(569) +DEFINE_INTEGER(570) +DEFINE_INTEGER(571) +DEFINE_INTEGER(572) +DEFINE_INTEGER(573) +DEFINE_INTEGER(574) +DEFINE_INTEGER(575) +DEFINE_INTEGER(576) +DEFINE_INTEGER(577) +DEFINE_INTEGER(578) +DEFINE_INTEGER(579) +DEFINE_INTEGER(580) +DEFINE_INTEGER(581) +DEFINE_INTEGER(582) +DEFINE_INTEGER(583) +DEFINE_INTEGER(584) +DEFINE_INTEGER(585) +DEFINE_INTEGER(586) +DEFINE_INTEGER(587) +DEFINE_INTEGER(588) +DEFINE_INTEGER(589) +DEFINE_INTEGER(590) +DEFINE_INTEGER(591) +DEFINE_INTEGER(592) +DEFINE_INTEGER(593) +DEFINE_INTEGER(594) +DEFINE_INTEGER(595) +DEFINE_INTEGER(596) +DEFINE_INTEGER(597) +DEFINE_INTEGER(598) +DEFINE_INTEGER(599) +DEFINE_INTEGER(600) +DEFINE_INTEGER(601) +DEFINE_INTEGER(602) +DEFINE_INTEGER(603) +DEFINE_INTEGER(604) +DEFINE_INTEGER(605) +DEFINE_INTEGER(606) +DEFINE_INTEGER(607) +DEFINE_INTEGER(608) +DEFINE_INTEGER(609) +DEFINE_INTEGER(610) +DEFINE_INTEGER(611) +DEFINE_INTEGER(612) +DEFINE_INTEGER(613) +DEFINE_INTEGER(614) +DEFINE_INTEGER(615) +DEFINE_INTEGER(616) +DEFINE_INTEGER(617) +DEFINE_INTEGER(618) +DEFINE_INTEGER(619) +DEFINE_INTEGER(620) +DEFINE_INTEGER(621) +DEFINE_INTEGER(622) +DEFINE_INTEGER(623) +DEFINE_INTEGER(624) +DEFINE_INTEGER(625) +DEFINE_INTEGER(626) +DEFINE_INTEGER(627) +DEFINE_INTEGER(628) +DEFINE_INTEGER(629) +DEFINE_INTEGER(630) +DEFINE_INTEGER(631) +DEFINE_INTEGER(632) +DEFINE_INTEGER(633) +DEFINE_INTEGER(634) +DEFINE_INTEGER(635) +DEFINE_INTEGER(636) +DEFINE_INTEGER(637) +DEFINE_INTEGER(638) +DEFINE_INTEGER(639) +DEFINE_INTEGER(640) +DEFINE_INTEGER(641) +DEFINE_INTEGER(642) +DEFINE_INTEGER(643) +DEFINE_INTEGER(644) +DEFINE_INTEGER(645) +DEFINE_INTEGER(646) +DEFINE_INTEGER(647) +DEFINE_INTEGER(648) +DEFINE_INTEGER(649) +DEFINE_INTEGER(650) +DEFINE_INTEGER(651) +DEFINE_INTEGER(652) +DEFINE_INTEGER(653) +DEFINE_INTEGER(654) +DEFINE_INTEGER(655) +DEFINE_INTEGER(656) +DEFINE_INTEGER(657) +DEFINE_INTEGER(658) +DEFINE_INTEGER(659) +DEFINE_INTEGER(660) +DEFINE_INTEGER(661) +DEFINE_INTEGER(662) +DEFINE_INTEGER(663) +DEFINE_INTEGER(664) +DEFINE_INTEGER(665) +DEFINE_INTEGER(666) +DEFINE_INTEGER(667) +DEFINE_INTEGER(668) +DEFINE_INTEGER(669) +DEFINE_INTEGER(670) +DEFINE_INTEGER(671) +DEFINE_INTEGER(672) +DEFINE_INTEGER(673) +DEFINE_INTEGER(674) +DEFINE_INTEGER(675) +DEFINE_INTEGER(676) +DEFINE_INTEGER(677) +DEFINE_INTEGER(678) +DEFINE_INTEGER(679) +DEFINE_INTEGER(680) +DEFINE_INTEGER(681) +DEFINE_INTEGER(682) +DEFINE_INTEGER(683) +DEFINE_INTEGER(684) +DEFINE_INTEGER(685) +DEFINE_INTEGER(686) +DEFINE_INTEGER(687) +DEFINE_INTEGER(688) +DEFINE_INTEGER(689) +DEFINE_INTEGER(690) +DEFINE_INTEGER(691) +DEFINE_INTEGER(692) +DEFINE_INTEGER(693) +DEFINE_INTEGER(694) +DEFINE_INTEGER(695) +DEFINE_INTEGER(696) +DEFINE_INTEGER(697) +DEFINE_INTEGER(698) +DEFINE_INTEGER(699) +DEFINE_INTEGER(700) +DEFINE_INTEGER(701) +DEFINE_INTEGER(702) +DEFINE_INTEGER(703) +DEFINE_INTEGER(704) +DEFINE_INTEGER(705) +DEFINE_INTEGER(706) +DEFINE_INTEGER(707) +DEFINE_INTEGER(708) +DEFINE_INTEGER(709) +DEFINE_INTEGER(710) +DEFINE_INTEGER(711) +DEFINE_INTEGER(712) +DEFINE_INTEGER(713) +DEFINE_INTEGER(714) +DEFINE_INTEGER(715) +DEFINE_INTEGER(716) +DEFINE_INTEGER(717) +DEFINE_INTEGER(718) +DEFINE_INTEGER(719) +DEFINE_INTEGER(720) +DEFINE_INTEGER(721) +DEFINE_INTEGER(722) +DEFINE_INTEGER(723) +DEFINE_INTEGER(724) +DEFINE_INTEGER(725) +DEFINE_INTEGER(726) +DEFINE_INTEGER(727) +DEFINE_INTEGER(728) +DEFINE_INTEGER(729) +DEFINE_INTEGER(730) +DEFINE_INTEGER(731) +DEFINE_INTEGER(732) +DEFINE_INTEGER(733) +DEFINE_INTEGER(734) +DEFINE_INTEGER(735) +DEFINE_INTEGER(736) +DEFINE_INTEGER(737) +DEFINE_INTEGER(738) +DEFINE_INTEGER(739) +DEFINE_INTEGER(740) +DEFINE_INTEGER(741) +DEFINE_INTEGER(742) +DEFINE_INTEGER(743) +DEFINE_INTEGER(744) +DEFINE_INTEGER(745) +DEFINE_INTEGER(746) +DEFINE_INTEGER(747) +DEFINE_INTEGER(748) +DEFINE_INTEGER(749) +DEFINE_INTEGER(750) +DEFINE_INTEGER(751) +DEFINE_INTEGER(752) +DEFINE_INTEGER(753) +DEFINE_INTEGER(754) +DEFINE_INTEGER(755) +DEFINE_INTEGER(756) +DEFINE_INTEGER(757) +DEFINE_INTEGER(758) +DEFINE_INTEGER(759) +DEFINE_INTEGER(760) +DEFINE_INTEGER(761) +DEFINE_INTEGER(762) +DEFINE_INTEGER(763) +DEFINE_INTEGER(764) +DEFINE_INTEGER(765) +DEFINE_INTEGER(766) +DEFINE_INTEGER(767) +DEFINE_INTEGER(768) +DEFINE_INTEGER(769) +DEFINE_INTEGER(770) +DEFINE_INTEGER(771) +DEFINE_INTEGER(772) +DEFINE_INTEGER(773) +DEFINE_INTEGER(774) +DEFINE_INTEGER(775) +DEFINE_INTEGER(776) +DEFINE_INTEGER(777) +DEFINE_INTEGER(778) +DEFINE_INTEGER(779) +DEFINE_INTEGER(780) +DEFINE_INTEGER(781) +DEFINE_INTEGER(782) +DEFINE_INTEGER(783) +DEFINE_INTEGER(784) +DEFINE_INTEGER(785) +DEFINE_INTEGER(786) +DEFINE_INTEGER(787) +DEFINE_INTEGER(788) +DEFINE_INTEGER(789) +DEFINE_INTEGER(790) +DEFINE_INTEGER(791) +DEFINE_INTEGER(792) +DEFINE_INTEGER(793) +DEFINE_INTEGER(794) +DEFINE_INTEGER(795) +DEFINE_INTEGER(796) +DEFINE_INTEGER(797) +DEFINE_INTEGER(798) +DEFINE_INTEGER(799) +DEFINE_INTEGER(800) +DEFINE_INTEGER(801) +DEFINE_INTEGER(802) +DEFINE_INTEGER(803) +DEFINE_INTEGER(804) +DEFINE_INTEGER(805) +DEFINE_INTEGER(806) +DEFINE_INTEGER(807) +DEFINE_INTEGER(808) +DEFINE_INTEGER(809) +DEFINE_INTEGER(810) +DEFINE_INTEGER(811) +DEFINE_INTEGER(812) +DEFINE_INTEGER(813) +DEFINE_INTEGER(814) +DEFINE_INTEGER(815) +DEFINE_INTEGER(816) +DEFINE_INTEGER(817) diff --git a/gpgscm/t-child.c b/gpgscm/t-child.c new file mode 100644 index 0000000..f4e3a04 --- /dev/null +++ b/gpgscm/t-child.c @@ -0,0 +1,74 @@ +/* Sanity check for the process and IPC primitives. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see . + */ + +#include +#include +#include + +#ifdef _WIN32 +# include +# include +#endif + +int +main (int argc, char **argv) +{ + char buffer[4096]; + memset (buffer, 'A', sizeof buffer); +#if _WIN32 + if (! setmode (fileno (stdin), O_BINARY)) + return 23; + if (! setmode (fileno (stdout), O_BINARY)) + return 23; +#endif + + if (argc == 1) + return 2; + else if (strcmp (argv[1], "return0") == 0) + return 0; + else if (strcmp (argv[1], "return1") == 0) + return 1; + else if (strcmp (argv[1], "return77") == 0) + return 77; + else if (strcmp (argv[1], "hello_stdout") == 0) + fprintf (stdout, "hello"); + else if (strcmp (argv[1], "hello_stderr") == 0) + fprintf (stderr, "hello"); + else if (strcmp (argv[1], "stdout4096") == 0) + fwrite (buffer, 1, sizeof buffer, stdout); + else if (strcmp (argv[1], "stdout8192") == 0) + { + fwrite (buffer, 1, sizeof buffer, stdout); + fwrite (buffer, 1, sizeof buffer, stdout); + } + else if (strcmp (argv[1], "cat") == 0) + while (! feof (stdin)) + { + size_t bytes_read; + bytes_read = fread (buffer, 1, sizeof buffer, stdin); + fwrite (buffer, 1, bytes_read, stdout); + } + else + { + fprintf (stderr, "unknown command %s\n", argv[1]); + return 2; + } + return 0; +} diff --git a/gpgscm/t-child.scm b/gpgscm/t-child.scm new file mode 100644 index 0000000..fd1dcc3 --- /dev/null +++ b/gpgscm/t-child.scm @@ -0,0 +1,118 @@ +;; Tests for the low-level process and IPC primitives. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(echo "Testing process and IPC primitives...") + +(define (qualify executable) + (string-append executable (getenv "EXEEXT"))) + +(define child (qualify "t-child")) + +(assert (= 0 (call `(,(qualify "t-child") "return0")))) +(assert (= 1 (call `(,(qualify "t-child") "return1")))) +(assert (= 77 (call `(,(qualify "t-child") "return77")))) + +(let ((r (call-with-io `(,(qualify "t-child") "return0") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return1") ""))) + (assert (= 1 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return77") ""))) + (assert (= 77 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "hello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "hello" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "stdout4096") ""))) + (assert (= 0 (:retcode r))) + (assert (= 4096 (string-length (:stdout r)))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "stdout8192") ""))) + (assert (= 0 (:retcode r))) + (assert (= 8192 (string-length (:stdout r)))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello"))) + (assert (= 0 (:retcode r))) + (assert (string=? "hellohello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(define (spawn what) + (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO)) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return1"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(1 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return77"))) + (pid2 (spawn `(,(qualify "t-child") "return1")))) + (assert (equal? '(0 77 1) + (wait-processes '("child0" "child1" "child2") + (list pid0 pid1 pid2) #t)))) + +(let* ((p (pipe)) + (pid0 (spawn-process-fd + `(,(qualify "t-child") "hello_stdout") + CLOSED_FD (:write-end p) STDERR_FILENO)) + (_ (close (:write-end p))) + (pid1 (spawn-process-fd + `(,(qualify "t-child") "cat") + (:read-end p) STDOUT_FILENO STDERR_FILENO))) + (close (:read-end p)) + (assert + (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) +(echo " world.") + +(tr:do + (tr:pipe-do + (pipe:spawn `(,child stdout4096)) + (pipe:spawn `(,child cat))) + (tr:call-with-content (lambda (c) + (assert (= 4096 (string-length c)))))) +(tr:do + (tr:pipe-do + (pipe:spawn `(,child stdout8192)) + (pipe:spawn `(,child cat))) + (tr:call-with-content (lambda (c) + (assert (= 8192 (string-length c)))))) + +(echo "All good.") diff --git a/gpgscm/tests.scm b/gpgscm/tests.scm new file mode 100644 index 0000000..5141002 --- /dev/null +++ b/gpgscm/tests.scm @@ -0,0 +1,886 @@ +;; Common definitions for writing tests. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; Reporting. +(define (echo . msg) + (for-each (lambda (x) (display x) (display " ")) msg) + (newline)) + +(define (info . msg) + (apply echo msg) + (flush-stdio)) + +(define (log . msg) + (if (> (*verbose*) 0) + (apply info msg))) + +(define (fail . msg) + (apply info msg) + (exit 1)) + +(define (skip . msg) + (apply info msg) + (exit 77)) + +(define (make-counter) + (let ((c 0)) + (lambda () + (let ((r c)) + (set! c (+ 1 c)) + r)))) + +(define *progress-nesting* 0) + +(define (call-with-progress msg what) + (set! *progress-nesting* (+ 1 *progress-nesting*)) + (if (= 1 *progress-nesting*) + (begin + (info msg) + (display " > ") + (flush-stdio) + (what (lambda (item) + (display item) + (display " ") + (flush-stdio))) + (info "< ")) + (begin + (what (lambda (item) (display ".") (flush-stdio))) + (display " ") + (flush-stdio))) + (set! *progress-nesting* (- *progress-nesting* 1))) + +(define (for-each-p msg proc lst . lsts) + (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts))) + +(define (for-each-p' msg proc fmt lst . lsts) + (call-with-progress + msg + (lambda (progress) + (apply for-each + `(,(lambda args + (progress (apply fmt args)) + (apply proc args)) + ,lst ,@lsts))))) + +;; Process management. +(define CLOSED_FD -1) +(define (call-with-fds what infd outfd errfd) + (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t)) +(define (call what) + (call-with-fds what + CLOSED_FD + (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD) + (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD))) + +;; Accessor functions for the results of 'spawn-process'. +(define :stdin car) +(define :stdout cadr) +(define :stderr caddr) +(define :pid cadddr) + +(define (call-with-io what in) + (let ((h (spawn-process what 0))) + (es-write (:stdin h) in) + (es-fclose (:stdin h)) + (let* ((out (es-read-all (:stdout h))) + (err (es-read-all (:stderr h))) + (result (wait-process (car what) (:pid h) #t))) + (es-fclose (:stdout h)) + (es-fclose (:stderr h)) + (if (> (*verbose*) 2) + (info "Child" (:pid h) "returned:" + `((command ,(stringify what)) + (status ,result) + (stdout ,out) + (stderr ,err)))) + (list result out err)))) + +;; Accessor function for the results of 'call-with-io'. ':stdout' and +;; ':stderr' can also be used. +(define :retcode car) + +(define (call-check what) + (let ((result (call-with-io what ""))) + (if (= 0 (:retcode result)) + (:stdout result) + (throw (string-append (stringify what) " failed") + (:stderr result))))) + +(define (call-popen command input-string) + (let ((result (call-with-io command input-string))) + (if (= 0 (:retcode result)) + (:stdout result) + (throw (:stderr result))))) + +;; +;; estream helpers. +;; + +(define (es-read-all stream) + (let loop + ((acc "")) + (if (es-feof stream) + acc + (loop (string-append acc (es-read stream 4096)))))) + +;; +;; File management. +;; +(define (file-exists? name) + (call-with-input-file name (lambda (port) #t))) + +(define (file=? a b) + (file-equal a b #t)) + +(define (text-file=? a b) + (file-equal a b #f)) + +(define (file-copy from to) + (catch '() (unlink to)) + (letfd ((source (open from (logior O_RDONLY O_BINARY))) + (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (splice source sink))) + +(define (text-file-copy from to) + (catch '() (unlink to)) + (letfd ((source (open from O_RDONLY)) + (sink (open to (logior O_WRONLY O_CREAT) #o600))) + (splice source sink))) + +(define (path-join . components) + (let loop ((acc #f) (rest (filter (lambda (s) + (not (string=? "" s))) components))) + (if (null? rest) + acc + (loop (if (string? acc) + (string-append acc "/" (car rest)) + (car rest)) + (cdr rest))))) +(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz")) +(assert (string=? (path-join "" "bar" "baz") "bar/baz")) + +;; Is PATH an absolute path? +(define (absolute-path? path) + (or (char=? #\/ (string-ref path 0)) + (and *win32* (char=? #\\ (string-ref path 0))) + (and *win32* + (char-alphabetic? (string-ref path 0)) + (char=? #\: (string-ref path 1)) + (or (char=? #\/ (string-ref path 2)) + (char=? #\\ (string-ref path 2)))))) + +;; Make PATH absolute. +(define (canonical-path path) + (if (absolute-path? path) path (path-join (getcwd) path))) + +(define (in-srcdir . names) + (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names)))) + +;; Split a list of paths. +(define (pathsep-split s) + (string-split s *pathsep*)) + +;; Join a list of paths. +(define (pathsep-join paths) + (foldr (lambda (a b) (string-append a (string *pathsep*) b)) + (car paths) + (cdr paths))) + +;; Try to find NAME in PATHS. Returns the full path name on success, +;; or raises an error. +(define (path-expand name paths) + (let loop ((path paths)) + (if (null? path) + (throw "Could not find" name "in" paths) + (let* ((qualified-name (path-join (car path) name)) + (file-exists (call-with-input-file qualified-name + (lambda (x) #t)))) + (if file-exists + qualified-name + (loop (cdr path))))))) + +;; Expand NAME using the gpgscm load path. Use like this: +;; (load (with-path "library.scm")) +(define (with-path name) + (catch name + (path-expand name (pathsep-split (getenv "GPGSCM_PATH"))))) + +(define (basename path) + (let ((i (string-index path #\/))) + (if (equal? i #f) + path + (basename (substring path (+ 1 i) (string-length path)))))) + +(define (basename-suffix path suffix) + (basename + (if (string-suffix? path suffix) + (substring path 0 (- (string-length path) (string-length suffix))) + path))) + +(define (dirname path) + (let ((i (string-rindex path #\/))) + (if i (substring path 0 i) "."))) +(assert (string=? "foo/bar" (dirname "foo/bar/baz"))) + +;; Helper for (pipe). +(define :read-end car) +(define :write-end cadr) + +;; let-like macro that manages file descriptors. +;; +;; (letfd ) +;; +;; Bind all variables given in and initialize each of them +;; to the given initial value, and close them after evaluating . +(define-macro (letfd bindings . body) + (let bind ((bindings' bindings)) + (if (null? bindings') + `(begin ,@body) + (let* ((binding (car bindings')) + (name (car binding)) + (initializer (cadr binding))) + `(let ((,name ,initializer)) + (finally (close ,name) + ,(bind (cdr bindings')))))))) + +(define-macro (with-working-directory new-directory . expressions) + (let ((new-dir (gensym)) + (old-dir (gensym))) + `(let* ((,new-dir ,new-directory) + (,old-dir (getcwd))) + (dynamic-wind + (lambda () (if ,new-dir (chdir ,new-dir))) + (lambda () ,@expressions) + (lambda () (chdir ,old-dir)))))) + +;; Make a temporary directory. If arguments are given, they are +;; joined using path-join, and must end in a component ending in +;; "XXXXXX". If no arguments are given, a suitable location and +;; generic name is used. Returns an absolute path. +(define (mkdtemp . components) + (canonical-path (_mkdtemp (if (null? components) + (path-join + (get-temp-path) + (string-append "gpgscm-" (get-isotime) "-" + (basename-suffix *scriptname* ".scm") + "-XXXXXX")) + (apply path-join components))))) + +;; Make a temporary directory and remove it at interpreter shutdown. +;; Note that there are macros that limit the lifetime of temporary +;; directories and files to a lexical scope. Use those if possible. +;; Otherwise this works like mkdtemp. +(define (mkdtemp-autoremove . components) + (let ((dir (apply mkdtemp components))) + (atexit (lambda () (unlink-recursively dir))) + dir)) + +(define-macro (with-temporary-working-directory . expressions) + (let ((tmp-sym (gensym))) + `(let* ((,tmp-sym (mkdtemp))) + (finally (unlink-recursively ,tmp-sym) + (with-working-directory ,tmp-sym + ,@expressions))))) + +(define (make-temporary-file . args) + (canonical-path (path-join + (mkdtemp) + (if (null? args) "a" (car args))))) + +(define (remove-temporary-file filename) + (catch '() + (unlink filename)) + (let ((dirname (substring filename 0 (string-rindex filename #\/)))) + (catch (echo "removing temporary directory" dirname "failed") + (rmdir dirname)))) + +;; let-like macro that manages temporary files. +;; +;; (lettmp ) +;; +;; Bind all variables given in , initialize each of them to +;; a string representing an unique path in the filesystem, and delete +;; them after evaluating . +(define-macro (lettmp bindings . body) + (let bind ((bindings' bindings)) + (if (null? bindings') + `(begin ,@body) + (let ((name (car bindings')) + (rest (cdr bindings'))) + `(let ((,name (make-temporary-file ,(symbol->string name)))) + (finally (remove-temporary-file ,name) + ,(bind rest))))))) + +(define (check-execution source transformer) + (lettmp (sink) + (transformer source sink))) + +(define (check-identity source transformer) + (lettmp (sink) + (transformer source sink) + (if (not (file=? source sink)) + (fail "mismatch")))) + +;; +;; Monadic pipe support. +;; + +(define pipeM + (package + (define (new procs source sink producer) + (package + (define (dump) + (write (list procs source sink producer)) + (newline)) + (define (add-proc command pid) + (new (cons (list command pid) procs) source sink producer)) + (define (commands) + (map car procs)) + (define (pids) + (map cadr procs)) + (define (set-source source') + (new procs source' sink producer)) + (define (set-sink sink') + (new procs source sink' producer)) + (define (set-producer producer') + (if producer + (throw "producer already set")) + (new procs source sink producer')))))) + + +(define (pipe:do . commands) + (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands)) + (if (null? cmds) + (begin + (if M::producer (M::producer)) + (if (not (null? M::procs)) + (let* ((retcodes (wait-processes (map stringify (M::commands)) + (M::pids) #t)) + (results (map (lambda (p r) (append p (list r))) + M::procs retcodes)) + (failed (filter (lambda (x) (not (= 0 (caddr x)))) + results))) + (if (not (null? failed)) + (throw failed))))) ; xxx nicer reporting + (if (and (= 2 (length cmds)) (number? (cadr cmds))) + ;; hack: if it's an fd, use it as sink + (let ((M' ((car cmds) (M::set-sink (cadr cmds))))) + (if (> M::source 2) (close M::source)) + (if (> (cadr cmds) 2) (close (cadr cmds))) + (loop M' '())) + (let ((M' ((car cmds) M))) + (if (> M::source 2) (close M::source)) + (loop M' (cdr cmds))))))) + +(define (pipe:open pathname flags) + (lambda (M) + (M::set-source (open pathname flags)))) + +(define (pipe:defer producer) + (lambda (M) + (let* ((p (outbound-pipe)) + (M' (M::set-source (:read-end p)))) + (M'::set-producer (lambda () + (producer (:write-end p)) + (close (:write-end p))))))) +(define (pipe:echo data) + (pipe:defer (lambda (sink) (display data (fdopen sink "wb"))))) + +(define (pipe:spawn command) + (lambda (M) + (define (do-spawn M new-source) + (let ((pid (spawn-process-fd command M::source M::sink + (if (> (*verbose*) 0) + STDERR_FILENO CLOSED_FD))) + (M' (M::set-source new-source))) + (M'::add-proc command pid))) + (if (= CLOSED_FD M::sink) + (let* ((p (pipe)) + (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p)))) + (close (:write-end p)) + (M'::set-sink CLOSED_FD)) + (do-spawn M CLOSED_FD)))) + +(define (pipe:splice sink) + (lambda (M) + (splice M::source sink) + (M::set-source CLOSED_FD))) + +(define (pipe:write-to pathname flags mode) + (open pathname flags mode)) + +;; +;; Monadic transformer support. +;; + +(define (tr:do . commands) + (let loop ((tmpfiles '()) (source #f) (cmds commands)) + (if (null? cmds) + (for-each remove-temporary-file tmpfiles) + (let* ((v ((car cmds) tmpfiles source)) + (tmpfiles' (car v)) + (sink (cadr v)) + (error (caddr v))) + (if error + (begin + (for-each remove-temporary-file tmpfiles') + (apply throw error))) + (loop tmpfiles' sink (cdr cmds)))))) + +(define (tr:open pathname) + (lambda (tmpfiles source) + (list tmpfiles pathname #f))) + +(define (tr:spawn input command) + (lambda (tmpfiles source) + (if (and (member '**in** command) (not source)) + (fail (string-append (stringify cmd) " needs an input"))) + (let* ((t (make-temporary-file)) + (cmd (map (lambda (x) + (cond + ((equal? '**in** x) source) + ((equal? '**out** x) t) + (else x))) command))) + (catch (list (cons t tmpfiles) t *error*) + (call-popen cmd input) + (if (and (member '**out** command) (not (file-exists? t))) + (fail (string-append (stringify cmd) + " did not produce '" t "'."))) + (list (cons t tmpfiles) t #f))))) + +(define (tr:write-to pathname) + (lambda (tmpfiles source) + (rename source pathname) + (list tmpfiles pathname #f))) + +(define (tr:pipe-do . commands) + (lambda (tmpfiles source) + (let ((t (make-temporary-file))) + (apply pipe:do + `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) + ,@commands + ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) + (list (cons t tmpfiles) t #f)))) + +(define (tr:assert-identity reference) + (lambda (tmpfiles source) + (if (not (file=? source reference)) + (fail "mismatch")) + (list tmpfiles source #f))) + +(define (tr:assert-weak-identity reference) + (lambda (tmpfiles source) + (if (not (text-file=? source reference)) + (fail "mismatch")) + (list tmpfiles source #f))) + +(define (tr:call-with-content function . args) + (lambda (tmpfiles source) + (catch (list tmpfiles source *error*) + (apply function `(,(call-with-input-file source read-all) ,@args))) + (list tmpfiles source #f))) + +;; +;; Developing and debugging tests. +;; + +;; Spawn an os shell. +(define (interactive-shell) + (call-with-fds `(,(getenv "SHELL") -i) 0 1 2)) + +;; +;; The main test framework. +;; + +(define semaphore + (package + (define (new n) + (package + (define (acquire!?) + (if (> n 0) + (begin + (set! n (- n 1)) + #t) + #f)) + (define (release!) + (set! n (+ n 1))))))) + +;; A pool of tests. +(define test-pool + (package + (define (new n) + (package + ;; A semaphore to restrict the number of spawned processes. + (define sem (semaphore::new n)) + + ;; A list of enqueued, but not yet run tests. + (define enqueued '()) + + ;; A list of running or finished processes. + (define procs '()) + + (define (add test) + (if (test::started?) + (set! procs (cons test procs)) + (if (sem::acquire!?) + (add (test::run-async)) + (set! enqueued (cons test enqueued)))) + (current-environment)) + + ;; Pop the last of the enqueued tests off the fifo queue. + (define (pop-test!) + (let ((i (length enqueued))) + (assert (> i 0)) + (cond + ((= i 1) + (let ((test (car enqueued))) + (set! enqueued '()) + test)) + (else + (let* ((tail (list-tail enqueued (- i 2))) + (test (cadr tail))) + (set-cdr! tail '()) + (assert (= (length enqueued) (- i 1))) + test))))) + + (define (pid->test pid) + (let ((t (filter (lambda (x) (= pid x::pid)) procs))) + (if (null? t) #f (car t)))) + (define (wait) + (if (null? enqueued) + ;; If no tests are enqueued, we can just block until all + ;; of them finished. + (wait' #t) + ;; Otherwise, we must not block, but give some tests the + ;; chance to finish so that we can start new ones. + (begin + (wait' #f) + (usleep (/ 1000000 10)) + (wait)))) + (define (wait' hang) + (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) + (if (null? unfinished) + (current-environment) + (let ((names (map (lambda (t) t::name) unfinished)) + (pids (map (lambda (t) t::pid) unfinished)) + (any #f)) + (for-each + (lambda (test retcode) + (unless (< retcode 0) + (test::set-end-time!) + (test:::set! 'retcode retcode) + (test::report) + (sem::release!) + (set! any #t))) + (map pid->test pids) + (wait-processes (map stringify names) pids hang)) + + ;; If some processes finished, try to start new ones. + (let loop () + (cond + ((not any) #f) + ((pair? enqueued) + (if (sem::acquire!?) + (let ((test (pop-test!))) + (add (test::run-async)) + (loop))))))))) + (current-environment)) + (define (filter-tests status) + (filter (lambda (p) (eq? status (p::status))) procs)) + (define (report) + (define (print-tests tests message) + (unless (null? tests) + (apply echo (cons message + (map (lambda (t) t::name) tests))))) + + (let ((failed (filter-tests 'FAIL)) + (xfailed (filter-tests 'XFAIL)) + (xpassed (filter-tests 'XPASS)) + (skipped (filter-tests 'SKIP))) + (echo "===================") + (echo (length procs) "tests run," + (length (filter-tests 'PASS)) "succeeded," + (length failed) "failed," + (length xfailed) "failed expectedly," + (length xpassed) "succeeded unexpectedly," + (length skipped) "skipped.") + (print-tests failed "Failed tests:") + (print-tests xfailed "Expectedly failed tests:") + (print-tests xpassed "Unexpectedly passed tests:") + (print-tests skipped "Skipped tests:") + (echo "===================") + (+ (length failed) (length xpassed)))) + + (define (xml) + (xx::document + (xx::tag 'testsuites + `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") + ("xsi:noNamespaceSchemaLocation" + "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd")) + (map (lambda (t) (t::xml)) procs)))))))) + +(define (verbosity n) + (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) + +(define (locate-test path) + (if (absolute-path? path) path (in-srcdir path))) + +;; A single test. +(define test + (begin + + ;; Private definitions. + + (define (isotime->junit t) + "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}" + "20170418T145809" + (string-append (substring t 0 4) + "-" + (substring t 4 6) + "-" + (substring t 6 11) + ":" + (substring t 11 13) + ":" + (substring t 13 15))) + + ;; If a tests name ends with a bang (!), it is expected to fail. + (define (expect-failure? name) + (string-suffix? name "!")) + ;; Strips the bang (if any). + (define (test-name name) + (if (expect-failure? name) + (substring name 0 (- (string-length name) 1)) + name)) + + (package + (define (scm setup name path . args) + ;; Start the process. + (define (spawn-scm args' in out err) + (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) + ,(locate-test (test-name path)) + ,@(if setup (force setup) '()) + ,@args' ,@args) in out err)) + (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name))) + + (define (binary setup name path . args) + ;; Start the process. + (define (spawn-binary args' in out err) + (spawn-process-fd `(,(test-name path) + ,@(if setup (force setup) '()) ,@args' ,@args) + in out err)) + (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name))) + + (define (new name directory spawn pid retcode logfd expect-failure) + (package + + ;; XXX: OO glue. + (define self (current-environment)) + (define (:set! key value) + (eval `(set! ,key ,value) (current-environment)) + (current-environment)) + + ;; The log is written here. + (define log-file-name #f) + + ;; Record time stamps. + (define timestamp #f) + (define start-time 0) + (define end-time 0) + + (define (set-start-time!) + (set! timestamp (isotime->junit (get-isotime))) + (set! start-time (get-time))) + (define (set-end-time!) + (set! end-time (get-time))) + + ;; Has the test been started yet? + (define (started?) + (number? pid)) + + (define (open-log-file) + (unless log-file-name + (set! log-file-name (string-append (basename name) ".log"))) + (catch '() (unlink log-file-name)) + (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) + + (define (run-sync . args) + (set-start-time!) + (letfd ((log (open-log-file))) + (with-working-directory directory + (let* ((p (inbound-pipe)) + (pid' (spawn args 0 (:write-end p) (:write-end p)))) + (close (:write-end p)) + (splice (:read-end p) STDERR_FILENO log) + (close (:read-end p)) + (set! pid pid') + (set! retcode (wait-process name pid' #t))))) + (report) + (current-environment)) + (define (run-sync-quiet . args) + (set-start-time!) + (with-working-directory directory + (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))) + (set! retcode (wait-process name pid #t)) + (set-end-time!) + (current-environment)) + (define (run-async . args) + (set-start-time!) + (let ((log (open-log-file))) + (with-working-directory directory + (set! pid (spawn args CLOSED_FD log log))) + (set! logfd log)) + (current-environment)) + (define (status) + (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))) + (t (if (not t') 'FAIL (cadr t')))) + (if expect-failure + (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t)) + t))) + (define (status-string) + (cadr (assoc (status) '((PASS "PASS") + (SKIP "SKIP") + (ERROR "ERROR") + (FAIL "FAIL") + (XPASS "XPASS") + (XFAIL "XFAIL"))))) + (define (report) + (unless (= logfd CLOSED_FD) + (seek logfd 0 SEEK_SET) + (splice logfd STDERR_FILENO) + (close logfd)) + (echo (string-append (status-string) ":") name)) + + (define (xml) + (xx::tag + 'testsuite + `((name ,name) + (time ,(- end-time start-time)) + (package ,(dirname name)) + (id 0) + (timestamp ,timestamp) + (hostname "unknown") + (tests 1) + (failures ,(if (eq? FAIL (status)) 1 0)) + (errors ,(if (eq? ERROR (status)) 1 0))) + (list + (xx::tag 'properties) + (xx::tag 'testcase + `((name ,(basename name)) + (classname ,(string-translate (dirname name) "/" ".")) + (time ,(- end-time start-time))) + `(,@(case (status) + ((PASS XFAIL) '()) + ((SKIP) (list (xx::tag 'skipped))) + ((ERROR) (list + (xx::tag 'error '((message "Unknown error."))))) + (else + (list (xx::tag 'failure '((message "Unknown error.")))))))) + (xx::tag 'system-out '() + (list (xx::textnode (read-all (open-input-file log-file-name))))) + (xx::tag 'system-err '() (list (xx::textnode ""))))))))))) + +;; Run the setup target to create an environment, then run all given +;; tests in parallel. +(define (run-tests-parallel tests n) + (let loop ((pool (test-pool::new n)) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + ((results::xml) (open-output-file "report.xml")) + (exit (results::report))) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add test) + (cdr tests')))))) + +;; Run the setup target to create an environment, then run all given +;; tests in sequence. +(define (run-tests-sequential tests) + (let loop ((pool (test-pool::new 1)) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + ((results::xml) (open-output-file "report.xml")) + (exit (results::report))) + (let ((wd (mkdtemp-autoremove)) + (test (car tests'))) + (test:::set! 'directory wd) + (loop (pool::add (test::run-sync)) + (cdr tests')))))) + +;; Run tests either in sequence or in parallel, depending on the +;; number of tests and the command line flags. +(define (run-tests tests) + (let ((parallel (flag "--parallel" *args*)) + (default-parallel-jobs 32)) + (if (and parallel (> (length tests) 1)) + (run-tests-parallel tests (if (and (pair? parallel) + (string->number (car parallel))) + (string->number (car parallel)) + default-parallel-jobs)) + (run-tests-sequential tests)))) + +;; Load all tests from the given path. +(define (load-tests . path) + (load (apply in-srcdir `(,@path "all-tests.scm"))) + all-tests) + +;; Helper to create environment caches from test functions. SETUP +;; must be a test implementing the producer side cache protocol. +;; Returns a promise containing the arguments that must be passed to a +;; test implementing the consumer side of the cache protocol. +(define (make-environment-cache setup) + (delay (with-temporary-working-directory + (let ((tarball (make-temporary-file "environment-cache"))) + (atexit (lambda () (remove-temporary-file tarball))) + (setup::run-sync '--create-tarball tarball) + (if (not (equal? 'PASS (setup::status))) + (fail "Setup failed.")) + `(--unpack-tarball ,tarball))))) + +;; Command line flag handling. Returns the elements following KEY in +;; ARGUMENTS up to the next argument, or #f if KEY is not in +;; ARGUMENTS. If 'KEY=XYZ' is encountered, then the singleton list +;; containing 'XYZ' is returned. +(define (flag key arguments) + (cond + ((null? arguments) + #f) + ((string=? key (car arguments)) + (let loop ((acc '()) + (args (cdr arguments))) + (if (or (null? args) (string-prefix? (car args) "--")) + (reverse acc) + (loop (cons (car args) acc) (cdr args))))) + ((string-prefix? (car arguments) (string-append key "=")) + (list (substring (car arguments) + (+ (string-length key) 1) + (string-length (car arguments))))) + ((string=? "--" (car arguments)) + #f) + (else + (flag key (cdr arguments))))) +(assert (equal? (flag "--xxx" '("--yyy")) #f)) +(assert (equal? (flag "--xxx" '("--xxx")) '())) +(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy"))) +(assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz"))) +(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy"))) +(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy"))) diff --git a/gpgscm/time.scm b/gpgscm/time.scm new file mode 100644 index 0000000..a9b06d0 --- /dev/null +++ b/gpgscm/time.scm @@ -0,0 +1,42 @@ +;; Simple time manipulation library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +;; This library mimics what GnuPG thinks about expiration times. +;; Granularity is one second. Its focus is not on correctness. + +;; Conversion functions. +(define (minutes->seconds minutes) + (* minutes 60)) +(define (hours->seconds hours) + (* hours 60 60)) +(define (days->seconds days) + (* days 24 60 60)) +(define (weeks->seconds weeks) + (days->seconds (* weeks 7))) +(define (months->seconds months) + (days->seconds (* months 30))) +(define (years->seconds years) + (days->seconds (* years 365))) + +(define (time-matches? a b slack) + (< (abs (- a b)) slack)) +(assert (time-matches? (hours->seconds 1) (hours->seconds 2) (hours->seconds 2))) +(assert (time-matches? (hours->seconds 2) (hours->seconds 1) (hours->seconds 2))) +(assert (not (time-matches? (hours->seconds 4) (hours->seconds 1) (hours->seconds 2)))) +(assert (not (time-matches? (hours->seconds 1) (hours->seconds 4) (hours->seconds 2)))) diff --git a/gpgscm/xml.scm b/gpgscm/xml.scm new file mode 100644 index 0000000..771ec36 --- /dev/null +++ b/gpgscm/xml.scm @@ -0,0 +1,142 @@ +;; A tiny XML library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(define xx + (begin + + ;; Private declarations. + (define quote-text + '((#\< "<") + (#\> ">") + (#\& "&"))) + + (define quote-attribute-' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\' "'"))) + + (define quote-attribute-'' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))) + + (define (escape-string quotation string sink) + ;; This implementation is a bit awkward because iteration is so + ;; slow in TinySCHEME. We rely on string-index to skip to the + ;; next character we need to escape. We also avoid allocations + ;; wherever possible. + + ;; Given a list of integers or #f, return the sublist that + ;; starts with the lowest integer. + (define (min* x) + (let loop ((lowest x) (rest x)) + (if (null? rest) + lowest + (loop (if (or (null? lowest) (not (car lowest)) + (and (car rest) (> (car lowest) (car rest)))) rest lowest) + (cdr rest))))) + + (let ((i 0) (start 0) (len (string-length string)) + (indices (map (lambda (x) (string-index string (car x))) quotation)) + (next #f) (c #f)) + + ;; Set 'i' to the index of the next character that needs + ;; escaping, 'c' to the character that needs to be escaped, + ;; and update 'indices'. + (define (skip!) + (set! next (min* indices)) + (set! i (if (null? next) #f (car next))) + (if i + (begin + (set! c (string-ref string i)) + (set-car! next (string-index string c (+ 1 i)))) + (set! i (string-length string)))) + + (let loop () + (skip!) + (if (< i len) + (begin + (display (substring string start i) sink) + (display (cadr (assv c quotation)) sink) + (set! i (+ 1 i)) + (set! start i) + (loop)) + (display (substring string start len) sink))))) + + (let ((escape-string-s (lambda (quotation string) + (let ((sink (open-output-string))) + (escape-string quotation string sink) + (get-output-string sink))))) + (assert (equal? (escape-string-s quote-text "foo") "foo")) + (assert (equal? (escape-string-s quote-text "foo&") "foo&")) + (assert (equal? (escape-string-s quote-text "&foo") "&foo")) + (assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar")) + (assert (equal? (escape-string-s quote-text "foobar") "foo>bar"))) + + (define (escape quotation datum sink) + (cond + ((string? datum) (escape-string quotation datum sink)) + ((symbol? datum) (escape-string quotation (symbol->string datum) sink)) + ((number? datum) (display (number->string datum) sink)) + (else + (throw "Do not know how to encode" datum)))) + + (define (name->string name) + (cond + ((symbol? name) (symbol->string name)) + (else name))) + + (package + + (define (textnode string) + (lambda (sink) + (escape quote-text string sink))) + + (define (tag name . rest) + (let ((attributes (if (null? rest) '() (car rest))) + (children (if (> (length rest) 1) (cadr rest) '()))) + (lambda (sink) + (display "<" sink) + (display (name->string name) sink) + (unless (null? attributes) + (display " " sink) + (for-each (lambda (a) + (display (car a) sink) + (display "=\"" sink) + (escape quote-attribute-'' (cadr a) sink) + (display "\" " sink)) attributes)) + (if (null? children) + (display "/>\n" sink) + (begin + (display ">\n" sink) + (for-each (lambda (c) (c sink)) children) + (display "string name) sink) + (display ">\n" sink)))))) + + (define (document root . rest) + (let ((attributes (if (null? rest) '() (car rest)))) + (lambda (sink) + ;; xxx ignores attributes + (display "\n" sink) + (root sink) + (newline sink))))))) diff --git a/init.scm b/init.scm deleted file mode 100644 index 66bec0f..0000000 --- a/init.scm +++ /dev/null @@ -1,823 +0,0 @@ -; Initialization file for TinySCHEME 1.41 - -; Per R5RS, up to four deep compositions should be defined -(define (caar x) (car (car x))) -(define (cadr x) (car (cdr x))) -(define (cdar x) (cdr (car x))) -(define (cddr x) (cdr (cdr x))) -(define (caaar x) (car (car (car x)))) -(define (caadr x) (car (car (cdr x)))) -(define (cadar x) (car (cdr (car x)))) -(define (caddr x) (car (cdr (cdr x)))) -(define (cdaar x) (cdr (car (car x)))) -(define (cdadr x) (cdr (car (cdr x)))) -(define (cddar x) (cdr (cdr (car x)))) -(define (cdddr x) (cdr (cdr (cdr x)))) -(define (caaaar x) (car (car (car (car x))))) -(define (caaadr x) (car (car (car (cdr x))))) -(define (caadar x) (car (car (cdr (car x))))) -(define (caaddr x) (car (car (cdr (cdr x))))) -(define (cadaar x) (car (cdr (car (car x))))) -(define (cadadr x) (car (cdr (car (cdr x))))) -(define (caddar x) (car (cdr (cdr (car x))))) -(define (cadddr x) (car (cdr (cdr (cdr x))))) -(define (cdaaar x) (cdr (car (car (car x))))) -(define (cdaadr x) (cdr (car (car (cdr x))))) -(define (cdadar x) (cdr (car (cdr (car x))))) -(define (cdaddr x) (cdr (car (cdr (cdr x))))) -(define (cddaar x) (cdr (cdr (car (car x))))) -(define (cddadr x) (cdr (cdr (car (cdr x))))) -(define (cdddar x) (cdr (cdr (cdr (car x))))) -(define (cddddr x) (cdr (cdr (cdr (cdr x))))) - -;;;; Utility to ease macro creation -(define (macro-expand form) - ((eval (get-closure-code (eval (car form)))) form)) - -(define (macro-expand-all form) - (if (macro? form) - (macro-expand-all (macro-expand form)) - form)) - -(define *compile-hook* macro-expand-all) - - -(macro (unless form) - `(if (not ,(cadr form)) (begin ,@(cddr form)))) - -(macro (when form) - `(if ,(cadr form) (begin ,@(cddr form)))) - -; DEFINE-MACRO Contributed by Andy Gaynor -(macro (define-macro dform) - (if (symbol? (cadr dform)) - `(macro ,@(cdr dform)) - (let ((form (gensym))) - `(macro (,(caadr dform) ,form) - (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) - -; Utilities for math. Notice that inexact->exact is primitive, -; but exact->inexact is not. -(define exact? integer?) -(define (inexact? x) (and (real? x) (not (integer? x)))) -(define (even? n) (= (remainder n 2) 0)) -(define (odd? n) (not (= (remainder n 2) 0))) -(define (zero? n) (= n 0)) -(define (positive? n) (> n 0)) -(define (negative? n) (< n 0)) -(define complex? number?) -(define rational? real?) -(define (abs n) (if (>= n 0) n (- n))) -(define (exact->inexact n) (* n 1.0)) -(define (<> n1 n2) (not (= n1 n2))) - -; min and max must return inexact if any arg is inexact; use (+ n 0.0) -(define (max . lst) - (foldr (lambda (a b) - (if (> a b) - (if (exact? b) a (+ a 0.0)) - (if (exact? a) b (+ b 0.0)))) - (car lst) (cdr lst))) -(define (min . lst) - (foldr (lambda (a b) - (if (< a b) - (if (exact? b) a (+ a 0.0)) - (if (exact? a) b (+ b 0.0)))) - (car lst) (cdr lst))) - -(define (succ x) (+ x 1)) -(define (pred x) (- x 1)) -(define gcd - (lambda a - (if (null? a) - 0 - (let ((aa (abs (car a))) - (bb (abs (cadr a)))) - (if (= bb 0) - aa - (gcd bb (remainder aa bb))))))) -(define lcm - (lambda a - (if (null? a) - 1 - (let ((aa (abs (car a))) - (bb (abs (cadr a)))) - (if (or (= aa 0) (= bb 0)) - 0 - (abs (* (quotient aa (gcd aa bb)) bb))))))) - - -(define (string . charlist) - (list->string charlist)) - -(define (list->string charlist) - (let* ((len (length charlist)) - (newstr (make-string len)) - (fill-string! - (lambda (str i len charlist) - (if (= i len) - str - (begin (string-set! str i (car charlist)) - (fill-string! str (+ i 1) len (cdr charlist))))))) - (fill-string! newstr 0 len charlist))) - -(define (string-fill! s e) - (let ((n (string-length s))) - (let loop ((i 0)) - (if (= i n) - s - (begin (string-set! s i e) (loop (succ i))))))) - -(define (string->list s) - (let loop ((n (pred (string-length s))) (l '())) - (if (= n -1) - l - (loop (pred n) (cons (string-ref s n) l))))) - -(define (string-copy str) - (string-append str)) - -(define (string->anyatom str pred) - (let* ((a (string->atom str))) - (if (pred a) a - (error "string->xxx: not a xxx" a)))) - -(define (string->number str . base) - (let ((n (string->atom str (if (null? base) 10 (car base))))) - (if (number? n) n #f))) - -(define (anyatom->string n pred) - (if (pred n) - (atom->string n) - (error "xxx->string: not a xxx" n))) - -(define (number->string n . base) - (atom->string n (if (null? base) 10 (car base)))) - - -(define (char-cmp? cmp a b) - (cmp (char->integer a) (char->integer b))) -(define (char-ci-cmp? cmp a b) - (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b)))) - -(define (char=? a b) (char-cmp? = a b)) -(define (char? a b) (char-cmp? > a b)) -(define (char<=? a b) (char-cmp? <= a b)) -(define (char>=? a b) (char-cmp? >= a b)) - -(define (char-ci=? a b) (char-ci-cmp? = a b)) -(define (char-ci? a b) (char-ci-cmp? > a b)) -(define (char-ci<=? a b) (char-ci-cmp? <= a b)) -(define (char-ci>=? a b) (char-ci-cmp? >= a b)) - -; Note the trick of returning (cmp x y) -(define (string-cmp? chcmp cmp a b) - (let ((na (string-length a)) (nb (string-length b))) - (let loop ((i 0)) - (cond - ((= i na) - (if (= i nb) (cmp 0 0) (cmp 0 1))) - ((= i nb) - (cmp 1 0)) - ((chcmp = (string-ref a i) (string-ref b i)) - (loop (succ i))) - (else - (chcmp cmp (string-ref a i) (string-ref b i))))))) - - -(define (string=? a b) (string-cmp? char-cmp? = a b)) -(define (string? a b) (string-cmp? char-cmp? > a b)) -(define (string<=? a b) (string-cmp? char-cmp? <= a b)) -(define (string>=? a b) (string-cmp? char-cmp? >= a b)) - -(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b)) -(define (string-ci? a b) (string-cmp? char-ci-cmp? > a b)) -(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b)) -(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b)) - -(define (list . x) x) - -(define (foldr f x lst) - (if (null? lst) - x - (foldr f (f x (car lst)) (cdr lst)))) - -(define (unzip1-with-cdr . lists) - (unzip1-with-cdr-iterative lists '() '())) - -(define (unzip1-with-cdr-iterative lists cars cdrs) - (if (null? lists) - (cons cars cdrs) - (let ((car1 (caar lists)) - (cdr1 (cdar lists))) - (unzip1-with-cdr-iterative - (cdr lists) - (append cars (list car1)) - (append cdrs (list cdr1)))))) - -(define (map proc . lists) - (if (null? lists) - (apply proc) - (if (null? (car lists)) - '() - (let* ((unz (apply unzip1-with-cdr lists)) - (cars (car unz)) - (cdrs (cdr unz))) - (cons (apply proc cars) (apply map (cons proc cdrs))))))) - -(define (for-each proc . lists) - (if (null? lists) - (apply proc) - (if (null? (car lists)) - #t - (let* ((unz (apply unzip1-with-cdr lists)) - (cars (car unz)) - (cdrs (cdr unz))) - (apply proc cars) (apply map (cons proc cdrs)))))) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(define (list-ref x k) - (car (list-tail x k))) - -(define (last-pair x) - (if (pair? (cdr x)) - (last-pair (cdr x)) - x)) - -(define (head stream) (car stream)) - -(define (tail stream) (force (cdr stream))) - -(define (vector-equal? x y) - (and (vector? x) (vector? y) (= (vector-length x) (vector-length y)) - (let ((n (vector-length x))) - (let loop ((i 0)) - (if (= i n) - #t - (and (equal? (vector-ref x i) (vector-ref y i)) - (loop (succ i)))))))) - -(define (list->vector x) - (apply vector x)) - -(define (vector-fill! v e) - (let ((n (vector-length v))) - (let loop ((i 0)) - (if (= i n) - v - (begin (vector-set! v i e) (loop (succ i))))))) - -(define (vector->list v) - (let loop ((n (pred (vector-length v))) (l '())) - (if (= n -1) - l - (loop (pred n) (cons (vector-ref v n) l))))) - -;; The following quasiquote macro is due to Eric S. Tiedemann. -;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. -;; -;; Subsequently modified to handle vectors: D. Souflis - -(macro - quasiquote - (lambda (l) - (define (mcons f l r) - (if (and (pair? r) - (eq? (car r) 'quote) - (eq? (car (cdr r)) (cdr f)) - (pair? l) - (eq? (car l) 'quote) - (eq? (car (cdr l)) (car f))) - (if (or (procedure? f) (number? f) (string? f)) - f - (list 'quote f)) - (if (eqv? l vector) - (apply l (eval r)) - (list 'cons l r) - ))) - (define (mappend f l r) - (if (or (null? (cdr f)) - (and (pair? r) - (eq? (car r) 'quote) - (eq? (car (cdr r)) '()))) - l - (list 'append l r))) - (define (foo level form) - (cond ((not (pair? form)) - (if (or (procedure? form) (number? form) (string? form)) - form - (list 'quote form)) - ) - ((eq? 'quasiquote (car form)) - (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) - (#t (if (zero? level) - (cond ((eq? (car form) 'unquote) (car (cdr form))) - ((eq? (car form) 'unquote-splicing) - (error "Unquote-splicing wasn't in a list:" - form)) - ((and (pair? (car form)) - (eq? (car (car form)) 'unquote-splicing)) - (mappend form (car (cdr (car form))) - (foo level (cdr form)))) - (#t (mcons form (foo level (car form)) - (foo level (cdr form))))) - (cond ((eq? (car form) 'unquote) - (mcons form ''unquote (foo (- level 1) - (cdr form)))) - ((eq? (car form) 'unquote-splicing) - (mcons form ''unquote-splicing - (foo (- level 1) (cdr form)))) - (#t (mcons form (foo level (car form)) - (foo level (cdr form))))))))) - (foo 0 (car (cdr l))))) - -;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom) -(define (shared-tail x y) - (let ((len-x (length x)) - (len-y (length y))) - (define (shared-tail-helper x y) - (if - (eq? x y) - x - (shared-tail-helper (cdr x) (cdr y)))) - - (cond - ((> len-x len-y) - (shared-tail-helper - (list-tail x (- len-x len-y)) - y)) - ((< len-x len-y) - (shared-tail-helper - x - (list-tail y (- len-y len-x)))) - (#t (shared-tail-helper x y))))) - -;;;;;Dynamic-wind by Tom Breton (Tehom) - -;;Guarded because we must only eval this once, because doing so -;;redefines call/cc in terms of old call/cc -(unless (defined? 'dynamic-wind) - (let - ;;These functions are defined in the context of a private list of - ;;pairs of before/after procs. - ( (*active-windings* '()) - ;;We'll define some functions into the larger environment, so - ;;we need to know it. - (outer-env (current-environment))) - - ;;Poor-man's structure operations - (define before-func car) - (define after-func cdr) - (define make-winding cons) - - ;;Manage active windings - (define (activate-winding! new) - ((before-func new)) - (set! *active-windings* (cons new *active-windings*))) - (define (deactivate-top-winding!) - (let ((old-top (car *active-windings*))) - ;;Remove it from the list first so it's not active during its - ;;own exit. - (set! *active-windings* (cdr *active-windings*)) - ((after-func old-top)))) - - (define (set-active-windings! new-ws) - (unless (eq? new-ws *active-windings*) - (let ((shared (shared-tail new-ws *active-windings*))) - - ;;Define the looping functions. - ;;Exit the old list. Do deeper ones last. Don't do - ;;any shared ones. - (define (pop-many) - (unless (eq? *active-windings* shared) - (deactivate-top-winding!) - (pop-many))) - ;;Enter the new list. Do deeper ones first so that the - ;;deeper windings will already be active. Don't do any - ;;shared ones. - (define (push-many new-ws) - (unless (eq? new-ws shared) - (push-many (cdr new-ws)) - (activate-winding! (car new-ws)))) - - ;;Do it. - (pop-many) - (push-many new-ws)))) - - ;;The definitions themselves. - (eval - `(define call-with-current-continuation - ;;It internally uses the built-in call/cc, so capture it. - ,(let ((old-c/cc call-with-current-continuation)) - (lambda (func) - ;;Use old call/cc to get the continuation. - (old-c/cc - (lambda (continuation) - ;;Call func with not the continuation itself - ;;but a procedure that adjusts the active - ;;windings to what they were when we made - ;;this, and only then calls the - ;;continuation. - (func - (let ((current-ws *active-windings*)) - (lambda (x) - (set-active-windings! current-ws) - (continuation x))))))))) - outer-env) - ;;We can't just say "define (dynamic-wind before thunk after)" - ;;because the lambda it's defined to lives in this environment, - ;;not in the global environment. - (eval - `(define dynamic-wind - ,(lambda (before thunk after) - ;;Make a new winding - (activate-winding! (make-winding before after)) - (let ((result (thunk))) - ;;Get rid of the new winding. - (deactivate-top-winding!) - ;;The return value is that of thunk. - result))) - outer-env))) - -(define call/cc call-with-current-continuation) - - -;;;;; atom? and equal? written by a.k - -;;;; atom? -(define (atom? x) - (not (pair? x))) - -;;;; equal? -(define (equal? x y) - (cond - ((pair? x) - (and (pair? y) - (equal? (car x) (car y)) - (equal? (cdr x) (cdr y)))) - ((vector? x) - (and (vector? y) (vector-equal? x y))) - ((string? x) - (and (string? y) (string=? x y))) - (else (eqv? x y)))) - -;;;; (do ((var init inc) ...) (endtest result ...) body ...) -;; -(macro do - (lambda (do-macro) - (apply (lambda (do vars endtest . body) - (let ((do-loop (gensym))) - `(letrec ((,do-loop - (lambda ,(map (lambda (x) - (if (pair? x) (car x) x)) - `,vars) - (if ,(car endtest) - (begin ,@(cdr endtest)) - (begin - ,@body - (,do-loop - ,@(map (lambda (x) - (cond - ((not (pair? x)) x) - ((< (length x) 3) (car x)) - (else (car (cdr (cdr x)))))) - `,vars))))))) - (,do-loop - ,@(map (lambda (x) - (if (and (pair? x) (cdr x)) - (car (cdr x)) - '())) - `,vars))))) - do-macro))) - -;;;; generic-member -(define (generic-member cmp obj lst) - (cond - ((null? lst) #f) - ((cmp obj (car lst)) lst) - (else (generic-member cmp obj (cdr lst))))) - -(define (memq obj lst) - (generic-member eq? obj lst)) -(define (memv obj lst) - (generic-member eqv? obj lst)) -(define (member obj lst) - (generic-member equal? obj lst)) - -;;;; generic-assoc -(define (generic-assoc cmp obj alst) - (cond - ((null? alst) #f) - ((cmp obj (caar alst)) (car alst)) - (else (generic-assoc cmp obj (cdr alst))))) - -(define (assq obj alst) - (generic-assoc eq? obj alst)) -(define (assv obj alst) - (generic-assoc eqv? obj alst)) -(define (assoc obj alst) - (generic-assoc equal? obj alst)) - -(define (acons x y z) (cons (cons x y) z)) - -;;;; Handy for imperative programs -;;;; Used as: (define-with-return (foo x y) .... (return z) ...) -(macro (define-with-return form) - `(define ,(cadr form) - (call/cc (lambda (return) ,@(cddr form))))) - -;; Print the given history. -(define (vm-history-print history) - (let loop ((n 0) (skip 0) (frames history)) - (cond - ((null? frames) - #t) - ((> skip 0) - (loop 0 (- skip 1) (cdr frames))) - (else - (let ((f (car frames))) - (display n) - (display ": ") - (let ((tag (get-tag f))) - (when (and (pair? tag) (string? (car tag)) (number? (cdr tag))) - (display (basename (car tag))) - (display ":") - (display (+ 1 (cdr tag))) - (display ": "))) - (write f)) - (newline) - (loop (+ n 1) skip (cdr frames)))))) - -;;;; Simple exception handling -; -; Exceptions are caught as follows: -; -; (catch (do-something to-recover and-return meaningful-value) -; (if-something goes-wrong) -; (with-these calls)) -; -; "Catch" establishes a scope spanning multiple call-frames until -; another "catch" is encountered. Within the recovery expression -; the thrown exception is bound to *error*. Errors can be rethrown -; using (rethrow *error*). -; -; Finalization can be expressed using "finally": -; -; (finally (finalize-something called-purely-for side-effects) -; (whether-or-not something goes-wrong) -; (with-these calls)) -; -; The final expression is executed purely for its side-effects, -; both when the function exits successfully, and when an exception -; is thrown. -; -; Exceptions are thrown with: -; -; (throw "message") -; -; If used outside a (catch ...), reverts to (error "message") - -(define *handlers* (list)) - -(define (push-handler proc) - (set! *handlers* (cons proc *handlers*))) - -(define (pop-handler) - (let ((h (car *handlers*))) - (set! *handlers* (cdr *handlers*)) - h)) - -(define (more-handlers?) - (pair? *handlers*)) - -;; This throws an exception. -(define (throw message . args) - (throw' message args (cdr (*vm-history*)))) - -;; This is used by the vm to throw exceptions. -(define (throw' message args history) - (cond - ((and args (list? args) (= 2 (length args)) - (equal? *interpreter-exit* (car args))) - (*run-atexit-handlers*) - (quit (cadr args))) - ((more-handlers?) - ((pop-handler) message args history)) - (else - (display message) - (when (and args (not (null? args))) - (display ": ") - (if (and (pair? args) (string? (car args))) - (begin (display (car args)) - (unless (null? (cdr args)) - (newline) - (write (cdr args)))) - (write args))) - (newline) - (vm-history-print history) - (quit 1)))) - -;; Convenience function to rethrow the error. -(define (rethrow e) - (apply throw' e)) - -(macro (catch form) - (let ((label (gensym))) - `(call/cc (lambda (**exit**) - (push-handler (lambda *error* (**exit** ,(cadr form)))) - (let ((,label (begin ,@(cddr form)))) - (pop-handler) - ,label))))) - -(define-macro (finally final-expression . expressions) - (let ((result (gensym))) - `(let ((,result (catch (begin ,final-expression (rethrow *error*)) - ,@expressions))) - ,final-expression - ,result))) - -;; Make the vm use throw'. -(define *error-hook* throw') - - - -;; High-level mechanism to terminate the process is to throw an error -;; of the form (*interpreter-exit* status). This gives automatic -;; resource management a chance to clean up. -(define *interpreter-exit* (gensym)) - -;; Terminate the process returning STATUS to the parent. -(define (exit status) - (throw "interpreter exit" *interpreter-exit* status)) - -;; A list of functions run at interpreter shutdown. -(define *atexit-handlers* (list)) - -;; Execute all these functions. -(define (*run-atexit-handlers*) - (unless (null? *atexit-handlers*) - (let ((proc (car *atexit-handlers*))) - ;; Drop proc from the list so that it will not get - ;; executed again even if it raises an exception. - (set! *atexit-handlers* (cdr *atexit-handlers*)) - (proc) - (*run-atexit-handlers*)))) - -;; Register a function to be run at interpreter shutdown. -(define (atexit proc) - (set! *atexit-handlers* (cons proc *atexit-handlers*))) - - - -;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL - -(macro (make-environment form) - `(apply (lambda () - ,@(cdr form) - (current-environment)))) - -(define-macro (eval-polymorphic x . envl) - (display envl) - (let* ((env (if (null? envl) (current-environment) (eval (car envl)))) - (xval (eval x env))) - (if (closure? xval) - (make-closure (get-closure-code xval) env) - xval))) - -; Redefine this if you install another package infrastructure -; Also redefine 'package' -(define *colon-hook* eval) - -(macro (package form) - `(apply (lambda () - ,@(cdr form) - (current-environment)))) - -(define-macro (export name . expressions) - `(define ,name - (begin - ,@expressions))) - -;;;;; I/O - -(define (input-output-port? p) - (and (input-port? p) (output-port? p))) - -(define (close-port p) - (cond - ((input-output-port? p) (close-input-port p) (close-output-port p)) - ((input-port? p) (close-input-port p)) - ((output-port? p) (close-output-port p)) - (else (throw "Not a port" p)))) - -(define (call-with-input-file s p) - (let ((inport (open-input-file s))) - (if (eq? inport #f) - #f - (let ((res (p inport))) - (close-input-port inport) - res)))) - -(define (call-with-output-file s p) - (let ((outport (open-output-file s))) - (if (eq? outport #f) - #f - (let ((res (p outport))) - (close-output-port outport) - res)))) - -(define (with-input-from-file s p) - (let ((inport (open-input-file s))) - (if (eq? inport #f) - #f - (let ((prev-inport (current-input-port))) - (set-input-port inport) - (let ((res (p))) - (close-input-port inport) - (set-input-port prev-inport) - res))))) - -(define (with-output-to-file s p) - (let ((outport (open-output-file s))) - (if (eq? outport #f) - #f - (let ((prev-outport (current-output-port))) - (set-output-port outport) - (let ((res (p))) - (close-output-port outport) - (set-output-port prev-outport) - res))))) - -(define (with-input-output-from-to-files si so p) - (let ((inport (open-input-file si)) - (outport (open-input-file so))) - (if (not (and inport outport)) - (begin - (close-input-port inport) - (close-output-port outport) - #f) - (let ((prev-inport (current-input-port)) - (prev-outport (current-output-port))) - (set-input-port inport) - (set-output-port outport) - (let ((res (p))) - (close-input-port inport) - (close-output-port outport) - (set-input-port prev-inport) - (set-output-port prev-outport) - res))))) - -; Random number generator (maximum cycle) -(define *seed* 1) -(define (random-next) - (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a))) - (set! *seed* - (- (* a (- *seed* - (* (quotient *seed* q) q))) - (* (quotient *seed* q) r))) - (if (< *seed* 0) (set! *seed* (+ *seed* m))) - *seed*)) -;; SRFI-0 -;; COND-EXPAND -;; Implemented as a macro -(define *features* '(srfi-0 tinyscheme)) - -(define-macro (cond-expand . cond-action-list) - (cond-expand-runtime cond-action-list)) - -(define (cond-expand-runtime cond-action-list) - (if (null? cond-action-list) - #t - (if (cond-eval (caar cond-action-list)) - `(begin ,@(cdar cond-action-list)) - (cond-expand-runtime (cdr cond-action-list))))) - -(define (cond-eval-and cond-list) - (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list)) - -(define (cond-eval-or cond-list) - (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list)) - -(define (cond-eval condition) - (cond - ((symbol? condition) - (if (member condition *features*) #t #f)) - ((eq? condition #t) #t) - ((eq? condition #f) #f) - (else (case (car condition) - ((and) (cond-eval-and (cdr condition))) - ((or) (cond-eval-or (cdr condition))) - ((not) (if (not (null? (cddr condition))) - (error "cond-expand : 'not' takes 1 argument") - (not (cond-eval (cadr condition))))) - (else (error "cond-expand : unknown operator" (car condition))))))) - -(gc-verbose #f) diff --git a/lib.scm b/lib.scm deleted file mode 100644 index 258f692..0000000 --- a/lib.scm +++ /dev/null @@ -1,307 +0,0 @@ -;; Additional library functions for TinySCHEME. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(macro (assert form) - (let ((tag (get-tag form))) - `(if (not ,(cadr form)) - (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag))) - `(string-append ,(car tag) ":" - ,(number->string (+ 1 (cdr tag))) - ": Assertion failed: ") - "Assertion failed: ") - (quote ,(cadr form)))))) -(assert #t) -(assert (not #f)) - -;; Trace displays and returns the given value. A debugging aid. -(define (trace x) - (display x) - (newline) - x) - -;; Stringification. -(define (stringify expression) - (let ((p (open-output-string))) - (write expression p) - (get-output-string p))) - -(define (filter pred lst) - (cond ((null? lst) '()) - ((pred (car lst)) - (cons (car lst) (filter pred (cdr lst)))) - (else (filter pred (cdr lst))))) - -(define (any p l) - (cond ((null? l) #f) - ((p (car l)) #t) - (else (any p (cdr l))))) - -(define (all p l) - (cond ((null? l) #t) - ((not (p (car l))) #f) - (else (all p (cdr l))))) - -;; Return the first element of a list. -(define first car) - -;; Return the last element of a list. -(define (last lst) - (if (null? (cdr lst)) - (car lst) - (last (cdr lst)))) - -;; Compute the powerset of a list. -(define (powerset set) - (if (null? set) - '(()) - (let ((rst (powerset (cdr set)))) - (append (map (lambda (x) (cons (car set) x)) - rst) - rst)))) - -;; Is PREFIX a prefix of S? -(define (string-prefix? s prefix) - (and (>= (string-length s) (string-length prefix)) - (string=? prefix (substring s 0 (string-length prefix))))) -(assert (string-prefix? "Scheme" "Sch")) - -;; Is SUFFIX a suffix of S? -(define (string-suffix? s suffix) - (and (>= (string-length s) (string-length suffix)) - (string=? suffix (substring s (- (string-length s) - (string-length suffix)) - (string-length s))))) -(assert (string-suffix? "Scheme" "eme")) - -;; Locate the first occurrence of needle in haystack starting at offset. -(ffi-define (string-index haystack needle [offset])) -(assert (= 2 (string-index "Hallo" #\l))) -(assert (= 3 (string-index "Hallo" #\l 3))) -(assert (equal? #f (string-index "Hallo" #\.))) - -;; Locate the last occurrence of needle in haystack starting at offset. -(ffi-define (string-rindex haystack needle [offset])) -(assert (= 3 (string-rindex "Hallo" #\l))) -(assert (equal? #f (string-rindex "Hallo" #\a 2))) -(assert (equal? #f (string-rindex "Hallo" #\.))) - -;; Split HAYSTACK at each character that makes PREDICATE true at most -;; N times. -(define (string-split-pln haystack predicate lookahead n) - (let ((length (string-length haystack))) - (define (split acc offset n) - (if (>= offset length) - (reverse! acc) - (let ((i (lookahead haystack offset))) - (if (or (eq? i #f) (= 0 n)) - (reverse! (cons (substring haystack offset length) acc)) - (split (cons (substring haystack offset i) acc) - (+ i 1) (- n 1)))))) - (split '() 0 n))) - -(define (string-indexp haystack offset predicate) - (cond - ((= (string-length haystack) offset) - #f) - ((predicate (string-ref haystack offset)) - offset) - (else - (string-indexp haystack (+ 1 offset) predicate)))) - -;; Split HAYSTACK at each character that makes PREDICATE true at most -;; N times. -(define (string-splitp haystack predicate n) - (string-split-pln haystack predicate - (lambda (haystack offset) - (string-indexp haystack offset predicate)) - n)) -(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1))) -(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1))) -(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1))) - -;; Split haystack at delimiter at most n times. -(define (string-splitn haystack delimiter n) - (string-split-pln haystack - (lambda (c) (char=? c delimiter)) - (lambda (haystack offset) - (string-index haystack delimiter offset)) - n)) -(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1)))) -(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1)))) -(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1)))) - -;; Split haystack at delimiter. -(define (string-split haystack delimiter) - (string-splitn haystack delimiter -1)) -(assert (= 3 (length (string-split "foo:bar:baz" #\:)))) -(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:)))) -(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:)))) -(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:)))) - -;; Split haystack at newlines. -(define (string-split-newlines haystack) - (if *win32* - (map (lambda (line) (if (string-suffix? line "\r") - (substring line 0 (- (string-length line) 1)) - line)) - (string-split haystack #\newline)) - (string-split haystack #\newline))) - -;; Trim the prefix of S containing only characters that make PREDICATE -;; true. -(define (string-ltrim predicate s) - (if (string=? s "") - "" - (let loop ((s' (string->list s))) - (if (predicate (car s')) - (loop (cdr s')) - (list->string s'))))) -(assert (string=? "" (string-ltrim char-whitespace? ""))) -(assert (string=? "foo" (string-ltrim char-whitespace? " foo"))) - -;; Trim the suffix of S containing only characters that make PREDICATE -;; true. -(define (string-rtrim predicate s) - (if (string=? s "") - "" - (let loop ((s' (reverse! (string->list s)))) - (if (predicate (car s')) - (loop (cdr s')) - (list->string (reverse! s')))))) -(assert (string=? "" (string-rtrim char-whitespace? ""))) -(assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) - -;; Trim both the prefix and suffix of S containing only characters -;; that make PREDICATE true. -(define (string-trim predicate s) - (string-ltrim predicate (string-rtrim predicate s))) -(assert (string=? "" (string-trim char-whitespace? ""))) -(assert (string=? "foo" (string-trim char-whitespace? " foo "))) - -;; Check if needle is contained in haystack. -(ffi-define (string-contains? haystack needle)) -(assert (string-contains? "Hallo" "llo")) -(assert (not (string-contains? "Hallo" "olla"))) - -;; Translate characters. -(define (string-translate s from to) - (list->string (map (lambda (c) - (let ((i (string-index from c))) - (if i (string-ref to i) c))) (string->list s)))) -(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar")) - -;; Read a word from port P. -(define (read-word . p) - (list->string - (let f () - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) '()) - ((char-alphabetic? c) - (apply read-char p) - (cons c (f))) - (else - (apply read-char p) - '())))))) - -(define (list->string-reversed lst) - (let* ((len (length lst)) - (str (make-string len))) - (let loop ((i (- len 1)) - (l lst)) - (if (< i 0) - (begin - (assert (null? l)) - str) - (begin - (string-set! str i (car l)) - (loop (- i 1) (cdr l))))))) - -;; Read a line from port P. -(define (read-line . p) - (let loop ((acc '())) - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) - (if (null? acc) - c ;; #eof - (list->string-reversed acc))) - ((char=? c #\newline) - (apply read-char p) - (list->string-reversed acc)) - (else - (apply read-char p) - (loop (cons c acc))))))) - -;; Read everything from port P. -(define (read-all . p) - (let loop ((acc (open-output-string))) - (let ((c (apply peek-char p))) - (cond - ((eof-object? c) (get-output-string acc)) - (else - (write-char (apply read-char p) acc) - (loop acc)))))) - -;; -;; Windows support. -;; - -;; Like call-with-input-file but opens the file in 'binary' mode. -(define (call-with-binary-input-file filename proc) - (letfd ((fd (open filename (logior O_RDONLY O_BINARY)))) - (proc (fdopen fd "rb")))) - -;; Like call-with-output-file but opens the file in 'binary' mode. -(define (call-with-binary-output-file filename proc) - (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600))) - (proc (fdopen fd "wb")))) - -;; -;; Libc functions. -;; - -;; Change the read/write offset. -(ffi-define (seek fd offset whence)) - -;; Constants for WHENCE. -(ffi-define SEEK_SET) -(ffi-define SEEK_CUR) -(ffi-define SEEK_END) - -;; Get our process id. -(ffi-define (getpid)) - -;; Copy data from file descriptor SOURCE to every file descriptor in -;; SINKS. -(ffi-define (splice source . sinks)) - -;; -;; Random numbers. -;; - -;; Seed the random number generator. -(ffi-define (srandom seed)) - -;; Get a pseudo-random number between 0 (inclusive) and SCALE -;; (exclusive). -(ffi-define (random scale)) - -;; Create a string of the given SIZE containing pseudo-random data. -(ffi-define (make-random-string size)) diff --git a/main.c b/main.c deleted file mode 100644 index 5540ac3..0000000 --- a/main.c +++ /dev/null @@ -1,359 +0,0 @@ -/* TinyScheme-based test driver. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#if HAVE_MMAP -#include -#endif - -#include "private.h" -#include "scheme.h" -#include "scheme-private.h" -#include "ffi.h" -#include "../common/i18n.h" -#include "../../common/argparse.h" -#include "../../common/init.h" -#include "../../common/logging.h" -#include "../../common/strlist.h" -#include "../../common/sysutils.h" -#include "../../common/util.h" - -/* The TinyScheme banner. Unfortunately, it isn't in the header - file. */ -#define ts_banner "TinyScheme 1.41" - -int verbose; - - - -/* Constants to identify the commands and options. */ -enum cmd_and_opt_values - { - aNull = 0, - oVerbose = 'v', - }; - -/* The list of commands and options. */ -static ARGPARSE_OPTS opts[] = - { - ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")), - ARGPARSE_end (), - }; - -char *scmpath = ""; -size_t scmpath_len = 0; - -/* Command line parsing. */ -static void -parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) -{ - int no_more_options = 0; - - while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts)) - { - switch (pargs->r_opt) - { - case oVerbose: - verbose++; - break; - - default: - pargs->err = 2; - break; - } - } -} - -/* Print usage information and provide strings for help. */ -static const char * -my_strusage( int level ) -{ - const char *p; - - switch (level) - { - case 11: p = "gpgscm (@GNUPG@)"; - break; - case 13: p = VERSION; break; - case 17: p = PRINTABLE_OS_NAME; break; - case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break; - - case 1: - case 40: - p = _("Usage: gpgscm [options] [file] (-h for help)"); - break; - case 41: - p = _("Syntax: gpgscm [options] [file]\n" - "Execute the given Scheme program, or spawn interactive shell.\n"); - break; - - default: p = NULL; break; - } - return p; -} - - - -static int -path_absolute_p (const char *p) -{ -#if _WIN32 - return ((strlen (p) > 2 && p[1] == ':' && (p[2] == '\\' || p[2] == '/')) - || p[0] == '\\' || p[0] == '/'); -#else - return p[0] == '/'; -#endif -} - - -/* Load the Scheme program from FILE_NAME. If FILE_NAME is not an - absolute path, and LOOKUP_IN_PATH is given, then it is qualified - with the values in scmpath until the file is found. */ -static gpg_error_t -load (scheme *sc, char *file_name, - int lookup_in_cwd, int lookup_in_path) -{ - gpg_error_t err = 0; - size_t n; - const char *directory; - char *qualified_name = file_name; - int use_path; - FILE *h = NULL; - - use_path = - lookup_in_path && ! (path_absolute_p (file_name) || scmpath_len == 0); - - if (path_absolute_p (file_name) || lookup_in_cwd || scmpath_len == 0) - { - h = fopen (file_name, "r"); - if (! h) - err = gpg_error_from_syserror (); - } - - if (h == NULL && use_path) - for (directory = scmpath, n = scmpath_len; n; - directory += strlen (directory) + 1, n--) - { - if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0) - return gpg_error_from_syserror (); - - h = fopen (qualified_name, "r"); - if (h) - { - err = 0; - break; - } - - if (n > 1) - { - free (qualified_name); - continue; /* Try again! */ - } - - err = gpg_error_from_syserror (); - } - - if (h == NULL) - { - /* Failed and no more elements in scmpath to try. */ - fprintf (stderr, "Could not read %s: %s.\n", - qualified_name, gpg_strerror (err)); - if (lookup_in_path) - fprintf (stderr, - "Consider using GPGSCM_PATH to specify the location " - "of the Scheme library.\n"); - goto leave; - } - if (verbose > 2) - fprintf (stderr, "Loading %s...\n", qualified_name); - -#if HAVE_MMAP - /* Always try to mmap the file. This allows the pages to be shared - * between processes. If anything fails, we fall back to using - * buffered streams. */ - if (1) - { - struct stat st; - void *map; - size_t len; - int fd = fileno (h); - - if (fd < 0) - goto fallback; - - if (fstat (fd, &st)) - goto fallback; - - len = (size_t) st.st_size; - if ((off_t) len != st.st_size) - goto fallback; /* Truncated. */ - - map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0); - if (map == MAP_FAILED) - goto fallback; - - scheme_load_memory (sc, map, len, qualified_name); - munmap (map, len); - } - else - fallback: -#endif - scheme_load_named_file (sc, h, qualified_name); - fclose (h); - - if (sc->retcode && sc->nesting) - { - fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); - err = gpg_error (GPG_ERR_GENERAL); - } - - leave: - if (file_name != qualified_name) - free (qualified_name); - return err; -} - - - -int -main (int argc, char **argv) -{ - int retcode; - gpg_error_t err; - char *argv0; - ARGPARSE_ARGS pargs; - scheme *sc; - char *p; -#if _WIN32 - char pathsep = ';'; -#else - char pathsep = ':'; -#endif - char *script = NULL; - - /* Save argv[0] so that we can re-exec. */ - argv0 = argv[0]; - - /* Parse path. */ - if (getenv ("GPGSCM_PATH")) - scmpath = getenv ("GPGSCM_PATH"); - - p = scmpath = strdup (scmpath); - if (p == NULL) - return 2; - - if (*p) - scmpath_len++; - for (; *p; p++) - if (*p == pathsep) - *p = 0, scmpath_len++; - - set_strusage (my_strusage); - log_set_prefix ("gpgscm", GPGRT_LOG_WITH_PREFIX); - - /* Make sure that our subsystems are ready. */ - i18n_init (); - init_common_subsystems (&argc, &argv); - - if (!gcry_check_version (NEED_LIBGCRYPT_VERSION)) - { - fputs ("libgcrypt version mismatch\n", stderr); - exit (2); - } - - /* Parse the command line. */ - pargs.argc = &argc; - pargs.argv = &argv; - pargs.flags = 0; - parse_arguments (&pargs, opts); - - if (log_get_errorcount (0)) - exit (2); - - sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free); - if (! sc) { - fprintf (stderr, "Could not initialize TinyScheme!\n"); - return 2; - } - scheme_set_input_port_file (sc, stdin); - scheme_set_output_port_file (sc, stderr); - - if (argc) - { - script = argv[0]; - argc--, argv++; - } - - err = load (sc, "init.scm", 0, 1); - if (! err) - err = load (sc, "ffi.scm", 0, 1); - if (! err) - err = ffi_init (sc, argv0, script ? script : "interactive", - argc, (const char **) argv); - if (! err) - err = load (sc, "lib.scm", 0, 1); - if (! err) - err = load (sc, "repl.scm", 0, 1); - if (! err) - err = load (sc, "xml.scm", 0, 1); - if (! err) - err = load (sc, "tests.scm", 0, 1); - if (! err) - err = load (sc, "gnupg.scm", 0, 1); - if (err) - { - fprintf (stderr, "Error initializing gpgscm: %s.\n", - gpg_strerror (err)); - exit (2); - } - - if (script == NULL) - { - /* Interactive shell. */ - fprintf (stderr, "gpgscm/"ts_banner".\n"); - scheme_load_string (sc, "(interactive-repl)"); - } - else - { - err = load (sc, script, 1, 1); - if (err) - log_fatal ("%s: %s", script, gpg_strerror (err)); - } - - retcode = sc->retcode; - scheme_load_string (sc, "(*run-atexit-handlers*)"); - scheme_deinit (sc); - xfree (sc); - return retcode; -} diff --git a/makefile.scm b/makefile.scm deleted file mode 100644 index 32fae3a..0000000 --- a/makefile.scm +++ /dev/null @@ -1,76 +0,0 @@ -;; Support for parsing Makefiles -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(define (parse-makefile port key) - (define (is-continuation? tokens) - (string=? (last tokens) "\\")) - (define (valid-token? s) - (< 0 (string-length s))) - (define (drop-continuations tokens) - (let loop ((acc '()) (tks tokens)) - (if (null? tks) - (reverse acc) - (loop (if (string=? "\\" (car tks)) - acc - (cons (car tks) acc)) (cdr tks))))) - (let next ((acc '()) (found #f)) - (let ((line (read-line port))) - (if (eof-object? line) - acc - (let ((tokens (filter valid-token? - (string-splitp (string-trim char-whitespace? - line) - char-whitespace? -1)))) - (cond - ((or (null? tokens) - (string-prefix? (car tokens) "#") - (and (not found) (not (and (string=? key (car tokens)) - (string=? "=" (cadr tokens)))))) - (next acc found)) - ((not found) - (assert (and (string=? key (car tokens)) - (string=? "=" (cadr tokens)))) - (if (is-continuation? tokens) - (next (drop-continuations (cddr tokens)) #t) - (drop-continuations (cddr tokens)))) - (else - (assert found) - (if (is-continuation? tokens) - (next (append acc (drop-continuations tokens)) found) - (append acc (drop-continuations tokens)))))))))) - -(define (parse-makefile-expand filename expand key) - (define (variable? v) - (and (string-prefix? v "$(") (string-suffix? v ")"))) - - (let expand-all ((values (parse-makefile (open-input-file filename) key))) - (if (any variable? values) - (expand-all - (let expand-one ((acc '()) (v values)) - (cond - ((null? v) - acc) - ((variable? (car v)) - (let ((makefile (open-input-file filename)) - (key (substring (car v) 2 (- (string-length (car v)) 1)))) - (expand-one (append acc (expand filename makefile key)) - (cdr v)))) - (else - (expand-one (append acc (list (car v))) (cdr v)))))) - values))) diff --git a/opdefines.h b/opdefines.h deleted file mode 100644 index 61f7971..0000000 --- a/opdefines.h +++ /dev/null @@ -1,205 +0,0 @@ -_OP_DEF("load", 1, 1, TST_STRING, OP_LOAD ) -_OP_DEF(0, 0, 0, 0, OP_T0LVL ) -_OP_DEF(0, 0, 0, 0, OP_T1LVL ) -_OP_DEF(0, 0, 0, 0, OP_READ_INTERNAL ) -_OP_DEF("gensym", 0, 0, 0, OP_GENSYM ) -_OP_DEF(0, 0, 0, 0, OP_VALUEPRINT ) -_OP_DEF(0, 0, 0, 0, OP_EVAL ) -#if USE_TRACING -_OP_DEF(0, 0, 0, 0, OP_REAL_EVAL ) -#endif -_OP_DEF(0, 0, 0, 0, OP_E0ARGS ) -_OP_DEF(0, 0, 0, 0, OP_E1ARGS ) -#if USE_HISTORY -_OP_DEF(0, 0, 0, 0, OP_CALLSTACK_POP ) -#endif -_OP_DEF(0, 0, 0, 0, OP_APPLY_CODE ) -_OP_DEF(0, 0, 0, 0, OP_APPLY ) -#if USE_TRACING -_OP_DEF(0, 0, 0, 0, OP_REAL_APPLY ) -_OP_DEF("tracing", 1, 1, TST_NATURAL, OP_TRACING ) -#endif -_OP_DEF(0, 0, 0, 0, OP_DOMACRO ) -_OP_DEF(0, 0, 0, 0, OP_LAMBDA ) -_OP_DEF(0, 0, 0, 0, OP_LAMBDA1 ) -_OP_DEF("make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) -_OP_DEF(0, 0, 0, 0, OP_QUOTE ) -_OP_DEF(0, 0, 0, 0, OP_DEF0 ) -_OP_DEF(0, 0, 0, 0, OP_DEF1 ) -_OP_DEF("defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) -_OP_DEF(0, 0, 0, 0, OP_BEGIN ) -_OP_DEF(0, 0, 0, 0, OP_IF0 ) -_OP_DEF(0, 0, 0, 0, OP_IF1 ) -_OP_DEF(0, 0, 0, 0, OP_SET0 ) -_OP_DEF(0, 0, 0, 0, OP_SET1 ) -_OP_DEF(0, 0, 0, 0, OP_LET0 ) -_OP_DEF(0, 0, 0, 0, OP_LET1 ) -_OP_DEF(0, 0, 0, 0, OP_LET2 ) -_OP_DEF(0, 0, 0, 0, OP_LET0AST ) -_OP_DEF(0, 0, 0, 0, OP_LET1AST ) -_OP_DEF(0, 0, 0, 0, OP_LET2AST ) -_OP_DEF(0, 0, 0, 0, OP_LET0REC ) -_OP_DEF(0, 0, 0, 0, OP_LET1REC ) -_OP_DEF(0, 0, 0, 0, OP_LET2REC ) -_OP_DEF(0, 0, 0, 0, OP_COND0 ) -_OP_DEF(0, 0, 0, 0, OP_COND1 ) -_OP_DEF(0, 0, 0, 0, OP_DELAY ) -_OP_DEF(0, 0, 0, 0, OP_AND0 ) -_OP_DEF(0, 0, 0, 0, OP_AND1 ) -_OP_DEF(0, 0, 0, 0, OP_OR0 ) -_OP_DEF(0, 0, 0, 0, OP_OR1 ) -_OP_DEF(0, 0, 0, 0, OP_C0STREAM ) -_OP_DEF(0, 0, 0, 0, OP_C1STREAM ) -_OP_DEF(0, 0, 0, 0, OP_MACRO0 ) -_OP_DEF(0, 0, 0, 0, OP_MACRO1 ) -_OP_DEF(0, 0, 0, 0, OP_CASE0 ) -_OP_DEF(0, 0, 0, 0, OP_CASE1 ) -_OP_DEF(0, 0, 0, 0, OP_CASE2 ) -_OP_DEF("eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) -_OP_DEF("apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) -_OP_DEF("call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) -#if USE_MATH -_OP_DEF("inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) -_OP_DEF("exp", 1, 1, TST_NUMBER, OP_EXP ) -_OP_DEF("log", 1, 1, TST_NUMBER, OP_LOG ) -_OP_DEF("sin", 1, 1, TST_NUMBER, OP_SIN ) -_OP_DEF("cos", 1, 1, TST_NUMBER, OP_COS ) -_OP_DEF("tan", 1, 1, TST_NUMBER, OP_TAN ) -_OP_DEF("asin", 1, 1, TST_NUMBER, OP_ASIN ) -_OP_DEF("acos", 1, 1, TST_NUMBER, OP_ACOS ) -_OP_DEF("atan", 1, 2, TST_NUMBER, OP_ATAN ) -_OP_DEF("sqrt", 1, 1, TST_NUMBER, OP_SQRT ) -_OP_DEF("expt", 2, 2, TST_NUMBER, OP_EXPT ) -_OP_DEF("floor", 1, 1, TST_NUMBER, OP_FLOOR ) -_OP_DEF("ceiling", 1, 1, TST_NUMBER, OP_CEILING ) -_OP_DEF("truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) -_OP_DEF("round", 1, 1, TST_NUMBER, OP_ROUND ) -#endif -_OP_DEF("+", 0, INF_ARG, TST_NUMBER, OP_ADD ) -_OP_DEF("-", 1, INF_ARG, TST_NUMBER, OP_SUB ) -_OP_DEF("*", 0, INF_ARG, TST_NUMBER, OP_MUL ) -_OP_DEF("/", 1, INF_ARG, TST_NUMBER, OP_DIV ) -_OP_DEF("quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) -_OP_DEF("remainder", 2, 2, TST_INTEGER, OP_REM ) -_OP_DEF("modulo", 2, 2, TST_INTEGER, OP_MOD ) -_OP_DEF("car", 1, 1, TST_PAIR, OP_CAR ) -_OP_DEF("cdr", 1, 1, TST_PAIR, OP_CDR ) -_OP_DEF("cons", 2, 2, TST_NONE, OP_CONS ) -_OP_DEF("set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) -_OP_DEF("set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) -_OP_DEF("char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) -_OP_DEF("integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) -_OP_DEF("char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) -_OP_DEF("char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) -_OP_DEF("symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) -_OP_DEF("atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) -_OP_DEF("string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) -_OP_DEF("string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) -_OP_DEF("make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) -_OP_DEF("string-length", 1, 1, TST_STRING, OP_STRLEN ) -_OP_DEF("string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) -_OP_DEF("string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) -_OP_DEF("string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) -_OP_DEF("substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) -_OP_DEF("vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) -_OP_DEF("make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) -_OP_DEF("vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) -_OP_DEF("vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) -_OP_DEF("vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) -_OP_DEF("not", 1, 1, TST_NONE, OP_NOT ) -_OP_DEF("boolean?", 1, 1, TST_NONE, OP_BOOLP ) -_OP_DEF("eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) -_OP_DEF("null?", 1, 1, TST_NONE, OP_NULLP ) -_OP_DEF("=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) -_OP_DEF("<", 2, INF_ARG, TST_NUMBER, OP_LESS ) -_OP_DEF(">", 2, INF_ARG, TST_NUMBER, OP_GRE ) -_OP_DEF("<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) -_OP_DEF(">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) -_OP_DEF("symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) -_OP_DEF("number?", 1, 1, TST_ANY, OP_NUMBERP ) -_OP_DEF("string?", 1, 1, TST_ANY, OP_STRINGP ) -_OP_DEF("integer?", 1, 1, TST_ANY, OP_INTEGERP ) -_OP_DEF("real?", 1, 1, TST_ANY, OP_REALP ) -_OP_DEF("char?", 1, 1, TST_ANY, OP_CHARP ) -#if USE_CHAR_CLASSIFIERS -_OP_DEF("char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) -_OP_DEF("char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) -_OP_DEF("char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) -_OP_DEF("char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) -_OP_DEF("char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) -#endif -_OP_DEF("port?", 1, 1, TST_ANY, OP_PORTP ) -_OP_DEF("input-port?", 1, 1, TST_ANY, OP_INPORTP ) -_OP_DEF("output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) -_OP_DEF("procedure?", 1, 1, TST_ANY, OP_PROCP ) -_OP_DEF("pair?", 1, 1, TST_ANY, OP_PAIRP ) -_OP_DEF("list?", 1, 1, TST_ANY, OP_LISTP ) -_OP_DEF("environment?", 1, 1, TST_ANY, OP_ENVP ) -_OP_DEF("vector?", 1, 1, TST_ANY, OP_VECTORP ) -_OP_DEF("eq?", 2, 2, TST_ANY, OP_EQ ) -_OP_DEF("eqv?", 2, 2, TST_ANY, OP_EQV ) -_OP_DEF("force", 1, 1, TST_ANY, OP_FORCE ) -_OP_DEF(0, 0, 0, 0, OP_SAVE_FORCED ) -_OP_DEF("write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) -_OP_DEF("write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) -_OP_DEF("display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) -_OP_DEF("newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) -_OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 ) -_OP_DEF(0, 0, 0, 0, OP_ERR1 ) -_OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE ) -_OP_DEF("reverse!", 1, 1, TST_LIST, OP_REVERSE_IN_PLACE ) -_OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) -_OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND ) -#if USE_PLIST -_OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY ) -_OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY ) -#endif -_OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE ) -_OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED ) -_OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG ) -_OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT ) -_OP_DEF("gc", 0, 0, 0, OP_GC ) -_OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) -_OP_DEF("new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) -_OP_DEF("oblist", 0, 0, 0, OP_OBLIST ) -_OP_DEF("current-input-port", 0, 0, 0, OP_CURR_INPORT ) -_OP_DEF("current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) -_OP_DEF("open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) -_OP_DEF("open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) -_OP_DEF("open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) -#if USE_STRING_PORTS -_OP_DEF("open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) -_OP_DEF("open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) -_OP_DEF("open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) -_OP_DEF("get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) -#endif -_OP_DEF("close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) -_OP_DEF("close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) -_OP_DEF("interaction-environment", 0, 0, 0, OP_INT_ENV ) -_OP_DEF("current-environment", 0, 0, 0, OP_CURR_ENV ) -_OP_DEF("read", 0, 1, TST_INPORT, OP_READ ) -_OP_DEF("read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) -_OP_DEF("peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) -_OP_DEF("char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) -_OP_DEF("set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) -_OP_DEF("set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) -_OP_DEF(0, 0, 0, 0, OP_RDSEXPR ) -_OP_DEF(0, 0, 0, 0, OP_RDLIST ) -_OP_DEF(0, 0, 0, 0, OP_RDDOT ) -_OP_DEF(0, 0, 0, 0, OP_RDQUOTE ) -_OP_DEF(0, 0, 0, 0, OP_RDQQUOTE ) -_OP_DEF(0, 0, 0, 0, OP_RDQQUOTEVEC ) -_OP_DEF(0, 0, 0, 0, OP_RDUNQUOTE ) -_OP_DEF(0, 0, 0, 0, OP_RDUQTSP ) -_OP_DEF(0, 0, 0, 0, OP_RDVEC ) -_OP_DEF(0, 0, 0, 0, OP_P0LIST ) -_OP_DEF(0, 0, 0, 0, OP_P1LIST ) -_OP_DEF(0, 0, 0, 0, OP_PVECFROM ) -_OP_DEF("length", 1, 1, TST_LIST, OP_LIST_LENGTH ) -_OP_DEF("assq", 2, 2, TST_NONE, OP_ASSQ ) -_OP_DEF("get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) -_OP_DEF("closure?", 1, 1, TST_NONE, OP_CLOSUREP ) -_OP_DEF("macro?", 1, 1, TST_NONE, OP_MACROP ) -_OP_DEF("*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY ) - -#undef _OP_DEF diff --git a/private.h b/private.h deleted file mode 100644 index 6e330e0..0000000 --- a/private.h +++ /dev/null @@ -1,26 +0,0 @@ -/* TinyScheme-based test driver. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#ifndef __GPGSCM_PRIVATE_H__ -#define __GPGSCM_PRIVATE_H__ - -extern int verbose; - -#endif /* __GPGSCM_PRIVATE_H__ */ diff --git a/repl.scm b/repl.scm deleted file mode 100644 index 833ec0d..0000000 --- a/repl.scm +++ /dev/null @@ -1,69 +0,0 @@ -;; A read-evaluate-print-loop for gpgscm. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Interactive repl using 'prompt' function. P must be a function -;; that given the current entered prefix returns the prompt to -;; display. -(define (repl p environment) - (call/cc - (lambda (exit) - (let loop ((prefix "")) - (let ((line (prompt (p prefix)))) - (if (and (not (eof-object? line)) (= 0 (string-length line))) - (exit (loop prefix))) - (if (not (eof-object? line)) - (let* ((next (string-append prefix line)) - (c (catch (begin (echo "Parse error:" *error*) - (loop prefix)) - (read (open-input-string next))))) - (if (not (eof-object? c)) - (begin - (catch (begin - (display (car *error*)) - (when (and (cadr *error*) - (not (null? (cadr *error*)))) - (display ": ") - (write (cadr *error*))) - (newline) - (vm-history-print (caddr *error*))) - (echo " ===>" (eval c environment))) - (exit (loop "")))) - (exit (loop next))))))))) - -(define (prompt-append-prefix prompt prefix) - (string-append prompt (if (> (string-length prefix) 0) - (string-append prefix "...") - "> "))) - -;; Default repl run by main.c. -(define (interactive-repl . environment) - (repl (lambda (p) (prompt-append-prefix "gpgscm " p)) - (if (null? environment) (interaction-environment) (car environment)))) - -;; Ask a yes/no question. -(define (prompt-yes-no? question default) - (let ((answer (prompt (string-append question "? [" - (if default "Y/n" "y/N") "] ")))) - (cond - ((= 0 (string-length answer)) - default) - ((or (equal? "y" answer) (equal? "Y" answer)) - #t) - (else - #f)))) diff --git a/scheme-config.h b/scheme-config.h deleted file mode 100644 index 15ca969..0000000 --- a/scheme-config.h +++ /dev/null @@ -1,32 +0,0 @@ -/* TinyScheme configuration. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#define STANDALONE 0 -#define USE_MATH 0 -#define USE_CHAR_CLASSIFIERS 1 -#define USE_ASCII_NAMES 1 -#define USE_STRING_PORTS 1 -#define USE_ERROR_HOOK 1 -#define USE_TRACING 1 -#define USE_COLON_HOOK 1 -#define USE_DL 0 -#define USE_PLIST 0 -#define USE_INTERFACE 1 -#define SHOW_ERROR_LINE 1 diff --git a/scheme-private.h b/scheme-private.h deleted file mode 100644 index 7f92bda..0000000 --- a/scheme-private.h +++ /dev/null @@ -1,274 +0,0 @@ -/* scheme-private.h */ - -#ifndef _SCHEME_PRIVATE_H -#define _SCHEME_PRIVATE_H - -#include -#include "scheme.h" -/*------------------ Ugly internals -----------------------------------*/ -/*------------------ Of interest only to FFI users --------------------*/ - -#ifdef __cplusplus -extern "C" { -#endif - -enum scheme_port_kind { - port_free=0, - port_file=1, - port_string=2, - port_srfi6=4, - port_input=16, - port_output=32, - port_saw_EOF=64 -}; - -typedef struct port { - unsigned char kind; - union { - struct { - FILE *file; - int closeit; - } stdio; - struct { - char *start; - char *past_the_end; - char *curr; - } string; - } rep; -#if SHOW_ERROR_LINE - pointer curr_line; - pointer filename; -#endif -} port; - -/* cell structure */ -struct cell { - uintptr_t _flag; - union { - num _number; - struct { - char *_svalue; - int _length; - } _string; - port *_port; - foreign_func _ff; - struct { - struct cell *_car; - struct cell *_cdr; - } _cons; - struct { - size_t _length; - pointer _elements[0]; - } _vector; - struct { - char *_data; - const foreign_object_vtable *_vtable; - } _foreign_object; - } _object; -}; - -#if USE_HISTORY -/* The history is a two-dimensional ring buffer. A donut-shaped data - * structure. This data structure is inspired by MIT/GNU Scheme. */ -struct history { - /* Number of calls to store. Must be a power of two. */ - size_t N; - - /* Number of tail-calls to store in each call frame. Must be a - * power of two. */ - size_t M; - - /* Masks for fast index calculations. */ - size_t mask_N; - size_t mask_M; - - /* A vector of size N containing calls. */ - pointer callstack; - - /* A vector of size N containing vectors of size M containing tail - * calls. */ - pointer tailstacks; - - /* Our current position. */ - size_t n; - size_t *m; -}; -#endif - -struct scheme { -/* arrays for segments */ -func_alloc malloc; -func_dealloc free; - -/* return code */ -int retcode; -int tracing; - - -#ifndef CELL_SEGSIZE -#define CELL_SEGSIZE 5000 /* # of cells in one segment */ -#endif - -/* If less than # of cells are recovered in a garbage collector run, - * allocate a new cell segment to avoid fruitless collection cycles in - * the near future. */ -#ifndef CELL_MINRECOVER -#define CELL_MINRECOVER (CELL_SEGSIZE >> 2) -#endif -struct cell_segment *cell_segments; - -/* We use 4 registers. */ -pointer args; /* register for arguments of function */ -pointer envir; /* stack register for current environment */ -pointer code; /* register for current code */ -pointer dump; /* stack register for next evaluation */ -pointer frame_freelist; - -#if USE_HISTORY -struct history history; /* we keep track of the call history for - * error messages */ -#endif - -int interactive_repl; /* are we in an interactive REPL? */ - -struct cell _sink; -pointer sink; /* when mem. alloc. fails */ -struct cell _NIL; -pointer NIL; /* special cell representing empty cell */ -struct cell _HASHT; -pointer T; /* special cell representing #t */ -struct cell _HASHF; -pointer F; /* special cell representing #f */ -struct cell _EOF_OBJ; -pointer EOF_OBJ; /* special cell representing end-of-file object */ -pointer oblist; /* pointer to symbol table */ -pointer global_env; /* pointer to global environment */ -pointer c_nest; /* stack for nested calls from C */ - -/* global pointers to special symbols */ -pointer LAMBDA; /* pointer to syntax lambda */ -pointer QUOTE; /* pointer to syntax quote */ - -pointer QQUOTE; /* pointer to symbol quasiquote */ -pointer UNQUOTE; /* pointer to symbol unquote */ -pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ -pointer FEED_TO; /* => */ -pointer COLON_HOOK; /* *colon-hook* */ -pointer ERROR_HOOK; /* *error-hook* */ -pointer SHARP_HOOK; /* *sharp-hook* */ -#if USE_COMPILE_HOOK -pointer COMPILE_HOOK; /* *compile-hook* */ -#endif - -pointer free_cell; /* pointer to top of free cells */ -long fcells; /* # of free cells */ -size_t inhibit_gc; /* nesting of gc_disable */ -size_t reserved_cells; /* # of reserved cells */ -#ifndef NDEBUG -int reserved_lineno; /* location of last reservation */ -#endif - -pointer inport; -pointer outport; -pointer save_inport; -pointer loadport; - -#ifndef MAXFIL -#define MAXFIL 64 -#endif -port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ -int nesting_stack[MAXFIL]; -int file_i; -int nesting; - -char gc_verbose; /* if gc_verbose is not zero, print gc status */ -char no_memory; /* Whether mem. alloc. has failed */ - -#ifndef LINESIZE -#define LINESIZE 1024 -#endif -char linebuff[LINESIZE]; -#ifndef STRBUFFSIZE -#define STRBUFFSIZE 256 -#endif -char *strbuff; -size_t strbuff_size; -FILE *tmpfp; -int tok; -int print_flag; -pointer value; -unsigned int flags; - -void *ext_data; /* For the benefit of foreign functions */ -long gensym_cnt; - -const struct scheme_interface *vptr; -}; - -/* operator code */ -enum scheme_opcodes { -#define _OP_DEF(A,B,C,D,OP) OP, -#include "opdefines.h" - OP_MAXDEFINED -}; - - -#define cons(sc,a,b) _cons(sc,a,b,0) -#define immutable_cons(sc,a,b) _cons(sc,a,b,1) - -int is_string(pointer p); -char *string_value(pointer p); -int is_number(pointer p); -num nvalue(pointer p); -long ivalue(pointer p); -double rvalue(pointer p); -int is_integer(pointer p); -int is_real(pointer p); -int is_character(pointer p); -long charvalue(pointer p); -int is_vector(pointer p); - -int is_port(pointer p); - -int is_pair(pointer p); -pointer pair_car(pointer p); -pointer pair_cdr(pointer p); -pointer set_car(pointer p, pointer q); -pointer set_cdr(pointer p, pointer q); - -int is_symbol(pointer p); -char *symname(pointer p); -int hasprop(pointer p); - -int is_syntax(pointer p); -int is_proc(pointer p); -int is_foreign(pointer p); -char *syntaxname(pointer p); -int is_closure(pointer p); -#ifdef USE_MACRO -int is_macro(pointer p); -#endif -pointer closure_code(pointer p); -pointer closure_env(pointer p); - -int is_continuation(pointer p); -int is_promise(pointer p); -int is_environment(pointer p); -int is_immutable(pointer p); -void setimmutable(pointer p); - -int is_foreign_object(pointer p); -const foreign_object_vtable *get_foreign_object_vtable(pointer p); -void *get_foreign_object_data(pointer p); - -#ifdef __cplusplus -} -#endif - -#endif - -/* -Local variables: -c-file-style: "k&r" -End: -*/ diff --git a/scheme.c b/scheme.c deleted file mode 100644 index 4384841..0000000 --- a/scheme.c +++ /dev/null @@ -1,6028 +0,0 @@ -/* T I N Y S C H E M E 1 . 4 1 - * Dimitrios Souflis (dsouflis@acm.org) - * Based on MiniScheme (original credits follow) - * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) - * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp - * (MINISCM) This version has been modified by R.C. Secrist. - * (MINISCM) - * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. - * (MINISCM) - * (MINISCM) This is a revised and modified version by Akira KIDA. - * (MINISCM) current version is 0.85k4 (15 May 1994) - * - */ - -#ifdef HAVE_CONFIG_H -# include -#endif - -#define _SCHEME_SOURCE -#include "scheme-private.h" -#ifndef WIN32 -# include -#endif -#ifdef WIN32 -#define snprintf _snprintf -#endif -#if USE_DL -# include "dynload.h" -#endif -#if USE_MATH -# include -#endif - -#include -#include -#include -#include -#include - -#if USE_STRCASECMP -#include -# ifndef __APPLE__ -# define stricmp strcasecmp -# endif -#endif - -/* Used for documentation purposes, to signal functions in 'interface' */ -#define INTERFACE - -#define TOK_EOF (-1) -#define TOK_LPAREN 0 -#define TOK_RPAREN 1 -#define TOK_DOT 2 -#define TOK_ATOM 3 -#define TOK_QUOTE 4 -#define TOK_COMMENT 5 -#define TOK_DQUOTE 6 -#define TOK_BQUOTE 7 -#define TOK_COMMA 8 -#define TOK_ATMARK 9 -#define TOK_SHARP 10 -#define TOK_SHARP_CONST 11 -#define TOK_VEC 12 - -#define BACKQUOTE '`' -#define DELIMITERS "()\";\f\t\v\n\r " - -/* - * Basic memory allocation units - */ - -#define banner "TinyScheme 1.41" - -#include -#include -#include - -#ifdef __APPLE__ -static int stricmp(const char *s1, const char *s2) -{ - unsigned char c1, c2; - do { - c1 = tolower(*s1); - c2 = tolower(*s2); - if (c1 < c2) - return -1; - else if (c1 > c2) - return 1; - s1++, s2++; - } while (c1 != 0); - return 0; -} -#endif /* __APPLE__ */ - -#if USE_STRLWR && !defined(HAVE_STRLWR) -static const char *strlwr(char *s) { - const char *p=s; - while(*s) { - *s=tolower(*s); - s++; - } - return p; -} -#endif - -#ifndef prompt -# define prompt "ts> " -#endif - -#ifndef InitFile -# define InitFile "init.scm" -#endif - -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - - - -/* All types have the LSB set. The garbage collector takes advantage - * of that to identify types. */ -enum scheme_types { - T_STRING = 1 << 1 | 1, - T_NUMBER = 2 << 1 | 1, - T_SYMBOL = 3 << 1 | 1, - T_PROC = 4 << 1 | 1, - T_PAIR = 5 << 1 | 1, - T_CLOSURE = 6 << 1 | 1, - T_CONTINUATION = 7 << 1 | 1, - T_FOREIGN = 8 << 1 | 1, - T_CHARACTER = 9 << 1 | 1, - T_PORT = 10 << 1 | 1, - T_VECTOR = 11 << 1 | 1, - T_MACRO = 12 << 1 | 1, - T_PROMISE = 13 << 1 | 1, - T_ENVIRONMENT = 14 << 1 | 1, - T_FOREIGN_OBJECT = 15 << 1 | 1, - T_BOOLEAN = 16 << 1 | 1, - T_NIL = 17 << 1 | 1, - T_EOF_OBJ = 18 << 1 | 1, - T_SINK = 19 << 1 | 1, - T_FRAME = 20 << 1 | 1, - T_LAST_SYSTEM_TYPE = 20 << 1 | 1 -}; - -static const char * -type_to_string (enum scheme_types typ) -{ - switch (typ) - { - case T_STRING: return "string"; - case T_NUMBER: return "number"; - case T_SYMBOL: return "symbol"; - case T_PROC: return "proc"; - case T_PAIR: return "pair"; - case T_CLOSURE: return "closure"; - case T_CONTINUATION: return "continuation"; - case T_FOREIGN: return "foreign"; - case T_CHARACTER: return "character"; - case T_PORT: return "port"; - case T_VECTOR: return "vector"; - case T_MACRO: return "macro"; - case T_PROMISE: return "promise"; - case T_ENVIRONMENT: return "environment"; - case T_FOREIGN_OBJECT: return "foreign object"; - case T_BOOLEAN: return "boolean"; - case T_NIL: return "nil"; - case T_EOF_OBJ: return "eof object"; - case T_SINK: return "sink"; - case T_FRAME: return "frame"; - } - assert (! "not reached"); -} - -/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ -#define TYPE_BITS 6 -#define ADJ (1 << TYPE_BITS) -#define T_MASKTYPE (ADJ - 1) - /* 0000000000111111 */ -#define T_TAGGED 1024 /* 0000010000000000 */ -#define T_FINALIZE 2048 /* 0000100000000000 */ -#define T_SYNTAX 4096 /* 0001000000000000 */ -#define T_IMMUTABLE 8192 /* 0010000000000000 */ -#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ -#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ -#define MARK 32768 /* 1000000000000000 */ -#define UNMARK 32767 /* 0111111111111111 */ - - -static num num_add(num a, num b); -static num num_mul(num a, num b); -static num num_div(num a, num b); -static num num_intdiv(num a, num b); -static num num_sub(num a, num b); -static num num_rem(num a, num b); -static num num_mod(num a, num b); -static int num_eq(num a, num b); -static int num_gt(num a, num b); -static int num_ge(num a, num b); -static int num_lt(num a, num b); -static int num_le(num a, num b); - -#if USE_MATH -static double round_per_R5RS(double x); -#endif -static int is_zero_double(double x); -static INLINE int num_is_integer(pointer p) { - return ((p)->_object._number.is_fixnum); -} - -static const struct num num_zero = { 1, {0} }; -static const struct num num_one = { 1, {1} }; - -/* macros for cell operations */ -#define typeflag(p) ((p)->_flag) -#define type(p) (typeflag(p)&T_MASKTYPE) -#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ)) - -INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } -#define strvalue(p) ((p)->_object._string._svalue) -#define strlength(p) ((p)->_object._string._length) - -INTERFACE static int is_list(scheme *sc, pointer p); -INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } -/* Given a vector, return it's length. */ -#define vector_length(v) (v)->_object._vector._length -/* Given a vector length, compute the amount of cells required to - * represent it. */ -#define vector_size(len) (1 + ((len) - 1 + 2) / 3) -INTERFACE static void fill_vector(pointer vec, pointer obj); -INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem); -INTERFACE static pointer vector_elem(pointer vec, int ielem); -INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); -INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } -INTERFACE INLINE int is_integer(pointer p) { - if (!is_number(p)) - return 0; - if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) - return 1; - return 0; -} - -INTERFACE INLINE int is_real(pointer p) { - return is_number(p) && (!(p)->_object._number.is_fixnum); -} - -INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } -INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } -INLINE num nvalue(pointer p) { return ((p)->_object._number); } -INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } -INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } -#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) -#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) -#define set_num_integer(p) (p)->_object._number.is_fixnum=1; -#define set_num_real(p) (p)->_object._number.is_fixnum=0; -INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } - -INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } -INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } -INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } - -INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } -#define car(p) ((p)->_object._cons._car) -#define cdr(p) ((p)->_object._cons._cdr) -INTERFACE pointer pair_car(pointer p) { return car(p); } -INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } -INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } -INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } - -INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } -INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } -#if USE_PLIST -SCHEME_EXPORT INLINE int hasprop(pointer p) { return (is_symbol(p)); } -#define symprop(p) cdr(p) -#endif - -INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } -INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } -INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } -INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } -#define procnum(p) ivalue_unchecked(p) -static const char *procname(pointer x); - -INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } -INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } -INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } -INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } - -INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } -#define cont_dump(p) cdr(p) - -INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); } -INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) { - return p->_object._foreign_object._vtable; -} -INTERFACE void *get_foreign_object_data(pointer p) { - return p->_object._foreign_object._data; -} - -/* To do: promise should be forced ONCE only */ -INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } - -INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } -#define setenvironment(p) typeflag(p) = T_ENVIRONMENT - -INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); } -#define setframe(p) settype(p, T_FRAME) - -#define is_atom(p) (typeflag(p)&T_ATOM) -#define setatom(p) typeflag(p) |= T_ATOM -#define clratom(p) typeflag(p) &= CLRATOM - -#define is_mark(p) (typeflag(p)&MARK) -#define setmark(p) typeflag(p) |= MARK -#define clrmark(p) typeflag(p) &= UNMARK - -INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } -/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ -INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } - -#define caar(p) car(car(p)) -#define cadr(p) car(cdr(p)) -#define cdar(p) cdr(car(p)) -#define cddr(p) cdr(cdr(p)) -#define cadar(p) car(cdr(car(p))) -#define caddr(p) car(cdr(cdr(p))) -#define cdaar(p) cdr(car(car(p))) -#define cadaar(p) car(cdr(car(car(p)))) -#define cadddr(p) car(cdr(cdr(cdr(p)))) -#define cddddr(p) cdr(cdr(cdr(cdr(p)))) - -#if USE_HISTORY -static pointer history_flatten(scheme *sc); -static void history_mark(scheme *sc); -#else -# define history_mark(SC) (void) 0 -# define history_flatten(SC) (SC)->NIL -#endif - -#if USE_CHAR_CLASSIFIERS -static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } -static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } -static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } -static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } -static INLINE int Cislower(int c) { return isascii(c) && islower(c); } -#endif - -#if USE_ASCII_NAMES -static const char charnames[32][3]={ - "nul", - "soh", - "stx", - "etx", - "eot", - "enq", - "ack", - "bel", - "bs", - "ht", - "lf", - "vt", - "ff", - "cr", - "so", - "si", - "dle", - "dc1", - "dc2", - "dc3", - "dc4", - "nak", - "syn", - "etb", - "can", - "em", - "sub", - "esc", - "fs", - "gs", - "rs", - "us" -}; - -static int is_ascii_name(const char *name, int *pc) { - int i; - for(i=0; i<32; i++) { - if (strncasecmp(name, charnames[i], 3) == 0) { - *pc=i; - return 1; - } - } - if (strcasecmp(name, "del") == 0) { - *pc=127; - return 1; - } - return 0; -} - -#endif - -static int file_push(scheme *sc, pointer fname); -static void file_pop(scheme *sc); -static int file_interactive(scheme *sc); -static INLINE int is_one_of(char *s, int c); -static int alloc_cellseg(scheme *sc, int n); -static long binary_decode(const char *s); -static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); -static pointer _get_cell(scheme *sc, pointer a, pointer b); -static pointer reserve_cells(scheme *sc, int n); -static pointer get_consecutive_cells(scheme *sc, int n); -static pointer find_consecutive_cells(scheme *sc, int n); -static int finalize_cell(scheme *sc, pointer a); -static int count_consecutive_cells(pointer x, int needed); -static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); -static pointer mk_number(scheme *sc, num n); -static char *store_string(scheme *sc, int len, const char *str, char fill); -static pointer mk_vector(scheme *sc, int len); -static pointer mk_atom(scheme *sc, char *q); -static pointer mk_sharp_const(scheme *sc, char *name); -static pointer mk_port(scheme *sc, port *p); -static pointer port_from_filename(scheme *sc, const char *fn, int prop); -static pointer port_from_file(scheme *sc, FILE *, int prop); -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); -static port *port_rep_from_file(scheme *sc, FILE *, int prop); -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static void port_close(scheme *sc, pointer p, int flag); -static void mark(pointer a); -static void gc(scheme *sc, pointer a, pointer b); -static int basic_inchar(port *pt); -static int inchar(scheme *sc); -static void backchar(scheme *sc, int c); -static char *readstr_upto(scheme *sc, char *delim); -static pointer readstrexp(scheme *sc); -static INLINE int skipspace(scheme *sc); -static int token(scheme *sc); -static void printslashstring(scheme *sc, char *s, int len); -static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); -static void printatom(scheme *sc, pointer l, int f); -static pointer mk_proc(scheme *sc, enum scheme_opcodes op); -static pointer mk_closure(scheme *sc, pointer c, pointer e); -static pointer mk_continuation(scheme *sc, pointer d); -static pointer reverse(scheme *sc, pointer term, pointer list); -static pointer reverse_in_place(scheme *sc, pointer term, pointer list); -static pointer revappend(scheme *sc, pointer a, pointer b); -static void dump_stack_preallocate_frame(scheme *sc); -static void dump_stack_mark(scheme *); -struct op_code_info { - char name[31]; /* strlen ("call-with-current-continuation") + 1 */ - unsigned char min_arity; - unsigned char max_arity; - char arg_tests_encoding[3]; -}; -static const struct op_code_info dispatch_table[]; -static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size); -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); -static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name); -static int syntaxnum(scheme *sc, pointer p); -static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name); - -#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) -#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) - -static num num_add(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue+b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)+num_rvalue(b); - } - return ret; -} - -static num num_mul(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue*b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)*num_rvalue(b); - } - return ret; -} - -static num num_div(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_intdiv(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_sub(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue-b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)-num_rvalue(b); - } - return ret; -} - -static num num_rem(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - /* remainder should have same sign as second operand */ - if (res > 0) { - if (e1 < 0) { - res -= labs(e2); - } - } else if (res < 0) { - if (e1 > 0) { - res += labs(e2); - } - } - ret.value.ivalue=res; - return ret; -} - -static num num_mod(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - /* modulo should have same sign as second operand */ - if (res * e2 < 0) { - res += e2; - } - ret.value.ivalue=res; - return ret; -} - -static int num_eq(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue==b.value.ivalue; - } else { - ret=num_rvalue(a)==num_rvalue(b); - } - return ret; -} - - -static int num_gt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue>b.value.ivalue; - } else { - ret=num_rvalue(a)>num_rvalue(b); - } - return ret; -} - -static int num_ge(num a, num b) { - return !num_lt(a,b); -} - -static int num_lt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivaluedce) { - return ce; - } else if(dfl-DBL_MIN; -} - -static long binary_decode(const char *s) { - long x=0; - - while(*s!=0 && (*s=='1' || *s=='0')) { - x<<=1; - x+=*s-'0'; - s++; - } - - return x; -} - - - -/* - * Copying values. - * - * Occasionally, we need to copy a value from one location in the - * storage to another. Scheme objects are fine. Some primitive - * objects, however, require finalization, usually to free resources. - * - * For these values, we either make a copy or acquire a reference. - */ - -/* - * Copy SRC to DST. - * - * Copies the representation of SRC to DST. This makes SRC - * indistinguishable from DST from the perspective of a Scheme - * expression modulo the fact that they reside at a different location - * in the store. - * - * Conditions: - * - * - SRC must not be a vector. - * - Caller must ensure that any resources associated with the - * value currently stored in DST is accounted for. - */ -static void -copy_value(scheme *sc, pointer dst, pointer src) -{ - memcpy(dst, src, sizeof *src); - - /* We may need to make a copy or acquire a reference. */ - if (typeflag(dst) & T_FINALIZE) - switch (type(dst)) { - case T_STRING: - strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0); - break; - case T_PORT: - /* XXX acquire reference */ - assert (!"implemented"); - break; - case T_FOREIGN_OBJECT: - /* XXX acquire reference */ - assert (!"implemented"); - break; - case T_VECTOR: - assert (!"vectors cannot be copied"); - } -} - - - -/* Tags are like property lists, but can be attached to arbitrary - * values. */ - -static pointer -mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr) -{ - pointer r, t; - - assert(! is_vector(v)); - - r = get_consecutive_cells(sc, 2); - if (r == sc->sink) - return sc->sink; - - copy_value(sc, r, v); - typeflag(r) |= T_TAGGED; - - t = r + 1; - typeflag(t) = T_PAIR; - car(t) = tag_car; - cdr(t) = tag_cdr; - - return r; -} - -static INLINE int -has_tag(pointer v) -{ - return !! (typeflag(v) & T_TAGGED); -} - -static INLINE pointer -get_tag(scheme *sc, pointer v) -{ - if (has_tag(v)) - return v + 1; - return sc->NIL; -} - - - -/* Low-level allocator. - * - * Memory is allocated in segments. Every segment holds a fixed - * number of cells. Segments are linked into a list, sorted in - * reverse address order (i.e. those with a higher address first). - * This is used in the garbage collector to build the freelist in - * address order. - */ - -struct cell_segment -{ - struct cell_segment *next; - void *alloc; - pointer cells; - size_t cells_len; -}; - -/* Allocate a new cell segment but do not make it available yet. */ -static int -_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment) -{ - int adj = ADJ; - void *cp; - - if (adj < sizeof(struct cell)) - adj = sizeof(struct cell); - - /* The segment header is conveniently allocated with the cells. */ - cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj); - if (cp == NULL) - return 1; - - *segment = cp; - (*segment)->next = NULL; - (*segment)->alloc = cp; - cp = (void *) ((uintptr_t) cp + sizeof **segment); - - /* adjust in TYPE_BITS-bit boundary */ - if (((uintptr_t) cp) % adj != 0) - cp = (void *) (adj * ((uintptr_t) cp / adj + 1)); - - (*segment)->cells = cp; - (*segment)->cells_len = len; - return 0; -} - -/* Deallocate a cell segment. Returns the next cell segment. - * Convenient for deallocation in a loop. */ -static struct cell_segment * -_dealloc_cellseg(scheme *sc, struct cell_segment *segment) -{ - - struct cell_segment *next; - - if (segment == NULL) - return NULL; - - next = segment->next; - sc->free(segment->alloc); - return next; -} - -/* allocate new cell segment */ -static int alloc_cellseg(scheme *sc, int n) { - pointer last; - pointer p; - int k; - - for (k = 0; k < n; k++) { - struct cell_segment *new, **s; - if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) { - return k; - } - /* insert new segment in reverse address order */ - for (s = &sc->cell_segments; - *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc; - s = &(*s)->next) { - /* walk */ - } - new->next = *s; - *s = new; - - sc->fcells += new->cells_len; - last = new->cells + new->cells_len - 1; - for (p = new->cells; p <= last; p++) { - typeflag(p) = 0; - cdr(p) = p + 1; - car(p) = sc->NIL; - } - /* insert new cells in address order on free list */ - if (sc->free_cell == sc->NIL || p < sc->free_cell) { - cdr(last) = sc->free_cell; - sc->free_cell = new->cells; - } else { - p = sc->free_cell; - while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p)) - p = cdr(p); - cdr(last) = cdr(p); - cdr(p) = new->cells; - } - } - return n; -} - - - -/* Controlling the garbage collector. - * - * Every time a cell is allocated, the interpreter may run out of free - * cells and do a garbage collection. This is problematic because it - * might garbage collect objects that have been allocated, but are not - * yet made available to the interpreter. - * - * Previously, we would plug such newly allocated cells into the list - * of newly allocated objects rooted at car(sc->sink), but that - * requires allocating yet another cell increasing pressure on the - * memory management system. - * - * A faster alternative is to preallocate the cells needed for an - * operation and make sure the garbage collection is not run until all - * allocated objects are plugged in. This can be done with gc_disable - * and gc_enable. - */ - -/* The garbage collector is enabled if the inhibit counter is - * zero. */ -#define GC_ENABLED 0 - -/* For now we provide a way to disable this optimization for - * benchmarking and because it produces slightly smaller code. */ -#ifndef USE_GC_LOCKING -# define USE_GC_LOCKING 1 -#endif - -/* To facilitate nested calls to gc_disable, functions that allocate - * more than one cell may define a macro, e.g. foo_allocates. This - * macro can be used to compute the amount of preallocation at the - * call site with the help of this macro. */ -#define gc_reservations(fn) fn ## _allocates - -#if USE_GC_LOCKING - -/* Report a shortage in reserved cells, and terminate the program. */ -static void -gc_reservation_failure(struct scheme *sc) -{ -#ifdef NDEBUG - fprintf(stderr, - "insufficient reservation\n") -#else - fprintf(stderr, - "insufficient %s reservation in line %d\n", - sc->frame_freelist == sc->NIL ? "frame" : "cell", - sc->reserved_lineno); -#endif - abort(); -} - -/* Disable the garbage collection and reserve the given number of - * cells. gc_disable may be nested, but the enclosing reservation - * must include the reservations of all nested calls. Note: You must - * re-enable the gc before calling Error_X. */ -static void -_gc_disable(struct scheme *sc, size_t reserve, int lineno) -{ - if (sc->inhibit_gc == 0) { - reserve_cells(sc, (reserve)); - sc->reserved_cells = (reserve); -#ifdef NDEBUG - (void) lineno; -#else - sc->reserved_lineno = lineno; -#endif - } else if (sc->reserved_cells < (reserve)) - gc_reservation_failure (sc); - sc->inhibit_gc += 1; -} -#define gc_disable(sc, reserve) \ - do { \ - if (sc->frame_freelist == sc->NIL) { \ - if (gc_enabled(sc)) \ - dump_stack_preallocate_frame(sc); \ - else \ - gc_reservation_failure(sc); \ - } \ - _gc_disable (sc, reserve, __LINE__); \ - } while (0) - -/* Enable the garbage collector. */ -#define gc_enable(sc) \ - do { \ - assert(sc->inhibit_gc); \ - sc->inhibit_gc -= 1; \ - } while (0) - -/* Test whether the garbage collector is enabled. */ -#define gc_enabled(sc) \ - (sc->inhibit_gc == GC_ENABLED) - -/* Consume a reserved cell. */ -#define gc_consume(sc) \ - do { \ - assert(! gc_enabled (sc)); \ - if (sc->reserved_cells == 0) \ - gc_reservation_failure (sc); \ - sc->reserved_cells -= 1; \ - } while (0) - -#else /* USE_GC_LOCKING */ - -#define gc_reservation_failure(sc) (void) 0 -#define gc_disable(sc, reserve) \ - do { \ - if (sc->frame_freelist == sc->NIL) \ - dump_stack_preallocate_frame(sc); \ - } while (0) -#define gc_enable(sc) (void) 0 -#define gc_enabled(sc) 1 -#define gc_consume(sc) (void) 0 - -#endif /* USE_GC_LOCKING */ - -static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { - if (! gc_enabled (sc) || sc->free_cell != sc->NIL) { - pointer x = sc->free_cell; - if (! gc_enabled (sc)) - gc_consume (sc); - sc->free_cell = cdr(x); - --sc->fcells; - return (x); - } - assert (gc_enabled (sc)); - return _get_cell (sc, a, b); -} - - -/* get new cell. parameter a, b is marked by gc. */ -static pointer _get_cell(scheme *sc, pointer a, pointer b) { - pointer x; - - if(sc->no_memory) { - return sc->sink; - } - - assert (gc_enabled (sc)); - if (sc->free_cell == sc->NIL) { - gc(sc,a, b); - if (sc->free_cell == sc->NIL) { - sc->no_memory=1; - return sc->sink; - } - } - x = sc->free_cell; - sc->free_cell = cdr(x); - --sc->fcells; - return (x); -} - -/* make sure that there is a given number of cells free */ -static pointer reserve_cells(scheme *sc, int n) { - if(sc->no_memory) { - return sc->NIL; - } - - /* Are there enough cells available? */ - if (sc->fcells < n) { - /* If not, try gc'ing some */ - gc(sc, sc->NIL, sc->NIL); - if (sc->fcells < n) { - /* If there still aren't, try getting more heap */ - if (!alloc_cellseg(sc,1)) { - sc->no_memory=1; - return sc->NIL; - } - } - if (sc->fcells < n) { - /* If all fail, report failure */ - sc->no_memory=1; - return sc->NIL; - } - } - return (sc->T); -} - -static pointer get_consecutive_cells(scheme *sc, int n) { - pointer x; - - if(sc->no_memory) { return sc->sink; } - - /* Are there any cells available? */ - x=find_consecutive_cells(sc,n); - if (x != sc->NIL) { return x; } - - /* If not, try gc'ing some */ - gc(sc, sc->NIL, sc->NIL); - x=find_consecutive_cells(sc,n); - if (x != sc->NIL) { return x; } - - /* If there still aren't, try getting more heap */ - if (!alloc_cellseg(sc,1)) - { - sc->no_memory=1; - return sc->sink; - } - - x=find_consecutive_cells(sc,n); - if (x != sc->NIL) { return x; } - - /* If all fail, report failure */ - sc->no_memory=1; - return sc->sink; -} - -static int count_consecutive_cells(pointer x, int needed) { - int n=1; - while(cdr(x)==x+1) { - x=cdr(x); - n++; - if(n>needed) return n; - } - return n; -} - -static pointer find_consecutive_cells(scheme *sc, int n) { - pointer *pp; - int cnt; - - pp=&sc->free_cell; - while(*pp!=sc->NIL) { - cnt=count_consecutive_cells(*pp,n); - if(cnt>=n) { - pointer x=*pp; - *pp=cdr(*pp+n-1); - sc->fcells -= n; - return x; - } - pp=&cdr(*pp+cnt-1); - } - return sc->NIL; -} - -/* Free a cell. This is dangerous. Only free cells that are not - * referenced. */ -static INLINE void -free_cell(scheme *sc, pointer a) -{ - cdr(a) = sc->free_cell; - sc->free_cell = a; - sc->fcells += 1; -} - -/* Free a cell and retrieve its content. This is dangerous. Only - * free cells that are not referenced. */ -static INLINE void -free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr) -{ - *r_car = car(a); - *r_cdr = cdr(a); - free_cell(sc, a); -} - -/* To retain recent allocs before interpreter knows about them - - Tehom */ - -static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) -{ - pointer holder = get_cell_x(sc, recent, extra); - typeflag(holder) = T_PAIR | T_IMMUTABLE; - car(holder) = recent; - cdr(holder) = car(sc->sink); - car(sc->sink) = holder; -} - -static INLINE void ok_to_freely_gc(scheme *sc) -{ - pointer a = car(sc->sink), next; - car(sc->sink) = sc->NIL; - while (a != sc->NIL) - { - next = cdr(a); - free_cell(sc, a); - a = next; - } -} - -static pointer get_cell(scheme *sc, pointer a, pointer b) -{ - pointer cell = get_cell_x(sc, a, b); - /* For right now, include "a" and "b" in "cell" so that gc doesn't - think they are garbage. */ - /* Tentatively record it as a pair so gc understands it. */ - typeflag(cell) = T_PAIR; - car(cell) = a; - cdr(cell) = b; - if (gc_enabled (sc)) - push_recent_alloc(sc, cell, sc->NIL); - return cell; -} - -static pointer get_vector_object(scheme *sc, int len, pointer init) -{ - pointer cells = get_consecutive_cells(sc, vector_size(len)); - int i; - int alloc_len = 1 + 3 * (vector_size(len) - 1); - if(sc->no_memory) { return sc->sink; } - /* Record it as a vector so that gc understands it. */ - typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE); - vector_length(cells) = len; - fill_vector(cells,init); - - /* Initialize the unused slots at the end. */ - assert (alloc_len - len < 3); - for (i = len; i < alloc_len; i++) - cells->_object._vector._elements[i] = sc->NIL; - - if (gc_enabled (sc)) - push_recent_alloc(sc, cells, sc->NIL); - return cells; -} - -/* Medium level cell allocation */ - -/* get new cons cell */ -pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { - pointer x = get_cell(sc,a, b); - - typeflag(x) = T_PAIR; - if(immutable) { - setimmutable(x); - } - car(x) = a; - cdr(x) = b; - return (x); -} - - -/* ========== oblist implementation ========== */ - -#ifndef USE_OBJECT_LIST - -static int hash_fn(const char *key, int table_size); - -static pointer oblist_initial_value(scheme *sc) -{ - /* There are about 768 symbols used after loading the - * interpreter. */ - return mk_vector(sc, 1009); -} - -/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not - * exist. In that case, SLOT points to the point where the new symbol - * is to be inserted. */ -static INLINE pointer -oblist_find_by_name(scheme *sc, const char *name, pointer **slot) -{ - int location; - pointer x; - char *s; - int d; - - location = hash_fn(name, vector_length(sc->oblist)); - for (*slot = vector_elem_slot(sc->oblist, location), x = **slot; - x != sc->NIL; *slot = &cdr(x), x = **slot) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - d = stricmp(name, s); - if (d == 0) - return car(x); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - return sc->NIL; -} - -static pointer oblist_all_symbols(scheme *sc) -{ - int i; - pointer x; - pointer ob_list = sc->NIL; - - for (i = 0; i < vector_length(sc->oblist); i++) { - for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { - ob_list = cons(sc, x, ob_list); - } - } - return ob_list; -} - -#else - -static pointer oblist_initial_value(scheme *sc) -{ - return sc->NIL; -} - -/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not - * exist. In that case, SLOT points to the point where the new symbol - * is to be inserted. */ -static INLINE pointer -oblist_find_by_name(scheme *sc, const char *name, pointer **slot) -{ - pointer x; - char *s; - int d; - - for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - d = stricmp(name, s); - if (d == 0) - return car(x); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - return sc->NIL; -} - -static pointer oblist_all_symbols(scheme *sc) -{ - return sc->oblist; -} - -#endif - -/* Add a new symbol NAME at SLOT. SLOT must be obtained using - * oblist_find_by_name, and no insertion must be done between - * obtaining the SLOT and calling this function. Returns the new - * symbol. */ -static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot) -{ -#define oblist_add_by_name_allocates 3 - pointer x; - - gc_disable(sc, gc_reservations (oblist_add_by_name)); - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - *slot = immutable_cons(sc, x, *slot); - gc_enable(sc); - return x; -} - - - -static pointer mk_port(scheme *sc, port *p) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = T_PORT|T_ATOM|T_FINALIZE; - x->_object._port=p; - return (x); -} - -pointer mk_foreign_func(scheme *sc, foreign_func f) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = (T_FOREIGN | T_ATOM); - x->_object._ff=f; - return (x); -} - -pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE); - x->_object._foreign_object._vtable=vtable; - x->_object._foreign_object._data = data; - return (x); -} - -INTERFACE pointer mk_character(scheme *sc, int c) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_CHARACTER | T_ATOM); - ivalue_unchecked(x)= c; - set_num_integer(x); - return (x); -} - - - -#if USE_SMALL_INTEGERS - -static const struct cell small_integers[] = { -#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}}, -#include "small-integers.h" -#undef DEFINE_INTEGER - {0} -}; - -#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1) - -static INLINE pointer -mk_small_integer(scheme *sc, long n) -{ -#define mk_small_integer_allocates 0 - (void) sc; - assert(0 <= n && n < MAX_SMALL_INTEGER); - return (pointer) &small_integers[n]; -} -#else - -#define mk_small_integer_allocates 1 -#define mk_small_integer mk_integer - -#endif - -/* get number atom (integer) */ -INTERFACE pointer mk_integer(scheme *sc, long n) { - pointer x; - -#if USE_SMALL_INTEGERS - if (0 <= n && n < MAX_SMALL_INTEGER) - return mk_small_integer(sc, n); -#endif - - x = get_cell(sc,sc->NIL, sc->NIL); - typeflag(x) = (T_NUMBER | T_ATOM); - ivalue_unchecked(x)= n; - set_num_integer(x); - return (x); -} - - - -INTERFACE pointer mk_real(scheme *sc, double n) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_NUMBER | T_ATOM); - rvalue_unchecked(x)= n; - set_num_real(x); - return (x); -} - -static pointer mk_number(scheme *sc, num n) { - if(n.is_fixnum) { - return mk_integer(sc,n.value.ivalue); - } else { - return mk_real(sc,n.value.rvalue); - } -} - -/* allocate name to string area */ -static char *store_string(scheme *sc, int len_str, const char *str, char fill) { - char *q; - - q=(char*)sc->malloc(len_str+1); - if(q==0) { - sc->no_memory=1; - return sc->strbuff; - } - if(str!=0) { - memcpy (q, str, len_str); - q[len_str]=0; - } else { - memset(q, fill, len_str); - q[len_str]=0; - } - return (q); -} - -/* get new string */ -INTERFACE pointer mk_string(scheme *sc, const char *str) { - return mk_counted_string(sc,str,strlen(str)); -} - -INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); - strvalue(x) = store_string(sc,len,str,0); - strlength(x) = len; - return (x); -} - -INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE); - strvalue(x) = store_string(sc,len,0,fill); - strlength(x) = len; - return (x); -} - -INTERFACE static pointer mk_vector(scheme *sc, int len) -{ return get_vector_object(sc,len,sc->NIL); } - -INTERFACE static void fill_vector(pointer vec, pointer obj) { - size_t i; - assert (is_vector (vec)); - for(i = 0; i < vector_length(vec); i++) { - vec->_object._vector._elements[i] = obj; - } -} - -INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) { - assert (is_vector (vec)); - assert (ielem < vector_length(vec)); - return &vec->_object._vector._elements[ielem]; -} - -INTERFACE static pointer vector_elem(pointer vec, int ielem) { - assert (is_vector (vec)); - assert (ielem < vector_length(vec)); - return vec->_object._vector._elements[ielem]; -} - -INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { - assert (is_vector (vec)); - assert (ielem < vector_length(vec)); - vec->_object._vector._elements[ielem] = a; - return a; -} - -/* get new symbol */ -INTERFACE pointer mk_symbol(scheme *sc, const char *name) { -#define mk_symbol_allocates oblist_add_by_name_allocates - pointer x; - pointer *slot; - - /* first check oblist */ - x = oblist_find_by_name(sc, name, &slot); - if (x != sc->NIL) { - return (x); - } else { - x = oblist_add_by_name(sc, name, slot); - return (x); - } -} - -INTERFACE pointer gensym(scheme *sc) { - pointer x; - pointer *slot; - char name[40]; - - for(; sc->gensym_cntgensym_cnt++) { - snprintf(name,40,"gensym-%ld",sc->gensym_cnt); - - /* first check oblist */ - x = oblist_find_by_name(sc, name, &slot); - - if (x != sc->NIL) { - continue; - } else { - x = oblist_add_by_name(sc, name, slot); - return (x); - } - } - - return sc->NIL; -} - -/* double the size of the string buffer */ -static int expand_strbuff(scheme *sc) { - size_t new_size = sc->strbuff_size * 2; - char *new_buffer = sc->malloc(new_size); - if (new_buffer == 0) { - sc->no_memory = 1; - return 1; - } - memcpy(new_buffer, sc->strbuff, sc->strbuff_size); - sc->free(sc->strbuff); - sc->strbuff = new_buffer; - sc->strbuff_size = new_size; - return 0; -} - -/* make symbol or number atom from string */ -static pointer mk_atom(scheme *sc, char *q) { - char c, *p; - int has_dec_point=0; - int has_fp_exp = 0; - -#if USE_COLON_HOOK - char *next; - next = p = q; - while ((next = strstr(next, "::")) != 0) { - /* Keep looking for the last occurrence. */ - p = next; - next = next + 2; - } - - if (p != q) { - *p=0; - return cons(sc, sc->COLON_HOOK, - cons(sc, - cons(sc, - sc->QUOTE, - cons(sc, mk_symbol(sc, strlwr(p + 2)), - sc->NIL)), - cons(sc, mk_atom(sc, q), sc->NIL))); - } -#endif - - p = q; - c = *p++; - if ((c == '+') || (c == '-')) { - c = *p++; - if (c == '.') { - has_dec_point=1; - c = *p++; - } - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (c == '.') { - has_dec_point=1; - c = *p++; - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - - for ( ; (c = *p) != 0; ++p) { - if (!isdigit(c)) { - if(c=='.') { - if(!has_dec_point) { - has_dec_point=1; - continue; - } - } - else if ((c == 'e') || (c == 'E')) { - if(!has_fp_exp) { - has_dec_point = 1; /* decimal point illegal - from now on */ - p++; - if ((*p == '-') || (*p == '+') || isdigit(*p)) { - continue; - } - } - } - return (mk_symbol(sc, strlwr(q))); - } - } - if(has_dec_point) { - return mk_real(sc,atof(q)); - } - return (mk_integer(sc, atol(q))); -} - -/* make constant */ -static pointer mk_sharp_const(scheme *sc, char *name) { - long x; - char tmp[STRBUFFSIZE]; - - if (!strcmp(name, "t")) - return (sc->T); - else if (!strcmp(name, "f")) - return (sc->F); - else if (*name == 'o') {/* #o (octal) */ - snprintf(tmp, STRBUFFSIZE, "0%s", name+1); - sscanf(tmp, "%lo", (long unsigned *)&x); - return (mk_integer(sc, x)); - } else if (*name == 'd') { /* #d (decimal) */ - sscanf(name+1, "%ld", (long int *)&x); - return (mk_integer(sc, x)); - } else if (*name == 'x') { /* #x (hex) */ - snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); - sscanf(tmp, "%lx", (long unsigned *)&x); - return (mk_integer(sc, x)); - } else if (*name == 'b') { /* #b (binary) */ - x = binary_decode(name+1); - return (mk_integer(sc, x)); - } else if (*name == '\\') { /* #\w (character) */ - int c=0; - if(stricmp(name+1,"space")==0) { - c=' '; - } else if(stricmp(name+1,"newline")==0) { - c='\n'; - } else if(stricmp(name+1,"return")==0) { - c='\r'; - } else if(stricmp(name+1,"tab")==0) { - c='\t'; - } else if(name[1]=='x' && name[2]!=0) { - int c1=0; - if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { - c=c1; - } else { - return sc->NIL; - } -#if USE_ASCII_NAMES - } else if(is_ascii_name(name+1,&c)) { - /* nothing */ -#endif - } else if(name[2]==0) { - c=name[1]; - } else { - return sc->NIL; - } - return mk_character(sc,c); - } else - return (sc->NIL); -} - -/* ========== garbage collector ========== */ - -const int frame_length; -static void dump_stack_deallocate_frame(scheme *sc, pointer frame); - -/*-- - * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, - * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, - * for marking. - */ -static void mark(pointer a) { - pointer t, q, p; - - t = (pointer) 0; - p = a; -E2: if (! is_mark(p)) - setmark(p); - if (is_vector(p) || is_frame(p)) { - int i; - int len = is_vector(p) ? vector_length(p) : frame_length; - for (i = 0; i < len; i++) { - mark(p->_object._vector._elements[i]); - } - } -#if SHOW_ERROR_LINE - else if (is_port(p)) { - port *pt = p->_object._port; - mark(pt->curr_line); - mark(pt->filename); - } -#endif - /* Mark tag if p has one. */ - if (has_tag(p)) - mark(p + 1); - if (is_atom(p)) - goto E6; - /* E4: down car */ - q = car(p); - if (q && !is_mark(q)) { - setatom(p); /* a note that we have moved car */ - car(p) = t; - t = p; - p = q; - goto E2; - } -E5: q = cdr(p); /* down cdr */ - if (q && !is_mark(q)) { - cdr(p) = t; - t = p; - p = q; - goto E2; - } -E6: /* up. Undo the link switching from steps E4 and E5. */ - if (!t) - return; - q = t; - if (is_atom(q)) { - clratom(q); - t = car(q); - car(q) = p; - p = q; - goto E5; - } else { - t = cdr(q); - cdr(q) = p; - p = q; - goto E6; - } -} - -/* garbage collection. parameter a, b is marked. */ -static void gc(scheme *sc, pointer a, pointer b) { - pointer p; - struct cell_segment *s; - int i; - - assert (gc_enabled (sc)); - - if(sc->gc_verbose) { - putstr(sc, "gc..."); - } - - /* mark system globals */ - mark(sc->oblist); - mark(sc->global_env); - - /* mark current registers */ - mark(sc->args); - mark(sc->envir); - mark(sc->code); - history_mark(sc); - dump_stack_mark(sc); - mark(sc->value); - mark(sc->inport); - mark(sc->save_inport); - mark(sc->outport); - mark(sc->loadport); - for (i = 0; i <= sc->file_i; i++) { - mark(sc->load_stack[i].filename); - mark(sc->load_stack[i].curr_line); - } - - /* Mark recent objects the interpreter doesn't know about yet. */ - mark(car(sc->sink)); - /* Mark any older stuff above nested C calls */ - mark(sc->c_nest); - - /* mark variables a, b */ - mark(a); - mark(b); - - /* garbage collect */ - clrmark(sc->NIL); - sc->fcells = 0; - sc->free_cell = sc->NIL; - /* free-list is kept sorted by address so as to maintain consecutive - ranges, if possible, for use with vectors. Here we scan the cells - (which are also kept sorted by address) downwards to build the - free-list in sorted order. - */ - for (s = sc->cell_segments; s; s = s->next) { - p = s->cells + s->cells_len; - while (--p >= s->cells) { - if ((typeflag(p) & 1) == 0) - /* All types have the LSB set. This is not a typeflag. */ - continue; - if (is_mark(p)) { - clrmark(p); - } else { - /* reclaim cell */ - if ((typeflag(p) & T_FINALIZE) == 0 - || finalize_cell(sc, p)) { - /* Reclaim cell. */ - ++sc->fcells; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; - } - } - } - } - - if (sc->gc_verbose) { - char msg[80]; - snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); - putstr(sc,msg); - } - - /* if only a few recovered, get more to avoid fruitless gc's */ - if (sc->fcells < CELL_MINRECOVER - && alloc_cellseg(sc, 1) == 0) - sc->no_memory = 1; -} - -/* Finalize A. Returns true if a can be added to the list of free - * cells. */ -static int -finalize_cell(scheme *sc, pointer a) -{ - switch (type(a)) { - case T_STRING: - sc->free(strvalue(a)); - break; - - case T_PORT: - if(a->_object._port->kind&port_file - && a->_object._port->rep.stdio.closeit) { - port_close(sc,a,port_input|port_output); - } else if (a->_object._port->kind & port_srfi6) { - sc->free(a->_object._port->rep.string.start); - } - sc->free(a->_object._port); - break; - - case T_FOREIGN_OBJECT: - a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); - break; - - case T_VECTOR: - do { - int i; - for (i = vector_size(vector_length(a)) - 1; i > 0; i--) { - pointer p = a + i; - typeflag(p) = 0; - car(p) = sc->NIL; - cdr(p) = sc->free_cell; - sc->free_cell = p; - sc->fcells += 1; - } - } while (0); - break; - - case T_FRAME: - dump_stack_deallocate_frame(sc, a); - return 0; /* Do not free cell. */ - } - - return 1; /* Free cell. */ -} - -#if SHOW_ERROR_LINE -static void -port_clear_location (scheme *sc, port *p) -{ - p->curr_line = sc->NIL; - p->filename = sc->NIL; -} - -static void -port_increment_current_line (scheme *sc, port *p, long delta) -{ - if (delta == 0) - return; - - p->curr_line = - mk_integer(sc, ivalue_unchecked(p->curr_line) + delta); -} - -static void -port_init_location (scheme *sc, port *p, pointer name) -{ - p->curr_line = mk_integer(sc, 0); - p->filename = name ? name : mk_string(sc, ""); -} - -#else - -static void -port_clear_location (scheme *sc, port *p) -{ -} - -static void -port_increment_current_line (scheme *sc, port *p, long delta) -{ -} - -static void -port_init_location (scheme *sc, port *p, pointer name) -{ -} - -#endif - -/* ========== Routines for Reading ========== */ - -static int file_push(scheme *sc, pointer fname) { - FILE *fin = NULL; - - if (sc->file_i == MAXFIL-1) - return 0; - fin = fopen(string_value(fname), "r"); - if(fin!=0) { - sc->file_i++; - sc->load_stack[sc->file_i].kind=port_file|port_input; - sc->load_stack[sc->file_i].rep.stdio.file=fin; - sc->load_stack[sc->file_i].rep.stdio.closeit=1; - sc->nesting_stack[sc->file_i]=0; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - port_init_location(sc, &sc->load_stack[sc->file_i], fname); - } - return fin!=0; -} - -static void file_pop(scheme *sc) { - if(sc->file_i != 0) { - sc->nesting=sc->nesting_stack[sc->file_i]; - port_close(sc,sc->loadport,port_input); - port_clear_location(sc, &sc->load_stack[sc->file_i]); - sc->file_i--; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - } -} - -static int file_interactive(scheme *sc) { - return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin - && sc->inport->_object._port->kind&port_file; -} - -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { - FILE *f; - char *rw; - port *pt; - if(prop==(port_input|port_output)) { - rw="a+"; - } else if(prop==port_output) { - rw="w"; - } else { - rw="r"; - } - f=fopen(fn,rw); - if(f==0) { - return 0; - } - pt=port_rep_from_file(sc,f,prop); - pt->rep.stdio.closeit=1; - port_init_location(sc, pt, mk_string(sc, fn)); - return pt; -} - -static pointer port_from_filename(scheme *sc, const char *fn, int prop) { - port *pt; - pt=port_rep_from_filename(sc,fn,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_file(scheme *sc, FILE *f, int prop) -{ - port *pt; - - pt = (port *)sc->malloc(sizeof *pt); - if (pt == NULL) { - return NULL; - } - pt->kind = port_file | prop; - pt->rep.stdio.file = f; - pt->rep.stdio.closeit = 0; - port_init_location(sc, pt, NULL); - return pt; -} - -static pointer port_from_file(scheme *sc, FILE *f, int prop) { - port *pt; - pt=port_rep_from_file(sc,f,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - pt->kind=port_string|prop; - pt->rep.string.start=start; - pt->rep.string.curr=start; - pt->rep.string.past_the_end=past_the_end; - port_init_location(sc, pt, NULL); - return pt; -} - -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=port_rep_from_string(sc,start,past_the_end,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -#define BLOCK_SIZE 256 - -static port *port_rep_from_scratch(scheme *sc) { - port *pt; - char *start; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - start=sc->malloc(BLOCK_SIZE); - if(start==0) { - return 0; - } - memset(start,' ',BLOCK_SIZE-1); - start[BLOCK_SIZE-1]='\0'; - pt->kind=port_string|port_output|port_srfi6; - pt->rep.string.start=start; - pt->rep.string.curr=start; - pt->rep.string.past_the_end=start+BLOCK_SIZE-1; - port_init_location(sc, pt, NULL); - return pt; -} - -static pointer port_from_scratch(scheme *sc) { - port *pt; - pt=port_rep_from_scratch(sc); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static void port_close(scheme *sc, pointer p, int flag) { - port *pt=p->_object._port; - pt->kind&=~flag; - if((pt->kind & (port_input|port_output))==0) { - /* Cleanup is here so (close-*-port) functions could work too */ - port_clear_location(sc, pt); - if(pt->kind&port_file) { - fclose(pt->rep.stdio.file); - } - pt->kind=port_free; - } -} - -/* get new character from input file */ -static int inchar(scheme *sc) { - int c; - port *pt; - - pt = sc->inport->_object._port; - if(pt->kind & port_saw_EOF) - { return EOF; } - c = basic_inchar(pt); - if(c == EOF && sc->inport == sc->loadport) { - /* Instead, set port_saw_EOF */ - pt->kind |= port_saw_EOF; - - /* file_pop(sc); */ - return EOF; - /* NOTREACHED */ - } - return c; -} - -static int basic_inchar(port *pt) { - if(pt->kind & port_file) { - return fgetc(pt->rep.stdio.file); - } else { - if(*pt->rep.string.curr == 0 || - pt->rep.string.curr == pt->rep.string.past_the_end) { - return EOF; - } else { - return *pt->rep.string.curr++; - } - } -} - -/* back character to input buffer */ -static void backchar(scheme *sc, int c) { - port *pt; - if(c==EOF) return; - pt=sc->inport->_object._port; - if(pt->kind&port_file) { - ungetc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.start) { - --pt->rep.string.curr; - } - } -} - -static int realloc_port_string(scheme *sc, port *p) -{ - char *start=p->rep.string.start; - size_t old_size = p->rep.string.past_the_end - start; - size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; - char *str=sc->malloc(new_size); - if(str) { - memset(str,' ',new_size-1); - str[new_size-1]='\0'; - memcpy(str, start, old_size); - p->rep.string.start=str; - p->rep.string.past_the_end=str+new_size-1; - p->rep.string.curr-=start-str; - sc->free(start); - return 1; - } else { - return 0; - } -} - -INTERFACE void putstr(scheme *sc, const char *s) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputs(s,pt->rep.stdio.file); - } else { - for(;*s;s++) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s; - } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { - *pt->rep.string.curr++=*s; - } - } - } -} - -static void putchars(scheme *sc, const char *s, int len) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fwrite(s,1,len,pt->rep.stdio.file); - } else { - for(;len;len--) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s++; - } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { - *pt->rep.string.curr++=*s++; - } - } - } -} - -INTERFACE void putcharacter(scheme *sc, int c) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=c; - } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { - *pt->rep.string.curr++=c; - } - } -} - -/* read characters up to delimiter, but cater to character constants */ -static char *readstr_upto(scheme *sc, char *delim) { - char *p = sc->strbuff; - - while ((p - sc->strbuff < sc->strbuff_size) && - !is_one_of(delim, (*p++ = inchar(sc)))); - - if(p == sc->strbuff+2 && p[-2] == '\\') { - *p=0; - } else { - backchar(sc,p[-1]); - *--p = '\0'; - } - return sc->strbuff; -} - -/* read string expression "xxx...xxx" */ -static pointer readstrexp(scheme *sc) { - char *p = sc->strbuff; - int c; - int c1=0; - enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; - - for (;;) { - c=inchar(sc); - if(c == EOF) { - return sc->F; - } - if(p-sc->strbuff > (sc->strbuff_size)-1) { - ptrdiff_t offset = p - sc->strbuff; - if (expand_strbuff(sc) != 0) { - return sc->F; - } - p = sc->strbuff + offset; - } - switch(state) { - case st_ok: - switch(c) { - case '\\': - state=st_bsl; - break; - case '"': - *p=0; - return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); - default: - *p++=c; - break; - } - break; - case st_bsl: - switch(c) { - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - state=st_oct1; - c1=c-'0'; - break; - case 'x': - case 'X': - state=st_x1; - c1=0; - break; - case 'n': - *p++='\n'; - state=st_ok; - break; - case 't': - *p++='\t'; - state=st_ok; - break; - case 'r': - *p++='\r'; - state=st_ok; - break; - case '"': - *p++='"'; - state=st_ok; - break; - default: - *p++=c; - state=st_ok; - break; - } - break; - case st_x1: - case st_x2: - c=toupper(c); - if(c>='0' && c<='F') { - if(c<='9') { - c1=(c1<<4)+c-'0'; - } else { - c1=(c1<<4)+c-'A'+10; - } - if(state==st_x1) { - state=st_x2; - } else { - *p++=c1; - state=st_ok; - } - } else { - return sc->F; - } - break; - case st_oct1: - case st_oct2: - if (c < '0' || c > '7') - { - *p++=c1; - backchar(sc, c); - state=st_ok; - } - else - { - if (state==st_oct2 && c1 >= 32) - return sc->F; - - c1=(c1<<3)+(c-'0'); - - if (state == st_oct1) - state=st_oct2; - else - { - *p++=c1; - state=st_ok; - } - } - break; - - } - } -} - -/* check c is in chars */ -static INLINE int is_one_of(char *s, int c) { - if(c==EOF) return 1; - while (*s) - if (*s++ == c) - return (1); - return (0); -} - -/* skip white characters */ -static INLINE int skipspace(scheme *sc) { - int c = 0, curr_line = 0; - - do { - c=inchar(sc); -#if SHOW_ERROR_LINE - if(c=='\n') - curr_line++; -#endif - } while (isspace(c)); - - /* record it */ - port_increment_current_line(sc, &sc->load_stack[sc->file_i], curr_line); - - if(c!=EOF) { - backchar(sc,c); - return 1; - } - else - { return EOF; } -} - -/* get token */ -static int token(scheme *sc) { - int c; - c = skipspace(sc); - if(c == EOF) { return (TOK_EOF); } - switch (c=inchar(sc)) { - case EOF: - return (TOK_EOF); - case '(': - return (TOK_LPAREN); - case ')': - return (TOK_RPAREN); - case '.': - c=inchar(sc); - if(is_one_of(" \n\t",c)) { - return (TOK_DOT); - } else { - backchar(sc,c); - backchar(sc,'.'); - return TOK_ATOM; - } - case '\'': - return (TOK_QUOTE); - case ';': - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - - if(c == '\n') - port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); - - if(c == EOF) - { return (TOK_EOF); } - else - { return (token(sc));} - case '"': - return (TOK_DQUOTE); - case BACKQUOTE: - return (TOK_BQUOTE); - case ',': - if ((c=inchar(sc)) == '@') { - return (TOK_ATMARK); - } else { - backchar(sc,c); - return (TOK_COMMA); - } - case '#': - c=inchar(sc); - if (c == '(') { - return (TOK_VEC); - } else if(c == '!') { - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - - if(c == '\n') - port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); - - if(c == EOF) - { return (TOK_EOF); } - else - { return (token(sc));} - } else { - backchar(sc,c); - if(is_one_of(" tfodxb\\",c)) { - return TOK_SHARP_CONST; - } else { - return (TOK_SHARP); - } - } - default: - backchar(sc,c); - return (TOK_ATOM); - } -} - -/* ========== Routines for Printing ========== */ -#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) - -static void printslashstring(scheme *sc, char *p, int len) { - int i; - unsigned char *s=(unsigned char*)p; - putcharacter(sc,'"'); - for ( i=0; iNIL) { - p = "()"; - } else if (l == sc->T) { - p = "#t"; - } else if (l == sc->F) { - p = "#f"; - } else if (l == sc->EOF_OBJ) { - p = "#"; - } else if (is_port(l)) { - p = "#"; - } else if (is_number(l)) { - p = sc->strbuff; - if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { - if(num_is_integer(l)) { - snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); - } else { - snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); - /* r5rs says there must be a '.' (unless 'e'?) */ - f = strcspn(p, ".e"); - if (p[f] == 0) { - p[f] = '.'; /* not found, so add '.0' at the end */ - p[f+1] = '0'; - p[f+2] = 0; - } - } - } else { - long v = ivalue(l); - if (f == 16) { - if (v >= 0) - snprintf(p, STRBUFFSIZE, "%lx", v); - else - snprintf(p, STRBUFFSIZE, "-%lx", -v); - } else if (f == 8) { - if (v >= 0) - snprintf(p, STRBUFFSIZE, "%lo", v); - else - snprintf(p, STRBUFFSIZE, "-%lo", -v); - } else if (f == 2) { - unsigned long b = (v < 0) ? -v : v; - p = &p[STRBUFFSIZE-1]; - *p = 0; - do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); - if (v < 0) *--p = '-'; - } - } - } else if (is_string(l)) { - if (!f) { - *pp = strvalue(l); - *plen = strlength(l); - return; - } else { /* Hack, uses the fact that printing is needed */ - *pp=sc->strbuff; - *plen=0; - printslashstring(sc, strvalue(l), strlength(l)); - return; - } - } else if (is_character(l)) { - int c=charvalue(l); - p = sc->strbuff; - if (!f) { - p[0]=c; - p[1]=0; - } else { - switch(c) { - case ' ': - p = "#\\space"; - break; - case '\n': - p = "#\\newline"; - break; - case '\r': - p = "#\\return"; - break; - case '\t': - p = "#\\tab"; - break; - default: -#if USE_ASCII_NAMES - if(c==127) { - p = "#\\del"; - break; - } else if(c<32) { - snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]); - break; - } -#else - if(c<32) { - snprintf(p,STRBUFFSIZE,"#\\x%x",c); - break; - } -#endif - snprintf(p,STRBUFFSIZE,"#\\%c",c); - break; - } - } - } else if (is_symbol(l)) { - p = symname(l); - } else if (is_proc(l)) { - p = sc->strbuff; - snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); - } else if (is_macro(l)) { - p = "#"; - } else if (is_closure(l)) { - p = "#"; - } else if (is_promise(l)) { - p = "#"; - } else if (is_foreign(l)) { - p = sc->strbuff; - snprintf(p,STRBUFFSIZE,"#", procnum(l)); - } else if (is_continuation(l)) { - p = "#"; - } else if (is_foreign_object(l)) { - p = sc->strbuff; - l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data); - } else { - p = "#"; - } - *pp=p; - *plen=strlen(p); -} -/* ========== Routines for Evaluation Cycle ========== */ - -/* make closure. c is code. e is environment */ -static pointer mk_closure(scheme *sc, pointer c, pointer e) { - pointer x = get_cell(sc, c, e); - - typeflag(x) = T_CLOSURE; - car(x) = c; - cdr(x) = e; - return (x); -} - -/* make continuation. */ -static pointer mk_continuation(scheme *sc, pointer d) { - pointer x = get_cell(sc, sc->NIL, d); - - typeflag(x) = T_CONTINUATION; - cont_dump(x) = d; - return (x); -} - -static pointer list_star(scheme *sc, pointer d) { - pointer p, q; - if(cdr(d)==sc->NIL) { - return car(d); - } - p=cons(sc,car(d),cdr(d)); - q=p; - while(cdr(cdr(p))!=sc->NIL) { - d=cons(sc,car(p),cdr(p)); - if(cdr(cdr(p))!=sc->NIL) { - p=cdr(d); - } - } - cdr(p)=car(cdr(p)); - return q; -} - -/* reverse list -- produce new list */ -static pointer reverse(scheme *sc, pointer term, pointer list) { -/* a must be checked by gc */ - pointer a = list, p = term; - - for ( ; is_pair(a); a = cdr(a)) { - p = cons(sc, car(a), p); - } - return (p); -} - -/* reverse list --- in-place */ -static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { - pointer p = list, result = term, q; - - while (p != sc->NIL) { - q = cdr(p); - cdr(p) = result; - result = p; - p = q; - } - return (result); -} - -/* append list -- produce new list (in reverse order) */ -static pointer revappend(scheme *sc, pointer a, pointer b) { - pointer result = a; - pointer p = b; - - while (is_pair(p)) { - result = cons(sc, car(p), result); - p = cdr(p); - } - - if (p == sc->NIL) { - return result; - } - - return sc->F; /* signal an error */ -} - -/* equivalence of atoms */ -int eqv(pointer a, pointer b) { - if (is_string(a)) { - if (is_string(b)) - return (strvalue(a) == strvalue(b)); - else - return (0); - } else if (is_number(a)) { - if (is_number(b)) { - if (num_is_integer(a) == num_is_integer(b)) - return num_eq(nvalue(a),nvalue(b)); - } - return (0); - } else if (is_character(a)) { - if (is_character(b)) - return charvalue(a)==charvalue(b); - else - return (0); - } else if (is_port(a)) { - if (is_port(b)) - return a==b; - else - return (0); - } else if (is_proc(a)) { - if (is_proc(b)) - return procnum(a)==procnum(b); - else - return (0); - } else { - return (a == b); - } -} - -/* true or false value macro */ -/* () is #t in R5RS */ -#define is_true(p) ((p) != sc->F) -#define is_false(p) ((p) == sc->F) - - -/* ========== Environment implementation ========== */ - -#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) - -static int hash_fn(const char *key, int table_size) -{ - unsigned int hashed = 0; - const char *c; - int bits_per_int = sizeof(unsigned int)*8; - - for (c = key; *c; c++) { - /* letters have about 5 bits in them */ - hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); - hashed ^= *c; - } - return hashed % table_size; -} -#endif - -/* Compares A and B. Returns an integer less than, equal to, or - * greater than zero if A is stored at a memory location that is - * numerical less than, equal to, or greater than that of B. */ -static int -pointercmp(pointer a, pointer b) -{ - uintptr_t a_n = (uintptr_t) a; - uintptr_t b_n = (uintptr_t) b; - - if (a_n < b_n) - return -1; - if (a_n > b_n) - return 1; - return 0; -} - -#ifndef USE_ALIST_ENV - -/* - * In this implementation, each frame of the environment may be - * a hash table: a vector of alists hashed by variable name. - * In practice, we use a vector only for the initial frame; - * subsequent frames are too small and transient for the lookup - * speed to out-weigh the cost of making a new vector. - */ - -static void new_frame_in_env(scheme *sc, pointer old_env) -{ - pointer new_frame; - - /* The interaction-environment has about 480 variables in it. */ - if (old_env == sc->NIL) { - new_frame = mk_vector(sc, 751); - } else { - new_frame = sc->NIL; - } - - gc_disable(sc, 1); - sc->envir = immutable_cons(sc, new_frame, old_env); - gc_enable(sc); - setenvironment(sc->envir); -} - -/* Find the slot in ENV under the key HDL. If ALL is given, look in - * all environments enclosing ENV. If the lookup fails, and SSLOT is - * given, the position where the new slot has to be inserted is stored - * at SSLOT. */ -static pointer -find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) -{ - pointer x,y; - int location; - pointer *sl; - int d; - assert(is_symbol(hdl)); - - for (x = env; x != sc->NIL; x = cdr(x)) { - if (is_vector(car(x))) { - location = hash_fn(symname(hdl), vector_length(car(x))); - sl = vector_elem_slot(car(x), location); - } else { - sl = &car(x); - } - for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) { - d = pointercmp(caar(y), hdl); - if (d == 0) - return car(y); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - - if (x == env && sslot) - *sslot = sl; /* Insert here. */ - - if (!all) - return sc->NIL; /* Miss, and stop looking. */ - } - - return sc->NIL; /* Not found in any environment. */ -} - -#else /* USE_ALIST_ENV */ - -static INLINE void new_frame_in_env(scheme *sc, pointer old_env) -{ - sc->envir = immutable_cons(sc, sc->NIL, old_env); - setenvironment(sc->envir); -} - -/* Find the slot in ENV under the key HDL. If ALL is given, look in - * all environments enclosing ENV. If the lookup fails, and SSLOT is - * given, the position where the new slot has to be inserted is stored - * at SSLOT. */ -static pointer -find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot) -{ - pointer x,y; - pointer *sl; - int d; - assert(is_symbol(hdl)); - - for (x = env; x != sc->NIL; x = cdr(x)) { - for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) { - d = pointercmp(caar(y), hdl); - if (d == 0) - return car(y); /* Hit. */ - else if (d > 0) - break; /* Miss. */ - } - - if (x == env && sslot) - *sslot = sl; /* Insert here. */ - - if (!all) - return sc->NIL; /* Miss, and stop looking. */ - } - - return sc->NIL; /* Not found in any environment. */ -} - -#endif /* USE_ALIST_ENV else */ - -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) -{ - return find_slot_spec_in_env(sc, env, hdl, all, NULL); -} - -/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using - * find_slot_spec_in_env, and no insertion must be done between - * obtaining SSLOT and the call to this function. */ -static INLINE void new_slot_spec_in_env(scheme *sc, - pointer variable, pointer value, - pointer *sslot) -{ -#define new_slot_spec_in_env_allocates 2 - pointer slot; - gc_disable(sc, gc_reservations (new_slot_spec_in_env)); - slot = immutable_cons(sc, variable, value); - *sslot = immutable_cons(sc, slot, *sslot); - gc_enable(sc); -} - -static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) -{ -#define new_slot_in_env_allocates new_slot_spec_in_env_allocates - pointer slot; - pointer *sslot; - assert(is_symbol(variable)); - slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot); - assert(slot == sc->NIL); - new_slot_spec_in_env(sc, variable, value, sslot); -} - -static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) -{ - (void)sc; - cdr(slot) = value; -} - -static INLINE pointer slot_value_in_env(pointer slot) -{ - return cdr(slot); -} - - -/* ========== Evaluation Cycle ========== */ - - -static enum scheme_opcodes -_Error_1(scheme *sc, const char *s, pointer a) { - const char *str = s; - pointer history; -#if USE_ERROR_HOOK - pointer x; - pointer hdl=sc->ERROR_HOOK; -#endif - -#if SHOW_ERROR_LINE - char sbuf[STRBUFFSIZE]; -#endif - - history = history_flatten(sc); - -#if SHOW_ERROR_LINE - /* make sure error is not in REPL */ - if (((sc->load_stack[sc->file_i].kind & port_file) == 0 - || sc->load_stack[sc->file_i].rep.stdio.file != stdin)) { - pointer tag; - const char *fname; - int ln; - - if (history != sc->NIL && has_tag(car(history)) - && (tag = get_tag(sc, car(history))) - && is_string(car(tag)) && is_integer(cdr(tag))) { - fname = string_value(car(tag)); - ln = ivalue_unchecked(cdr(tag)); - } else { - fname = string_value(sc->load_stack[sc->file_i].filename); - ln = ivalue_unchecked(sc->load_stack[sc->file_i].curr_line); - } - - /* should never happen */ - if(!fname) fname = ""; - - /* we started from 0 */ - ln++; - snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s); - - str = (const char*)sbuf; - } -#endif - -#if USE_ERROR_HOOK - x=find_slot_in_env(sc,sc->envir,hdl,1); - if (x != sc->NIL) { - sc->code = cons(sc, cons(sc, sc->QUOTE, - cons(sc, history, sc->NIL)), - sc->NIL); - if(a!=0) { - sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)), - sc->code); - } else { - sc->code = cons(sc, sc->F, sc->code); - } - sc->code = cons(sc, mk_string(sc, str), sc->code); - setimmutable(car(sc->code)); - sc->code = cons(sc, slot_value_in_env(x), sc->code); - return OP_EVAL; - } -#endif - - if(a!=0) { - sc->args = cons(sc, (a), sc->NIL); - } else { - sc->args = sc->NIL; - } - sc->args = cons(sc, mk_string(sc, str), sc->args); - setimmutable(car(sc->args)); - return OP_ERR0; -} -#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; } -#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; } - -/* Too small to turn into function */ -# define BEGIN do { -# define END } while (0) - - - -/* Flags. The interpreter has a flags field. When the interpreter - * pushes a frame to the dump stack, it is encoded with the opcode. - * Therefore, we do not use the least significant byte. */ - -/* Masks used to encode and decode opcode and flags. */ -#define S_OP_MASK 0x000000ff -#define S_FLAG_MASK 0xffffff00 - -/* Set if the interpreter evaluates an expression in a tail context - * (see R5RS, section 3.5). If a function, procedure, or continuation - * is invoked while this flag is set, the call is recorded as tail - * call in the history buffer. */ -#define S_FLAG_TAIL_CONTEXT 0x00000100 - -/* Set flag F. */ -#define s_set_flag(sc, f) \ - BEGIN \ - (sc)->flags |= S_FLAG_ ## f; \ - END - -/* Clear flag F. */ -#define s_clear_flag(sc, f) \ - BEGIN \ - (sc)->flags &= ~ S_FLAG_ ## f; \ - END - -/* Check if flag F is set. */ -#define s_get_flag(sc, f) \ - !!((sc)->flags & S_FLAG_ ## f) - - - -/* Bounce back to Eval_Cycle and execute A. */ -#define s_goto(sc, a) { op = (a); goto dispatch; } - -#if USE_THREADED_CODE - -/* Do not bounce back to Eval_Cycle but execute A by jumping directly - * to it. */ -#define s_thread_to(sc, a) \ - BEGIN \ - op = (a); \ - goto a; \ - END - -/* Define a label OP and emit a case statement for OP. For use in the - * dispatch function. The slightly peculiar goto that is never - * executed avoids warnings about unused labels. */ -#define CASE(OP) case OP: if (0) goto OP; OP - -#else /* USE_THREADED_CODE */ -#define s_thread_to(sc, a) s_goto(sc, a) -#define CASE(OP) case OP -#endif /* USE_THREADED_CODE */ - -/* Return to the previous frame on the dump stack, setting the current - * value to A. */ -#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0)) - -/* Return to the previous frame on the dump stack, setting the current - * value to A, and re-enable the garbage collector. */ -#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1)) - -static INLINE void dump_stack_reset(scheme *sc) -{ - sc->dump = sc->NIL; -} - -static INLINE void dump_stack_initialize(scheme *sc) -{ - dump_stack_reset(sc); - sc->frame_freelist = sc->NIL; -} - -static void dump_stack_free(scheme *sc) -{ - dump_stack_initialize(sc); -} - -const int frame_length = 4; - -static pointer -dump_stack_make_frame(scheme *sc) -{ - pointer frame; - - frame = mk_vector(sc, frame_length); - if (! sc->no_memory) - setframe(frame); - - return frame; -} - -static INLINE pointer * -frame_slots(pointer frame) -{ - return &frame->_object._vector._elements[0]; -} - -#define frame_payload vector_length - -static pointer -dump_stack_allocate_frame(scheme *sc) -{ - pointer frame = sc->frame_freelist; - if (frame == sc->NIL) { - if (gc_enabled(sc)) - frame = dump_stack_make_frame(sc); - else - gc_reservation_failure(sc); - } else - sc->frame_freelist = *frame_slots(frame); - return frame; -} - -static void -dump_stack_deallocate_frame(scheme *sc, pointer frame) -{ - pointer *p = frame_slots(frame); - *p++ = sc->frame_freelist; - *p++ = sc->NIL; - *p++ = sc->NIL; - *p++ = sc->NIL; - sc->frame_freelist = frame; -} - -static void -dump_stack_preallocate_frame(scheme *sc) -{ - pointer frame = dump_stack_make_frame(sc); - if (! sc->no_memory) - dump_stack_deallocate_frame(sc, frame); -} - -static enum scheme_opcodes -_s_return(scheme *sc, pointer a, int enable_gc) { - pointer dump = sc->dump; - pointer *p; - unsigned long v; - enum scheme_opcodes next_op; - sc->value = (a); - if (enable_gc) - gc_enable(sc); - if (dump == sc->NIL) - return OP_QUIT; - v = frame_payload(dump); - next_op = (int) (v & S_OP_MASK); - sc->flags = v & S_FLAG_MASK; - p = frame_slots(dump); - sc->args = *p++; - sc->envir = *p++; - sc->code = *p++; - sc->dump = *p++; - dump_stack_deallocate_frame(sc, dump); - return next_op; -} - -static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { -#define s_save_allocates 0 - pointer dump; - pointer *p; - gc_disable(sc, gc_reservations (s_save)); - dump = dump_stack_allocate_frame(sc); - frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op); - p = frame_slots(dump); - *p++ = args; - *p++ = sc->envir; - *p++ = code; - *p++ = sc->dump; - sc->dump = dump; - gc_enable(sc); -} - -static INLINE void dump_stack_mark(scheme *sc) -{ - mark(sc->dump); - mark(sc->frame_freelist); -} - - - -#if USE_HISTORY - -static void -history_free(scheme *sc) -{ - sc->free(sc->history.m); - sc->history.tailstacks = sc->NIL; - sc->history.callstack = sc->NIL; -} - -static pointer -history_init(scheme *sc, size_t N, size_t M) -{ - size_t i; - struct history *h = &sc->history; - - h->N = N; - h->mask_N = N - 1; - h->n = N - 1; - assert ((N & h->mask_N) == 0); - - h->M = M; - h->mask_M = M - 1; - assert ((M & h->mask_M) == 0); - - h->callstack = mk_vector(sc, N); - if (h->callstack == sc->sink) - goto fail; - - h->tailstacks = mk_vector(sc, N); - for (i = 0; i < N; i++) { - pointer tailstack = mk_vector(sc, M); - if (tailstack == sc->sink) - goto fail; - set_vector_elem(h->tailstacks, i, tailstack); - } - - h->m = sc->malloc(N * sizeof *h->m); - if (h->m == NULL) - goto fail; - - for (i = 0; i < N; i++) - h->m[i] = 0; - - return sc->T; - -fail: - history_free(sc); - return sc->F; -} - -static void -history_mark(scheme *sc) -{ - struct history *h = &sc->history; - mark(h->callstack); - mark(h->tailstacks); -} - -#define add_mod(a, b, mask) (((a) + (b)) & (mask)) -#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask) - -static INLINE void -tailstack_clear(scheme *sc, pointer v) -{ - assert(is_vector(v)); - /* XXX optimize */ - fill_vector(v, sc->NIL); -} - -static pointer -callstack_pop(scheme *sc) -{ - struct history *h = &sc->history; - size_t n = h->n; - pointer item; - - if (h->callstack == sc->NIL) - return sc->NIL; - - item = vector_elem(h->callstack, n); - /* Clear our frame so that it can be gc'ed and we don't run into it - * when walking the history. */ - set_vector_elem(h->callstack, n, sc->NIL); - tailstack_clear(sc, vector_elem(h->tailstacks, n)); - - /* Exit from the frame. */ - h->n = sub_mod(h->n, 1, h->mask_N); - - return item; -} - -static void -callstack_push(scheme *sc, pointer item) -{ - struct history *h = &sc->history; - size_t n = h->n; - - if (h->callstack == sc->NIL) - return; - - /* Enter a new frame. */ - n = h->n = add_mod(n, 1, h->mask_N); - - /* Initialize tail stack. */ - tailstack_clear(sc, vector_elem(h->tailstacks, n)); - h->m[n] = h->mask_M; - - set_vector_elem(h->callstack, n, item); -} - -static void -tailstack_push(scheme *sc, pointer item) -{ - struct history *h = &sc->history; - size_t n = h->n; - size_t m = h->m[n]; - - if (h->callstack == sc->NIL) - return; - - /* Enter a new tail frame. */ - m = h->m[n] = add_mod(m, 1, h->mask_M); - set_vector_elem(vector_elem(h->tailstacks, n), m, item); -} - -static pointer -tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n, - pointer acc) -{ - struct history *h = &sc->history; - pointer frame; - - assert(i <= h->M); - assert(n < h->M); - - if (acc == sc->sink) - return sc->sink; - - if (i == 0) { - /* We reached the end, but we did not see a unused frame. Signal - this using '... . */ - return cons(sc, mk_symbol(sc, "..."), acc); - } - - frame = vector_elem(tailstack, n); - if (frame == sc->NIL) { - /* A unused frame. We reached the end of the history. */ - return acc; - } - - /* Add us. */ - acc = cons(sc, frame, acc); - - return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M), - acc); -} - -static pointer -callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc) -{ - struct history *h = &sc->history; - pointer frame; - - assert(i <= h->N); - assert(n < h->N); - - if (acc == sc->sink) - return sc->sink; - - if (i == 0) { - /* We reached the end, but we did not see a unused frame. Signal - this using '... . */ - return cons(sc, mk_symbol(sc, "..."), acc); - } - - frame = vector_elem(h->callstack, n); - if (frame == sc->NIL) { - /* A unused frame. We reached the end of the history. */ - return acc; - } - - /* First, emit the tail calls. */ - acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n], - acc); - - /* Then us. */ - acc = cons(sc, frame, acc); - - return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc); -} - -static pointer -history_flatten(scheme *sc) -{ - struct history *h = &sc->history; - pointer history; - - if (h->callstack == sc->NIL) - return sc->NIL; - - history = callstack_flatten(sc, h->N, h->n, sc->NIL); - if (history == sc->sink) - return sc->sink; - - return reverse_in_place(sc, sc->NIL, history); -} - -#undef add_mod -#undef sub_mod - -#else /* USE_HISTORY */ - -#define history_init(SC, A, B) (void) 0 -#define history_free(SC) (void) 0 -#define callstack_pop(SC) (void) 0 -#define callstack_push(SC, X) (void) 0 -#define tailstack_push(SC, X) (void) 0 - -#endif /* USE_HISTORY */ - - - -#if USE_PLIST -static pointer -get_property(scheme *sc, pointer obj, pointer key) -{ - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - return cdar(x); - - return sc->NIL; -} - -static pointer -set_property(scheme *sc, pointer obj, pointer key, pointer value) -{ -#define set_property_allocates 2 - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - cdar(x) = value; - else { - gc_disable(sc, gc_reservations(set_property)); - symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); - gc_enable(sc); - } - - return sc->T; -} -#endif - - - -static int is_list(scheme *sc, pointer a) -{ return list_length(sc,a) >= 0; } - -/* Result is: - proper list: length - circular list: -1 - not even a pair: -2 - dotted list: -2 minus length before dot -*/ -int list_length(scheme *sc, pointer a) { - int i=0; - pointer slow, fast; - - slow = fast = a; - while (1) - { - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - fast = cdr(fast); - ++i; - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - ++i; - fast = cdr(fast); - - /* Safe because we would have already returned if `fast' - encountered a non-pair. */ - slow = cdr(slow); - if (fast == slow) - { - /* the fast pointer has looped back around and caught up - with the slow pointer, hence the structure is circular, - not of finite length, and therefore not a list */ - return -1; - } - } -} - - - -#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) - -/* kernel of this interpreter */ -static void -Eval_Cycle(scheme *sc, enum scheme_opcodes op) { - for (;;) { - pointer x, y; - pointer callsite; - num v; -#if USE_MATH - double dd; -#endif - int (*comp_func)(num, num) = NULL; - const struct op_code_info *pcd; - - dispatch: - pcd = &dispatch_table[op]; - if (pcd->name[0] != 0) { /* if built-in function, check arguments */ - char msg[STRBUFFSIZE]; - if (! check_arguments (sc, pcd, msg, sizeof msg)) { - s_goto(sc, _Error_1(sc, msg, 0)); - } - } - - if(sc->no_memory) { - fprintf(stderr,"No memory!\n"); - exit(1); - } - ok_to_freely_gc(sc); - - switch (op) { - CASE(OP_LOAD): /* load */ - if(file_interactive(sc)) { - fprintf(sc->outport->_object._port->rep.stdio.file, - "Loading %s\n", strvalue(car(sc->args))); - } - if (!file_push(sc, car(sc->args))) { - Error_1(sc,"unable to open", car(sc->args)); - } - else - { - sc->args = mk_integer(sc,sc->file_i); - s_thread_to(sc,OP_T0LVL); - } - - CASE(OP_T0LVL): /* top level */ - /* If we reached the end of file, this loop is done. */ - if(sc->loadport->_object._port->kind & port_saw_EOF) - { - if(sc->file_i == 0) - { - sc->args=sc->NIL; - sc->nesting = sc->nesting_stack[0]; - s_thread_to(sc,OP_QUIT); - } - else - { - file_pop(sc); - s_return(sc,sc->value); - } - /* NOTREACHED */ - } - - /* If interactive, be nice to user. */ - if(file_interactive(sc)) - { - sc->envir = sc->global_env; - dump_stack_reset(sc); - putstr(sc,"\n"); - putstr(sc,prompt); - } - - /* Set up another iteration of REPL */ - sc->nesting=0; - sc->save_inport=sc->inport; - sc->inport = sc->loadport; - s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); - s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); - s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); - s_thread_to(sc,OP_READ_INTERNAL); - - CASE(OP_T1LVL): /* top level */ - sc->code = sc->value; - sc->inport=sc->save_inport; - s_thread_to(sc,OP_EVAL); - - CASE(OP_READ_INTERNAL): /* internal read */ - sc->tok = token(sc); - if(sc->tok==TOK_EOF) - { s_return(sc,sc->EOF_OBJ); } - s_thread_to(sc,OP_RDSEXPR); - - CASE(OP_GENSYM): - s_return(sc, gensym(sc)); - - CASE(OP_VALUEPRINT): /* print evaluation result */ - /* OP_VALUEPRINT is always pushed, because when changing from - non-interactive to interactive mode, it needs to be - already on the stack */ - if(sc->tracing) { - putstr(sc,"\nGives: "); - } - if(file_interactive(sc)) { - sc->print_flag = 1; - sc->args = sc->value; - s_thread_to(sc,OP_P0LIST); - } else { - s_return(sc,sc->value); - } - - CASE(OP_EVAL): /* main part of evaluation */ -#if USE_TRACING - if(sc->tracing) { - /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ - s_save(sc,OP_REAL_EVAL,sc->args,sc->code); - sc->args=sc->code; - putstr(sc,"\nEval: "); - s_thread_to(sc,OP_P0LIST); - } - /* fall through */ - CASE(OP_REAL_EVAL): -#endif - if (is_symbol(sc->code)) { /* symbol */ - x=find_slot_in_env(sc,sc->envir,sc->code,1); - if (x != sc->NIL) { - s_return(sc,slot_value_in_env(x)); - } else { - Error_1(sc, "eval: unbound variable", sc->code); - } - } else if (is_pair(sc->code)) { - if (is_syntax(x = car(sc->code))) { /* SYNTAX */ - sc->code = cdr(sc->code); - s_goto(sc, syntaxnum(sc, x)); - } else {/* first, eval top element and eval arguments */ - s_save(sc,OP_E0ARGS, sc->NIL, sc->code); - /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ - sc->code = car(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } - } else { - s_return(sc,sc->code); - } - - CASE(OP_E0ARGS): /* eval arguments */ - if (is_macro(sc->value)) { /* macro expansion */ - gc_disable(sc, 1 + gc_reservations (s_save)); - s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); - sc->args = cons(sc,sc->code, sc->NIL); - gc_enable(sc); - sc->code = sc->value; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_APPLY); - } else { - gc_disable(sc, 1); - sc->args = cons(sc, sc->code, sc->NIL); - gc_enable(sc); - sc->code = cdr(sc->code); - s_thread_to(sc,OP_E1ARGS); - } - - CASE(OP_E1ARGS): /* eval arguments */ - gc_disable(sc, 1); - sc->args = cons(sc, sc->value, sc->args); - gc_enable(sc); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); - sc->code = car(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - s_thread_to(sc,OP_APPLY_CODE); - } - -#if USE_TRACING - CASE(OP_TRACING): { - int tr=sc->tracing; - sc->tracing=ivalue(car(sc->args)); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, tr)); - } -#endif - -#if USE_HISTORY - CASE(OP_CALLSTACK_POP): /* pop the call stack */ - callstack_pop(sc); - s_return(sc, sc->value); -#endif - - CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)', - * record in the history as invoked from - * 'car(args)' */ - free_cons(sc, sc->args, &callsite, &sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - /* Fallthrough. */ - - CASE(OP_APPLY): /* apply 'code' to 'args' */ -#if USE_TRACING - if(sc->tracing) { - s_save(sc,OP_REAL_APPLY,sc->args,sc->code); - sc->print_flag = 1; - /* sc->args=cons(sc,sc->code,sc->args);*/ - putstr(sc,"\nApply to: "); - s_thread_to(sc,OP_P0LIST); - } - /* fall through */ - CASE(OP_REAL_APPLY): -#endif -#if USE_HISTORY - if (op != OP_APPLY_CODE) - callsite = sc->code; - if (s_get_flag(sc, TAIL_CONTEXT)) { - /* We are evaluating a tail call. */ - tailstack_push(sc, callsite); - } else { - callstack_push(sc, callsite); - s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL); - } -#endif - - if (is_proc(sc->code)) { - s_goto(sc,procnum(sc->code)); /* PROCEDURE */ - } else if (is_foreign(sc->code)) - { - /* Keep nested calls from GC'ing the arglist */ - push_recent_alloc(sc,sc->args,sc->NIL); - x=sc->code->_object._ff(sc,sc->args); - s_return(sc,x); - } else if (is_closure(sc->code) || is_macro(sc->code) - || is_promise(sc->code)) { /* CLOSURE */ - /* Should not accept promise */ - /* make environment */ - new_frame_in_env(sc, closure_env(sc->code)); - for (x = car(closure_code(sc->code)), y = sc->args; - is_pair(x); x = cdr(x), y = cdr(y)) { - if (y == sc->NIL) { - Error_1(sc, "not enough arguments, missing", x); - } else if (is_symbol(car(x))) { - new_slot_in_env(sc, car(x), car(y)); - } else { - Error_1(sc, "syntax error in closure: not a symbol", car(x)); - } - } - - if (x == sc->NIL) { - if (y != sc->NIL) { - Error_0(sc, "too many arguments"); - } - } else if (is_symbol(x)) - new_slot_in_env(sc, x, y); - else { - Error_1(sc, "syntax error in closure: not a symbol", x); - } - sc->code = cdr(closure_code(sc->code)); - sc->args = sc->NIL; - s_set_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_BEGIN); - } else if (is_continuation(sc->code)) { /* CONTINUATION */ - sc->dump = cont_dump(sc->code); - s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); - } else { - Error_1(sc,"illegal function",sc->code); - } - - CASE(OP_DOMACRO): /* do macro */ - sc->code = sc->value; - s_thread_to(sc,OP_EVAL); - -#if USE_COMPILE_HOOK - CASE(OP_LAMBDA): /* lambda */ - /* If the hook is defined, apply it to sc->code, otherwise - set sc->value fall through */ - { - pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); - if(f==sc->NIL) { - sc->value = sc->code; - /* Fallthru */ - } else { - gc_disable(sc, 1 + gc_reservations (s_save)); - s_save(sc,OP_LAMBDA1,sc->args,sc->code); - sc->args=cons(sc,sc->code,sc->NIL); - gc_enable(sc); - sc->code=slot_value_in_env(f); - s_thread_to(sc,OP_APPLY); - } - } - /* Fallthrough. */ -#else - CASE(OP_LAMBDA): /* lambda */ - sc->value = sc->code; - /* Fallthrough. */ -#endif - - CASE(OP_LAMBDA1): - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); - - - CASE(OP_MKCLOSURE): /* make-closure */ - x=car(sc->args); - if(car(x)==sc->LAMBDA) { - x=cdr(x); - } - if(cdr(sc->args)==sc->NIL) { - y=sc->envir; - } else { - y=cadr(sc->args); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_closure(sc, x, y)); - - CASE(OP_QUOTE): /* quote */ - s_return(sc,car(sc->code)); - - CASE(OP_DEF0): /* define */ - if(is_immutable(car(sc->code))) - Error_1(sc,"define: unable to alter immutable", car(sc->code)); - - if (is_pair(car(sc->code))) { - x = caar(sc->code); - gc_disable(sc, 2); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - gc_enable(sc); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_DEF1, sc->NIL, x); - s_thread_to(sc,OP_EVAL); - - CASE(OP_DEF1): { /* define */ - pointer *sslot; - x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_spec_in_env(sc, sc->code, sc->value, sslot); - } - s_return(sc,sc->code); - } - - CASE(OP_DEFP): /* defined? */ - x=sc->envir; - if(cdr(sc->args)!=sc->NIL) { - x=cadr(sc->args); - } - s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); - - CASE(OP_SET0): /* set! */ - if(is_immutable(car(sc->code))) - Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); - s_save(sc,OP_SET1, sc->NIL, car(sc->code)); - sc->code = cadr(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_SET1): /* set! */ - y=find_slot_in_env(sc,sc->envir,sc->code,1); - if (y != sc->NIL) { - set_slot_in_env(sc, y, sc->value); - s_return(sc,sc->value); - } else { - Error_1(sc, "set!: unbound variable", sc->code); - } - - - CASE(OP_BEGIN): /* begin */ - { - int last; - - if (!is_pair(sc->code)) { - s_return(sc,sc->code); - } - - last = cdr(sc->code) == sc->NIL; - if (!last) { - s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); - } - sc->code = car(sc->code); - if (! last) - /* This is not the end of the list. This is not a tail - * position. */ - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } - - CASE(OP_IF0): /* if */ - s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_IF1): /* if */ - if (is_true(sc->value)) - sc->code = car(sc->code); - else - sc->code = cadr(sc->code); /* (if #f 1) ==> () because - * car(sc->NIL) = sc->NIL */ - s_thread_to(sc,OP_EVAL); - - CASE(OP_LET0): /* let */ - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); - s_thread_to(sc,OP_LET1); - - CASE(OP_LET1): /* let (calculate parameters) */ - gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0)); - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { - gc_enable(sc); - Error_1(sc, "Bad syntax of binding spec in let", - car(sc->code)); - } - s_save(sc,OP_LET1, sc->args, cdr(sc->code)); - gc_enable(sc); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - gc_enable(sc); - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_thread_to(sc,OP_LET2); - } - - CASE(OP_LET2): /* let */ - new_frame_in_env(sc, sc->envir); - for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; - y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - if (is_symbol(car(sc->code))) { /* named let */ - for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { - if (!is_pair(x)) - Error_1(sc, "Bad syntax of binding in let", x); - if (!is_list(sc, car(x))) - Error_1(sc, "Bad syntax of binding in let", car(x)); - gc_disable(sc, 1); - sc->args = cons(sc, caar(x), sc->args); - gc_enable(sc); - } - gc_disable(sc, 2 + gc_reservations (new_slot_in_env)); - x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); - new_slot_in_env(sc, car(sc->code), x); - gc_enable(sc); - sc->code = cddr(sc->code); - sc->args = sc->NIL; - } else { - sc->code = cdr(sc->code); - sc->args = sc->NIL; - } - s_thread_to(sc,OP_BEGIN); - - CASE(OP_LET0AST): /* let* */ - if (car(sc->code) == sc->NIL) { - new_frame_in_env(sc, sc->envir); - sc->code = cdr(sc->code); - s_thread_to(sc,OP_BEGIN); - } - if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { - Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code)); - } - s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); - sc->code = cadaar(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_LET1AST): /* let* (make new frame) */ - new_frame_in_env(sc, sc->envir); - s_thread_to(sc,OP_LET2AST); - - CASE(OP_LET2AST): /* let* (calculate parameters) */ - new_slot_in_env(sc, caar(sc->code), sc->value); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET2AST, sc->args, sc->code); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - sc->code = sc->args; - sc->args = sc->NIL; - s_thread_to(sc,OP_BEGIN); - } - - CASE(OP_LET0REC): /* letrec */ - new_frame_in_env(sc, sc->envir); - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = car(sc->code); - s_thread_to(sc,OP_LET1REC); - - CASE(OP_LET1REC): /* letrec (calculate parameters) */ - gc_disable(sc, 1); - sc->args = cons(sc, sc->value, sc->args); - gc_enable(sc); - if (is_pair(sc->code)) { /* continue */ - if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { - Error_1(sc, "Bad syntax of binding spec in letrec", - car(sc->code)); - } - s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_thread_to(sc,OP_LET2REC); - } - - CASE(OP_LET2REC): /* letrec */ - for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - sc->code = cdr(sc->code); - sc->args = sc->NIL; - s_thread_to(sc,OP_BEGIN); - - CASE(OP_COND0): /* cond */ - if (!is_pair(sc->code)) { - Error_0(sc,"syntax error in cond"); - } - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_COND1): /* cond */ - if (is_true(sc->value)) { - if ((sc->code = cdar(sc->code)) == sc->NIL) { - s_return(sc,sc->value); - } - if(!sc->code || car(sc->code)==sc->FEED_TO) { - if(!is_pair(cdr(sc->code))) { - Error_0(sc,"syntax error in cond"); - } - gc_disable(sc, 4); - x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); - sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); - gc_enable(sc); - s_thread_to(sc,OP_EVAL); - } - s_thread_to(sc,OP_BEGIN); - } else { - if ((sc->code = cdr(sc->code)) == sc->NIL) { - s_return(sc,sc->NIL); - } else { - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - } - } - - CASE(OP_DELAY): /* delay */ - gc_disable(sc, 2); - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return_enable_gc(sc,x); - - CASE(OP_AND0): /* and */ - if (sc->code == sc->NIL) { - s_return(sc,sc->T); - } - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_AND1): /* and */ - if (is_false(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - } - - CASE(OP_OR0): /* or */ - if (sc->code == sc->NIL) { - s_return(sc,sc->F); - } - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_OR1): /* or */ - if (is_true(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - if (cdr(sc->code) != sc->NIL) - s_clear_flag(sc, TAIL_CONTEXT); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - } - - CASE(OP_C0STREAM): /* cons-stream */ - s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_thread_to(sc,OP_EVAL); - - CASE(OP_C1STREAM): /* cons-stream */ - sc->args = sc->value; /* save sc->value to register sc->args for gc */ - gc_disable(sc, 3); - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return_enable_gc(sc, cons(sc, sc->args, x)); - - CASE(OP_MACRO0): /* macro */ - if (is_pair(car(sc->code))) { - x = caar(sc->code); - gc_disable(sc, 2); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - gc_enable(sc); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_MACRO1, sc->NIL, x); - s_thread_to(sc,OP_EVAL); - - CASE(OP_MACRO1): { /* macro */ - pointer *sslot; - typeflag(sc->value) = T_MACRO; - x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_spec_in_env(sc, sc->code, sc->value, sslot); - } - s_return(sc,sc->code); - } - - CASE(OP_CASE0): /* case */ - s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_clear_flag(sc, TAIL_CONTEXT); - s_thread_to(sc,OP_EVAL); - - CASE(OP_CASE1): /* case */ - for (x = sc->code; x != sc->NIL; x = cdr(x)) { - if (!is_pair(y = caar(x))) { - break; - } - for ( ; y != sc->NIL; y = cdr(y)) { - if (eqv(car(y), sc->value)) { - break; - } - } - if (y != sc->NIL) { - break; - } - } - if (x != sc->NIL) { - if (is_pair(caar(x))) { - sc->code = cdar(x); - s_thread_to(sc,OP_BEGIN); - } else {/* else */ - s_save(sc,OP_CASE2, sc->NIL, cdar(x)); - sc->code = caar(x); - s_thread_to(sc,OP_EVAL); - } - } else { - s_return(sc,sc->NIL); - } - - CASE(OP_CASE2): /* case */ - if (is_true(sc->value)) { - s_thread_to(sc,OP_BEGIN); - } else { - s_return(sc,sc->NIL); - } - - CASE(OP_PAPPLY): /* apply */ - sc->code = car(sc->args); - sc->args = list_star(sc,cdr(sc->args)); - /*sc->args = cadr(sc->args);*/ - s_thread_to(sc,OP_APPLY); - - CASE(OP_PEVAL): /* eval */ - if(cdr(sc->args)!=sc->NIL) { - sc->envir=cadr(sc->args); - } - sc->code = car(sc->args); - s_thread_to(sc,OP_EVAL); - - CASE(OP_CONTINUATION): /* call-with-current-continuation */ - sc->code = car(sc->args); - gc_disable(sc, 2); - sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); - gc_enable(sc); - s_thread_to(sc,OP_APPLY); - -#if USE_MATH - CASE(OP_INEX2EX): /* inexact->exact */ - x=car(sc->args); - if(num_is_integer(x)) { - s_return(sc,x); - } else if(modf(rvalue_unchecked(x),&dd)==0.0) { - s_return(sc,mk_integer(sc,ivalue(x))); - } else { - Error_1(sc, "inexact->exact: not integral", x); - } - - CASE(OP_EXP): - x=car(sc->args); - s_return(sc, mk_real(sc, exp(rvalue(x)))); - - CASE(OP_LOG): - x=car(sc->args); - s_return(sc, mk_real(sc, log(rvalue(x)))); - - CASE(OP_SIN): - x=car(sc->args); - s_return(sc, mk_real(sc, sin(rvalue(x)))); - - CASE(OP_COS): - x=car(sc->args); - s_return(sc, mk_real(sc, cos(rvalue(x)))); - - CASE(OP_TAN): - x=car(sc->args); - s_return(sc, mk_real(sc, tan(rvalue(x)))); - - CASE(OP_ASIN): - x=car(sc->args); - s_return(sc, mk_real(sc, asin(rvalue(x)))); - - CASE(OP_ACOS): - x=car(sc->args); - s_return(sc, mk_real(sc, acos(rvalue(x)))); - - CASE(OP_ATAN): - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - s_return(sc, mk_real(sc, atan(rvalue(x)))); - } else { - pointer y=cadr(sc->args); - s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); - } - - CASE(OP_SQRT): - x=car(sc->args); - s_return(sc, mk_real(sc, sqrt(rvalue(x)))); - - CASE(OP_EXPT): { - double result; - int real_result=1; - pointer y=cadr(sc->args); - x=car(sc->args); - if (num_is_integer(x) && num_is_integer(y)) - real_result=0; - /* This 'if' is an R5RS compatibility fix. */ - /* NOTE: Remove this 'if' fix for R6RS. */ - if (rvalue(x) == 0 && rvalue(y) < 0) { - result = 0.0; - } else { - result = pow(rvalue(x),rvalue(y)); - } - /* Before returning integer result make sure we can. */ - /* If the test fails, result is too big for integer. */ - if (!real_result) - { - long result_as_long = (long)result; - if (result != (double)result_as_long) - real_result = 1; - } - if (real_result) { - s_return(sc, mk_real(sc, result)); - } else { - s_return(sc, mk_integer(sc, result)); - } - } - - CASE(OP_FLOOR): - x=car(sc->args); - s_return(sc, mk_real(sc, floor(rvalue(x)))); - - CASE(OP_CEILING): - x=car(sc->args); - s_return(sc, mk_real(sc, ceil(rvalue(x)))); - - CASE(OP_TRUNCATE ): { - double rvalue_of_x ; - x=car(sc->args); - rvalue_of_x = rvalue(x) ; - if (rvalue_of_x > 0) { - s_return(sc, mk_real(sc, floor(rvalue_of_x))); - } else { - s_return(sc, mk_real(sc, ceil(rvalue_of_x))); - } - } - - CASE(OP_ROUND): - x=car(sc->args); - if (num_is_integer(x)) - s_return(sc, x); - s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); -#endif - - CASE(OP_ADD): /* + */ - v=num_zero; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_add(v,nvalue(car(x))); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_MUL): /* * */ - v=num_one; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_mul(v,nvalue(car(x))); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_SUB): /* - */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_zero; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - v=num_sub(v,nvalue(car(x))); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_DIV): /* / */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (!is_zero_double(rvalue(car(x)))) - v=num_div(v,nvalue(car(x))); - else { - Error_0(sc,"/: division by zero"); - } - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_INTDIV): /* quotient */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (ivalue(car(x)) != 0) - v=num_intdiv(v,nvalue(car(x))); - else { - Error_0(sc,"quotient: division by zero"); - } - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_REM): /* remainder */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_rem(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"remainder: division by zero"); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_MOD): /* modulo */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_mod(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"modulo: division by zero"); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_number(sc, v)); - - CASE(OP_CAR): /* car */ - s_return(sc,caar(sc->args)); - - CASE(OP_CDR): /* cdr */ - s_return(sc,cdar(sc->args)); - - CASE(OP_CONS): /* cons */ - cdr(sc->args) = cadr(sc->args); - s_return(sc,sc->args); - - CASE(OP_SETCAR): /* set-car! */ - if(!is_immutable(car(sc->args))) { - caar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-car!: unable to alter immutable pair"); - } - - CASE(OP_SETCDR): /* set-cdr! */ - if(!is_immutable(car(sc->args))) { - cdar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-cdr!: unable to alter immutable pair"); - } - - CASE(OP_CHAR2INT): { /* char->integer */ - char c; - c=(char)ivalue(car(sc->args)); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c)); - } - - CASE(OP_INT2CHAR): { /* integer->char */ - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_character(sc, (char) c)); - } - - CASE(OP_CHARUPCASE): { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=toupper(c); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_character(sc, (char) c)); - } - - CASE(OP_CHARDNCASE): { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=tolower(c); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_character(sc, (char) c)); - } - - CASE(OP_STR2SYM): /* string->symbol */ - gc_disable(sc, gc_reservations (mk_symbol)); - s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args)))); - - CASE(OP_STR2ATOM): /* string->atom */ { - char *s=strvalue(car(sc->args)); - long pf = 0; - if(cdr(sc->args)!=sc->NIL) { - /* we know cadr(sc->args) is a natural number */ - /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked(cadr(sc->args)); - if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { - /* base is OK */ - } - else { - pf = -1; - } - } - if (pf < 0) { - Error_1(sc, "string->atom: bad base", cadr(sc->args)); - } else if(*s=='#') /* no use of base! */ { - s_return(sc, mk_sharp_const(sc, s+1)); - } else { - if (pf == 0 || pf == 10) { - s_return(sc, mk_atom(sc, s)); - } - else { - char *ep; - long iv = strtol(s,&ep,(int )pf); - if (*ep == 0) { - s_return(sc, mk_integer(sc, iv)); - } - else { - s_return(sc, sc->F); - } - } - } - } - - CASE(OP_SYM2STR): /* symbol->string */ - gc_disable(sc, 1); - x=mk_string(sc,symname(car(sc->args))); - setimmutable(x); - s_return_enable_gc(sc, x); - - CASE(OP_ATOM2STR): /* atom->string */ { - long pf = 0; - x=car(sc->args); - if(cdr(sc->args)!=sc->NIL) { - /* we know cadr(sc->args) is a natural number */ - /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked(cadr(sc->args)); - if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { - /* base is OK */ - } - else { - pf = -1; - } - } - if (pf < 0) { - Error_1(sc, "atom->string: bad base", cadr(sc->args)); - } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { - char *p; - int len; - atom2str(sc,x,(int )pf,&p,&len); - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_counted_string(sc, p, len)); - } else { - Error_1(sc, "atom->string: not an atom", x); - } - } - - CASE(OP_MKSTRING): { /* make-string */ - int fill=' '; - int len; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=charvalue(cadr(sc->args)); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill)); - } - - CASE(OP_STRLEN): /* string-length */ - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args)))); - - CASE(OP_STRREF): { /* string-ref */ - char *str; - int index; - - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - - if(index>=strlength(car(sc->args))) { - Error_1(sc, "string-ref: out of bounds", cadr(sc->args)); - } - - gc_disable(sc, 1); - s_return_enable_gc(sc, - mk_character(sc, ((unsigned char*) str)[index])); - } - - CASE(OP_STRSET): { /* string-set! */ - char *str; - int index; - int c; - - if(is_immutable(car(sc->args))) { - Error_1(sc, "string-set!: unable to alter immutable string", - car(sc->args)); - } - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - if(index>=strlength(car(sc->args))) { - Error_1(sc, "string-set!: out of bounds", cadr(sc->args)); - } - - c=charvalue(caddr(sc->args)); - - str[index]=(char)c; - s_return(sc,car(sc->args)); - } - - CASE(OP_STRAPPEND): { /* string-append */ - /* in 1.29 string-append was in Scheme in init.scm but was too slow */ - int len = 0; - pointer newstr; - char *pos; - - /* compute needed length for new string */ - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - len += strlength(car(x)); - } - gc_disable(sc, 1); - newstr = mk_empty_string(sc, len, ' '); - /* store the contents of the argument strings into the new string */ - for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; - pos += strlength(car(x)), x = cdr(x)) { - memcpy(pos, strvalue(car(x)), strlength(car(x))); - } - s_return_enable_gc(sc, newstr); - } - - CASE(OP_SUBSTR): { /* substring */ - char *str; - int index0; - int index1; - - str=strvalue(car(sc->args)); - - index0=ivalue(cadr(sc->args)); - - if(index0>strlength(car(sc->args))) { - Error_1(sc, "substring: start out of bounds", cadr(sc->args)); - } - - if(cddr(sc->args)!=sc->NIL) { - index1=ivalue(caddr(sc->args)); - if(index1>strlength(car(sc->args)) || index1args)); - } - } else { - index1=strlength(car(sc->args)); - } - - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0)); - } - - CASE(OP_VECTOR): { /* vector */ - int i; - pointer vec; - int len=list_length(sc,sc->args); - if(len<0) { - Error_1(sc, "vector: not a proper list", sc->args); - } - vec=mk_vector(sc,len); - if(sc->no_memory) { s_return(sc, sc->sink); } - for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { - set_vector_elem(vec,i,car(x)); - } - s_return(sc,vec); - } - - CASE(OP_MKVECTOR): { /* make-vector */ - pointer fill=sc->NIL; - int len; - pointer vec; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=cadr(sc->args); - } - vec=mk_vector(sc,len); - if(sc->no_memory) { s_return(sc, sc->sink); } - if(fill!=sc->NIL) { - fill_vector(vec,fill); - } - s_return(sc,vec); - } - - CASE(OP_VECLEN): /* vector-length */ - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args)))); - - CASE(OP_VECREF): { /* vector-ref */ - int index; - - index=ivalue(cadr(sc->args)); - - if(index >= vector_length(car(sc->args))) { - Error_1(sc, "vector-ref: out of bounds", cadr(sc->args)); - } - - s_return(sc,vector_elem(car(sc->args),index)); - } - - CASE(OP_VECSET): { /* vector-set! */ - int index; - - if(is_immutable(car(sc->args))) { - Error_1(sc, "vector-set!: unable to alter immutable vector", - car(sc->args)); - } - - index=ivalue(cadr(sc->args)); - if(index >= vector_length(car(sc->args))) { - Error_1(sc, "vector-set!: out of bounds", cadr(sc->args)); - } - - set_vector_elem(car(sc->args),index,caddr(sc->args)); - s_return(sc,car(sc->args)); - } - - CASE(OP_NOT): /* not */ - s_retbool(is_false(car(sc->args))); - CASE(OP_BOOLP): /* boolean? */ - s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); - CASE(OP_EOFOBJP): /* boolean? */ - s_retbool(car(sc->args) == sc->EOF_OBJ); - CASE(OP_NULLP): /* null? */ - s_retbool(car(sc->args) == sc->NIL); - CASE(OP_NUMEQ): /* = */ - /* Fallthrough. */ - CASE(OP_LESS): /* < */ - /* Fallthrough. */ - CASE(OP_GRE): /* > */ - /* Fallthrough. */ - CASE(OP_LEQ): /* <= */ - /* Fallthrough. */ - CASE(OP_GEQ): /* >= */ - switch(op) { - case OP_NUMEQ: comp_func=num_eq; break; - case OP_LESS: comp_func=num_lt; break; - case OP_GRE: comp_func=num_gt; break; - case OP_LEQ: comp_func=num_le; break; - case OP_GEQ: comp_func=num_ge; break; - default: assert (! "reached"); - } - x=sc->args; - v=nvalue(car(x)); - x=cdr(x); - - for (; x != sc->NIL; x = cdr(x)) { - if(!comp_func(v,nvalue(car(x)))) { - s_retbool(0); - } - v=nvalue(car(x)); - } - s_retbool(1); - CASE(OP_SYMBOLP): /* symbol? */ - s_retbool(is_symbol(car(sc->args))); - CASE(OP_NUMBERP): /* number? */ - s_retbool(is_number(car(sc->args))); - CASE(OP_STRINGP): /* string? */ - s_retbool(is_string(car(sc->args))); - CASE(OP_INTEGERP): /* integer? */ - s_retbool(is_integer(car(sc->args))); - CASE(OP_REALP): /* real? */ - s_retbool(is_number(car(sc->args))); /* All numbers are real */ - CASE(OP_CHARP): /* char? */ - s_retbool(is_character(car(sc->args))); -#if USE_CHAR_CLASSIFIERS - CASE(OP_CHARAP): /* char-alphabetic? */ - s_retbool(Cisalpha(ivalue(car(sc->args)))); - CASE(OP_CHARNP): /* char-numeric? */ - s_retbool(Cisdigit(ivalue(car(sc->args)))); - CASE(OP_CHARWP): /* char-whitespace? */ - s_retbool(Cisspace(ivalue(car(sc->args)))); - CASE(OP_CHARUP): /* char-upper-case? */ - s_retbool(Cisupper(ivalue(car(sc->args)))); - CASE(OP_CHARLP): /* char-lower-case? */ - s_retbool(Cislower(ivalue(car(sc->args)))); -#endif - CASE(OP_PORTP): /* port? */ - s_retbool(is_port(car(sc->args))); - CASE(OP_INPORTP): /* input-port? */ - s_retbool(is_inport(car(sc->args))); - CASE(OP_OUTPORTP): /* output-port? */ - s_retbool(is_outport(car(sc->args))); - CASE(OP_PROCP): /* procedure? */ - /*-- - * continuation should be procedure by the example - * (call-with-current-continuation procedure?) ==> #t - * in R^3 report sec. 6.9 - */ - s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) - || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); - CASE(OP_PAIRP): /* pair? */ - s_retbool(is_pair(car(sc->args))); - CASE(OP_LISTP): /* list? */ - s_retbool(list_length(sc,car(sc->args)) >= 0); - - CASE(OP_ENVP): /* environment? */ - s_retbool(is_environment(car(sc->args))); - CASE(OP_VECTORP): /* vector? */ - s_retbool(is_vector(car(sc->args))); - CASE(OP_EQ): /* eq? */ - s_retbool(car(sc->args) == cadr(sc->args)); - CASE(OP_EQV): /* eqv? */ - s_retbool(eqv(car(sc->args), cadr(sc->args))); - - CASE(OP_FORCE): /* force */ - sc->code = car(sc->args); - if (is_promise(sc->code)) { - /* Should change type to closure here */ - s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); - sc->args = sc->NIL; - s_thread_to(sc,OP_APPLY); - } else { - s_return(sc,sc->code); - } - - CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */ - copy_value(sc, sc->code, sc->value); - s_return(sc,sc->value); - - CASE(OP_WRITE): /* write */ - /* Fallthrough. */ - CASE(OP_DISPLAY): /* display */ - /* Fallthrough. */ - CASE(OP_WRITE_CHAR): /* write-char */ - if(is_pair(cdr(sc->args))) { - if(cadr(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=cadr(sc->args); - } - } - sc->args = car(sc->args); - if(op==OP_WRITE) { - sc->print_flag = 1; - } else { - sc->print_flag = 0; - } - s_thread_to(sc,OP_P0LIST); - - CASE(OP_NEWLINE): /* newline */ - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=car(sc->args); - } - } - putstr(sc, "\n"); - s_return(sc,sc->T); - - CASE(OP_ERR0): /* error */ - sc->retcode=-1; - if (!is_string(car(sc->args))) { - sc->args=cons(sc,mk_string(sc," -- "),sc->args); - setimmutable(car(sc->args)); - } - putstr(sc, "Error: "); - putstr(sc, strvalue(car(sc->args))); - sc->args = cdr(sc->args); - s_thread_to(sc,OP_ERR1); - - CASE(OP_ERR1): /* error */ - putstr(sc, " "); - if (sc->args != sc->NIL) { - s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - sc->print_flag = 1; - s_thread_to(sc,OP_P0LIST); - } else { - putstr(sc, "\n"); - if(sc->interactive_repl) { - s_thread_to(sc,OP_T0LVL); - } else { - return; - } - } - - CASE(OP_REVERSE): /* reverse */ - s_return(sc,reverse(sc, sc->NIL, car(sc->args))); - - CASE(OP_REVERSE_IN_PLACE): /* reverse! */ - s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args))); - - CASE(OP_LIST_STAR): /* list* */ - s_return(sc,list_star(sc,sc->args)); - - CASE(OP_APPEND): /* append */ - x = sc->NIL; - y = sc->args; - if (y == x) { - s_return(sc, x); - } - - /* cdr() in the while condition is not a typo. If car() */ - /* is used (append '() 'a) will return the wrong result.*/ - while (cdr(y) != sc->NIL) { - x = revappend(sc, x, car(y)); - y = cdr(y); - if (x == sc->F) { - Error_0(sc, "non-list argument to append"); - } - } - - s_return(sc, reverse_in_place(sc, car(y), x)); - -#if USE_PLIST - CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */ - gc_disable(sc, gc_reservations(set_property)); - s_return_enable_gc(sc, - set_property(sc, car(sc->args), - cadr(sc->args), caddr(sc->args))); - - CASE(OP_SYMBOL_PROPERTY): /* symbol-property */ - s_return(sc, get_property(sc, car(sc->args), cadr(sc->args))); -#endif /* USE_PLIST */ - - CASE(OP_TAG_VALUE): { /* not exposed */ - /* This tags sc->value with car(sc->args). Useful to tag - * results of opcode evaluations. */ - pointer a, b, c; - free_cons(sc, sc->args, &a, &b); - free_cons(sc, b, &b, &c); - assert(c == sc->NIL); - s_return(sc, mk_tagged_value(sc, sc->value, a, b)); - } - - CASE(OP_MK_TAGGED): /* make-tagged-value */ - if (is_vector(car(sc->args))) - Error_0(sc, "cannot tag vector"); - s_return(sc, mk_tagged_value(sc, car(sc->args), - car(cadr(sc->args)), - cdr(cadr(sc->args)))); - - CASE(OP_GET_TAG): /* get-tag */ - s_return(sc, get_tag(sc, car(sc->args))); - - CASE(OP_QUIT): /* quit */ - if(is_pair(sc->args)) { - sc->retcode=ivalue(car(sc->args)); - } - return; - - CASE(OP_GC): /* gc */ - gc(sc, sc->NIL, sc->NIL); - s_return(sc,sc->T); - - CASE(OP_GCVERB): /* gc-verbose */ - { int was = sc->gc_verbose; - - sc->gc_verbose = (car(sc->args) != sc->F); - s_retbool(was); - } - - CASE(OP_NEWSEGMENT): /* new-segment */ - if (!is_pair(sc->args) || !is_number(car(sc->args))) { - Error_0(sc,"new-segment: argument must be a number"); - } - alloc_cellseg(sc, (int) ivalue(car(sc->args))); - s_return(sc,sc->T); - - CASE(OP_OBLIST): /* oblist */ - s_return(sc, oblist_all_symbols(sc)); - - CASE(OP_CURR_INPORT): /* current-input-port */ - s_return(sc,sc->inport); - - CASE(OP_CURR_OUTPORT): /* current-output-port */ - s_return(sc,sc->outport); - - CASE(OP_OPEN_INFILE): /* open-input-file */ - /* Fallthrough. */ - CASE(OP_OPEN_OUTFILE): /* open-output-file */ - /* Fallthrough. */ - CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ { - int prop=0; - pointer p; - switch(op) { - case OP_OPEN_INFILE: prop=port_input; break; - case OP_OPEN_OUTFILE: prop=port_output; break; - case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; - default: assert (! "reached"); - } - p=port_from_filename(sc,strvalue(car(sc->args)),prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - break; - } - -#if USE_STRING_PORTS - CASE(OP_OPEN_INSTRING): /* open-input-string */ - /* Fallthrough. */ - CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ { - int prop=0; - pointer p; - switch(op) { - case OP_OPEN_INSTRING: prop=port_input; break; - case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; - default: assert (! "reached"); - } - p=port_from_string(sc, strvalue(car(sc->args)), - strvalue(car(sc->args))+strlength(car(sc->args)), prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - } - CASE(OP_OPEN_OUTSTRING): /* open-output-string */ { - pointer p; - if(car(sc->args)==sc->NIL) { - p=port_from_scratch(sc); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - } else { - p=port_from_string(sc, strvalue(car(sc->args)), - strvalue(car(sc->args))+strlength(car(sc->args)), - port_output); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - } - s_return(sc,p); - } - CASE(OP_GET_OUTSTRING): /* get-output-string */ { - port *p; - - if ((p=car(sc->args)->_object._port)->kind&port_string) { - gc_disable(sc, 1); - s_return_enable_gc( - sc, - mk_counted_string(sc, - p->rep.string.start, - p->rep.string.curr - p->rep.string.start)); - } - s_return(sc,sc->F); - } -#endif - - CASE(OP_CLOSE_INPORT): /* close-input-port */ - port_close(sc,car(sc->args),port_input); - s_return(sc,sc->T); - - CASE(OP_CLOSE_OUTPORT): /* close-output-port */ - port_close(sc,car(sc->args),port_output); - s_return(sc,sc->T); - - CASE(OP_INT_ENV): /* interaction-environment */ - s_return(sc,sc->global_env); - - CASE(OP_CURR_ENV): /* current-environment */ - s_return(sc,sc->envir); - - - /* ========== reading part ========== */ - CASE(OP_READ): - if(!is_pair(sc->args)) { - s_thread_to(sc,OP_READ_INTERNAL); - } - if(!is_inport(car(sc->args))) { - Error_1(sc, "read: not an input port", car(sc->args)); - } - if(car(sc->args)==sc->inport) { - s_thread_to(sc,OP_READ_INTERNAL); - } - x=sc->inport; - sc->inport=car(sc->args); - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - s_thread_to(sc,OP_READ_INTERNAL); - - CASE(OP_READ_CHAR): /* read-char */ - /* Fallthrough. */ - CASE(OP_PEEK_CHAR): /* peek-char */ { - int c; - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->inport) { - x=sc->inport; - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - sc->inport=car(sc->args); - } - } - c=inchar(sc); - if(c==EOF) { - s_return(sc,sc->EOF_OBJ); - } - if(op==OP_PEEK_CHAR) { - backchar(sc,c); - } - s_return(sc,mk_character(sc,c)); - } - - CASE(OP_CHAR_READY): /* char-ready? */ { - pointer p=sc->inport; - int res; - if(is_pair(sc->args)) { - p=car(sc->args); - } - res=p->_object._port->kind&port_string; - s_retbool(res); - } - - CASE(OP_SET_INPORT): /* set-input-port */ - sc->inport=car(sc->args); - s_return(sc,sc->value); - - CASE(OP_SET_OUTPORT): /* set-output-port */ - sc->outport=car(sc->args); - s_return(sc,sc->value); - - CASE(OP_RDSEXPR): - switch (sc->tok) { - case TOK_EOF: - s_return(sc,sc->EOF_OBJ); - /* NOTREACHED */ - case TOK_VEC: - s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); - /* fall through */ - case TOK_LPAREN: - sc->tok = token(sc); - if (sc->tok == TOK_RPAREN) { - s_return(sc,sc->NIL); - } else if (sc->tok == TOK_DOT) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { -#if SHOW_ERROR_LINE - pointer filename; - pointer lineno; -#endif - sc->nesting_stack[sc->file_i]++; -#if SHOW_ERROR_LINE - filename = sc->load_stack[sc->file_i].filename; - lineno = sc->load_stack[sc->file_i].curr_line; - - s_save(sc, OP_TAG_VALUE, - cons(sc, filename, cons(sc, lineno, sc->NIL)), - sc->NIL); -#endif - s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); - s_thread_to(sc,OP_RDSEXPR); - } - case TOK_QUOTE: - s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - case TOK_BQUOTE: - sc->tok = token(sc); - if(sc->tok==TOK_VEC) { - s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); - sc->tok=TOK_LPAREN; - s_thread_to(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); - } - s_thread_to(sc,OP_RDSEXPR); - case TOK_COMMA: - s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - case TOK_ATMARK: - s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - case TOK_ATOM: - s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); - case TOK_DQUOTE: - x=readstrexp(sc); - if(x==sc->F) { - Error_0(sc,"Error reading string"); - } - setimmutable(x); - s_return(sc,x); - case TOK_SHARP: { - pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); - if(f==sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - sc->code=cons(sc,slot_value_in_env(f),sc->NIL); - s_thread_to(sc,OP_EVAL); - } - } - case TOK_SHARP_CONST: - if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - s_return(sc,x); - } - default: - Error_0(sc,"syntax error: illegal token"); - } - break; - - CASE(OP_RDLIST): { - gc_disable(sc, 1); - sc->args = cons(sc, sc->value, sc->args); - gc_enable(sc); - sc->tok = token(sc); - if (sc->tok == TOK_EOF) - { s_return(sc,sc->EOF_OBJ); } - else if (sc->tok == TOK_RPAREN) { - int c = inchar(sc); - if (c != '\n') - backchar(sc,c); - else - port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1); - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); - } else if (sc->tok == TOK_DOT) { - s_save(sc,OP_RDDOT, sc->args, sc->NIL); - sc->tok = token(sc); - s_thread_to(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDLIST, sc->args, sc->NIL);; - s_thread_to(sc,OP_RDSEXPR); - } - } - - CASE(OP_RDDOT): - if (token(sc) != TOK_RPAREN) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->value, sc->args)); - } - - CASE(OP_RDQUOTE): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->QUOTE, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDQQUOTE): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->QQUOTE, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDQQUOTEVEC): - gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol)); - s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"), - cons(sc, mk_symbol(sc,"vector"), - cons(sc,cons(sc, sc->QQUOTE, - cons(sc,sc->value,sc->NIL)), - sc->NIL)))); - - CASE(OP_RDUNQUOTE): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->UNQUOTE, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDUQTSP): - gc_disable(sc, 2); - s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP, - cons(sc, sc->value, sc->NIL))); - - CASE(OP_RDVEC): - /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_thread_to(sc,OP_EVAL); Cannot be quoted*/ - /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_return(sc,x); Cannot be part of pairs*/ - /*sc->code=mk_proc(sc,OP_VECTOR); - sc->args=sc->value; - s_thread_to(sc,OP_APPLY);*/ - sc->args=sc->value; - s_thread_to(sc,OP_VECTOR); - - /* ========== printing part ========== */ - CASE(OP_P0LIST): - if(is_vector(sc->args)) { - putstr(sc,"#("); - sc->args=cons(sc,sc->args,mk_integer(sc,0)); - s_thread_to(sc,OP_PVECFROM); - } else if(is_environment(sc->args)) { - putstr(sc,"#"); - s_return(sc,sc->T); - } else if (!is_pair(sc->args)) { - printatom(sc, sc->args, sc->print_flag); - s_return(sc,sc->T); - } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "'"); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "`"); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, ","); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { - putstr(sc, ",@"); - sc->args = cadr(sc->args); - s_thread_to(sc,OP_P0LIST); - } else { - putstr(sc, "("); - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - s_thread_to(sc,OP_P0LIST); - } - - CASE(OP_P1LIST): - if (is_pair(sc->args)) { - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - putstr(sc, " "); - sc->args = car(sc->args); - s_thread_to(sc,OP_P0LIST); - } else if(is_vector(sc->args)) { - s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); - putstr(sc, " . "); - s_thread_to(sc,OP_P0LIST); - } else { - if (sc->args != sc->NIL) { - putstr(sc, " . "); - printatom(sc, sc->args, sc->print_flag); - } - putstr(sc, ")"); - s_return(sc,sc->T); - } - CASE(OP_PVECFROM): { - int i=ivalue_unchecked(cdr(sc->args)); - pointer vec=car(sc->args); - int len = vector_length(vec); - if(i==len) { - putstr(sc,")"); - s_return(sc,sc->T); - } else { - pointer elem=vector_elem(vec,i); - cdr(sc->args) = mk_integer(sc, i + 1); - s_save(sc,OP_PVECFROM, sc->args, sc->NIL); - sc->args=elem; - if (i > 0) - putstr(sc," "); - s_thread_to(sc,OP_P0LIST); - } - } - - CASE(OP_LIST_LENGTH): { /* length */ /* a.k */ - long l = list_length(sc, car(sc->args)); - if(l<0) { - Error_1(sc, "length: not a list", car(sc->args)); - } - gc_disable(sc, 1); - s_return_enable_gc(sc, mk_integer(sc, l)); - } - CASE(OP_ASSQ): /* assq */ /* a.k */ - x = car(sc->args); - for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { - if (!is_pair(car(y))) { - Error_0(sc,"unable to handle non pair element"); - } - if (x == caar(y)) - break; - } - if (is_pair(y)) { - s_return(sc,car(y)); - } else { - s_return(sc,sc->F); - } - - - CASE(OP_GET_CLOSURE): /* get-closure-code */ /* a.k */ - sc->args = car(sc->args); - if (sc->args == sc->NIL) { - s_return(sc,sc->F); - } else if (is_closure(sc->args)) { - gc_disable(sc, 1); - s_return_enable_gc(sc, cons(sc, sc->LAMBDA, - closure_code(sc->value))); - } else if (is_macro(sc->args)) { - gc_disable(sc, 1); - s_return_enable_gc(sc, cons(sc, sc->LAMBDA, - closure_code(sc->value))); - } else { - s_return(sc,sc->F); - } - CASE(OP_CLOSUREP): /* closure? */ - /* - * Note, macro object is also a closure. - * Therefore, (closure? <#MACRO>) ==> #t - */ - s_retbool(is_closure(car(sc->args))); - CASE(OP_MACROP): /* macro? */ - s_retbool(is_macro(car(sc->args))); - CASE(OP_VM_HISTORY): /* *vm-history* */ - s_return(sc, history_flatten(sc)); - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op); - Error_0(sc,sc->strbuff); - } - } -} - -typedef int (*test_predicate)(pointer); - -static int is_any(pointer p) { - (void)p; - return 1; -} - -static int is_nonneg(pointer p) { - return ivalue(p)>=0 && is_integer(p); -} - -/* Correspond carefully with following defines! */ -static const struct { - test_predicate fct; - const char *kind; -} tests[]={ - {0,0}, /* unused */ - {is_any, 0}, - {is_string, "string"}, - {is_symbol, "symbol"}, - {is_port, "port"}, - {is_inport,"input port"}, - {is_outport,"output port"}, - {is_environment, "environment"}, - {is_pair, "pair"}, - {0, "pair or '()"}, - {is_character, "character"}, - {is_vector, "vector"}, - {is_number, "number"}, - {is_integer, "integer"}, - {is_nonneg, "non-negative integer"} -}; - -#define TST_NONE 0 -#define TST_ANY "\001" -#define TST_STRING "\002" -#define TST_SYMBOL "\003" -#define TST_PORT "\004" -#define TST_INPORT "\005" -#define TST_OUTPORT "\006" -#define TST_ENVIRONMENT "\007" -#define TST_PAIR "\010" -#define TST_LIST "\011" -#define TST_CHAR "\012" -#define TST_VECTOR "\013" -#define TST_NUMBER "\014" -#define TST_INTEGER "\015" -#define TST_NATURAL "\016" - -#define INF_ARG 0xff - -static const struct op_code_info dispatch_table[]= { -#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}}, -#include "opdefines.h" -#undef _OP_DEF - {{0},0,0,{0}}, -}; - -static const char *procname(pointer x) { - int n=procnum(x); - const char *name=dispatch_table[n].name; - if (name[0] == 0) { - name="ILLEGAL!"; - } - return name; -} - -static int -check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size) -{ - int ok = 1; - int n = list_length(sc, sc->args); - - /* Check number of arguments */ - if (n < pcd->min_arity) { - ok = 0; - snprintf(msg, msg_size, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity == pcd->max_arity ? "" : " at least", - pcd->min_arity); - } - if (ok && n>pcd->max_arity) { - ok = 0; - snprintf(msg, msg_size, "%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity == pcd->max_arity ? "" : " at most", - pcd->max_arity); - } - if (ok) { - if (pcd->arg_tests_encoding[0] != 0) { - int i = 0; - int j; - const char *t = pcd->arg_tests_encoding; - pointer arglist = sc->args; - - do { - pointer arg = car(arglist); - j = (int)t[0]; - if (j == TST_LIST[0]) { - if (arg != sc->NIL && !is_pair(arg)) break; - } else { - if (!tests[j].fct(arg)) break; - } - - if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) { - /* last test is replicated as necessary */ - t++; - } - arglist = cdr(arglist); - i++; - } while (i < n); - - if (i < n) { - ok = 0; - snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s", - pcd->name, - i + 1, - tests[j].kind, - type_to_string(type(car(arglist)))); - } - } - } - - return ok; -} - -/* ========== Initialization of internal keywords ========== */ - -/* Symbols representing syntax are tagged with (OP . '()). */ -static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) { - pointer x, y; - pointer *slot; - - x = oblist_find_by_name(sc, name, &slot); - assert (x == sc->NIL); - - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL | T_SYNTAX; - setimmutable(car(x)); - y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL); - free_cell(sc, x); - setimmutable(get_tag(sc, y)); - *slot = immutable_cons(sc, y, *slot); -} - -/* Returns the opcode for the syntax represented by P. */ -static int syntaxnum(scheme *sc, pointer p) { - int op = ivalue_unchecked(car(get_tag(sc, p))); - assert (op < OP_MAXDEFINED); - return op; -} - -static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) { - pointer x, y; - - x = mk_symbol(sc, name); - y = mk_proc(sc,op); - new_slot_in_env(sc, x, y); -} - -static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { - pointer y; - - y = get_cell(sc, sc->NIL, sc->NIL); - typeflag(y) = (T_PROC | T_ATOM); - ivalue_unchecked(y) = (long) op; - set_num_integer(y); - return y; -} - -/* initialization of TinyScheme */ -#if USE_INTERFACE -INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { - return cons(sc,a,b); -} -INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { - return immutable_cons(sc,a,b); -} - -static const struct scheme_interface vtbl = { - scheme_define, - s_cons, - s_immutable_cons, - reserve_cells, - mk_integer, - mk_real, - mk_symbol, - gensym, - mk_string, - mk_counted_string, - mk_character, - mk_vector, - mk_foreign_func, - mk_foreign_object, - get_foreign_object_vtable, - get_foreign_object_data, - putstr, - putcharacter, - - is_string, - string_value, - is_number, - nvalue, - ivalue, - rvalue, - is_integer, - is_real, - is_character, - charvalue, - is_list, - is_vector, - list_length, - ivalue, - fill_vector, - vector_elem, - set_vector_elem, - is_port, - is_pair, - pair_car, - pair_cdr, - set_car, - set_cdr, - - is_symbol, - symname, - - is_syntax, - is_proc, - is_foreign, - syntaxname, - is_closure, - is_macro, - closure_code, - closure_env, - - is_continuation, - is_promise, - is_environment, - is_immutable, - setimmutable, - - scheme_load_file, - scheme_load_string, - port_from_file -}; -#endif - -scheme *scheme_init_new() { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init(sc)) { - free(sc); - return 0; - } else { - return sc; - } -} - -scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init_custom_alloc(sc,malloc,free)) { - free(sc); - return 0; - } else { - return sc; - } -} - - -int scheme_init(scheme *sc) { - return scheme_init_custom_alloc(sc,malloc,free); -} - -int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { - int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); - pointer x; - -#if USE_INTERFACE - sc->vptr=&vtbl; -#endif - sc->gensym_cnt=0; - sc->malloc=malloc; - sc->free=free; - sc->sink = &sc->_sink; - sc->NIL = &sc->_NIL; - sc->T = &sc->_HASHT; - sc->F = &sc->_HASHF; - sc->EOF_OBJ=&sc->_EOF_OBJ; - - sc->free_cell = &sc->_NIL; - sc->fcells = 0; - sc->inhibit_gc = GC_ENABLED; - sc->reserved_cells = 0; - sc->reserved_lineno = 0; - sc->no_memory=0; - sc->inport=sc->NIL; - sc->outport=sc->NIL; - sc->save_inport=sc->NIL; - sc->loadport=sc->NIL; - sc->nesting=0; - memset (sc->nesting_stack, 0, sizeof sc->nesting_stack); - sc->interactive_repl=0; - sc->strbuff = sc->malloc(STRBUFFSIZE); - if (sc->strbuff == 0) { - sc->no_memory=1; - return 0; - } - sc->strbuff_size = STRBUFFSIZE; - - sc->cell_segments = NULL; - if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { - sc->no_memory=1; - return 0; - } - sc->gc_verbose = 0; - dump_stack_initialize(sc); - sc->code = sc->NIL; - sc->tracing=0; - sc->flags = 0; - - /* init sc->NIL */ - typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK); - car(sc->NIL) = cdr(sc->NIL) = sc->NIL; - /* init T */ - typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK); - car(sc->T) = cdr(sc->T) = sc->T; - /* init F */ - typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK); - car(sc->F) = cdr(sc->F) = sc->F; - /* init EOF_OBJ */ - typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK); - car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; - /* init sink */ - typeflag(sc->sink) = (T_SINK | T_PAIR | MARK); - car(sc->sink) = cdr(sc->sink) = sc->NIL; - /* init c_nest */ - sc->c_nest = sc->NIL; - - sc->oblist = oblist_initial_value(sc); - /* init global_env */ - new_frame_in_env(sc, sc->NIL); - sc->global_env = sc->envir; - /* init else */ - x = mk_symbol(sc,"else"); - new_slot_in_env(sc, x, sc->T); - - assign_syntax(sc, OP_LAMBDA, "lambda"); - assign_syntax(sc, OP_QUOTE, "quote"); - assign_syntax(sc, OP_DEF0, "define"); - assign_syntax(sc, OP_IF0, "if"); - assign_syntax(sc, OP_BEGIN, "begin"); - assign_syntax(sc, OP_SET0, "set!"); - assign_syntax(sc, OP_LET0, "let"); - assign_syntax(sc, OP_LET0AST, "let*"); - assign_syntax(sc, OP_LET0REC, "letrec"); - assign_syntax(sc, OP_COND0, "cond"); - assign_syntax(sc, OP_DELAY, "delay"); - assign_syntax(sc, OP_AND0, "and"); - assign_syntax(sc, OP_OR0, "or"); - assign_syntax(sc, OP_C0STREAM, "cons-stream"); - assign_syntax(sc, OP_MACRO0, "macro"); - assign_syntax(sc, OP_CASE0, "case"); - - for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); - sc->QUOTE = mk_symbol(sc, "quote"); - sc->QQUOTE = mk_symbol(sc, "quasiquote"); - sc->UNQUOTE = mk_symbol(sc, "unquote"); - sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); - sc->FEED_TO = mk_symbol(sc, "=>"); - sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); - sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); - sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); -#if USE_COMPILE_HOOK - sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); -#endif - - return !sc->no_memory; -} - -void scheme_set_input_port_file(scheme *sc, FILE *fin) { - sc->inport=port_from_file(sc,fin,port_input); -} - -void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { - sc->inport=port_from_string(sc,start,past_the_end,port_input); -} - -void scheme_set_output_port_file(scheme *sc, FILE *fout) { - sc->outport=port_from_file(sc,fout,port_output); -} - -void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { - sc->outport=port_from_string(sc,start,past_the_end,port_output); -} - -void scheme_set_external_data(scheme *sc, void *p) { - sc->ext_data=p; -} - -void scheme_deinit(scheme *sc) { - struct cell_segment *s; - int i; - - sc->oblist=sc->NIL; - sc->global_env=sc->NIL; - dump_stack_free(sc); - sc->envir=sc->NIL; - sc->code=sc->NIL; - history_free(sc); - sc->args=sc->NIL; - sc->value=sc->NIL; - if(is_port(sc->inport)) { - typeflag(sc->inport) = T_ATOM; - } - sc->inport=sc->NIL; - sc->outport=sc->NIL; - if(is_port(sc->save_inport)) { - typeflag(sc->save_inport) = T_ATOM; - } - sc->save_inport=sc->NIL; - if(is_port(sc->loadport)) { - typeflag(sc->loadport) = T_ATOM; - } - sc->loadport=sc->NIL; - - for(i=0; i<=sc->file_i; i++) { - port_clear_location(sc, &sc->load_stack[i]); - } - - sc->gc_verbose=0; - gc(sc,sc->NIL,sc->NIL); - - for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) { - /* nop */ - } - sc->free(sc->strbuff); -} - -void scheme_load_file(scheme *sc, FILE *fin) -{ scheme_load_named_file(sc,fin,0); } - -void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_file; - sc->load_stack[0].rep.stdio.file=fin; - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - if(fin==stdin) { - sc->interactive_repl=1; - } - - port_init_location(sc, &sc->load_stack[0], - (fin != stdin && filename) - ? mk_string(sc, filename) - : NULL); - - sc->inport=sc->loadport; - sc->args = mk_integer(sc,sc->file_i); - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } - - port_clear_location(sc, &sc->load_stack[0]); -} - -void scheme_load_string(scheme *sc, const char *cmd) { - scheme_load_memory(sc, cmd, strlen(cmd), NULL); -} - -void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_string; - sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */ - sc->load_stack[0].rep.string.past_the_end = (char *) buf + len; - sc->load_stack[0].rep.string.curr = (char *) buf; - port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL); - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - sc->interactive_repl=0; - sc->inport=sc->loadport; - sc->args = mk_integer(sc,sc->file_i); - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } - - port_clear_location(sc, &sc->load_stack[0]); -} - -void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { - pointer x; - pointer *sslot; - x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot); - if (x != sc->NIL) { - set_slot_in_env(sc, x, value); - } else { - new_slot_spec_in_env(sc, symbol, value, sslot); - } -} - -#if !STANDALONE -void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) -{ - scheme_define(sc, - sc->global_env, - mk_symbol(sc,sr->name), - mk_foreign_func(sc, sr->f)); -} - -void scheme_register_foreign_func_list(scheme * sc, - scheme_registerable * list, - int count) -{ - int i; - for(i = 0; i < count; i++) - { - scheme_register_foreign_func(sc, list + i); - } -} - -pointer scheme_apply0(scheme *sc, const char *procname) -{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } - -void save_from_C_call(scheme *sc) -{ - pointer saved_data = - cons(sc, - car(sc->sink), - cons(sc, - sc->envir, - sc->dump)); - /* Push */ - sc->c_nest = cons(sc, saved_data, sc->c_nest); - /* Truncate the dump stack so TS will return here when done, not - directly resume pre-C-call operations. */ - dump_stack_reset(sc); -} -void restore_from_C_call(scheme *sc) -{ - car(sc->sink) = caar(sc->c_nest); - sc->envir = cadar(sc->c_nest); - sc->dump = cdr(cdar(sc->c_nest)); - /* Pop */ - sc->c_nest = cdr(sc->c_nest); -} - -/* "func" and "args" are assumed to be already eval'ed. */ -pointer scheme_call(scheme *sc, pointer func, pointer args) -{ - int old_repl = sc->interactive_repl; - sc->interactive_repl = 0; - save_from_C_call(sc); - sc->envir = sc->global_env; - sc->args = args; - sc->code = func; - sc->retcode = 0; - Eval_Cycle(sc, OP_APPLY); - sc->interactive_repl = old_repl; - restore_from_C_call(sc); - return sc->value; -} - -pointer scheme_eval(scheme *sc, pointer obj) -{ - int old_repl = sc->interactive_repl; - sc->interactive_repl = 0; - save_from_C_call(sc); - sc->args = sc->NIL; - sc->code = obj; - sc->retcode = 0; - Eval_Cycle(sc, OP_EVAL); - sc->interactive_repl = old_repl; - restore_from_C_call(sc); - return sc->value; -} - - -#endif - -/* ========== Main ========== */ - -#if STANDALONE - -#if defined(__APPLE__) && !defined (OSX) -int main() -{ - extern MacTS_main(int argc, char **argv); - char** argv; - int argc = ccommand(&argv); - MacTS_main(argc,argv); - return 0; -} -int MacTS_main(int argc, char **argv) { -#else -int main(int argc, char **argv) { -#endif - scheme sc; - FILE *fin; - char *file_name=InitFile; - int retcode; - int isfile=1; - - if(argc==1) { - printf(banner); - } - if(argc==2 && strcmp(argv[1],"-?")==0) { - printf("Usage: tinyscheme -?\n"); - printf("or: tinyscheme [ ...]\n"); - printf("followed by\n"); - printf(" -1 [ ...]\n"); - printf(" -c [ ...]\n"); - printf("assuming that the executable is named tinyscheme.\n"); - printf("Use - as filename for stdin.\n"); - return 1; - } - if(!scheme_init(&sc)) { - fprintf(stderr,"Could not initialize!\n"); - return 2; - } - scheme_set_input_port_file(&sc, stdin); - scheme_set_output_port_file(&sc, stdout); -#if USE_DL - scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); -#endif - argv++; - if(access(file_name,0)!=0) { - char *p=getenv("TINYSCHEMEINIT"); - if(p!=0) { - file_name=p; - } - } - do { - if(strcmp(file_name,"-")==0) { - fin=stdin; - } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { - pointer args=sc.NIL; - isfile=file_name[1]=='1'; - file_name=*argv++; - if(strcmp(file_name,"-")==0) { - fin=stdin; - } else if(isfile) { - fin=fopen(file_name,"r"); - } - for(;*argv;argv++) { - pointer value=mk_string(&sc,*argv); - args=cons(&sc,value,args); - } - args=reverse_in_place(&sc,sc.NIL,args); - scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); - - } else { - fin=fopen(file_name,"r"); - } - if(isfile && fin==0) { - fprintf(stderr,"Could not open file %s\n",file_name); - } else { - if(isfile) { - scheme_load_named_file(&sc,fin,file_name); - } else { - scheme_load_string(&sc,file_name); - } - if(!isfile || fin!=stdin) { - if(sc.retcode!=0) { - fprintf(stderr,"Errors encountered reading %s\n",file_name); - } - if(isfile) { - fclose(fin); - } - } - } - file_name=*argv++; - } while(file_name!=0); - if(argc==1) { - scheme_load_named_file(&sc,stdin,0); - } - retcode=sc.retcode; - scheme_deinit(&sc); - - return retcode; -} - -#endif - -/* -Local variables: -c-file-style: "k&r" -End: -*/ diff --git a/scheme.h b/scheme.h deleted file mode 100644 index 6f917da..0000000 --- a/scheme.h +++ /dev/null @@ -1,290 +0,0 @@ -/* SCHEME.H */ - -#ifndef _SCHEME_H -#define _SCHEME_H - -#include - -#ifdef __cplusplus -extern "C" { -#endif - -/* - * Default values for #define'd symbols - */ -#ifndef STANDALONE /* If used as standalone interpreter */ -# define STANDALONE 1 -#endif - -#ifndef _MSC_VER -# define USE_STRCASECMP 1 -# ifndef USE_STRLWR -# define USE_STRLWR 1 -# endif -# define SCHEME_EXPORT -#else -# define USE_STRCASECMP 0 -# define USE_STRLWR 0 -# ifdef _SCHEME_SOURCE -# define SCHEME_EXPORT __declspec(dllexport) -# else -# define SCHEME_EXPORT __declspec(dllimport) -# endif -#endif - -#if USE_NO_FEATURES -# define USE_MATH 0 -# define USE_CHAR_CLASSIFIERS 0 -# define USE_ASCII_NAMES 0 -# define USE_STRING_PORTS 0 -# define USE_ERROR_HOOK 0 -# define USE_TRACING 0 -# define USE_COLON_HOOK 0 -# define USE_COMPILE_HOOK 0 -# define USE_DL 0 -# define USE_PLIST 0 -# define USE_SMALL_INTEGERS 0 -# define USE_HISTORY 0 -#endif - - -#if USE_DL -# define USE_INTERFACE 1 -#endif - - -#ifndef USE_MATH /* If math support is needed */ -# define USE_MATH 1 -#endif - -#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ -# define USE_CHAR_CLASSIFIERS 1 -#endif - -#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ -# define USE_ASCII_NAMES 1 -#endif - -#ifndef USE_STRING_PORTS /* Enable string ports */ -# define USE_STRING_PORTS 1 -#endif - -#ifndef USE_TRACING -# define USE_TRACING 1 -#endif - -#ifndef USE_PLIST -# define USE_PLIST 0 -#endif - -/* Keep a history of function calls. This enables a feature similar - * to stack traces. */ -#ifndef USE_HISTORY -# define USE_HISTORY 1 -#endif - -/* To force system errors through user-defined error handling (see *error-hook*) */ -#ifndef USE_ERROR_HOOK -# define USE_ERROR_HOOK 1 -#endif - -#ifndef USE_COLON_HOOK /* Enable qualified qualifier */ -# define USE_COLON_HOOK 1 -#endif - -/* Compile functions using *compile-hook*. The default hook expands - * macros. */ -#ifndef USE_COMPILE_HOOK -# define USE_COMPILE_HOOK 1 -#endif - -/* Enable faster opcode dispatch. */ -#ifndef USE_THREADED_CODE -# define USE_THREADED_CODE 1 -#endif - -/* Use a static set of cells to represent small numbers. This set - * notably includes all opcodes, and hence saves a cell reservation - * during 's_save'. */ -#ifndef USE_SMALL_INTEGERS -# define USE_SMALL_INTEGERS 1 -#endif - -#ifndef USE_STRCASECMP /* stricmp for Unix */ -# define USE_STRCASECMP 0 -#endif - -#ifndef USE_STRLWR -# define USE_STRLWR 1 -#endif - -#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ -# define STDIO_ADDS_CR 0 -#endif - -#ifndef INLINE -# define INLINE -#endif - -#ifndef USE_INTERFACE -# define USE_INTERFACE 0 -#endif - -#ifndef SHOW_ERROR_LINE /* Show error line in file */ -# define SHOW_ERROR_LINE 1 -#endif - -typedef struct scheme scheme; -typedef struct cell *pointer; - -typedef void * (*func_alloc)(size_t); -typedef void (*func_dealloc)(void *); - -/* table of functions required for foreign objects */ -typedef struct foreign_object_vtable { - void (*finalize)(scheme *sc, void *data); - void (*to_string)(scheme *sc, char *out, size_t size, void *data); -} foreign_object_vtable; - -/* num, for generic arithmetic */ -typedef struct num { - char is_fixnum; - union { - long ivalue; - double rvalue; - } value; -} num; - -SCHEME_EXPORT scheme *scheme_init_new(void); -SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); -SCHEME_EXPORT int scheme_init(scheme *sc); -SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); -SCHEME_EXPORT void scheme_deinit(scheme *sc); -void scheme_set_input_port_file(scheme *sc, FILE *fin); -void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); -SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); -void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); -SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); -SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); -SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); -SCHEME_EXPORT void scheme_load_memory(scheme *sc, const char *buf, size_t len, - const char *filename); -SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); -SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); -SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); -void scheme_set_external_data(scheme *sc, void *p); -SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); - -typedef pointer (*foreign_func)(scheme *, pointer); - -pointer _cons(scheme *sc, pointer a, pointer b, int immutable); -pointer mk_integer(scheme *sc, long num); -pointer mk_real(scheme *sc, double num); -pointer mk_symbol(scheme *sc, const char *name); -pointer gensym(scheme *sc); -pointer mk_string(scheme *sc, const char *str); -pointer mk_counted_string(scheme *sc, const char *str, int len); -pointer mk_empty_string(scheme *sc, int len, char fill); -pointer mk_character(scheme *sc, int c); -pointer mk_foreign_func(scheme *sc, foreign_func f); -pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data); -void putstr(scheme *sc, const char *s); -int list_length(scheme *sc, pointer a); -int eqv(pointer a, pointer b); - - -#if USE_INTERFACE -struct scheme_interface { - void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); - pointer (*cons)(scheme *sc, pointer a, pointer b); - pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); - pointer (*reserve_cells)(scheme *sc, int n); - pointer (*mk_integer)(scheme *sc, long num); - pointer (*mk_real)(scheme *sc, double num); - pointer (*mk_symbol)(scheme *sc, const char *name); - pointer (*gensym)(scheme *sc); - pointer (*mk_string)(scheme *sc, const char *str); - pointer (*mk_counted_string)(scheme *sc, const char *str, int len); - pointer (*mk_character)(scheme *sc, int c); - pointer (*mk_vector)(scheme *sc, int len); - pointer (*mk_foreign_func)(scheme *sc, foreign_func f); - pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data); - const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p); - void *(*get_foreign_object_data)(pointer p); - void (*putstr)(scheme *sc, const char *s); - void (*putcharacter)(scheme *sc, int c); - - int (*is_string)(pointer p); - char *(*string_value)(pointer p); - int (*is_number)(pointer p); - num (*nvalue)(pointer p); - long (*ivalue)(pointer p); - double (*rvalue)(pointer p); - int (*is_integer)(pointer p); - int (*is_real)(pointer p); - int (*is_character)(pointer p); - long (*charvalue)(pointer p); - int (*is_list)(scheme *sc, pointer p); - int (*is_vector)(pointer p); - int (*list_length)(scheme *sc, pointer vec); - long (*vector_length)(pointer vec); - void (*fill_vector)(pointer vec, pointer elem); - pointer (*vector_elem)(pointer vec, int ielem); - pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); - int (*is_port)(pointer p); - - int (*is_pair)(pointer p); - pointer (*pair_car)(pointer p); - pointer (*pair_cdr)(pointer p); - pointer (*set_car)(pointer p, pointer q); - pointer (*set_cdr)(pointer p, pointer q); - - int (*is_symbol)(pointer p); - char *(*symname)(pointer p); - - int (*is_syntax)(pointer p); - int (*is_proc)(pointer p); - int (*is_foreign)(pointer p); - char *(*syntaxname)(pointer p); - int (*is_closure)(pointer p); - int (*is_macro)(pointer p); - pointer (*closure_code)(pointer p); - pointer (*closure_env)(pointer p); - - int (*is_continuation)(pointer p); - int (*is_promise)(pointer p); - int (*is_environment)(pointer p); - int (*is_immutable)(pointer p); - void (*setimmutable)(pointer p); - void (*load_file)(scheme *sc, FILE *fin); - void (*load_string)(scheme *sc, const char *input); - pointer (*mk_port_from_file)(scheme *sc, FILE *f, int kind); -}; -#endif - -#if !STANDALONE -typedef struct scheme_registerable -{ - foreign_func f; - const char * name; -} -scheme_registerable; - -void scheme_register_foreign_func_list(scheme * sc, - scheme_registerable * list, - int n); - -#endif /* !STANDALONE */ - -#ifdef __cplusplus -} -#endif - -#endif - - -/* -Local variables: -c-file-style: "k&r" -End: -*/ diff --git a/small-integers.h b/small-integers.h deleted file mode 100644 index 46eda34..0000000 --- a/small-integers.h +++ /dev/null @@ -1,847 +0,0 @@ -/* Constant integer objects for TinySCHEME. - * - * Copyright (C) 2017 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -/* - * Ohne Worte. Generated using: - * - * $ n=0; while read line ; do \ - * echo "DEFINE_INTEGER($n)" ; \ - * n="$(expr $n + 1)" ; \ - * done <./init.scm >> small-integers.h - */ - -DEFINE_INTEGER(0) -DEFINE_INTEGER(1) -DEFINE_INTEGER(2) -DEFINE_INTEGER(3) -DEFINE_INTEGER(4) -DEFINE_INTEGER(5) -DEFINE_INTEGER(6) -DEFINE_INTEGER(7) -DEFINE_INTEGER(8) -DEFINE_INTEGER(9) -DEFINE_INTEGER(10) -DEFINE_INTEGER(11) -DEFINE_INTEGER(12) -DEFINE_INTEGER(13) -DEFINE_INTEGER(14) -DEFINE_INTEGER(15) -DEFINE_INTEGER(16) -DEFINE_INTEGER(17) -DEFINE_INTEGER(18) -DEFINE_INTEGER(19) -DEFINE_INTEGER(20) -DEFINE_INTEGER(21) -DEFINE_INTEGER(22) -DEFINE_INTEGER(23) -DEFINE_INTEGER(24) -DEFINE_INTEGER(25) -DEFINE_INTEGER(26) -DEFINE_INTEGER(27) -DEFINE_INTEGER(28) -DEFINE_INTEGER(29) -DEFINE_INTEGER(30) -DEFINE_INTEGER(31) -DEFINE_INTEGER(32) -DEFINE_INTEGER(33) -DEFINE_INTEGER(34) -DEFINE_INTEGER(35) -DEFINE_INTEGER(36) -DEFINE_INTEGER(37) -DEFINE_INTEGER(38) -DEFINE_INTEGER(39) -DEFINE_INTEGER(40) -DEFINE_INTEGER(41) -DEFINE_INTEGER(42) -DEFINE_INTEGER(43) -DEFINE_INTEGER(44) -DEFINE_INTEGER(45) -DEFINE_INTEGER(46) -DEFINE_INTEGER(47) -DEFINE_INTEGER(48) -DEFINE_INTEGER(49) -DEFINE_INTEGER(50) -DEFINE_INTEGER(51) -DEFINE_INTEGER(52) -DEFINE_INTEGER(53) -DEFINE_INTEGER(54) -DEFINE_INTEGER(55) -DEFINE_INTEGER(56) -DEFINE_INTEGER(57) -DEFINE_INTEGER(58) -DEFINE_INTEGER(59) -DEFINE_INTEGER(60) -DEFINE_INTEGER(61) -DEFINE_INTEGER(62) -DEFINE_INTEGER(63) -DEFINE_INTEGER(64) -DEFINE_INTEGER(65) -DEFINE_INTEGER(66) -DEFINE_INTEGER(67) -DEFINE_INTEGER(68) -DEFINE_INTEGER(69) -DEFINE_INTEGER(70) -DEFINE_INTEGER(71) -DEFINE_INTEGER(72) -DEFINE_INTEGER(73) -DEFINE_INTEGER(74) -DEFINE_INTEGER(75) -DEFINE_INTEGER(76) -DEFINE_INTEGER(77) -DEFINE_INTEGER(78) -DEFINE_INTEGER(79) -DEFINE_INTEGER(80) -DEFINE_INTEGER(81) -DEFINE_INTEGER(82) -DEFINE_INTEGER(83) -DEFINE_INTEGER(84) -DEFINE_INTEGER(85) -DEFINE_INTEGER(86) -DEFINE_INTEGER(87) -DEFINE_INTEGER(88) -DEFINE_INTEGER(89) -DEFINE_INTEGER(90) -DEFINE_INTEGER(91) -DEFINE_INTEGER(92) -DEFINE_INTEGER(93) -DEFINE_INTEGER(94) -DEFINE_INTEGER(95) -DEFINE_INTEGER(96) -DEFINE_INTEGER(97) -DEFINE_INTEGER(98) -DEFINE_INTEGER(99) -DEFINE_INTEGER(100) -DEFINE_INTEGER(101) -DEFINE_INTEGER(102) -DEFINE_INTEGER(103) -DEFINE_INTEGER(104) -DEFINE_INTEGER(105) -DEFINE_INTEGER(106) -DEFINE_INTEGER(107) -DEFINE_INTEGER(108) -DEFINE_INTEGER(109) -DEFINE_INTEGER(110) -DEFINE_INTEGER(111) -DEFINE_INTEGER(112) -DEFINE_INTEGER(113) -DEFINE_INTEGER(114) -DEFINE_INTEGER(115) -DEFINE_INTEGER(116) -DEFINE_INTEGER(117) -DEFINE_INTEGER(118) -DEFINE_INTEGER(119) -DEFINE_INTEGER(120) -DEFINE_INTEGER(121) -DEFINE_INTEGER(122) -DEFINE_INTEGER(123) -DEFINE_INTEGER(124) -DEFINE_INTEGER(125) -DEFINE_INTEGER(126) -DEFINE_INTEGER(127) -DEFINE_INTEGER(128) -DEFINE_INTEGER(129) -DEFINE_INTEGER(130) -DEFINE_INTEGER(131) -DEFINE_INTEGER(132) -DEFINE_INTEGER(133) -DEFINE_INTEGER(134) -DEFINE_INTEGER(135) -DEFINE_INTEGER(136) -DEFINE_INTEGER(137) -DEFINE_INTEGER(138) -DEFINE_INTEGER(139) -DEFINE_INTEGER(140) -DEFINE_INTEGER(141) -DEFINE_INTEGER(142) -DEFINE_INTEGER(143) -DEFINE_INTEGER(144) -DEFINE_INTEGER(145) -DEFINE_INTEGER(146) -DEFINE_INTEGER(147) -DEFINE_INTEGER(148) -DEFINE_INTEGER(149) -DEFINE_INTEGER(150) -DEFINE_INTEGER(151) -DEFINE_INTEGER(152) -DEFINE_INTEGER(153) -DEFINE_INTEGER(154) -DEFINE_INTEGER(155) -DEFINE_INTEGER(156) -DEFINE_INTEGER(157) -DEFINE_INTEGER(158) -DEFINE_INTEGER(159) -DEFINE_INTEGER(160) -DEFINE_INTEGER(161) -DEFINE_INTEGER(162) -DEFINE_INTEGER(163) -DEFINE_INTEGER(164) -DEFINE_INTEGER(165) -DEFINE_INTEGER(166) -DEFINE_INTEGER(167) -DEFINE_INTEGER(168) -DEFINE_INTEGER(169) -DEFINE_INTEGER(170) -DEFINE_INTEGER(171) -DEFINE_INTEGER(172) -DEFINE_INTEGER(173) -DEFINE_INTEGER(174) -DEFINE_INTEGER(175) -DEFINE_INTEGER(176) -DEFINE_INTEGER(177) -DEFINE_INTEGER(178) -DEFINE_INTEGER(179) -DEFINE_INTEGER(180) -DEFINE_INTEGER(181) -DEFINE_INTEGER(182) -DEFINE_INTEGER(183) -DEFINE_INTEGER(184) -DEFINE_INTEGER(185) -DEFINE_INTEGER(186) -DEFINE_INTEGER(187) -DEFINE_INTEGER(188) -DEFINE_INTEGER(189) -DEFINE_INTEGER(190) -DEFINE_INTEGER(191) -DEFINE_INTEGER(192) -DEFINE_INTEGER(193) -DEFINE_INTEGER(194) -DEFINE_INTEGER(195) -DEFINE_INTEGER(196) -DEFINE_INTEGER(197) -DEFINE_INTEGER(198) -DEFINE_INTEGER(199) -DEFINE_INTEGER(200) -DEFINE_INTEGER(201) -DEFINE_INTEGER(202) -DEFINE_INTEGER(203) -DEFINE_INTEGER(204) -DEFINE_INTEGER(205) -DEFINE_INTEGER(206) -DEFINE_INTEGER(207) -DEFINE_INTEGER(208) -DEFINE_INTEGER(209) -DEFINE_INTEGER(210) -DEFINE_INTEGER(211) -DEFINE_INTEGER(212) -DEFINE_INTEGER(213) -DEFINE_INTEGER(214) -DEFINE_INTEGER(215) -DEFINE_INTEGER(216) -DEFINE_INTEGER(217) -DEFINE_INTEGER(218) -DEFINE_INTEGER(219) -DEFINE_INTEGER(220) -DEFINE_INTEGER(221) -DEFINE_INTEGER(222) -DEFINE_INTEGER(223) -DEFINE_INTEGER(224) -DEFINE_INTEGER(225) -DEFINE_INTEGER(226) -DEFINE_INTEGER(227) -DEFINE_INTEGER(228) -DEFINE_INTEGER(229) -DEFINE_INTEGER(230) -DEFINE_INTEGER(231) -DEFINE_INTEGER(232) -DEFINE_INTEGER(233) -DEFINE_INTEGER(234) -DEFINE_INTEGER(235) -DEFINE_INTEGER(236) -DEFINE_INTEGER(237) -DEFINE_INTEGER(238) -DEFINE_INTEGER(239) -DEFINE_INTEGER(240) -DEFINE_INTEGER(241) -DEFINE_INTEGER(242) -DEFINE_INTEGER(243) -DEFINE_INTEGER(244) -DEFINE_INTEGER(245) -DEFINE_INTEGER(246) -DEFINE_INTEGER(247) -DEFINE_INTEGER(248) -DEFINE_INTEGER(249) -DEFINE_INTEGER(250) -DEFINE_INTEGER(251) -DEFINE_INTEGER(252) -DEFINE_INTEGER(253) -DEFINE_INTEGER(254) -DEFINE_INTEGER(255) -DEFINE_INTEGER(256) -DEFINE_INTEGER(257) -DEFINE_INTEGER(258) -DEFINE_INTEGER(259) -DEFINE_INTEGER(260) -DEFINE_INTEGER(261) -DEFINE_INTEGER(262) -DEFINE_INTEGER(263) -DEFINE_INTEGER(264) -DEFINE_INTEGER(265) -DEFINE_INTEGER(266) -DEFINE_INTEGER(267) -DEFINE_INTEGER(268) -DEFINE_INTEGER(269) -DEFINE_INTEGER(270) -DEFINE_INTEGER(271) -DEFINE_INTEGER(272) -DEFINE_INTEGER(273) -DEFINE_INTEGER(274) -DEFINE_INTEGER(275) -DEFINE_INTEGER(276) -DEFINE_INTEGER(277) -DEFINE_INTEGER(278) -DEFINE_INTEGER(279) -DEFINE_INTEGER(280) -DEFINE_INTEGER(281) -DEFINE_INTEGER(282) -DEFINE_INTEGER(283) -DEFINE_INTEGER(284) -DEFINE_INTEGER(285) -DEFINE_INTEGER(286) -DEFINE_INTEGER(287) -DEFINE_INTEGER(288) -DEFINE_INTEGER(289) -DEFINE_INTEGER(290) -DEFINE_INTEGER(291) -DEFINE_INTEGER(292) -DEFINE_INTEGER(293) -DEFINE_INTEGER(294) -DEFINE_INTEGER(295) -DEFINE_INTEGER(296) -DEFINE_INTEGER(297) -DEFINE_INTEGER(298) -DEFINE_INTEGER(299) -DEFINE_INTEGER(300) -DEFINE_INTEGER(301) -DEFINE_INTEGER(302) -DEFINE_INTEGER(303) -DEFINE_INTEGER(304) -DEFINE_INTEGER(305) -DEFINE_INTEGER(306) -DEFINE_INTEGER(307) -DEFINE_INTEGER(308) -DEFINE_INTEGER(309) -DEFINE_INTEGER(310) -DEFINE_INTEGER(311) -DEFINE_INTEGER(312) -DEFINE_INTEGER(313) -DEFINE_INTEGER(314) -DEFINE_INTEGER(315) -DEFINE_INTEGER(316) -DEFINE_INTEGER(317) -DEFINE_INTEGER(318) -DEFINE_INTEGER(319) -DEFINE_INTEGER(320) -DEFINE_INTEGER(321) -DEFINE_INTEGER(322) -DEFINE_INTEGER(323) -DEFINE_INTEGER(324) -DEFINE_INTEGER(325) -DEFINE_INTEGER(326) -DEFINE_INTEGER(327) -DEFINE_INTEGER(328) -DEFINE_INTEGER(329) -DEFINE_INTEGER(330) -DEFINE_INTEGER(331) -DEFINE_INTEGER(332) -DEFINE_INTEGER(333) -DEFINE_INTEGER(334) -DEFINE_INTEGER(335) -DEFINE_INTEGER(336) -DEFINE_INTEGER(337) -DEFINE_INTEGER(338) -DEFINE_INTEGER(339) -DEFINE_INTEGER(340) -DEFINE_INTEGER(341) -DEFINE_INTEGER(342) -DEFINE_INTEGER(343) -DEFINE_INTEGER(344) -DEFINE_INTEGER(345) -DEFINE_INTEGER(346) -DEFINE_INTEGER(347) -DEFINE_INTEGER(348) -DEFINE_INTEGER(349) -DEFINE_INTEGER(350) -DEFINE_INTEGER(351) -DEFINE_INTEGER(352) -DEFINE_INTEGER(353) -DEFINE_INTEGER(354) -DEFINE_INTEGER(355) -DEFINE_INTEGER(356) -DEFINE_INTEGER(357) -DEFINE_INTEGER(358) -DEFINE_INTEGER(359) -DEFINE_INTEGER(360) -DEFINE_INTEGER(361) -DEFINE_INTEGER(362) -DEFINE_INTEGER(363) -DEFINE_INTEGER(364) -DEFINE_INTEGER(365) -DEFINE_INTEGER(366) -DEFINE_INTEGER(367) -DEFINE_INTEGER(368) -DEFINE_INTEGER(369) -DEFINE_INTEGER(370) -DEFINE_INTEGER(371) -DEFINE_INTEGER(372) -DEFINE_INTEGER(373) -DEFINE_INTEGER(374) -DEFINE_INTEGER(375) -DEFINE_INTEGER(376) -DEFINE_INTEGER(377) -DEFINE_INTEGER(378) -DEFINE_INTEGER(379) -DEFINE_INTEGER(380) -DEFINE_INTEGER(381) -DEFINE_INTEGER(382) -DEFINE_INTEGER(383) -DEFINE_INTEGER(384) -DEFINE_INTEGER(385) -DEFINE_INTEGER(386) -DEFINE_INTEGER(387) -DEFINE_INTEGER(388) -DEFINE_INTEGER(389) -DEFINE_INTEGER(390) -DEFINE_INTEGER(391) -DEFINE_INTEGER(392) -DEFINE_INTEGER(393) -DEFINE_INTEGER(394) -DEFINE_INTEGER(395) -DEFINE_INTEGER(396) -DEFINE_INTEGER(397) -DEFINE_INTEGER(398) -DEFINE_INTEGER(399) -DEFINE_INTEGER(400) -DEFINE_INTEGER(401) -DEFINE_INTEGER(402) -DEFINE_INTEGER(403) -DEFINE_INTEGER(404) -DEFINE_INTEGER(405) -DEFINE_INTEGER(406) -DEFINE_INTEGER(407) -DEFINE_INTEGER(408) -DEFINE_INTEGER(409) -DEFINE_INTEGER(410) -DEFINE_INTEGER(411) -DEFINE_INTEGER(412) -DEFINE_INTEGER(413) -DEFINE_INTEGER(414) -DEFINE_INTEGER(415) -DEFINE_INTEGER(416) -DEFINE_INTEGER(417) -DEFINE_INTEGER(418) -DEFINE_INTEGER(419) -DEFINE_INTEGER(420) -DEFINE_INTEGER(421) -DEFINE_INTEGER(422) -DEFINE_INTEGER(423) -DEFINE_INTEGER(424) -DEFINE_INTEGER(425) -DEFINE_INTEGER(426) -DEFINE_INTEGER(427) -DEFINE_INTEGER(428) -DEFINE_INTEGER(429) -DEFINE_INTEGER(430) -DEFINE_INTEGER(431) -DEFINE_INTEGER(432) -DEFINE_INTEGER(433) -DEFINE_INTEGER(434) -DEFINE_INTEGER(435) -DEFINE_INTEGER(436) -DEFINE_INTEGER(437) -DEFINE_INTEGER(438) -DEFINE_INTEGER(439) -DEFINE_INTEGER(440) -DEFINE_INTEGER(441) -DEFINE_INTEGER(442) -DEFINE_INTEGER(443) -DEFINE_INTEGER(444) -DEFINE_INTEGER(445) -DEFINE_INTEGER(446) -DEFINE_INTEGER(447) -DEFINE_INTEGER(448) -DEFINE_INTEGER(449) -DEFINE_INTEGER(450) -DEFINE_INTEGER(451) -DEFINE_INTEGER(452) -DEFINE_INTEGER(453) -DEFINE_INTEGER(454) -DEFINE_INTEGER(455) -DEFINE_INTEGER(456) -DEFINE_INTEGER(457) -DEFINE_INTEGER(458) -DEFINE_INTEGER(459) -DEFINE_INTEGER(460) -DEFINE_INTEGER(461) -DEFINE_INTEGER(462) -DEFINE_INTEGER(463) -DEFINE_INTEGER(464) -DEFINE_INTEGER(465) -DEFINE_INTEGER(466) -DEFINE_INTEGER(467) -DEFINE_INTEGER(468) -DEFINE_INTEGER(469) -DEFINE_INTEGER(470) -DEFINE_INTEGER(471) -DEFINE_INTEGER(472) -DEFINE_INTEGER(473) -DEFINE_INTEGER(474) -DEFINE_INTEGER(475) -DEFINE_INTEGER(476) -DEFINE_INTEGER(477) -DEFINE_INTEGER(478) -DEFINE_INTEGER(479) -DEFINE_INTEGER(480) -DEFINE_INTEGER(481) -DEFINE_INTEGER(482) -DEFINE_INTEGER(483) -DEFINE_INTEGER(484) -DEFINE_INTEGER(485) -DEFINE_INTEGER(486) -DEFINE_INTEGER(487) -DEFINE_INTEGER(488) -DEFINE_INTEGER(489) -DEFINE_INTEGER(490) -DEFINE_INTEGER(491) -DEFINE_INTEGER(492) -DEFINE_INTEGER(493) -DEFINE_INTEGER(494) -DEFINE_INTEGER(495) -DEFINE_INTEGER(496) -DEFINE_INTEGER(497) -DEFINE_INTEGER(498) -DEFINE_INTEGER(499) -DEFINE_INTEGER(500) -DEFINE_INTEGER(501) -DEFINE_INTEGER(502) -DEFINE_INTEGER(503) -DEFINE_INTEGER(504) -DEFINE_INTEGER(505) -DEFINE_INTEGER(506) -DEFINE_INTEGER(507) -DEFINE_INTEGER(508) -DEFINE_INTEGER(509) -DEFINE_INTEGER(510) -DEFINE_INTEGER(511) -DEFINE_INTEGER(512) -DEFINE_INTEGER(513) -DEFINE_INTEGER(514) -DEFINE_INTEGER(515) -DEFINE_INTEGER(516) -DEFINE_INTEGER(517) -DEFINE_INTEGER(518) -DEFINE_INTEGER(519) -DEFINE_INTEGER(520) -DEFINE_INTEGER(521) -DEFINE_INTEGER(522) -DEFINE_INTEGER(523) -DEFINE_INTEGER(524) -DEFINE_INTEGER(525) -DEFINE_INTEGER(526) -DEFINE_INTEGER(527) -DEFINE_INTEGER(528) -DEFINE_INTEGER(529) -DEFINE_INTEGER(530) -DEFINE_INTEGER(531) -DEFINE_INTEGER(532) -DEFINE_INTEGER(533) -DEFINE_INTEGER(534) -DEFINE_INTEGER(535) -DEFINE_INTEGER(536) -DEFINE_INTEGER(537) -DEFINE_INTEGER(538) -DEFINE_INTEGER(539) -DEFINE_INTEGER(540) -DEFINE_INTEGER(541) -DEFINE_INTEGER(542) -DEFINE_INTEGER(543) -DEFINE_INTEGER(544) -DEFINE_INTEGER(545) -DEFINE_INTEGER(546) -DEFINE_INTEGER(547) -DEFINE_INTEGER(548) -DEFINE_INTEGER(549) -DEFINE_INTEGER(550) -DEFINE_INTEGER(551) -DEFINE_INTEGER(552) -DEFINE_INTEGER(553) -DEFINE_INTEGER(554) -DEFINE_INTEGER(555) -DEFINE_INTEGER(556) -DEFINE_INTEGER(557) -DEFINE_INTEGER(558) -DEFINE_INTEGER(559) -DEFINE_INTEGER(560) -DEFINE_INTEGER(561) -DEFINE_INTEGER(562) -DEFINE_INTEGER(563) -DEFINE_INTEGER(564) -DEFINE_INTEGER(565) -DEFINE_INTEGER(566) -DEFINE_INTEGER(567) -DEFINE_INTEGER(568) -DEFINE_INTEGER(569) -DEFINE_INTEGER(570) -DEFINE_INTEGER(571) -DEFINE_INTEGER(572) -DEFINE_INTEGER(573) -DEFINE_INTEGER(574) -DEFINE_INTEGER(575) -DEFINE_INTEGER(576) -DEFINE_INTEGER(577) -DEFINE_INTEGER(578) -DEFINE_INTEGER(579) -DEFINE_INTEGER(580) -DEFINE_INTEGER(581) -DEFINE_INTEGER(582) -DEFINE_INTEGER(583) -DEFINE_INTEGER(584) -DEFINE_INTEGER(585) -DEFINE_INTEGER(586) -DEFINE_INTEGER(587) -DEFINE_INTEGER(588) -DEFINE_INTEGER(589) -DEFINE_INTEGER(590) -DEFINE_INTEGER(591) -DEFINE_INTEGER(592) -DEFINE_INTEGER(593) -DEFINE_INTEGER(594) -DEFINE_INTEGER(595) -DEFINE_INTEGER(596) -DEFINE_INTEGER(597) -DEFINE_INTEGER(598) -DEFINE_INTEGER(599) -DEFINE_INTEGER(600) -DEFINE_INTEGER(601) -DEFINE_INTEGER(602) -DEFINE_INTEGER(603) -DEFINE_INTEGER(604) -DEFINE_INTEGER(605) -DEFINE_INTEGER(606) -DEFINE_INTEGER(607) -DEFINE_INTEGER(608) -DEFINE_INTEGER(609) -DEFINE_INTEGER(610) -DEFINE_INTEGER(611) -DEFINE_INTEGER(612) -DEFINE_INTEGER(613) -DEFINE_INTEGER(614) -DEFINE_INTEGER(615) -DEFINE_INTEGER(616) -DEFINE_INTEGER(617) -DEFINE_INTEGER(618) -DEFINE_INTEGER(619) -DEFINE_INTEGER(620) -DEFINE_INTEGER(621) -DEFINE_INTEGER(622) -DEFINE_INTEGER(623) -DEFINE_INTEGER(624) -DEFINE_INTEGER(625) -DEFINE_INTEGER(626) -DEFINE_INTEGER(627) -DEFINE_INTEGER(628) -DEFINE_INTEGER(629) -DEFINE_INTEGER(630) -DEFINE_INTEGER(631) -DEFINE_INTEGER(632) -DEFINE_INTEGER(633) -DEFINE_INTEGER(634) -DEFINE_INTEGER(635) -DEFINE_INTEGER(636) -DEFINE_INTEGER(637) -DEFINE_INTEGER(638) -DEFINE_INTEGER(639) -DEFINE_INTEGER(640) -DEFINE_INTEGER(641) -DEFINE_INTEGER(642) -DEFINE_INTEGER(643) -DEFINE_INTEGER(644) -DEFINE_INTEGER(645) -DEFINE_INTEGER(646) -DEFINE_INTEGER(647) -DEFINE_INTEGER(648) -DEFINE_INTEGER(649) -DEFINE_INTEGER(650) -DEFINE_INTEGER(651) -DEFINE_INTEGER(652) -DEFINE_INTEGER(653) -DEFINE_INTEGER(654) -DEFINE_INTEGER(655) -DEFINE_INTEGER(656) -DEFINE_INTEGER(657) -DEFINE_INTEGER(658) -DEFINE_INTEGER(659) -DEFINE_INTEGER(660) -DEFINE_INTEGER(661) -DEFINE_INTEGER(662) -DEFINE_INTEGER(663) -DEFINE_INTEGER(664) -DEFINE_INTEGER(665) -DEFINE_INTEGER(666) -DEFINE_INTEGER(667) -DEFINE_INTEGER(668) -DEFINE_INTEGER(669) -DEFINE_INTEGER(670) -DEFINE_INTEGER(671) -DEFINE_INTEGER(672) -DEFINE_INTEGER(673) -DEFINE_INTEGER(674) -DEFINE_INTEGER(675) -DEFINE_INTEGER(676) -DEFINE_INTEGER(677) -DEFINE_INTEGER(678) -DEFINE_INTEGER(679) -DEFINE_INTEGER(680) -DEFINE_INTEGER(681) -DEFINE_INTEGER(682) -DEFINE_INTEGER(683) -DEFINE_INTEGER(684) -DEFINE_INTEGER(685) -DEFINE_INTEGER(686) -DEFINE_INTEGER(687) -DEFINE_INTEGER(688) -DEFINE_INTEGER(689) -DEFINE_INTEGER(690) -DEFINE_INTEGER(691) -DEFINE_INTEGER(692) -DEFINE_INTEGER(693) -DEFINE_INTEGER(694) -DEFINE_INTEGER(695) -DEFINE_INTEGER(696) -DEFINE_INTEGER(697) -DEFINE_INTEGER(698) -DEFINE_INTEGER(699) -DEFINE_INTEGER(700) -DEFINE_INTEGER(701) -DEFINE_INTEGER(702) -DEFINE_INTEGER(703) -DEFINE_INTEGER(704) -DEFINE_INTEGER(705) -DEFINE_INTEGER(706) -DEFINE_INTEGER(707) -DEFINE_INTEGER(708) -DEFINE_INTEGER(709) -DEFINE_INTEGER(710) -DEFINE_INTEGER(711) -DEFINE_INTEGER(712) -DEFINE_INTEGER(713) -DEFINE_INTEGER(714) -DEFINE_INTEGER(715) -DEFINE_INTEGER(716) -DEFINE_INTEGER(717) -DEFINE_INTEGER(718) -DEFINE_INTEGER(719) -DEFINE_INTEGER(720) -DEFINE_INTEGER(721) -DEFINE_INTEGER(722) -DEFINE_INTEGER(723) -DEFINE_INTEGER(724) -DEFINE_INTEGER(725) -DEFINE_INTEGER(726) -DEFINE_INTEGER(727) -DEFINE_INTEGER(728) -DEFINE_INTEGER(729) -DEFINE_INTEGER(730) -DEFINE_INTEGER(731) -DEFINE_INTEGER(732) -DEFINE_INTEGER(733) -DEFINE_INTEGER(734) -DEFINE_INTEGER(735) -DEFINE_INTEGER(736) -DEFINE_INTEGER(737) -DEFINE_INTEGER(738) -DEFINE_INTEGER(739) -DEFINE_INTEGER(740) -DEFINE_INTEGER(741) -DEFINE_INTEGER(742) -DEFINE_INTEGER(743) -DEFINE_INTEGER(744) -DEFINE_INTEGER(745) -DEFINE_INTEGER(746) -DEFINE_INTEGER(747) -DEFINE_INTEGER(748) -DEFINE_INTEGER(749) -DEFINE_INTEGER(750) -DEFINE_INTEGER(751) -DEFINE_INTEGER(752) -DEFINE_INTEGER(753) -DEFINE_INTEGER(754) -DEFINE_INTEGER(755) -DEFINE_INTEGER(756) -DEFINE_INTEGER(757) -DEFINE_INTEGER(758) -DEFINE_INTEGER(759) -DEFINE_INTEGER(760) -DEFINE_INTEGER(761) -DEFINE_INTEGER(762) -DEFINE_INTEGER(763) -DEFINE_INTEGER(764) -DEFINE_INTEGER(765) -DEFINE_INTEGER(766) -DEFINE_INTEGER(767) -DEFINE_INTEGER(768) -DEFINE_INTEGER(769) -DEFINE_INTEGER(770) -DEFINE_INTEGER(771) -DEFINE_INTEGER(772) -DEFINE_INTEGER(773) -DEFINE_INTEGER(774) -DEFINE_INTEGER(775) -DEFINE_INTEGER(776) -DEFINE_INTEGER(777) -DEFINE_INTEGER(778) -DEFINE_INTEGER(779) -DEFINE_INTEGER(780) -DEFINE_INTEGER(781) -DEFINE_INTEGER(782) -DEFINE_INTEGER(783) -DEFINE_INTEGER(784) -DEFINE_INTEGER(785) -DEFINE_INTEGER(786) -DEFINE_INTEGER(787) -DEFINE_INTEGER(788) -DEFINE_INTEGER(789) -DEFINE_INTEGER(790) -DEFINE_INTEGER(791) -DEFINE_INTEGER(792) -DEFINE_INTEGER(793) -DEFINE_INTEGER(794) -DEFINE_INTEGER(795) -DEFINE_INTEGER(796) -DEFINE_INTEGER(797) -DEFINE_INTEGER(798) -DEFINE_INTEGER(799) -DEFINE_INTEGER(800) -DEFINE_INTEGER(801) -DEFINE_INTEGER(802) -DEFINE_INTEGER(803) -DEFINE_INTEGER(804) -DEFINE_INTEGER(805) -DEFINE_INTEGER(806) -DEFINE_INTEGER(807) -DEFINE_INTEGER(808) -DEFINE_INTEGER(809) -DEFINE_INTEGER(810) -DEFINE_INTEGER(811) -DEFINE_INTEGER(812) -DEFINE_INTEGER(813) -DEFINE_INTEGER(814) -DEFINE_INTEGER(815) -DEFINE_INTEGER(816) -DEFINE_INTEGER(817) diff --git a/t-child.c b/t-child.c deleted file mode 100644 index f4e3a04..0000000 --- a/t-child.c +++ /dev/null @@ -1,74 +0,0 @@ -/* Sanity check for the process and IPC primitives. - * - * Copyright (C) 2016 g10 code GmbH - * - * This file is part of GnuPG. - * - * GnuPG is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 3 of the License, or - * (at your option) any later version. - * - * GnuPG is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, see . - */ - -#include -#include -#include - -#ifdef _WIN32 -# include -# include -#endif - -int -main (int argc, char **argv) -{ - char buffer[4096]; - memset (buffer, 'A', sizeof buffer); -#if _WIN32 - if (! setmode (fileno (stdin), O_BINARY)) - return 23; - if (! setmode (fileno (stdout), O_BINARY)) - return 23; -#endif - - if (argc == 1) - return 2; - else if (strcmp (argv[1], "return0") == 0) - return 0; - else if (strcmp (argv[1], "return1") == 0) - return 1; - else if (strcmp (argv[1], "return77") == 0) - return 77; - else if (strcmp (argv[1], "hello_stdout") == 0) - fprintf (stdout, "hello"); - else if (strcmp (argv[1], "hello_stderr") == 0) - fprintf (stderr, "hello"); - else if (strcmp (argv[1], "stdout4096") == 0) - fwrite (buffer, 1, sizeof buffer, stdout); - else if (strcmp (argv[1], "stdout8192") == 0) - { - fwrite (buffer, 1, sizeof buffer, stdout); - fwrite (buffer, 1, sizeof buffer, stdout); - } - else if (strcmp (argv[1], "cat") == 0) - while (! feof (stdin)) - { - size_t bytes_read; - bytes_read = fread (buffer, 1, sizeof buffer, stdin); - fwrite (buffer, 1, bytes_read, stdout); - } - else - { - fprintf (stderr, "unknown command %s\n", argv[1]); - return 2; - } - return 0; -} diff --git a/t-child.scm b/t-child.scm deleted file mode 100644 index fd1dcc3..0000000 --- a/t-child.scm +++ /dev/null @@ -1,118 +0,0 @@ -;; Tests for the low-level process and IPC primitives. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(echo "Testing process and IPC primitives...") - -(define (qualify executable) - (string-append executable (getenv "EXEEXT"))) - -(define child (qualify "t-child")) - -(assert (= 0 (call `(,(qualify "t-child") "return0")))) -(assert (= 1 (call `(,(qualify "t-child") "return1")))) -(assert (= 77 (call `(,(qualify "t-child") "return77")))) - -(let ((r (call-with-io `(,(qualify "t-child") "return0") ""))) - (assert (= 0 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "return1") ""))) - (assert (= 1 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "return77") ""))) - (assert (= 77 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") ""))) - (assert (= 0 (:retcode r))) - (assert (string=? "hello" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") ""))) - (assert (= 0 (:retcode r))) - (assert (string=? "" (:stdout r))) - (assert (string=? "hello" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "stdout4096") ""))) - (assert (= 0 (:retcode r))) - (assert (= 4096 (string-length (:stdout r)))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "stdout8192") ""))) - (assert (= 0 (:retcode r))) - (assert (= 8192 (string-length (:stdout r)))) - (assert (string=? "" (:stderr r)))) - -(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello"))) - (assert (= 0 (:retcode r))) - (assert (string=? "hellohello" (:stdout r))) - (assert (string=? "" (:stderr r)))) - -(define (spawn what) - (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO)) - -(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) - (pid1 (spawn `(,(qualify "t-child") "return0")))) - (assert (equal? '(0 0) - (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) - -(let ((pid0 (spawn `(,(qualify "t-child") "return1"))) - (pid1 (spawn `(,(qualify "t-child") "return0")))) - (assert (equal? '(1 0) - (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) - -(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) - (pid1 (spawn `(,(qualify "t-child") "return77"))) - (pid2 (spawn `(,(qualify "t-child") "return1")))) - (assert (equal? '(0 77 1) - (wait-processes '("child0" "child1" "child2") - (list pid0 pid1 pid2) #t)))) - -(let* ((p (pipe)) - (pid0 (spawn-process-fd - `(,(qualify "t-child") "hello_stdout") - CLOSED_FD (:write-end p) STDERR_FILENO)) - (_ (close (:write-end p))) - (pid1 (spawn-process-fd - `(,(qualify "t-child") "cat") - (:read-end p) STDOUT_FILENO STDERR_FILENO))) - (close (:read-end p)) - (assert - (equal? '(0 0) - (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) -(echo " world.") - -(tr:do - (tr:pipe-do - (pipe:spawn `(,child stdout4096)) - (pipe:spawn `(,child cat))) - (tr:call-with-content (lambda (c) - (assert (= 4096 (string-length c)))))) -(tr:do - (tr:pipe-do - (pipe:spawn `(,child stdout8192)) - (pipe:spawn `(,child cat))) - (tr:call-with-content (lambda (c) - (assert (= 8192 (string-length c)))))) - -(echo "All good.") diff --git a/tests.scm b/tests.scm deleted file mode 100644 index 5141002..0000000 --- a/tests.scm +++ /dev/null @@ -1,886 +0,0 @@ -;; Common definitions for writing tests. -;; -;; Copyright (C) 2016 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; Reporting. -(define (echo . msg) - (for-each (lambda (x) (display x) (display " ")) msg) - (newline)) - -(define (info . msg) - (apply echo msg) - (flush-stdio)) - -(define (log . msg) - (if (> (*verbose*) 0) - (apply info msg))) - -(define (fail . msg) - (apply info msg) - (exit 1)) - -(define (skip . msg) - (apply info msg) - (exit 77)) - -(define (make-counter) - (let ((c 0)) - (lambda () - (let ((r c)) - (set! c (+ 1 c)) - r)))) - -(define *progress-nesting* 0) - -(define (call-with-progress msg what) - (set! *progress-nesting* (+ 1 *progress-nesting*)) - (if (= 1 *progress-nesting*) - (begin - (info msg) - (display " > ") - (flush-stdio) - (what (lambda (item) - (display item) - (display " ") - (flush-stdio))) - (info "< ")) - (begin - (what (lambda (item) (display ".") (flush-stdio))) - (display " ") - (flush-stdio))) - (set! *progress-nesting* (- *progress-nesting* 1))) - -(define (for-each-p msg proc lst . lsts) - (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts))) - -(define (for-each-p' msg proc fmt lst . lsts) - (call-with-progress - msg - (lambda (progress) - (apply for-each - `(,(lambda args - (progress (apply fmt args)) - (apply proc args)) - ,lst ,@lsts))))) - -;; Process management. -(define CLOSED_FD -1) -(define (call-with-fds what infd outfd errfd) - (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t)) -(define (call what) - (call-with-fds what - CLOSED_FD - (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD) - (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD))) - -;; Accessor functions for the results of 'spawn-process'. -(define :stdin car) -(define :stdout cadr) -(define :stderr caddr) -(define :pid cadddr) - -(define (call-with-io what in) - (let ((h (spawn-process what 0))) - (es-write (:stdin h) in) - (es-fclose (:stdin h)) - (let* ((out (es-read-all (:stdout h))) - (err (es-read-all (:stderr h))) - (result (wait-process (car what) (:pid h) #t))) - (es-fclose (:stdout h)) - (es-fclose (:stderr h)) - (if (> (*verbose*) 2) - (info "Child" (:pid h) "returned:" - `((command ,(stringify what)) - (status ,result) - (stdout ,out) - (stderr ,err)))) - (list result out err)))) - -;; Accessor function for the results of 'call-with-io'. ':stdout' and -;; ':stderr' can also be used. -(define :retcode car) - -(define (call-check what) - (let ((result (call-with-io what ""))) - (if (= 0 (:retcode result)) - (:stdout result) - (throw (string-append (stringify what) " failed") - (:stderr result))))) - -(define (call-popen command input-string) - (let ((result (call-with-io command input-string))) - (if (= 0 (:retcode result)) - (:stdout result) - (throw (:stderr result))))) - -;; -;; estream helpers. -;; - -(define (es-read-all stream) - (let loop - ((acc "")) - (if (es-feof stream) - acc - (loop (string-append acc (es-read stream 4096)))))) - -;; -;; File management. -;; -(define (file-exists? name) - (call-with-input-file name (lambda (port) #t))) - -(define (file=? a b) - (file-equal a b #t)) - -(define (text-file=? a b) - (file-equal a b #f)) - -(define (file-copy from to) - (catch '() (unlink to)) - (letfd ((source (open from (logior O_RDONLY O_BINARY))) - (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600))) - (splice source sink))) - -(define (text-file-copy from to) - (catch '() (unlink to)) - (letfd ((source (open from O_RDONLY)) - (sink (open to (logior O_WRONLY O_CREAT) #o600))) - (splice source sink))) - -(define (path-join . components) - (let loop ((acc #f) (rest (filter (lambda (s) - (not (string=? "" s))) components))) - (if (null? rest) - acc - (loop (if (string? acc) - (string-append acc "/" (car rest)) - (car rest)) - (cdr rest))))) -(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz")) -(assert (string=? (path-join "" "bar" "baz") "bar/baz")) - -;; Is PATH an absolute path? -(define (absolute-path? path) - (or (char=? #\/ (string-ref path 0)) - (and *win32* (char=? #\\ (string-ref path 0))) - (and *win32* - (char-alphabetic? (string-ref path 0)) - (char=? #\: (string-ref path 1)) - (or (char=? #\/ (string-ref path 2)) - (char=? #\\ (string-ref path 2)))))) - -;; Make PATH absolute. -(define (canonical-path path) - (if (absolute-path? path) path (path-join (getcwd) path))) - -(define (in-srcdir . names) - (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names)))) - -;; Split a list of paths. -(define (pathsep-split s) - (string-split s *pathsep*)) - -;; Join a list of paths. -(define (pathsep-join paths) - (foldr (lambda (a b) (string-append a (string *pathsep*) b)) - (car paths) - (cdr paths))) - -;; Try to find NAME in PATHS. Returns the full path name on success, -;; or raises an error. -(define (path-expand name paths) - (let loop ((path paths)) - (if (null? path) - (throw "Could not find" name "in" paths) - (let* ((qualified-name (path-join (car path) name)) - (file-exists (call-with-input-file qualified-name - (lambda (x) #t)))) - (if file-exists - qualified-name - (loop (cdr path))))))) - -;; Expand NAME using the gpgscm load path. Use like this: -;; (load (with-path "library.scm")) -(define (with-path name) - (catch name - (path-expand name (pathsep-split (getenv "GPGSCM_PATH"))))) - -(define (basename path) - (let ((i (string-index path #\/))) - (if (equal? i #f) - path - (basename (substring path (+ 1 i) (string-length path)))))) - -(define (basename-suffix path suffix) - (basename - (if (string-suffix? path suffix) - (substring path 0 (- (string-length path) (string-length suffix))) - path))) - -(define (dirname path) - (let ((i (string-rindex path #\/))) - (if i (substring path 0 i) "."))) -(assert (string=? "foo/bar" (dirname "foo/bar/baz"))) - -;; Helper for (pipe). -(define :read-end car) -(define :write-end cadr) - -;; let-like macro that manages file descriptors. -;; -;; (letfd ) -;; -;; Bind all variables given in and initialize each of them -;; to the given initial value, and close them after evaluating . -(define-macro (letfd bindings . body) - (let bind ((bindings' bindings)) - (if (null? bindings') - `(begin ,@body) - (let* ((binding (car bindings')) - (name (car binding)) - (initializer (cadr binding))) - `(let ((,name ,initializer)) - (finally (close ,name) - ,(bind (cdr bindings')))))))) - -(define-macro (with-working-directory new-directory . expressions) - (let ((new-dir (gensym)) - (old-dir (gensym))) - `(let* ((,new-dir ,new-directory) - (,old-dir (getcwd))) - (dynamic-wind - (lambda () (if ,new-dir (chdir ,new-dir))) - (lambda () ,@expressions) - (lambda () (chdir ,old-dir)))))) - -;; Make a temporary directory. If arguments are given, they are -;; joined using path-join, and must end in a component ending in -;; "XXXXXX". If no arguments are given, a suitable location and -;; generic name is used. Returns an absolute path. -(define (mkdtemp . components) - (canonical-path (_mkdtemp (if (null? components) - (path-join - (get-temp-path) - (string-append "gpgscm-" (get-isotime) "-" - (basename-suffix *scriptname* ".scm") - "-XXXXXX")) - (apply path-join components))))) - -;; Make a temporary directory and remove it at interpreter shutdown. -;; Note that there are macros that limit the lifetime of temporary -;; directories and files to a lexical scope. Use those if possible. -;; Otherwise this works like mkdtemp. -(define (mkdtemp-autoremove . components) - (let ((dir (apply mkdtemp components))) - (atexit (lambda () (unlink-recursively dir))) - dir)) - -(define-macro (with-temporary-working-directory . expressions) - (let ((tmp-sym (gensym))) - `(let* ((,tmp-sym (mkdtemp))) - (finally (unlink-recursively ,tmp-sym) - (with-working-directory ,tmp-sym - ,@expressions))))) - -(define (make-temporary-file . args) - (canonical-path (path-join - (mkdtemp) - (if (null? args) "a" (car args))))) - -(define (remove-temporary-file filename) - (catch '() - (unlink filename)) - (let ((dirname (substring filename 0 (string-rindex filename #\/)))) - (catch (echo "removing temporary directory" dirname "failed") - (rmdir dirname)))) - -;; let-like macro that manages temporary files. -;; -;; (lettmp ) -;; -;; Bind all variables given in , initialize each of them to -;; a string representing an unique path in the filesystem, and delete -;; them after evaluating . -(define-macro (lettmp bindings . body) - (let bind ((bindings' bindings)) - (if (null? bindings') - `(begin ,@body) - (let ((name (car bindings')) - (rest (cdr bindings'))) - `(let ((,name (make-temporary-file ,(symbol->string name)))) - (finally (remove-temporary-file ,name) - ,(bind rest))))))) - -(define (check-execution source transformer) - (lettmp (sink) - (transformer source sink))) - -(define (check-identity source transformer) - (lettmp (sink) - (transformer source sink) - (if (not (file=? source sink)) - (fail "mismatch")))) - -;; -;; Monadic pipe support. -;; - -(define pipeM - (package - (define (new procs source sink producer) - (package - (define (dump) - (write (list procs source sink producer)) - (newline)) - (define (add-proc command pid) - (new (cons (list command pid) procs) source sink producer)) - (define (commands) - (map car procs)) - (define (pids) - (map cadr procs)) - (define (set-source source') - (new procs source' sink producer)) - (define (set-sink sink') - (new procs source sink' producer)) - (define (set-producer producer') - (if producer - (throw "producer already set")) - (new procs source sink producer')))))) - - -(define (pipe:do . commands) - (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands)) - (if (null? cmds) - (begin - (if M::producer (M::producer)) - (if (not (null? M::procs)) - (let* ((retcodes (wait-processes (map stringify (M::commands)) - (M::pids) #t)) - (results (map (lambda (p r) (append p (list r))) - M::procs retcodes)) - (failed (filter (lambda (x) (not (= 0 (caddr x)))) - results))) - (if (not (null? failed)) - (throw failed))))) ; xxx nicer reporting - (if (and (= 2 (length cmds)) (number? (cadr cmds))) - ;; hack: if it's an fd, use it as sink - (let ((M' ((car cmds) (M::set-sink (cadr cmds))))) - (if (> M::source 2) (close M::source)) - (if (> (cadr cmds) 2) (close (cadr cmds))) - (loop M' '())) - (let ((M' ((car cmds) M))) - (if (> M::source 2) (close M::source)) - (loop M' (cdr cmds))))))) - -(define (pipe:open pathname flags) - (lambda (M) - (M::set-source (open pathname flags)))) - -(define (pipe:defer producer) - (lambda (M) - (let* ((p (outbound-pipe)) - (M' (M::set-source (:read-end p)))) - (M'::set-producer (lambda () - (producer (:write-end p)) - (close (:write-end p))))))) -(define (pipe:echo data) - (pipe:defer (lambda (sink) (display data (fdopen sink "wb"))))) - -(define (pipe:spawn command) - (lambda (M) - (define (do-spawn M new-source) - (let ((pid (spawn-process-fd command M::source M::sink - (if (> (*verbose*) 0) - STDERR_FILENO CLOSED_FD))) - (M' (M::set-source new-source))) - (M'::add-proc command pid))) - (if (= CLOSED_FD M::sink) - (let* ((p (pipe)) - (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p)))) - (close (:write-end p)) - (M'::set-sink CLOSED_FD)) - (do-spawn M CLOSED_FD)))) - -(define (pipe:splice sink) - (lambda (M) - (splice M::source sink) - (M::set-source CLOSED_FD))) - -(define (pipe:write-to pathname flags mode) - (open pathname flags mode)) - -;; -;; Monadic transformer support. -;; - -(define (tr:do . commands) - (let loop ((tmpfiles '()) (source #f) (cmds commands)) - (if (null? cmds) - (for-each remove-temporary-file tmpfiles) - (let* ((v ((car cmds) tmpfiles source)) - (tmpfiles' (car v)) - (sink (cadr v)) - (error (caddr v))) - (if error - (begin - (for-each remove-temporary-file tmpfiles') - (apply throw error))) - (loop tmpfiles' sink (cdr cmds)))))) - -(define (tr:open pathname) - (lambda (tmpfiles source) - (list tmpfiles pathname #f))) - -(define (tr:spawn input command) - (lambda (tmpfiles source) - (if (and (member '**in** command) (not source)) - (fail (string-append (stringify cmd) " needs an input"))) - (let* ((t (make-temporary-file)) - (cmd (map (lambda (x) - (cond - ((equal? '**in** x) source) - ((equal? '**out** x) t) - (else x))) command))) - (catch (list (cons t tmpfiles) t *error*) - (call-popen cmd input) - (if (and (member '**out** command) (not (file-exists? t))) - (fail (string-append (stringify cmd) - " did not produce '" t "'."))) - (list (cons t tmpfiles) t #f))))) - -(define (tr:write-to pathname) - (lambda (tmpfiles source) - (rename source pathname) - (list tmpfiles pathname #f))) - -(define (tr:pipe-do . commands) - (lambda (tmpfiles source) - (let ((t (make-temporary-file))) - (apply pipe:do - `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) - ,@commands - ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) - (list (cons t tmpfiles) t #f)))) - -(define (tr:assert-identity reference) - (lambda (tmpfiles source) - (if (not (file=? source reference)) - (fail "mismatch")) - (list tmpfiles source #f))) - -(define (tr:assert-weak-identity reference) - (lambda (tmpfiles source) - (if (not (text-file=? source reference)) - (fail "mismatch")) - (list tmpfiles source #f))) - -(define (tr:call-with-content function . args) - (lambda (tmpfiles source) - (catch (list tmpfiles source *error*) - (apply function `(,(call-with-input-file source read-all) ,@args))) - (list tmpfiles source #f))) - -;; -;; Developing and debugging tests. -;; - -;; Spawn an os shell. -(define (interactive-shell) - (call-with-fds `(,(getenv "SHELL") -i) 0 1 2)) - -;; -;; The main test framework. -;; - -(define semaphore - (package - (define (new n) - (package - (define (acquire!?) - (if (> n 0) - (begin - (set! n (- n 1)) - #t) - #f)) - (define (release!) - (set! n (+ n 1))))))) - -;; A pool of tests. -(define test-pool - (package - (define (new n) - (package - ;; A semaphore to restrict the number of spawned processes. - (define sem (semaphore::new n)) - - ;; A list of enqueued, but not yet run tests. - (define enqueued '()) - - ;; A list of running or finished processes. - (define procs '()) - - (define (add test) - (if (test::started?) - (set! procs (cons test procs)) - (if (sem::acquire!?) - (add (test::run-async)) - (set! enqueued (cons test enqueued)))) - (current-environment)) - - ;; Pop the last of the enqueued tests off the fifo queue. - (define (pop-test!) - (let ((i (length enqueued))) - (assert (> i 0)) - (cond - ((= i 1) - (let ((test (car enqueued))) - (set! enqueued '()) - test)) - (else - (let* ((tail (list-tail enqueued (- i 2))) - (test (cadr tail))) - (set-cdr! tail '()) - (assert (= (length enqueued) (- i 1))) - test))))) - - (define (pid->test pid) - (let ((t (filter (lambda (x) (= pid x::pid)) procs))) - (if (null? t) #f (car t)))) - (define (wait) - (if (null? enqueued) - ;; If no tests are enqueued, we can just block until all - ;; of them finished. - (wait' #t) - ;; Otherwise, we must not block, but give some tests the - ;; chance to finish so that we can start new ones. - (begin - (wait' #f) - (usleep (/ 1000000 10)) - (wait)))) - (define (wait' hang) - (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) - (if (null? unfinished) - (current-environment) - (let ((names (map (lambda (t) t::name) unfinished)) - (pids (map (lambda (t) t::pid) unfinished)) - (any #f)) - (for-each - (lambda (test retcode) - (unless (< retcode 0) - (test::set-end-time!) - (test:::set! 'retcode retcode) - (test::report) - (sem::release!) - (set! any #t))) - (map pid->test pids) - (wait-processes (map stringify names) pids hang)) - - ;; If some processes finished, try to start new ones. - (let loop () - (cond - ((not any) #f) - ((pair? enqueued) - (if (sem::acquire!?) - (let ((test (pop-test!))) - (add (test::run-async)) - (loop))))))))) - (current-environment)) - (define (filter-tests status) - (filter (lambda (p) (eq? status (p::status))) procs)) - (define (report) - (define (print-tests tests message) - (unless (null? tests) - (apply echo (cons message - (map (lambda (t) t::name) tests))))) - - (let ((failed (filter-tests 'FAIL)) - (xfailed (filter-tests 'XFAIL)) - (xpassed (filter-tests 'XPASS)) - (skipped (filter-tests 'SKIP))) - (echo "===================") - (echo (length procs) "tests run," - (length (filter-tests 'PASS)) "succeeded," - (length failed) "failed," - (length xfailed) "failed expectedly," - (length xpassed) "succeeded unexpectedly," - (length skipped) "skipped.") - (print-tests failed "Failed tests:") - (print-tests xfailed "Expectedly failed tests:") - (print-tests xpassed "Unexpectedly passed tests:") - (print-tests skipped "Skipped tests:") - (echo "===================") - (+ (length failed) (length xpassed)))) - - (define (xml) - (xx::document - (xx::tag 'testsuites - `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") - ("xsi:noNamespaceSchemaLocation" - "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd")) - (map (lambda (t) (t::xml)) procs)))))))) - -(define (verbosity n) - (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) - -(define (locate-test path) - (if (absolute-path? path) path (in-srcdir path))) - -;; A single test. -(define test - (begin - - ;; Private definitions. - - (define (isotime->junit t) - "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}" - "20170418T145809" - (string-append (substring t 0 4) - "-" - (substring t 4 6) - "-" - (substring t 6 11) - ":" - (substring t 11 13) - ":" - (substring t 13 15))) - - ;; If a tests name ends with a bang (!), it is expected to fail. - (define (expect-failure? name) - (string-suffix? name "!")) - ;; Strips the bang (if any). - (define (test-name name) - (if (expect-failure? name) - (substring name 0 (- (string-length name) 1)) - name)) - - (package - (define (scm setup name path . args) - ;; Start the process. - (define (spawn-scm args' in out err) - (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) - ,(locate-test (test-name path)) - ,@(if setup (force setup) '()) - ,@args' ,@args) in out err)) - (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name))) - - (define (binary setup name path . args) - ;; Start the process. - (define (spawn-binary args' in out err) - (spawn-process-fd `(,(test-name path) - ,@(if setup (force setup) '()) ,@args' ,@args) - in out err)) - (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name))) - - (define (new name directory spawn pid retcode logfd expect-failure) - (package - - ;; XXX: OO glue. - (define self (current-environment)) - (define (:set! key value) - (eval `(set! ,key ,value) (current-environment)) - (current-environment)) - - ;; The log is written here. - (define log-file-name #f) - - ;; Record time stamps. - (define timestamp #f) - (define start-time 0) - (define end-time 0) - - (define (set-start-time!) - (set! timestamp (isotime->junit (get-isotime))) - (set! start-time (get-time))) - (define (set-end-time!) - (set! end-time (get-time))) - - ;; Has the test been started yet? - (define (started?) - (number? pid)) - - (define (open-log-file) - (unless log-file-name - (set! log-file-name (string-append (basename name) ".log"))) - (catch '() (unlink log-file-name)) - (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) - - (define (run-sync . args) - (set-start-time!) - (letfd ((log (open-log-file))) - (with-working-directory directory - (let* ((p (inbound-pipe)) - (pid' (spawn args 0 (:write-end p) (:write-end p)))) - (close (:write-end p)) - (splice (:read-end p) STDERR_FILENO log) - (close (:read-end p)) - (set! pid pid') - (set! retcode (wait-process name pid' #t))))) - (report) - (current-environment)) - (define (run-sync-quiet . args) - (set-start-time!) - (with-working-directory directory - (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))) - (set! retcode (wait-process name pid #t)) - (set-end-time!) - (current-environment)) - (define (run-async . args) - (set-start-time!) - (let ((log (open-log-file))) - (with-working-directory directory - (set! pid (spawn args CLOSED_FD log log))) - (set! logfd log)) - (current-environment)) - (define (status) - (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))) - (t (if (not t') 'FAIL (cadr t')))) - (if expect-failure - (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t)) - t))) - (define (status-string) - (cadr (assoc (status) '((PASS "PASS") - (SKIP "SKIP") - (ERROR "ERROR") - (FAIL "FAIL") - (XPASS "XPASS") - (XFAIL "XFAIL"))))) - (define (report) - (unless (= logfd CLOSED_FD) - (seek logfd 0 SEEK_SET) - (splice logfd STDERR_FILENO) - (close logfd)) - (echo (string-append (status-string) ":") name)) - - (define (xml) - (xx::tag - 'testsuite - `((name ,name) - (time ,(- end-time start-time)) - (package ,(dirname name)) - (id 0) - (timestamp ,timestamp) - (hostname "unknown") - (tests 1) - (failures ,(if (eq? FAIL (status)) 1 0)) - (errors ,(if (eq? ERROR (status)) 1 0))) - (list - (xx::tag 'properties) - (xx::tag 'testcase - `((name ,(basename name)) - (classname ,(string-translate (dirname name) "/" ".")) - (time ,(- end-time start-time))) - `(,@(case (status) - ((PASS XFAIL) '()) - ((SKIP) (list (xx::tag 'skipped))) - ((ERROR) (list - (xx::tag 'error '((message "Unknown error."))))) - (else - (list (xx::tag 'failure '((message "Unknown error.")))))))) - (xx::tag 'system-out '() - (list (xx::textnode (read-all (open-input-file log-file-name))))) - (xx::tag 'system-err '() (list (xx::textnode ""))))))))))) - -;; Run the setup target to create an environment, then run all given -;; tests in parallel. -(define (run-tests-parallel tests n) - (let loop ((pool (test-pool::new n)) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - ((results::xml) (open-output-file "report.xml")) - (exit (results::report))) - (let ((wd (mkdtemp-autoremove)) - (test (car tests'))) - (test:::set! 'directory wd) - (loop (pool::add test) - (cdr tests')))))) - -;; Run the setup target to create an environment, then run all given -;; tests in sequence. -(define (run-tests-sequential tests) - (let loop ((pool (test-pool::new 1)) (tests' tests)) - (if (null? tests') - (let ((results (pool::wait))) - ((results::xml) (open-output-file "report.xml")) - (exit (results::report))) - (let ((wd (mkdtemp-autoremove)) - (test (car tests'))) - (test:::set! 'directory wd) - (loop (pool::add (test::run-sync)) - (cdr tests')))))) - -;; Run tests either in sequence or in parallel, depending on the -;; number of tests and the command line flags. -(define (run-tests tests) - (let ((parallel (flag "--parallel" *args*)) - (default-parallel-jobs 32)) - (if (and parallel (> (length tests) 1)) - (run-tests-parallel tests (if (and (pair? parallel) - (string->number (car parallel))) - (string->number (car parallel)) - default-parallel-jobs)) - (run-tests-sequential tests)))) - -;; Load all tests from the given path. -(define (load-tests . path) - (load (apply in-srcdir `(,@path "all-tests.scm"))) - all-tests) - -;; Helper to create environment caches from test functions. SETUP -;; must be a test implementing the producer side cache protocol. -;; Returns a promise containing the arguments that must be passed to a -;; test implementing the consumer side of the cache protocol. -(define (make-environment-cache setup) - (delay (with-temporary-working-directory - (let ((tarball (make-temporary-file "environment-cache"))) - (atexit (lambda () (remove-temporary-file tarball))) - (setup::run-sync '--create-tarball tarball) - (if (not (equal? 'PASS (setup::status))) - (fail "Setup failed.")) - `(--unpack-tarball ,tarball))))) - -;; Command line flag handling. Returns the elements following KEY in -;; ARGUMENTS up to the next argument, or #f if KEY is not in -;; ARGUMENTS. If 'KEY=XYZ' is encountered, then the singleton list -;; containing 'XYZ' is returned. -(define (flag key arguments) - (cond - ((null? arguments) - #f) - ((string=? key (car arguments)) - (let loop ((acc '()) - (args (cdr arguments))) - (if (or (null? args) (string-prefix? (car args) "--")) - (reverse acc) - (loop (cons (car args) acc) (cdr args))))) - ((string-prefix? (car arguments) (string-append key "=")) - (list (substring (car arguments) - (+ (string-length key) 1) - (string-length (car arguments))))) - ((string=? "--" (car arguments)) - #f) - (else - (flag key (cdr arguments))))) -(assert (equal? (flag "--xxx" '("--yyy")) #f)) -(assert (equal? (flag "--xxx" '("--xxx")) '())) -(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy"))) -(assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo"))) -(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz"))) -(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz"))) -(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy"))) -(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy"))) diff --git a/time.scm b/time.scm deleted file mode 100644 index a9b06d0..0000000 --- a/time.scm +++ /dev/null @@ -1,42 +0,0 @@ -;; Simple time manipulation library. -;; -;; Copyright (C) 2017 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -;; This library mimics what GnuPG thinks about expiration times. -;; Granularity is one second. Its focus is not on correctness. - -;; Conversion functions. -(define (minutes->seconds minutes) - (* minutes 60)) -(define (hours->seconds hours) - (* hours 60 60)) -(define (days->seconds days) - (* days 24 60 60)) -(define (weeks->seconds weeks) - (days->seconds (* weeks 7))) -(define (months->seconds months) - (days->seconds (* months 30))) -(define (years->seconds years) - (days->seconds (* years 365))) - -(define (time-matches? a b slack) - (< (abs (- a b)) slack)) -(assert (time-matches? (hours->seconds 1) (hours->seconds 2) (hours->seconds 2))) -(assert (time-matches? (hours->seconds 2) (hours->seconds 1) (hours->seconds 2))) -(assert (not (time-matches? (hours->seconds 4) (hours->seconds 1) (hours->seconds 2)))) -(assert (not (time-matches? (hours->seconds 1) (hours->seconds 4) (hours->seconds 2)))) diff --git a/xml.scm b/xml.scm deleted file mode 100644 index 771ec36..0000000 --- a/xml.scm +++ /dev/null @@ -1,142 +0,0 @@ -;; A tiny XML library. -;; -;; Copyright (C) 2017 g10 Code GmbH -;; -;; This file is part of GnuPG. -;; -;; GnuPG is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3 of the License, or -;; (at your option) any later version. -;; -;; GnuPG is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, see . - -(define xx - (begin - - ;; Private declarations. - (define quote-text - '((#\< "<") - (#\> ">") - (#\& "&"))) - - (define quote-attribute-' - '((#\< "<") - (#\> ">") - (#\& "&") - (#\' "'"))) - - (define quote-attribute-'' - '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """))) - - (define (escape-string quotation string sink) - ;; This implementation is a bit awkward because iteration is so - ;; slow in TinySCHEME. We rely on string-index to skip to the - ;; next character we need to escape. We also avoid allocations - ;; wherever possible. - - ;; Given a list of integers or #f, return the sublist that - ;; starts with the lowest integer. - (define (min* x) - (let loop ((lowest x) (rest x)) - (if (null? rest) - lowest - (loop (if (or (null? lowest) (not (car lowest)) - (and (car rest) (> (car lowest) (car rest)))) rest lowest) - (cdr rest))))) - - (let ((i 0) (start 0) (len (string-length string)) - (indices (map (lambda (x) (string-index string (car x))) quotation)) - (next #f) (c #f)) - - ;; Set 'i' to the index of the next character that needs - ;; escaping, 'c' to the character that needs to be escaped, - ;; and update 'indices'. - (define (skip!) - (set! next (min* indices)) - (set! i (if (null? next) #f (car next))) - (if i - (begin - (set! c (string-ref string i)) - (set-car! next (string-index string c (+ 1 i)))) - (set! i (string-length string)))) - - (let loop () - (skip!) - (if (< i len) - (begin - (display (substring string start i) sink) - (display (cadr (assv c quotation)) sink) - (set! i (+ 1 i)) - (set! start i) - (loop)) - (display (substring string start len) sink))))) - - (let ((escape-string-s (lambda (quotation string) - (let ((sink (open-output-string))) - (escape-string quotation string sink) - (get-output-string sink))))) - (assert (equal? (escape-string-s quote-text "foo") "foo")) - (assert (equal? (escape-string-s quote-text "foo&") "foo&")) - (assert (equal? (escape-string-s quote-text "&foo") "&foo")) - (assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar")) - (assert (equal? (escape-string-s quote-text "foobar") "foo>bar"))) - - (define (escape quotation datum sink) - (cond - ((string? datum) (escape-string quotation datum sink)) - ((symbol? datum) (escape-string quotation (symbol->string datum) sink)) - ((number? datum) (display (number->string datum) sink)) - (else - (throw "Do not know how to encode" datum)))) - - (define (name->string name) - (cond - ((symbol? name) (symbol->string name)) - (else name))) - - (package - - (define (textnode string) - (lambda (sink) - (escape quote-text string sink))) - - (define (tag name . rest) - (let ((attributes (if (null? rest) '() (car rest))) - (children (if (> (length rest) 1) (cadr rest) '()))) - (lambda (sink) - (display "<" sink) - (display (name->string name) sink) - (unless (null? attributes) - (display " " sink) - (for-each (lambda (a) - (display (car a) sink) - (display "=\"" sink) - (escape quote-attribute-'' (cadr a) sink) - (display "\" " sink)) attributes)) - (if (null? children) - (display "/>\n" sink) - (begin - (display ">\n" sink) - (for-each (lambda (c) (c sink)) children) - (display "string name) sink) - (display ">\n" sink)))))) - - (define (document root . rest) - (let ((attributes (if (null? rest) '() (car rest)))) - (lambda (sink) - ;; xxx ignores attributes - (display "\n" sink) - (root sink) - (newline sink))))))) -- cgit v1.2.3