From 282d65bef2af461f5f43af2846ef131a898940c3 Mon Sep 17 00:00:00 2001 From: Michael Natterer Date: Wed, 26 Nov 2003 17:14:58 +0000 Subject: [PATCH] configure.in plug-ins/script-fu/siod/Makefile.am 2003-11-26 Michael Natterer * configure.in * plug-ins/script-fu/siod/Makefile.am * plug-ins/script-fu/siod/.cvsignore * plug-ins/script-fu/siod/regex.c * plug-ins/script-fu/siod/slib.c * plug-ins/script-fu/siod/sliba.c * plug-ins/script-fu/siod/trace.c * plug-ins/script-fu/siod/siod.h * plug-ins/script-fu/siod/siodp.h: added new directory for siod. * plug-ins/script-fu/Makefile.am * plug-ins/script-fu/interp_regex.c * plug-ins/script-fu/interp_slib.c * plug-ins/script-fu/interp_sliba.c * plug-ins/script-fu/interp_trace.c * plug-ins/script-fu/siod.h * plug-ins/script-fu/siodp.h: removed siod from here. * plug-ins/script-fu/script-fu-scripts.[ch] * plug-ins/script-fu/script-fu.c * plug-ins/script-fu/siod-wrapper.c * tools/pdbgen/enumcode.pl: changed #includes accordingly. * plug-ins/script-fu/script-fu-constants.c: regenerated. * plug-ins/script-fu/script-fu-scripts.c (script_fu_error_msg): use siod-wrapper.c siod_get_error_msg() instead of accessing siod's global siod_err_msg variable directly. --- ChangeLog | 31 + configure.in | 1 + plug-ins/script-fu/Makefile.am | 9 +- plug-ins/script-fu/interp_regex.c | 190 -- plug-ins/script-fu/interp_slib.c | 3742 ---------------------- plug-ins/script-fu/interp_sliba.c | 2927 ----------------- plug-ins/script-fu/interp_trace.c | 192 -- plug-ins/script-fu/scheme-wrapper.c | 3 +- plug-ins/script-fu/script-fu-constants.c | 2 +- plug-ins/script-fu/script-fu-interface.c | 7 +- plug-ins/script-fu/script-fu-scripts.c | 7 +- plug-ins/script-fu/script-fu-scripts.h | 1 - plug-ins/script-fu/script-fu.c | 2 + plug-ins/script-fu/siod-wrapper.c | 3 +- plug-ins/script-fu/siod.h | 424 --- plug-ins/script-fu/siod/.cvsignore | 6 + plug-ins/script-fu/siod/Makefile.am | 16 + plug-ins/script-fu/siodp.h | 203 -- tools/pdbgen/enumcode.pl | 2 +- 19 files changed, 72 insertions(+), 7696 deletions(-) delete mode 100644 plug-ins/script-fu/interp_regex.c delete mode 100644 plug-ins/script-fu/interp_slib.c delete mode 100644 plug-ins/script-fu/interp_sliba.c delete mode 100644 plug-ins/script-fu/interp_trace.c delete mode 100644 plug-ins/script-fu/siod.h create mode 100644 plug-ins/script-fu/siod/.cvsignore create mode 100644 plug-ins/script-fu/siod/Makefile.am delete mode 100644 plug-ins/script-fu/siodp.h diff --git a/ChangeLog b/ChangeLog index 6426b9a619..138f76293b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,34 @@ +2003-11-26 Michael Natterer + + * configure.in + * plug-ins/script-fu/siod/Makefile.am + * plug-ins/script-fu/siod/.cvsignore + * plug-ins/script-fu/siod/regex.c + * plug-ins/script-fu/siod/slib.c + * plug-ins/script-fu/siod/sliba.c + * plug-ins/script-fu/siod/trace.c + * plug-ins/script-fu/siod/siod.h + * plug-ins/script-fu/siod/siodp.h: added new directory for siod. + + * plug-ins/script-fu/Makefile.am + * plug-ins/script-fu/interp_regex.c + * plug-ins/script-fu/interp_slib.c + * plug-ins/script-fu/interp_sliba.c + * plug-ins/script-fu/interp_trace.c + * plug-ins/script-fu/siod.h + * plug-ins/script-fu/siodp.h: removed siod from here. + + * plug-ins/script-fu/script-fu-scripts.[ch] + * plug-ins/script-fu/script-fu.c + * plug-ins/script-fu/siod-wrapper.c + * tools/pdbgen/enumcode.pl: changed #includes accordingly. + + * plug-ins/script-fu/script-fu-constants.c: regenerated. + + * plug-ins/script-fu/script-fu-scripts.c (script_fu_error_msg): + use siod-wrapper.c siod_get_error_msg() instead of accessing + siod's global siod_err_msg variable directly. + 2003-11-26 Sven Neumann * libgimpthumb/Makefile.am diff --git a/configure.in b/configure.in index 81479c010b..166aab79cb 100644 --- a/configure.in +++ b/configure.in @@ -1400,6 +1400,7 @@ plug-ins/libgck/Makefile plug-ins/libgck/gck/Makefile plug-ins/dbbrowser/Makefile plug-ins/script-fu/Makefile +plug-ins/script-fu/siod/Makefile plug-ins/script-fu/scripts/Makefile plug-ins/script-fu/scripts/images/Makefile plug-ins/xjt/Makefile diff --git a/plug-ins/script-fu/Makefile.am b/plug-ins/script-fu/Makefile.am index fda47f4473..5c008cc82d 100644 --- a/plug-ins/script-fu/Makefile.am +++ b/plug-ins/script-fu/Makefile.am @@ -6,17 +6,13 @@ endif AM_LDFLAGS = $(mwindows) -SUBDIRS = scripts +SUBDIRS = siod scripts libexecdir = $(gimpplugindir)/plug-ins libexec_PROGRAMS = script-fu script_fu_SOURCES = \ - interp_regex.c \ - interp_slib.c \ - interp_sliba.c \ - interp_trace.c \ script-fu.c \ script-fu-console.c \ script-fu-console.h \ @@ -30,8 +26,6 @@ script_fu_SOURCES = \ script-fu-server.c \ script-fu-server.h \ script-fu-enums.h \ - siod.h \ - siodp.h \ siod-wrapper.c \ siod-wrapper.h @@ -53,6 +47,7 @@ LDADD = \ $(top_builddir)/libgimp/libgimp-$(LT_RELEASE).la \ $(top_builddir)/libgimpcolor/libgimpcolor-$(LT_RELEASE).la \ $(top_builddir)/libgimpbase/libgimpbase-$(LT_RELEASE).la \ + siod/libsiod.a \ $(GTK_LIBS) \ $(SOCKET_LIBS) \ $(INTLLIBS) \ diff --git a/plug-ins/script-fu/interp_regex.c b/plug-ins/script-fu/interp_regex.c deleted file mode 100644 index e89027c142..0000000000 --- a/plug-ins/script-fu/interp_regex.c +++ /dev/null @@ -1,190 +0,0 @@ -#include "config.h" - -#include -#include -#include -#include - -#ifndef HAVE_GLIBC_REGEX -#include "regexrepl/regex.h" -#else -#include -#endif - -#include "siod.h" - -/* OSF/1 doc says that POSIX and XPG4 include regcomp in libc. - So we might as well set ourselves up to take advantage of it. - This functionality is also available in hpux, and is also provided - by the FSF's librx package, so if you can use that if your - operating system vendor doesn't supply it. - */ - -static void -init_regex_version (void) -{ - setvar (cintern ("*regex-version*"), - cintern ("$Id$"), - NIL); -} - -long tc_regex = 0; - -struct tc_regex - { - int compflag; - size_t nmatch; - regex_t *r; - regmatch_t *m; - }; - -struct tc_regex * -get_tc_regex (LISP ptr) -{ - if NTYPEP - (ptr, tc_regex) my_err ("not a regular expression", ptr); - return ((struct tc_regex *) ptr->storage_as.string.data); -} - -LISP -regcomp_l (LISP pattern, LISP flags) -{ - long iflag, iflags; - char *str, errbuff[1024]; - int error; - LISP result; - struct tc_regex *h; - iflags = NNULLP (flags) ? get_c_long (flags) : 0; - str = get_c_string (pattern); - iflag = no_interrupt (1); - result = cons (NIL, NIL); - h = (struct tc_regex *) must_malloc (sizeof (struct tc_regex)); - h->compflag = 0; - h->nmatch = 0; - h->r = NULL; - h->m = NULL; - result->type = tc_regex; - result->storage_as.string.data = (char *) h; - h->r = (regex_t *) must_malloc (sizeof (regex_t)); - if ((error = regcomp (h->r, str, iflags))) - { - regerror (error, h->r, errbuff, sizeof (errbuff)); - return (my_err (errbuff, pattern)); - } - h->compflag = 1; - if (iflags & REG_NOSUB) - { - no_interrupt (iflag); - return (result); - } - h->nmatch = h->r->re_nsub + 1; - h->m = (regmatch_t *) must_malloc (sizeof (regmatch_t) * h->nmatch); - no_interrupt (iflag); - return (result); -} - -LISP -regerror_l (LISP code, LISP ptr) -{ - char errbuff[1024]; - regerror (get_c_long (code), get_tc_regex (ptr)->r, errbuff, sizeof (errbuff)); - return (strcons (strlen (errbuff), errbuff)); -} - -LISP -regexec_l (LISP ptr, LISP str, LISP eflags) -{ - size_t j; - int error; - LISP result; - struct tc_regex *h; - h = get_tc_regex (ptr); - if ((error = regexec (h->r, - get_c_string (str), - h->nmatch, - h->m, - NNULLP (eflags) ? get_c_long (eflags) : 0))) - return (flocons (error)); - for (j = 0, result = NIL; j < h->nmatch; ++j) - result = cons (cons (flocons (h->m[j].rm_so), - flocons (h->m[j].rm_eo)), - result); - return (nreverse (result)); -} - -void -regex_gc_free (LISP ptr) -{ - struct tc_regex *h; - if ((h = (struct tc_regex *) ptr->storage_as.string.data)) - { - if ((h->compflag) && h->r) - regfree (h->r); - if (h->r) - { - free (h->r); - h->r = NULL; - } - if (h->m) - { - free (h->m); - h->m = NULL; - } - free (h); - ptr->storage_as.string.data = NULL; - } -} - -void -regex_prin1 (LISP ptr, struct gen_printio *f) -{ - char buffer[256]; - regex_t *p; - p = get_tc_regex (ptr)->r; - sprintf (buffer, "#re_nsub); - gput_st (f, buffer); - gput_st (f, ">"); -} - -void -init_regex (void) -{ - long j; - tc_regex = allocate_user_tc (); - set_gc_hooks (tc_regex, - NULL, - NULL, - NULL, - regex_gc_free, - &j); - set_print_hooks (tc_regex, regex_prin1); - init_subr_2 ("regcomp", regcomp_l); - init_subr_2 ("regerror", regerror_l); - init_subr_3 ("regexec", regexec_l); - setvar (cintern ("REG_EXTENDED"), flocons (REG_EXTENDED), NIL); - setvar (cintern ("REG_ICASE"), flocons (REG_ICASE), NIL); - setvar (cintern ("REG_NOSUB"), flocons (REG_NOSUB), NIL); - setvar (cintern ("REG_NEWLINE"), flocons (REG_NEWLINE), NIL); - - setvar (cintern ("REG_NOTBOL"), flocons (REG_NOTBOL), NIL); - setvar (cintern ("REG_NOTEOL"), flocons (REG_NOTEOL), NIL); - - setvar (cintern ("REG_NOMATCH"), flocons (REG_NOMATCH), NIL); - setvar (cintern ("REG_BADPAT"), flocons (REG_BADPAT), NIL); - setvar (cintern ("REG_ECOLLATE"), flocons (REG_ECOLLATE), NIL); - setvar (cintern ("REG_ECTYPE"), flocons (REG_ECTYPE), NIL); - setvar (cintern ("REG_EESCAPE"), flocons (REG_EESCAPE), NIL); - setvar (cintern ("REG_ESUBREG"), flocons (REG_ESUBREG), NIL); - setvar (cintern ("REG_EBRACK"), flocons (REG_EBRACK), NIL); - setvar (cintern ("REG_EPAREN"), flocons (REG_EPAREN), NIL); - setvar (cintern ("REG_EBRACE"), flocons (REG_EBRACE), NIL); - setvar (cintern ("REG_BADBR"), flocons (REG_BADBR), NIL); - setvar (cintern ("REG_ERANGE"), flocons (REG_ERANGE), NIL); - setvar (cintern ("REG_ESPACE"), flocons (REG_ESPACE), NIL); - setvar (cintern ("REG_BADRPT"), flocons (REG_BADRPT), NIL); -#ifdef REG_ECHAR - setvar (cintern ("REG_ECHAR"), flocons (REG_ECHAR), NIL); -#endif - init_regex_version (); -} diff --git a/plug-ins/script-fu/interp_slib.c b/plug-ins/script-fu/interp_slib.c deleted file mode 100644 index 14a29840fb..0000000000 --- a/plug-ins/script-fu/interp_slib.c +++ /dev/null @@ -1,3742 +0,0 @@ -/* Scheme In One Defun, but in C this time. - - * COPYRIGHT (c) 1988-1994 BY * - * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * - * ALL RIGHTS RESERVED * - - Permission to use, copy, modify, distribute and sell this software - and its documentation for any purpose and without fee is hereby - granted, provided that the above copyright notice appear in all copies - and that both that copyright notice and this permission notice appear - in supporting documentation, and that the name of Paradigm Associates - Inc not be used in advertising or publicity pertaining to distribution - of the software without specific, written prior permission. - - PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING - ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL - PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR - ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, - WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, - ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS - SOFTWARE. - - */ - -/* - - gjc@world.std.com - - Paradigm Associates Inc Phone: 617-492-6079 - 29 Putnam Ave, Suite 6 - Cambridge, MA 02138 - - - Release 1.0: 24-APR-88 - Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by - Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer, - cleaned up uses of NULL/0. Now distributed with siod.scm. - Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU, - plus some bug fixes. - Release 1.3: 1-MAY-88, changed env to use frames instead of alist. - define now works properly. vms specific function edit. - Release 1.4 20-NOV-89. Minor Cleanup and remodularization. - Now in 3 files, siod.h, slib.c, siod.c. Makes it easier to write your - own main loops. Some short-int changes for lightspeed C included. - Release 1.5 29-NOV-89. Added startup flag -g, select stop and copy - or mark-and-sweep garbage collection, which assumes that the stack/register - marking code is correct for your architecture. - Release 2.0 1-DEC-89. Added repl_hooks, Catch, Throw. This is significantly - different enough (from 1.3) now that I'm calling it a major release. - Release 2.1 4-DEC-89. Small reader features, dot, backquote, comma. - Release 2.2 5-DEC-89. gc,read,print,eval, hooks for user defined datatypes. - Release 2.3 6-DEC-89. save_forms, obarray intern mechanism. comment char. - Release 2.3a......... minor speed-ups. i/o interrupt considerations. - Release 2.4 27-APR-90 gen_readr, for read-from-string. - Release 2.5 18-SEP-90 arrays added to SIOD.C by popular demand. inums. - Release 2.6 11-MAR-92 function prototypes, some remodularization. - Release 2.7 20-MAR-92 hash tables, fasload. Stack check. - Release 2.8 3-APR-92 Bug fixes, \n syntax in string reading. - Release 2.9 28-AUG-92 gc sweep bug fix. fseek, ftell, etc. Change to - envlookup to allow (a . rest) suggested by bowles@is.s.u-tokyo.ac.jp. - Release 2.9a 10-AUG-93. Minor changes for Windows NT. - Release 3.0 1-MAY-94. Release it, include changes/cleanup recommended by - andreasg@nynexst.com for the OS2 C++ compiler. Compilation and running - tested using DEC C, VAX C. WINDOWS NT. GNU C on SPARC. Storage - management improvements, more string functions. SQL support. - Release 3.1? -JUN-95 verbose flag, other integration improvements for htqs.c - hpux by denson@sdd.hp.com, solaris by pgw9@columbia.edu. - Release 3.2X MAR-96. dynamic linking, subr closures, other improvements. - */ - -#include "config.h" - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#if HAVE_SYS_TIMES_H -#include -#endif - -#include - -#ifdef G_OS_WIN32 -#define STRICT -#include -#endif - -#include "siod.h" -#include "siodp.h" - -#define MAX_ERROR 1024 -char siod_err_msg[MAX_ERROR]; - -static void -init_slib_version (void) -{ - setvar (cintern ("*slib-version*"), - cintern ("$Id$"), - NIL); -} - -char * -siod_version (void) -{ - return ("3.2x 12-MAR-96"); -} - -long nheaps = 2; -LISP *heaps; -LISP heap, heap_end, heap_org; -long heap_size = 5000; -long old_heap_used; -long gc_status_flag = 1; -char *init_file = (char *) NULL; -char *tkbuffer = NULL; -long gc_kind_copying = 0; -long gc_cells_allocated = 0; -double gc_time_taken; -LISP *stack_start_ptr = NULL; -LISP freelist; -jmp_buf errjmp; -long errjmp_ok = 0; -long nointerrupt = 1; -long interrupt_differed = 0; -LISP oblistvar = NIL; -LISP sym_t = NIL; -LISP eof_val = NIL; -LISP sym_errobj = NIL; -LISP sym_catchall = NIL; -LISP sym_progn = NIL; -LISP sym_lambda = NIL; -LISP sym_quote = NIL; -LISP sym_dot = NIL; -LISP sym_after_gc = NIL; -LISP sym_eval_history_ptr = NIL; -LISP unbound_marker = NIL; -LISP *obarray; -LISP repl_return_val = NIL; -long obarray_dim = 100; -struct catch_frame *catch_framep = (struct catch_frame *) NULL; -void (*repl_puts) (char *) = NULL; -LISP (*repl_read) (void) = NULL; -LISP (*repl_eval) (LISP) = NULL; -void (*repl_print) (LISP) = NULL; -LISP *inums; -long inums_dim = 256; -struct user_type_hooks *user_types = NULL; -long user_tc_next = tc_user_min; -struct gc_protected *protected_registers = NULL; -jmp_buf save_regs_gc_mark; -double gc_rt; -long gc_cells_collected; -char *user_ch_readm = ""; -char *user_te_readm = ""; -LISP (*user_readm) (int, struct gen_readio *) = NULL; -LISP (*user_readt) (char *, long, int *) = NULL; -void (*fatal_exit_hook) (void) = NULL; -#ifdef THINK_C -int ipoll_counter = 0; -#endif - -char *stack_limit_ptr = NULL; -long stack_size = -#ifdef THINK_C -10000; -#else -50000; -#endif - -long siod_verbose_level = 4; - -#ifndef SIOD_LIB_DEFAULT -#define SIOD_LIB_DEFAULT "/usr/local/lib/siod" -#endif - -/* Added by Spencer Kimball for script-fu shit 6/3/97 */ -FILE *siod_output; - -char *siod_lib = SIOD_LIB_DEFAULT; - -void -process_cla (int argc, char **argv, int warnflag) -{ - int k; - char *ptr; - static int siod_lib_set = 0; -#if !defined(vms) - if (!siod_lib_set) - { - if (getenv ("SIOD_LIB")) - { - siod_lib = getenv ("SIOD_LIB"); - siod_lib_set = 1; - } - } -#endif - for (k = 1; k < argc; ++k) - { - if (strlen (argv[k]) < 2) - continue; - if (argv[k][0] != '-') - { - if (warnflag) - fprintf (stderr, "bad arg: %s\n", argv[k]); - continue; - } - switch (argv[k][1]) - { - case 'l': - siod_lib = &argv[k][2]; - break; - case 'h': - heap_size = atol (&(argv[k][2])); - if ((ptr = strchr (&(argv[k][2]), ':'))) - nheaps = atol (&ptr[1]); - break; - case 'o': - obarray_dim = atol (&(argv[k][2])); - break; - case 'i': - init_file = &(argv[k][2]); - break; - case 'n': - inums_dim = atol (&(argv[k][2])); - break; - case 'g': - gc_kind_copying = atol (&(argv[k][2])); - break; - case 's': - stack_size = atol (&(argv[k][2])); - break; - case 'v': - siod_verbose_level = atol (&(argv[k][2])); - break; - default: - if (warnflag) - fprintf (stderr, "bad arg: %s\n", argv[k]); - } - } -} - -void -print_welcome (void) -{ - if (siod_verbose_level >= 2) - { - fprintf (siod_output, "Welcome to SIOD, Scheme In One Defun, Version %s\n", - siod_version ()); - fprintf (siod_output, "(C) Copyright 1988-1994 Paradigm Associates Inc. Help: (help)\n\n"); - fflush (siod_output); - } -} - -void -print_hs_1 (void) -{ - if (siod_verbose_level >= 2) - { - fprintf (siod_output, "%ld heaps. size = %ld cells, %ld bytes. %ld inums. GC is %s\n", - nheaps, - heap_size, heap_size * sizeof (struct obj), - inums_dim, - (gc_kind_copying == 1) ? "stop and copy" : "mark and sweep"); - fflush (siod_output); - } -} - -void -print_hs_2 (void) -{ - if (siod_verbose_level >= 2) - { - if (gc_kind_copying == 1) - fprintf (siod_output, "heaps[0] at %p, heaps[1] at %p\n", heaps[0], heaps[1]); - else - fprintf (siod_output, "heaps[0] at %p\n", heaps[0]); - fflush (siod_output); - } -} - -long -no_interrupt (long n) -{ - long x; - x = nointerrupt; - nointerrupt = n; - if ((nointerrupt == 0) && (interrupt_differed == 1)) - { - interrupt_differed = 0; - err_ctrl_c (); - } - return (x); -} - -void -handle_sigfpe (int sig SIG_restargs) -{ - signal (SIGFPE, handle_sigfpe); - my_err ("floating point exception", NIL); -} - -void -handle_sigint (int sig SIG_restargs) -{ - signal (SIGINT, handle_sigint); - if (nointerrupt == 1) - interrupt_differed = 1; - else - err_ctrl_c (); -} - -void -err_ctrl_c (void) -{ - my_err ("control-c interrupt", NIL); -} - -LISP -get_eof_val (void) -{ - return (eof_val); -} - -long -repl_driver (long want_sigint, long want_init, struct repl_hooks *h) -{ - int k; - struct repl_hooks hd; - LISP stack_start; - stack_start_ptr = &stack_start; - stack_limit_ptr = STACK_LIMIT (stack_start_ptr, stack_size); - k = setjmp (errjmp); - if (k == 2) - return (2); - if (want_sigint) - signal (SIGINT, handle_sigint); - signal (SIGFPE, handle_sigfpe); - catch_framep = (struct catch_frame *) NULL; - errjmp_ok = 1; - interrupt_differed = 0; - nointerrupt = 0; - if (want_init && init_file && (k == 0)) - vload (init_file, 0, 1); - if (!h) - { - hd.repl_puts = repl_puts; - hd.repl_read = repl_read; - hd.repl_eval = repl_eval; - hd.repl_print = repl_print; - return (repl (&hd)); - } - else - return (repl (h)); -} - -static void -ignore_puts (char *st) -{ -} - -static void -noprompt_puts (char *st) -{ - if (strcmp (st, "> ") != 0) - put_st (st); -} - -static char *repl_c_string_arg = NULL; -static long repl_c_string_flag = 0; - -static LISP -repl_c_string_read (void) -{ - LISP s; - if (repl_c_string_arg == NULL) - return (get_eof_val ()); - s = strcons (strlen (repl_c_string_arg), repl_c_string_arg); - repl_c_string_arg = NULL; - return (read_from_string (s)); -} - -static void -ignore_print (LISP x) -{ - repl_c_string_flag = 1; -} - -static void -not_ignore_print (LISP x) -{ - repl_c_string_flag = 1; - lprint (x, NIL); -} - -long -repl_c_string (char *str, - long want_sigint, long want_init, long want_print) -{ - struct repl_hooks h; - long retval; - if (want_print) - h.repl_puts = noprompt_puts; - else - h.repl_puts = ignore_puts; - h.repl_read = repl_c_string_read; - h.repl_eval = NULL; - if (want_print) - h.repl_print = not_ignore_print; - else - h.repl_print = ignore_print; - repl_c_string_arg = str; - repl_c_string_flag = 0; - retval = repl_driver (want_sigint, want_init, &h); - if (retval != 0) - return (retval); - else if (repl_c_string_flag == 1) - return (0); - else - return (2); -} - -double -myruntime (void) -{ -#if HAVE_SYS_TIMES_H - double total; - struct tms b; - times (&b); - total = b.tms_utime; - total += b.tms_stime; - return (total / 60.0); -#elif defined (G_OS_WIN32) - FILETIME creation, exit, kernel, user; - GetProcessTimes (GetCurrentProcess (), &creation, &exit, &kernel, &user); - return (kernel.dwLowDateTime * 1e7 + user.dwLowDateTime * 1e7); -#endif -} - -#if defined(__osf__) -#include -#ifndef TIMEOFDAY -#define TIMEOFDAY 1 -#endif -double -myrealtime (void) -{ - struct timespec x; - if (!getclock (TIMEOFDAY, &x)) - return (x.tv_sec + (((double) x.tv_nsec) * 1.0e-9)); - else - return (0.0); -} -#endif - -#if defined(VMS) -#include -#include - -double -myrealtime (void) -{ - unsigned long x[2]; - static double c = 0.0; - if (sys$gettim (&x) == SS$_NORMAL) - { - if (c == 0.0) - c = pow ((double) 2, (double) 31) * 100.0e-9; - return (x[0] * 100.0e-9 + x[1] * c); - } - else - return (0.0); -} - -#endif - -#if !defined(__osf__) & !defined(VMS) -double -myrealtime (void) -{ - time_t x; - time (&x); - return ((double) x); -} -#endif - -void -set_repl_hooks (void (*puts_f) (char *), - LISP (*read_f) (void), - LISP (*eval_f) (LISP), - void (*print_f) (LISP)) -{ - repl_puts = puts_f; - repl_read = read_f; - repl_eval = eval_f; - repl_print = print_f; -} - -void -gput_st (struct gen_printio *f, char *st) -{ - PUTS_FCN (st, f); -} - -void -fput_st (FILE * f, char *st) -{ - long flag; - flag = no_interrupt (1); - if (siod_verbose_level >= 1) - { - fprintf (f, "%s", st); - fflush (siod_output); - } - no_interrupt (flag); -} - -int -fputs_fcn (char *st, void *cb) -{ - fput_st ((FILE *) cb, st); - return (1); -} - -void -put_st (char *st) -{ - fput_st (siod_output, st); - fflush (siod_output); -} - -void -grepl_puts (char *st, void (*repl_puts) (char *)) -{ - if (repl_puts == NULL) - put_st (st); - else - (*repl_puts) (st); -} - -long -repl (struct repl_hooks *h) -{ - LISP x, cw = 0; - double rt, ct; - while (1) - { - if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end)) - { - rt = myruntime (); - gc_stop_and_copy (); - if (siod_verbose_level >= 2) - { - sprintf (tkbuffer, - "GC took %g seconds, %ld compressed to %d, %d free\n", - myruntime () - rt, old_heap_used, (int)(heap - heap_org), (int)(heap_end - heap)); - grepl_puts (tkbuffer, h->repl_puts); - } - } - if (siod_verbose_level >= 2) - grepl_puts ("> ", h->repl_puts); - if (h->repl_read == NULL) - x = lread (NIL); - else - x = (*h->repl_read) (); - if EQ - (x, eof_val) break; - - rt = myruntime (); - ct = myrealtime (); - if (gc_kind_copying == 1) - cw = heap; - else - { - gc_cells_allocated = 0; - gc_time_taken = 0.0; - } - if (h->repl_eval == NULL) - repl_return_val = x = leval (x, NIL); - else - repl_return_val = x = (*h->repl_eval) (x); - if (gc_kind_copying == 1) - sprintf (tkbuffer, - "Evaluation took %g seconds %d cons work, %g real.\n", - myruntime () - rt, - (int)(heap - cw), - myrealtime () - ct); - else - sprintf (tkbuffer, - "Evaluation took %g seconds (%g in gc) %ld cons work, %g real.\n", - myruntime () - rt, - gc_time_taken, - gc_cells_allocated, - myrealtime () - ct); - if (siod_verbose_level >= 3) - grepl_puts (tkbuffer, h->repl_puts); - if (h->repl_print == NULL) - { - if (siod_verbose_level >= 2) - lprint (x, NIL); - } - else - (*h->repl_print) (x); - } - - return (0); -} - -void -set_fatal_exit_hook (void (*fcn) (void)) -{ - fatal_exit_hook = fcn; -} - -static long inside_err = 0; - -LISP -my_err (char *message, LISP x) -{ - struct catch_frame *l; - long was_inside = inside_err; - LISP retval, nx; - char *msg, *eobj; - nointerrupt = 1; - if ((!message) && CONSP (x) && TYPEP (CAR (x), tc_string)) - { - msg = get_c_string (CAR (x)); - nx = CDR (x); - retval = x; - } - else - { - msg = message; - nx = x; - retval = NIL; - } - if ((eobj = try_get_c_string (nx)) && !memchr (eobj, 0, 30)) - eobj = NULL; - - if NULLP - (nx) - sprintf (siod_err_msg, "ERROR: %s\n", msg); - else if (eobj) - sprintf (siod_err_msg, "ERROR: %s (errobj %s)\n", msg, eobj); - else - sprintf (siod_err_msg, "ERROR: %s (see errobj)\n", msg); - - if ((siod_verbose_level >= 1) && msg) - { - fprintf (siod_output, "%s\n", siod_err_msg); - fflush (siod_output); - } - if (errjmp_ok == 1) - { - inside_err = 1; - setvar (sym_errobj, nx, NIL); - for (l = catch_framep; l; l = (*l).next) - if (EQ ((*l).tag, sym_errobj) || - EQ ((*l).tag, sym_catchall)) - { - if (!msg) - msg = "quit"; - (*l).retval = (NNULLP (retval) ? retval : - (was_inside) ? NIL : - cons (strcons (strlen (msg), msg), nx)); - nointerrupt = 0; - inside_err = 0; - longjmp ((*l).cframe, 2); - } - inside_err = 0; - longjmp (errjmp, (msg) ? 1 : 2); - } - if (siod_verbose_level >= 1) - { - fprintf (stderr, "FATAL ERROR DURING STARTUP OR CRITICAL CODE SECTION\n"); - fflush (stderr); - } - if (fatal_exit_hook) - (*fatal_exit_hook) (); - else - exit (1); - return (NIL); -} - -LISP -errswitch (void) -{ - return (my_err ("BUG. Reached impossible case", NIL)); -} - -void -err_stack (char *ptr) - /* The user could be given an option to continue here */ -{ - my_err ("the currently assigned stack limit has been exceeded", NIL); -} - -LISP -stack_limit (LISP amount, LISP silent) -{ - if NNULLP - (amount) - { - stack_size = get_c_long (amount); - stack_limit_ptr = STACK_LIMIT (stack_start_ptr, stack_size); - } - if NULLP - (silent) - { - sprintf (tkbuffer, "Stack_size = %ld bytes, [%p,%p]\n", - stack_size, stack_start_ptr, stack_limit_ptr); - put_st (tkbuffer); - return (NIL); - } - else - return (flocons (stack_size)); -} - -char * -try_get_c_string (LISP x) -{ - if TYPEP - (x, tc_symbol) - return (PNAME (x)); - else if TYPEP - (x, tc_string) - return (x->storage_as.string.data); - else - return (NULL); -} - -char * -get_c_string (LISP x) -{ - if TYPEP - (x, tc_symbol) - return (PNAME (x)); - else if TYPEP - (x, tc_string) - return (x->storage_as.string.data); - else - my_err ("not a symbol or string", x); - return (NULL); -} - -char * -get_c_string_dim (LISP x, long *len) -{ - switch (TYPE (x)) - { - case tc_symbol: - *len = strlen (PNAME (x)); - return (PNAME (x)); - case tc_string: - case tc_byte_array: - *len = x->storage_as.string.dim; - return (x->storage_as.string.data); - case tc_long_array: - *len = x->storage_as.long_array.dim * sizeof (long); - return ((char *) x->storage_as.long_array.data); - default: - my_err ("not a symbol or string", x); - return (NULL); - } -} - -LISP -lerr (LISP message, LISP x) -{ - if (CONSP (message) && TYPEP (CAR (message), tc_string)) - my_err (NULL, message); - else - my_err (get_c_string (message), x); - return (NIL); -} - -void -gc_fatal_error (void) -{ - my_err ("ran out of storage", NIL); -} - -LISP -newcell (long type) -{ - LISP z; - NEWCELL (z, type); - return (z); -} - -LISP -cons (LISP x, LISP y) -{ - LISP z; - NEWCELL (z, tc_cons); - CAR (z) = x; - CDR (z) = y; - return (z); -} - -LISP -consp (LISP x) -{ - if CONSP - (x) return (sym_t); - else - return (NIL); -} - -LISP -car (LISP x) -{ - switch TYPE - (x) - { - case tc_nil: - return (NIL); - case tc_cons: - return (CAR (x)); - default: - return (my_err ("wta to car", x)); - } -} - -LISP -cdr (LISP x) -{ - switch TYPE - (x) - { - case tc_nil: - return (NIL); - case tc_cons: - return (CDR (x)); - default: - return (my_err ("wta to cdr", x)); - } -} - -LISP -setcar (LISP cell, LISP value) -{ - if NCONSP - (cell) my_err ("wta to setcar", cell); - return (CAR (cell) = value); -} - -LISP -setcdr (LISP cell, LISP value) -{ - if NCONSP - (cell) my_err ("wta to setcdr", cell); - return (CDR (cell) = value); -} - -LISP -flocons (double x) -{ - LISP z; - long n; - if ((inums_dim > 0) && - ((x - (n = (long) x)) == 0) && - (x >= 0) && - (n < inums_dim)) - return (inums[n]); - NEWCELL (z, tc_flonum); - FLONM (z) = x; - return (z); -} - -LISP -numberp (LISP x) -{ - if FLONUMP - (x) return (sym_t); - else - return (NIL); -} - -LISP -plus (LISP x, LISP y) -{ - if NULLP - (y) - return (NULLP (x) ? flocons (0) : x); - if NFLONUMP - (x) my_err ("wta(1st) to plus", x); - if NFLONUMP - (y) my_err ("wta(2nd) to plus", y); - return (flocons (FLONM (x) + FLONM (y))); -} - -LISP -ltimes (LISP x, LISP y) -{ - if NULLP - (y) - return (NULLP (x) ? flocons (1) : x); - if NFLONUMP - (x) my_err ("wta(1st) to times", x); - if NFLONUMP - (y) my_err ("wta(2nd) to times", y); - return (flocons (FLONM (x) * FLONM (y))); -} - -LISP -difference (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to difference", x); - if NULLP - (y) - return (flocons (-FLONM (x))); - else - { - if NFLONUMP - (y) my_err ("wta(2nd) to difference", y); - return (flocons (FLONM (x) - FLONM (y))); - } -} - -LISP -Quotient (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to quotient", x); - if NULLP - (y) - return (flocons (1 / FLONM (x))); - else - { - if NFLONUMP - (y) my_err ("wta(2nd) to quotient", y); - return (flocons (FLONM (x) / FLONM (y))); - } -} - -LISP -lllabs (LISP x) -{ - double v; - if NFLONUMP - (x) my_err ("wta to abs", x); - v = FLONM (x); - if (v < 0) - return (flocons (-v)); - else - return (x); -} - -LISP -lsqrt (LISP x) -{ - if NFLONUMP - (x) my_err ("wta to sqrt", x); - return (flocons (sqrt (FLONM (x)))); -} - -LISP -greaterp (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to greaterp", x); - if NFLONUMP - (y) my_err ("wta(2nd) to greaterp", y); - if (FLONM (x) > FLONM (y)) - return (sym_t); - return (NIL); -} - -LISP -lessp (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to lessp", x); - if NFLONUMP - (y) my_err ("wta(2nd) to lessp", y); - if (FLONM (x) < FLONM (y)) - return (sym_t); - return (NIL); -} - -LISP -greaterEp (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to greaterp", x); - if NFLONUMP - (y) my_err ("wta(2nd) to greaterp", y); - if (FLONM (x) >= FLONM (y)) - return (sym_t); - return (NIL); -} - -LISP -lessEp (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to lessp", x); - if NFLONUMP - (y) my_err ("wta(2nd) to lessp", y); - if (FLONM (x) <= FLONM (y)) - return (sym_t); - return (NIL); -} - -LISP -lmax (LISP x, LISP y) -{ - if NULLP - (y) return (x); - if NFLONUMP - (x) my_err ("wta(1st) to max", x); - if NFLONUMP - (y) my_err ("wta(2nd) to max", y); - return ((FLONM (x) > FLONM (y)) ? x : y); -} - -LISP -lmin (LISP x, LISP y) -{ - if NULLP - (y) return (x); - if NFLONUMP - (x) my_err ("wta(1st) to min", x); - if NFLONUMP - (y) my_err ("wta(2nd) to min", y); - return ((FLONM (x) < FLONM (y)) ? x : y); -} - -LISP -eq (LISP x, LISP y) -{ - if EQ - (x, y) return (sym_t); - else - return (NIL); -} - -LISP -eql (LISP x, LISP y) -{ - if EQ - (x, y) return (sym_t); - else if NFLONUMP - (x) return (NIL); - else if NFLONUMP - (y) return (NIL); - else if (FLONM (x) == FLONM (y)) - return (sym_t); - return (NIL); -} - -LISP -symcons (char *pname, LISP vcell) -{ - LISP z; - NEWCELL (z, tc_symbol); - PNAME (z) = pname; - VCELL (z) = vcell; - return (z); -} - -LISP -symbolp (LISP x) -{ - if SYMBOLP - (x) return (sym_t); - else - return (NIL); -} - -LISP -err_ubv (LISP v) -{ - return (my_err ("unbound variable", v)); -} - -LISP -symbol_boundp (LISP x, LISP env) -{ - LISP tmp; - if NSYMBOLP - (x) my_err ("not a symbol", x); - tmp = envlookup (x, env); - if NNULLP - (tmp) return (sym_t); - if EQ - (VCELL (x), unbound_marker) return (NIL); - else - return (sym_t); -} - -LISP -symbol_value (LISP x, LISP env) -{ - LISP tmp; - if NSYMBOLP - (x) my_err ("not a symbol", x); - tmp = envlookup (x, env); - if NNULLP - (tmp) return (CAR (tmp)); - tmp = VCELL (x); - if EQ - (tmp, unbound_marker) err_ubv (x); - return (tmp); -} - - - -char * -must_malloc (unsigned long size) -{ - char *tmp; - tmp = (char *) malloc ((size) ? size : 1); - if (tmp == (char *) NULL) - my_err ("failed to allocate storage from system", NIL); - return (tmp); -} - -LISP -gen_intern (char *name, long copyp) -{ - LISP l, sym, sl; - char *cname; - long hash = 0, n, c, flag; - flag = no_interrupt (1); - if (obarray_dim > 1) - { - hash = 0; - n = obarray_dim; - cname = name; - while ((c = *cname++)) - hash = ((hash * 17) ^ c) % n; - sl = obarray[hash]; - } - else - sl = oblistvar; - for (l = sl; NNULLP (l); l = CDR (l)) - if (strcmp (name, PNAME (CAR (l))) == 0) - { - no_interrupt (flag); - return (CAR (l)); - } - if (copyp == 1) - { - cname = (char *) must_malloc (strlen (name) + 1); - strcpy (cname, name); - } - else - cname = name; - sym = symcons (cname, unbound_marker); - if (obarray_dim > 1) - obarray[hash] = cons (sym, sl); - oblistvar = cons (sym, oblistvar); - no_interrupt (flag); - return (sym); -} - -LISP -cintern (char *name) -{ - return (gen_intern (name, 0)); -} - -LISP -rintern (char *name) -{ - return (gen_intern (name, 1)); -} - -LISP -intern (LISP name) -{ - return (rintern (get_c_string (name))); -} - -LISP -subrcons (long type, char *name, SUBR_FUNC f) -{ - LISP z; - NEWCELL (z, type); - (*z).storage_as.subr.name = name; - (*z).storage_as.subr0.f = f; - return (z); -} - -LISP -closure (LISP env, LISP code) -{ - LISP z; - NEWCELL (z, tc_closure); - (*z).storage_as.closure.env = env; - (*z).storage_as.closure.code = code; - return (z); -} - -void -gc_protect (LISP * location) -{ - gc_protect_n (location, 1); -} - -void -gc_protect_n (LISP * location, long n) -{ - struct gc_protected *reg; - reg = (struct gc_protected *) must_malloc (sizeof (struct gc_protected)); - (*reg).location = location; - (*reg).length = n; - (*reg).next = protected_registers; - protected_registers = reg; -} - -void -gc_protect_sym (LISP * location, char *st) -{ - *location = cintern (st); - gc_protect (location); -} - -void -gc_unprotect (LISP * location) -{ - struct gc_protected *reg; - struct gc_protected *prev_reg; - - prev_reg = NULL; - reg = protected_registers; - - while (reg) - { - if (location == reg->location) - { - if (prev_reg) - prev_reg->next = reg->next; - if (reg == protected_registers) - protected_registers = protected_registers->next; - - free (reg); - break; - } - - prev_reg = reg; - reg = reg->next; - } -} - -void -scan_registers (void) -{ - struct gc_protected *reg; - LISP *location; - long j, n; - - for (reg = protected_registers; reg; reg = (*reg).next) - { - location = (*reg).location; - n = (*reg).length; - for (j = 0; j < n; ++j) - location[j] = gc_relocate (location[j]); - } -} - -void -init_storage (void) -{ - long j; - LISP stack_start; - if (stack_start_ptr == NULL) - stack_start_ptr = &stack_start; - init_storage_1 (); - init_storage_a (); - set_gc_hooks (tc_c_file, 0, 0, 0, file_gc_free, &j); - set_print_hooks (tc_c_file, file_prin1); -} - -void -init_storage_1 (void) -{ - LISP ptr; - long j; - tkbuffer = (char *) must_malloc (TKBUFFERN + 1); - if (((gc_kind_copying == 1) && (nheaps != 2)) || (nheaps < 1)) - my_err ("invalid number of heaps", NIL); - heaps = (LISP *) must_malloc (sizeof (LISP) * nheaps); - for (j = 0; j < nheaps; ++j) - heaps[j] = NULL; - heaps[0] = (LISP) must_malloc (sizeof (struct obj) * heap_size); - heap = heaps[0]; - heap_org = heap; - heap_end = heap + heap_size; - if (gc_kind_copying == 1) - heaps[1] = (LISP) must_malloc (sizeof (struct obj) * heap_size); - else - freelist = NIL; - gc_protect (&oblistvar); - if (obarray_dim > 1) - { - obarray = (LISP *) must_malloc (sizeof (LISP) * obarray_dim); - for (j = 0; j < obarray_dim; ++j) - obarray[j] = NIL; - gc_protect_n (obarray, obarray_dim); - } - unbound_marker = cons (cintern ("**unbound-marker**"), NIL); - gc_protect (&unbound_marker); - eof_val = cons (cintern ("eof"), NIL); - gc_protect (&eof_val); - gc_protect_sym (&sym_t, "t"); - setvar (sym_t, sym_t, NIL); - setvar (cintern ("nil"), NIL, NIL); - setvar (cintern ("let"), cintern ("let-internal-macro"), NIL); - setvar (cintern ("let*"), cintern ("let*-macro"), NIL); - setvar (cintern ("letrec"), cintern ("letrec-macro"), NIL); - gc_protect_sym (&sym_errobj, "errobj"); - setvar (sym_errobj, NIL, NIL); - gc_protect_sym (&sym_catchall, "all"); - gc_protect_sym (&sym_progn, "begin"); - gc_protect_sym (&sym_lambda, "lambda"); - gc_protect_sym (&sym_quote, "quote"); - gc_protect_sym (&sym_dot, "."); - gc_protect_sym (&sym_after_gc, "*after-gc*"); - setvar (sym_after_gc, NIL, NIL); - gc_protect_sym (&sym_eval_history_ptr, "*eval-history-ptr*"); - setvar (sym_eval_history_ptr, NIL, NIL); - if (inums_dim > 0) - { - inums = (LISP *) must_malloc (sizeof (LISP) * inums_dim); - for (j = 0; j < inums_dim; ++j) - { - NEWCELL (ptr, tc_flonum); - FLONM (ptr) = j; - inums[j] = ptr; - } - gc_protect_n (inums, inums_dim); - } -} - -void -init_subr (char *name, long type, SUBR_FUNC fcn) -{ - setvar (cintern (name), subrcons (type, name, fcn), NIL); -} - -void -init_subr_0 (char *name, LISP (*fcn) (void)) -{ - init_subr (name, tc_subr_0, (SUBR_FUNC) fcn); -} - -void -init_subr_1 (char *name, LISP (*fcn) (LISP)) -{ - init_subr (name, tc_subr_1, (SUBR_FUNC) fcn); -} - -void -init_subr_2 (char *name, LISP (*fcn) (LISP, LISP)) -{ - init_subr (name, tc_subr_2, (SUBR_FUNC) fcn); -} - -void -init_subr_2n (char *name, LISP (*fcn) (LISP, LISP)) -{ - init_subr (name, tc_subr_2n, (SUBR_FUNC) fcn); -} - -void -init_subr_3 (char *name, LISP (*fcn) (LISP, LISP, LISP)) -{ - init_subr (name, tc_subr_3, (SUBR_FUNC) fcn); -} - -void -init_subr_4 (char *name, LISP (*fcn) (LISP, LISP, LISP, LISP)) -{ - init_subr (name, tc_subr_4, (SUBR_FUNC) fcn); -} - -void -init_subr_5 (char *name, LISP (*fcn) (LISP, LISP, LISP, LISP, LISP)) -{ - init_subr (name, tc_subr_5, (SUBR_FUNC) fcn); -} - -void -init_lsubr (char *name, LISP (*fcn) (LISP)) -{ - init_subr (name, tc_lsubr, (SUBR_FUNC) fcn); -} - -void -init_fsubr (char *name, LISP (*fcn) (LISP, LISP)) -{ - init_subr (name, tc_fsubr, (SUBR_FUNC) fcn); -} - -void -init_msubr (char *name, LISP (*fcn) (LISP *, LISP *)) -{ - init_subr (name, tc_msubr, (SUBR_FUNC) fcn); -} - -LISP -assq (LISP x, LISP alist) -{ - LISP l, tmp; - for (l = alist; CONSP (l); l = CDR (l)) - { - tmp = CAR (l); - if (CONSP (tmp) && EQ (CAR (tmp), x)) - return (tmp); - INTERRUPT_CHECK (); - } - if EQ - (l, NIL) return (NIL); - return (my_err ("improper list to assq", alist)); -} - - -struct user_type_hooks * -get_user_type_hooks (long type) -{ - long n; - if (user_types == NULL) - { - n = sizeof (struct user_type_hooks) * tc_table_dim; - user_types = (struct user_type_hooks *) must_malloc (n); - memset (user_types, 0, n); - } - if ((type >= 0) && (type < tc_table_dim)) - return (&user_types[type]); - else - my_err ("type number out of range", NIL); - return (NULL); -} - -long -allocate_user_tc (void) -{ - long x = user_tc_next; - if (x > tc_user_max) - my_err ("ran out of user type codes", NIL); - ++user_tc_next; - return (x); -} - -void -set_gc_hooks (long type, - LISP (*rel) (LISP), - LISP (*mark) (LISP), - void (*scan) (LISP), - void (*free) (LISP), - long *kind) -{ - struct user_type_hooks *p; - p = get_user_type_hooks (type); - p->gc_relocate = rel; - p->gc_scan = scan; - p->gc_mark = mark; - p->gc_free = free; - *kind = gc_kind_copying; -} - -LISP -gc_relocate (LISP x) -{ - LISP nw; - struct user_type_hooks *p; - if EQ - (x, NIL) return (NIL); - if ((*x).gc_mark == 1) - return (CAR (x)); - switch TYPE - (x) - { - case tc_flonum: - case tc_cons: - case tc_symbol: - case tc_closure: - case tc_subr_0: - case tc_subr_1: - case tc_subr_2: - case tc_subr_2n: - case tc_subr_3: - case tc_subr_4: - case tc_subr_5: - case tc_lsubr: - case tc_fsubr: - case tc_msubr: - if ((nw = heap) >= heap_end) - gc_fatal_error (); - heap = nw + 1; - memcpy (nw, x, sizeof (struct obj)); - break; - default: - p = get_user_type_hooks (TYPE (x)); - if (p->gc_relocate) - nw = (*p->gc_relocate) (x); - else - { - if ((nw = heap) >= heap_end) - gc_fatal_error (); - heap = nw + 1; - memcpy (nw, x, sizeof (struct obj)); - } - } - (*x).gc_mark = 1; - CAR (x) = nw; - return (nw); -} - -LISP -get_newspace (void) -{ - LISP newspace; - if (heap_org == heaps[0]) - newspace = heaps[1]; - else - newspace = heaps[0]; - heap = newspace; - heap_org = heap; - heap_end = heap + heap_size; - return (newspace); -} - -void -scan_newspace (LISP newspace) -{ - LISP ptr; - struct user_type_hooks *p; - for (ptr = newspace; ptr < heap; ++ptr) - { - switch TYPE - (ptr) - { - case tc_cons: - case tc_closure: - CAR (ptr) = gc_relocate (CAR (ptr)); - CDR (ptr) = gc_relocate (CDR (ptr)); - break; - case tc_symbol: - VCELL (ptr) = gc_relocate (VCELL (ptr)); - break; - case tc_flonum: - case tc_subr_0: - case tc_subr_1: - case tc_subr_2: - case tc_subr_2n: - case tc_subr_3: - case tc_subr_4: - case tc_subr_5: - case tc_lsubr: - case tc_fsubr: - case tc_msubr: - break; - default: - p = get_user_type_hooks (TYPE (ptr)); - if (p->gc_scan) - (*p->gc_scan) (ptr); - } - } -} - -void -free_oldspace (LISP space, LISP end) -{ - LISP ptr; - struct user_type_hooks *p; - for (ptr = space; ptr < end; ++ptr) - if (ptr->gc_mark == 0) - switch TYPE - (ptr) - { - case tc_cons: - case tc_closure: - case tc_symbol: - case tc_flonum: - case tc_subr_0: - case tc_subr_1: - case tc_subr_2: - case tc_subr_2n: - case tc_subr_3: - case tc_subr_4: - case tc_subr_5: - case tc_lsubr: - case tc_fsubr: - case tc_msubr: - break; - default: - p = get_user_type_hooks (TYPE (ptr)); - if (p->gc_free) - (*p->gc_free) (ptr); - } -} - -void -gc_stop_and_copy (void) -{ - LISP newspace, oldspace, end; - long flag; - flag = no_interrupt (1); - errjmp_ok = 0; - oldspace = heap_org; - end = heap; - old_heap_used = end - oldspace; - newspace = get_newspace (); - scan_registers (); - scan_newspace (newspace); - free_oldspace (oldspace, end); - errjmp_ok = 1; - no_interrupt (flag); -} - -LISP -allocate_aheap (void) -{ - long j, flag; - LISP ptr, end, next; - gc_kind_check (); - for (j = 0; j < nheaps; ++j) - if (!heaps[j]) - { - flag = no_interrupt (1); - if (gc_status_flag && (siod_verbose_level >= 4)) - fprintf (siod_output, "[allocating heap %ld]\n", j); - heaps[j] = (LISP) must_malloc (sizeof (struct obj) * heap_size); - ptr = heaps[j]; - end = heaps[j] + heap_size; - while (1) - { - (*ptr).type = tc_free_cell; - next = ptr + 1; - if (next < end) - { - CDR (ptr) = next; - ptr = next; - } - else - { - CDR (ptr) = freelist; - break; - } - } - freelist = heaps[j]; - flag = no_interrupt (flag); - return (sym_t); - } - return (NIL); -} - -void -gc_for_newcell (void) -{ - long flag, n; - LISP l; - if (heap < heap_end) - { - freelist = heap; - CDR (freelist) = NIL; - ++heap; - return; - } - if (errjmp_ok == 0) - gc_fatal_error (); - flag = no_interrupt (1); - errjmp_ok = 0; - gc_mark_and_sweep (); - errjmp_ok = 1; - no_interrupt (flag); - for (n = 0, l = freelist; (n < 100) && NNULLP (l); ++n) - l = CDR (l); - if (n == 0) - { - if NULLP - (allocate_aheap ()) - gc_fatal_error (); - } - else if ((n == 100) && NNULLP (sym_after_gc)) - leval (leval (sym_after_gc, NIL), NIL); - else - allocate_aheap (); -} - -void -gc_mark_and_sweep (void) -{ - LISP stack_end; - gc_ms_stats_start (); - while (heap < heap_end) - { - heap->type = tc_free_cell; - heap->gc_mark = 0; - ++heap; - } - setjmp (save_regs_gc_mark); - mark_locations ((LISP *) save_regs_gc_mark, - (LISP *) (((char *) save_regs_gc_mark) + sizeof (save_regs_gc_mark))); - mark_protected_registers (); - mark_locations ((LISP *) stack_start_ptr, - (LISP *) & stack_end); -#ifdef THINK_C - mark_locations ((LISP *) ((char *) stack_start_ptr + 2), - (LISP *) ((char *) &stack_end + 2)); -#endif - gc_sweep (); - gc_ms_stats_end (); -} - -void -gc_ms_stats_start (void) -{ - gc_rt = myruntime (); - gc_cells_collected = 0; - if (gc_status_flag && (siod_verbose_level >= 4)) - fprintf (siod_output, "[starting GC]\n"); -} - -void -gc_ms_stats_end (void) -{ - gc_rt = myruntime () - gc_rt; - gc_time_taken = gc_time_taken + gc_rt; - if (gc_status_flag && (siod_verbose_level >= 4)) - fprintf (siod_output, "[GC took %g cpu seconds, %ld cells collected]\n", - gc_rt, - gc_cells_collected); -} - -void -gc_mark (LISP ptr) -{ - struct user_type_hooks *p; -gc_mark_loop: - if NULLP - (ptr) return; - if ((*ptr).gc_mark) - return; - (*ptr).gc_mark = 1; - switch ((*ptr).type) - { - case tc_flonum: - break; - case tc_cons: - gc_mark (CAR (ptr)); - ptr = CDR (ptr); - goto gc_mark_loop; - case tc_symbol: - ptr = VCELL (ptr); - goto gc_mark_loop; - case tc_closure: - gc_mark ((*ptr).storage_as.closure.code); - ptr = (*ptr).storage_as.closure.env; - goto gc_mark_loop; - case tc_subr_0: - case tc_subr_1: - case tc_subr_2: - case tc_subr_2n: - case tc_subr_3: - case tc_subr_4: - case tc_subr_5: - case tc_lsubr: - case tc_fsubr: - case tc_msubr: - break; - default: - p = get_user_type_hooks (TYPE (ptr)); - if (p->gc_mark) - ptr = (*p->gc_mark) (ptr); - } -} - -void -mark_protected_registers (void) -{ - struct gc_protected *reg; - LISP *location; - long j, n; - for (reg = protected_registers; reg; reg = (*reg).next) - { - location = (*reg).location; - n = (*reg).length; - for (j = 0; j < n; ++j) - gc_mark (location[j]); - } -} - -void -mark_locations (LISP * start, LISP * end) -{ - LISP *tmp; - long n; - if (start > end) - { - tmp = start; - start = end; - end = tmp; - } - n = end - start; - mark_locations_array (start, n); -} - -long -looks_pointerp (LISP p) -{ - long j; - LISP h; - for (j = 0; j < nheaps; ++j) - if ((h = heaps[j]) && - (p >= h) && - (p < (h + heap_size)) && - (((((char *) p) - ((char *) h)) % sizeof (struct obj)) == 0) && - NTYPEP (p, tc_free_cell)) - return (1); - return (0); -} - -void -mark_locations_array (LISP * x, long n) -{ - int j; - LISP p; - for (j = 0; j < n; ++j) - { - p = x[j]; - if (looks_pointerp (p)) - gc_mark (p); - } -} - -void -gc_sweep (void) -{ - LISP ptr, end, nfreelist, org; - long n, k; - struct user_type_hooks *p; - end = heap_end; - n = 0; - nfreelist = NIL; - for (k = 0; k < nheaps; ++k) - if (heaps[k]) - { - org = heaps[k]; - end = org + heap_size; - for (ptr = org; ptr < end; ++ptr) - if (((*ptr).gc_mark == 0)) - { - switch ((*ptr).type) - { - case tc_free_cell: - case tc_cons: - case tc_closure: - case tc_symbol: - case tc_flonum: - case tc_subr_0: - case tc_subr_1: - case tc_subr_2: - case tc_subr_2n: - case tc_subr_3: - case tc_subr_4: - case tc_subr_5: - case tc_lsubr: - case tc_fsubr: - case tc_msubr: - break; - default: - p = get_user_type_hooks (TYPE (ptr)); - if (p->gc_free) - (*p->gc_free) (ptr); - } - ++n; - (*ptr).type = tc_free_cell; - CDR (ptr) = nfreelist; - nfreelist = ptr; - } - else - (*ptr).gc_mark = 0; - } - gc_cells_collected = n; - freelist = nfreelist; -} - -void -gc_kind_check (void) -{ - if (gc_kind_copying == 1) - my_err ("cannot perform operation with stop-and-copy GC mode. Use -g0\n", - NIL); -} - -LISP -user_gc (LISP args) -{ - long old_status_flag, flag; - gc_kind_check (); - flag = no_interrupt (1); - errjmp_ok = 0; - old_status_flag = gc_status_flag; - if NNULLP (args) - { - if NULLP (car (args)) - gc_status_flag = 0; - else - gc_status_flag = 1; - } - gc_mark_and_sweep (); - gc_status_flag = old_status_flag; - errjmp_ok = 1; - no_interrupt (flag); - return (NIL); -} - -long -nactive_heaps (void) -{ - long m; - for (m = 0; (m < nheaps) && heaps[m]; ++m); - return (m); -} - -long -freelist_length (void) -{ - long n; - LISP l; - for (n = 0, l = freelist; NNULLP (l); ++n) - l = CDR (l); - n += (heap_end - heap); - return (n); -} - -LISP -gc_status (LISP args) -{ - long n, m; - if NNULLP (args) - { - if NULLP (car (args)) - gc_status_flag = 0; - else - gc_status_flag = 1; - } - - if (gc_kind_copying == 1) - { - if (gc_status_flag) - put_st ("garbage collection is on\n"); - else - put_st ("garbage collection is off\n"); - sprintf (tkbuffer, "%d allocated %d free\n", - (int)(heap - heap_org), (int)(heap_end - heap)); - put_st (tkbuffer); - } - else - { - if (gc_status_flag) - put_st ("garbage collection verbose\n"); - else - put_st ("garbage collection silent\n"); - { - m = nactive_heaps (); - n = freelist_length (); - sprintf (tkbuffer, "%ld/%ld heaps, %ld allocated %ld free\n", - m, nheaps, m * heap_size - n, n); - put_st (tkbuffer); - } - } - return (NIL); -} - -LISP -gc_info (LISP arg) -{ - switch (get_c_long (arg)) - { - case 0: - return ((gc_kind_copying == 1) ? sym_t : NIL); - case 1: - return (flocons (nactive_heaps ())); - case 2: - return (flocons (nheaps)); - case 3: - return (flocons (heap_size)); - case 4: - return (flocons ((gc_kind_copying == 1) - ? (long) (heap_end - heap) - : freelist_length ())); - default: - return (NIL); - } -} - -LISP -leval_args (LISP l, LISP env) -{ - LISP result, v1, v2, tmp; - if NULLP - (l) return (NIL); - if NCONSP - (l) my_err ("bad syntax argument list", l); - result = cons (leval (CAR (l), env), NIL); - for (v1 = result, v2 = CDR (l); - CONSP (v2); - v1 = tmp, v2 = CDR (v2)) - { - tmp = cons (leval (CAR (v2), env), NIL); - CDR (v1) = tmp; - } - if NNULLP - (v2) my_err ("bad syntax argument list", l); - return (result); -} - -LISP -extend_env (LISP actuals, LISP formals, LISP env) -{ - if SYMBOLP - (formals) - return (cons (cons (cons (formals, NIL), cons (actuals, NIL)), env)); - return (cons (cons (formals, actuals), env)); -} - -#define ENVLOOKUP_TRICK 1 - -LISP -envlookup (LISP var, LISP env) -{ - LISP frame, al, fl, tmp; - for (frame = env; CONSP (frame); frame = CDR (frame)) - { - tmp = CAR (frame); - if NCONSP - (tmp) my_err ("damaged frame", tmp); - for (fl = CAR (tmp), al = CDR (tmp); CONSP (fl); fl = CDR (fl), al = CDR (al)) - { - if NCONSP - (al) my_err ("too few arguments", tmp); - if EQ - (CAR (fl), var) return (al); - } - /* suggested by a user. It works for reference (although conses) - but doesn't allow for set! to work properly... */ -#if (ENVLOOKUP_TRICK) - if (SYMBOLP (fl) && EQ (fl, var)) - return (cons (al, NIL)); -#endif - } - if NNULLP - (frame) my_err ("damaged env", env); - return (NIL); -} - -void -set_eval_hooks (long type, LISP (*fcn) (LISP, LISP *, LISP *)) -{ - struct user_type_hooks *p; - p = get_user_type_hooks (type); - p->leval = fcn; -} - -LISP -err_closure_code (LISP tmp) -{ - return (my_err ("closure code type not valid", tmp)); -} - -LISP -leval (LISP x, LISP env) -{ - LISP tmp, arg1; - struct user_type_hooks *p; - STACK_CHECK (&x); -loop: - INTERRUPT_CHECK (); - tmp = VCELL (sym_eval_history_ptr); - if TYPEP - (tmp, tc_cons) - { - CAR (tmp) = x; - VCELL (sym_eval_history_ptr) = CDR (tmp); - } - switch TYPE - (x) - { - case tc_symbol: - tmp = envlookup (x, env); - if NNULLP - (tmp) return (CAR (tmp)); - tmp = VCELL (x); - if EQ - (tmp, unbound_marker) err_ubv (x); - return (tmp); - case tc_cons: - tmp = CAR (x); - switch TYPE - (tmp) - { - case tc_symbol: - tmp = envlookup (tmp, env); - if NNULLP - (tmp) - { - tmp = CAR (tmp); - break; - } - tmp = VCELL (CAR (x)); - if EQ - (tmp, unbound_marker) err_ubv (CAR (x)); - break; - case tc_cons: - tmp = leval (tmp, env); - break; - } - switch TYPE - (tmp) - { - case tc_subr_0: - return (SUBR0 (tmp) ()); - case tc_subr_1: - return (SUBR1 (tmp) (leval (car (CDR (x)), env))); - case tc_subr_2: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - return (SUBR2 (tmp) (arg1, - leval (car (x), env))); - case tc_subr_2n: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - arg1 = SUBR2 (tmp) (arg1, - leval (car (x), env)); - for (x = cdr (x); CONSP (x); x = CDR (x)) - arg1 = SUBR2 (tmp) (arg1, leval (CAR (x), env)); - return (arg1); - case tc_subr_3: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - return (SUBR3 (tmp) (arg1, - leval (car (x), env), - leval (car (cdr (x)), env))); - - case tc_subr_4: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - return (SUBR4 (tmp) (arg1, - leval (car (x), env), - leval (car (cdr (x)), env), - leval (car (cdr (cdr (x))), env))); - - case tc_subr_5: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - return (SUBR5 (tmp) (arg1, - leval (car (x), env), - leval (car (cdr (x)), env), - leval (car (cdr (cdr (x))), env), - leval (car (cdr (cdr (cdr (x)))), env))); - - case tc_lsubr: - return (SUBR1 (tmp) (leval_args (CDR (x), env))); - case tc_fsubr: - return (SUBR2 (tmp) (CDR (x), env)); - case tc_msubr: - if NULLP - (SUBRM (tmp) (&x, &env)) return (x); - goto loop; - case tc_closure: - switch TYPE - ((*tmp).storage_as.closure.code) - { - case tc_cons: - env = extend_env (leval_args (CDR (x), env), - CAR ((*tmp).storage_as.closure.code), - (*tmp).storage_as.closure.env); - x = CDR ((*tmp).storage_as.closure.code); - goto loop; - case tc_subr_1: - return (SUBR1 (tmp->storage_as.closure.code) - (tmp->storage_as.closure.env)); - case tc_subr_2: - x = CDR (x); - arg1 = leval (car (x), env); - return (SUBR2 (tmp->storage_as.closure.code) - (tmp->storage_as.closure.env, arg1)); - case tc_subr_3: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - return (SUBR3 (tmp->storage_as.closure.code) - (tmp->storage_as.closure.env, - arg1, - leval (car (x), env))); - case tc_subr_4: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - return (SUBR4 (tmp->storage_as.closure.code) - (tmp->storage_as.closure.env, - arg1, - leval (car (x), env), - leval (car (cdr (x)), env))); - case tc_subr_5: - x = CDR (x); - arg1 = leval (car (x), env); - x = NULLP (x) ? NIL : CDR (x); - return (SUBR5 (tmp->storage_as.closure.code) - (tmp->storage_as.closure.env, - arg1, - leval (car (x), env), - leval (car (cdr (x)), env), - leval (car (cdr (cdr (x))), env))); - - case tc_lsubr: - return (SUBR1 (tmp->storage_as.closure.code) - (cons (tmp->storage_as.closure.env, - leval_args (CDR (x), env)))); - default: - err_closure_code (tmp); - } - break; - case tc_symbol: - x = cons (tmp, cons (cons (sym_quote, cons (x, NIL)), NIL)); - x = leval (x, NIL); - goto loop; - default: - p = get_user_type_hooks (TYPE (tmp)); - if (p->leval) - { - if NULLP - ((*p->leval) (tmp, &x, &env)) return (x); - else - goto loop; - } - my_err ("bad function", tmp); - } - default: - return (x); - } -} - -LISP -lapply (LISP fcn, LISP args) -{ - struct user_type_hooks *p; - LISP acc; - STACK_CHECK (&fcn); - INTERRUPT_CHECK (); - switch TYPE - (fcn) - { - case tc_subr_0: - return (SUBR0 (fcn) ()); - case tc_subr_1: - return (SUBR1 (fcn) (car (args))); - case tc_subr_2: - return (SUBR2 (fcn) (car (args), car (cdr (args)))); - case tc_subr_2n: - acc = SUBR2 (fcn) (car (args), car (cdr (args))); - for (args = cdr (cdr (args)); CONSP (args); args = CDR (args)) - acc = SUBR2 (fcn) (acc, CAR (args)); - return (acc); - case tc_subr_3: - return (SUBR3 (fcn) (car (args), car (cdr (args)), car (cdr (cdr (args))))); - case tc_subr_4: - return (SUBR4 (fcn) (car (args), car (cdr (args)), car (cdr (cdr (args))), - car (cdr (cdr (cdr (args)))))); - case tc_subr_5: - return (SUBR5 (fcn) (car (args), car (cdr (args)), car (cdr (cdr (args))), - car (cdr (cdr (cdr (args)))), - car (cdr (cdr (cdr (cdr (args))))))); - case tc_lsubr: - return (SUBR1 (fcn) (args)); - case tc_fsubr: - case tc_msubr: - case tc_symbol: - my_err ("cannot be applied", fcn); - case tc_closure: - switch TYPE - (fcn->storage_as.closure.code) - { - case tc_cons: - return (leval (cdr (fcn->storage_as.closure.code), - extend_env (args, - car (fcn->storage_as.closure.code), - fcn->storage_as.closure.env))); - case tc_subr_1: - return (SUBR1 (fcn->storage_as.closure.code) - (fcn->storage_as.closure.env)); - case tc_subr_2: - return (SUBR2 (fcn->storage_as.closure.code) - (fcn->storage_as.closure.env, - car (args))); - case tc_subr_3: - return (SUBR3 (fcn->storage_as.closure.code) - (fcn->storage_as.closure.env, - car (args), car (cdr (args)))); - case tc_subr_4: - return (SUBR4 (fcn->storage_as.closure.code) - (fcn->storage_as.closure.env, - car (args), car (cdr (args)), car (cdr (cdr (args))))); - case tc_subr_5: - return (SUBR5 (fcn->storage_as.closure.code) - (fcn->storage_as.closure.env, - car (args), car (cdr (args)), car (cdr (cdr (args))), - car (cdr (cdr (cdr (args)))))); - case tc_lsubr: - return (SUBR1 (fcn->storage_as.closure.code) - (cons (fcn->storage_as.closure.env, args))); - default: - err_closure_code (fcn); - } - default: - p = get_user_type_hooks (TYPE (fcn)); - if (p->leval) - return my_err ("have eval, dont know apply", fcn); - else - return my_err ("cannot be applied", fcn); - } -} - -LISP -setvar (LISP var, LISP val, LISP env) -{ - LISP tmp; - if NSYMBOLP - (var) my_err ("wta(non-symbol) to setvar", var); - tmp = envlookup (var, env); - if NULLP - (tmp) return (VCELL (var) = val); - return (CAR (tmp) = val); -} - -LISP -leval_setq (LISP args, LISP env) -{ - return (setvar (car (args), leval (car (cdr (args)), env), env)); -} - -LISP -syntax_define (LISP args) -{ - if SYMBOLP - (car (args)) return (args); - return (syntax_define ( - cons (car (car (args)), - cons (cons (sym_lambda, - cons (cdr (car (args)), - cdr (args))), - NIL)))); -} - -LISP -leval_define (LISP args, LISP env) -{ - LISP tmp, var, val; - tmp = syntax_define (args); - var = car (tmp); - if NSYMBOLP - (var) my_err ("wta(non-symbol) to define", var); - val = leval (car (cdr (tmp)), env); - tmp = envlookup (var, env); - if NNULLP - (tmp) return (CAR (tmp) = val); - if NULLP - (env) return (VCELL (var) = val); - tmp = car (env); - setcar (tmp, cons (var, car (tmp))); - setcdr (tmp, cons (val, cdr (tmp))); - return (val); -} - -LISP -leval_if (LISP * pform, LISP * penv) -{ - LISP args, env; - args = cdr (*pform); - env = *penv; - if NNULLP - (leval (car (args), env)) - * pform = car (cdr (args)); - else - *pform = car (cdr (cdr (args))); - return (sym_t); -} - -LISP -leval_lambda (LISP args, LISP env) -{ - LISP body; - if NULLP - (cdr (cdr (args))) - body = car (cdr (args)); - else - body = cons (sym_progn, cdr (args)); - return (closure (env, cons (arglchk (car (args)), body))); -} - -LISP -leval_progn (LISP * pform, LISP * penv) -{ - LISP env, l, next; - env = *penv; - l = cdr (*pform); - next = cdr (l); - while (NNULLP (next)) - { - leval (car (l), env); - l = next; - next = cdr (next); - } - *pform = car (l); - return (sym_t); -} - -LISP -leval_or (LISP * pform, LISP * penv) -{ - LISP env, l, next, val; - env = *penv; - l = cdr (*pform); - next = cdr (l); - while (NNULLP (next)) - { - val = leval (car (l), env); - if NNULLP - (val) - { - *pform = val; - return (NIL); - } - l = next; - next = cdr (next); - } - *pform = car (l); - return (sym_t); -} - -LISP -leval_and (LISP * pform, LISP * penv) -{ - LISP env, l, next; - env = *penv; - l = cdr (*pform); - if NULLP - (l) - { - *pform = sym_t; - return (NIL); - } - next = cdr (l); - while (NNULLP (next)) - { - if NULLP - (leval (car (l), env)) - { - *pform = NIL; - return (NIL); - } - l = next; - next = cdr (next); - } - *pform = car (l); - return (sym_t); -} - -LISP -leval_catch_1 (LISP forms, LISP env) -{ - LISP l, val = NIL; - for (l = forms; NNULLP (l); l = cdr (l)) - val = leval (car (l), env); - catch_framep = catch_framep->next; - return (val); -} - -LISP -leval_catch (LISP args, LISP env) -{ - struct catch_frame frame; - int k; - frame.tag = leval (car (args), env); - frame.next = catch_framep; - k = setjmp (frame.cframe); - catch_framep = &frame; - if (k == 2) - { - catch_framep = frame.next; - return (frame.retval); - } - return (leval_catch_1 (cdr (args), env)); -} - -LISP -lthrow (LISP tag, LISP value) -{ - struct catch_frame *l; - for (l = catch_framep; l; l = (*l).next) - if (EQ ((*l).tag, tag) || - EQ ((*l).tag, sym_catchall)) - { - (*l).retval = value; - longjmp ((*l).cframe, 2); - } - my_err ("no *catch found with this tag", tag); - return (NIL); -} - -LISP -leval_let (LISP * pform, LISP * penv) -{ - LISP env, l; - l = cdr (*pform); - env = *penv; - *penv = extend_env (leval_args (car (cdr (l)), env), car (l), env); - *pform = car (cdr (cdr (l))); - return (sym_t); -} - -LISP -letstar_macro (LISP form) -{ - LISP bindings = cadr (form); - if (NNULLP (bindings) && NNULLP (cdr (bindings))) - setcdr (form, cons (cons (car (bindings), NIL), - cons (cons (cintern ("let*"), - cons (cdr (bindings), - cddr (form))), - NIL))); - setcar (form, cintern ("let")); - return (form); -} - -LISP -letrec_macro (LISP form) -{ - LISP letb, setb, l; - for (letb = NIL, setb = cddr (form), l = cadr (form); NNULLP (l); l = cdr (l)) - { - letb = cons (cons (caar (l), NIL), letb); - setb = cons (listn (3, cintern ("set!"), caar (l), cadar (l)), setb); - } - setcdr (form, cons (letb, setb)); - setcar (form, cintern ("let")); - return (form); -} - -LISP -reverse (LISP l) -{ - LISP n, p; - n = NIL; - for (p = l; NNULLP (p); p = cdr (p)) - n = cons (car (p), n); - return (n); -} - -LISP -let_macro (LISP form) -{ - LISP p, fl, al, tmp; - fl = NIL; - al = NIL; - for (p = car (cdr (form)); NNULLP (p); p = cdr (p)) - { - tmp = car (p); - if SYMBOLP - (tmp) - { - fl = cons (tmp, fl); - al = cons (NIL, al); - } - else - { - fl = cons (car (tmp), fl); - al = cons (car (cdr (tmp)), al); - } - } - p = cdr (cdr (form)); - if NULLP - (cdr (p)) p = car (p); - else - p = cons (sym_progn, p); - setcdr (form, cons (reverse (fl), cons (reverse (al), cons (p, NIL)))); - setcar (form, cintern ("let-internal")); - return (form); -} - -LISP -leval_quote (LISP args, LISP env) -{ - return (car (args)); -} - -LISP -leval_tenv (LISP args, LISP env) -{ - return (env); -} - -LISP -leval_while (LISP args, LISP env) -{ - LISP l; - while NNULLP - (leval (car (args), env)) - for (l = cdr (args); NNULLP (l); l = cdr (l)) - leval (car (l), env); - return (NIL); -} - -LISP -symbolconc (LISP args) -{ - long size; - LISP l, s; - size = 0; - tkbuffer[0] = 0; - for (l = args; NNULLP (l); l = cdr (l)) - { - s = car (l); - if NSYMBOLP - (s) my_err ("wta(non-symbol) to symbolconc", s); - size = size + strlen (PNAME (s)); - if (size > TKBUFFERN) - my_err ("symbolconc buffer overflow", NIL); - strcat (tkbuffer, PNAME (s)); - } - return (rintern (tkbuffer)); -} - -void -set_print_hooks (long type, void (*fcn) (LISP, struct gen_printio *)) -{ - struct user_type_hooks *p; - p = get_user_type_hooks (type); - p->prin1 = fcn; -} - -char * -subr_kind_str (long n) -{ - switch (n) - { - case tc_subr_0: - return ("subr_0"); - case tc_subr_1: - return ("subr_1"); - case tc_subr_2: - return ("subr_2"); - case tc_subr_2n: - return ("subr_2n"); - case tc_subr_3: - return ("subr_3"); - case tc_subr_4: - return ("subr_4"); - case tc_subr_5: - return ("subr_5"); - case tc_lsubr: - return ("lsubr"); - case tc_fsubr: - return ("fsubr"); - case tc_msubr: - return ("msubr"); - default: - return ("???"); - } -} - -LISP -lprin1g (LISP exp, struct gen_printio * f) -{ - LISP tmp; - long n; - struct user_type_hooks *p; - STACK_CHECK (&exp); - INTERRUPT_CHECK (); - switch TYPE - (exp) - { - case tc_nil: - gput_st (f, "()"); - break; - case tc_cons: - gput_st (f, "("); - lprin1g (car (exp), f); - for (tmp = cdr (exp); CONSP (tmp); tmp = cdr (tmp)) - { - gput_st (f, " "); - lprin1g (car (tmp), f); - } - if NNULLP - (tmp) - { - gput_st (f, " . "); - lprin1g (tmp, f); - } - gput_st (f, ")"); - break; - case tc_flonum: - n = (long) FLONM (exp); - if (((double) n) == FLONM (exp)) - sprintf (tkbuffer, "%ld", n); - else - g_ascii_formatd (tkbuffer, TKBUFFERN, "%g", FLONM (exp)); - gput_st (f, tkbuffer); - break; - case tc_symbol: - gput_st (f, PNAME (exp)); - break; - case tc_subr_0: - case tc_subr_1: - case tc_subr_2: - case tc_subr_2n: - case tc_subr_3: - case tc_subr_4: - case tc_subr_5: - case tc_lsubr: - case tc_fsubr: - case tc_msubr: - sprintf (tkbuffer, "#<%s ", subr_kind_str (TYPE (exp))); - gput_st (f, tkbuffer); - gput_st (f, (*exp).storage_as.subr.name); - gput_st (f, ">"); - break; - case tc_closure: - gput_st (f, "#"); - break; - default: - p = get_user_type_hooks (TYPE (exp)); - if (p->prin1) - (*p->prin1) (exp, f); - else - { - sprintf (tkbuffer, "#", TYPE (exp), exp); - gput_st (f, tkbuffer); - } - } - return (NIL); -} - -LISP -lprint (LISP exp, LISP lf) -{ - FILE *f = get_c_file (lf, siod_output); - lprin1f (exp, f); - if (siod_verbose_level > 0) - fput_st (f, "\n"); - return (NIL); -} - -LISP -lprin1 (LISP exp, LISP lf) -{ - FILE *f = get_c_file (lf, siod_output); - lprin1f (exp, f); - return (NIL); -} - -LISP -lprin1f (LISP exp, FILE * f) -{ - struct gen_printio s; - s.putc_fcn = NULL; - s.puts_fcn = fputs_fcn; - s.cb_argument = f; - lprin1g (exp, &s); - return (NIL); -} - -LISP -lread (LISP f) -{ - return (lreadf (get_c_file (f, stdin))); -} - -int -f_getc (FILE * f) -{ - long iflag, dflag; - int c; - iflag = no_interrupt (1); - dflag = interrupt_differed; - c = getc (f); -#ifdef VMS - if ((dflag == 0) & interrupt_differed & (f == stdin)) - while ((c != 0) & (c != EOF)) - c = getc (f); -#endif - no_interrupt (iflag); - return (c); -} - -void -f_ungetc (int c, FILE * f) -{ - ungetc (c, f); -} - -int -flush_ws (struct gen_readio *f, char *eoferr) -{ - int c, commentp; - commentp = 0; - while (1) - { - c = GETC_FCN (f); - if (c == EOF) - { - if (eoferr) - my_err (eoferr, NIL); - else - return (c); - } - - if (commentp) - { - if (c == '\n') - commentp = 0; - } - else if (c == ';') - commentp = 1; - else if (!isspace (c)) - return (c); - } -} - -LISP -lreadf (FILE * f) -{ - struct gen_readio s; - s.getc_fcn = (int (*)(void *)) f_getc; - s.ungetc_fcn = (void (*)(int, void *)) f_ungetc; - s.cb_argument = (char *) f; - return (readtl (&s)); -} - -LISP -readtl (struct gen_readio * f) -{ - int c; - c = flush_ws (f, (char *) NULL); - if (c == EOF) - return (eof_val); - UNGETC_FCN (c, f); - return (lreadr (f)); -} - -void -set_read_hooks (char *all_set, char *end_set, - LISP (*fcn1) (int, struct gen_readio *), - LISP (*fcn2) (char *, long, int *)) -{ - user_ch_readm = all_set; - user_te_readm = end_set; - user_readm = fcn1; - user_readt = fcn2; -} - -LISP -lreadr (struct gen_readio *f) -{ - int c, j; - char *p, *buffer = tkbuffer; - STACK_CHECK (&f); - p = buffer; - c = flush_ws (f, "end of file inside read"); - switch (c) - { - case '(': - return (lreadparen (f)); - case ')': - my_err ("unexpected close paren", NIL); - case '\'': - return (cons (sym_quote, cons (lreadr (f), NIL))); - case '`': - return (cons (cintern ("+internal-backquote"), lreadr (f))); - case ',': - c = GETC_FCN (f); - switch (c) - { - case '@': - p = "+internal-comma-atsign"; - break; - case '.': - p = "+internal-comma-dot"; - break; - default: - p = "+internal-comma"; - UNGETC_FCN (c, f); - } - return (cons (cintern (p), lreadr (f))); - case '_': /* might be a string marked for translation using _(...) */ - c = GETC_FCN (f); - if (c == '"') - return (lreadstring (f)); - else - UNGETC_FCN (c, f); - break; - case '"': - return (lreadstring (f)); - case '#': - return (lreadsharp (f)); - default: - if ((user_readm != NULL) && strchr (user_ch_readm, c)) - return ((*user_readm) (c, f)); - } - *p++ = c; - for (j = 1; j < TKBUFFERN; ++j) - { - c = GETC_FCN (f); - if (c == EOF) - return (lreadtk (buffer, j)); - if (isspace (c)) - return (lreadtk (buffer, j)); - if (strchr ("()'`,;\"", c) || strchr (user_te_readm, c)) - { - UNGETC_FCN (c, f); - return (lreadtk (buffer, j)); - } - *p++ = c; - } - return (my_err ("token larger than TKBUFFERN", NIL)); -} - -LISP -lreadparen (struct gen_readio * f) -{ - int c; - LISP tmp; - c = flush_ws (f, "end of file inside list"); - if (c == ')') - return (NIL); - UNGETC_FCN (c, f); - tmp = lreadr (f); - if EQ - (tmp, sym_dot) - { - tmp = lreadr (f); - c = flush_ws (f, "end of file inside list"); - if (c != ')') - my_err ("missing close paren", NIL); - return (tmp); - } - return (cons (tmp, lreadparen (f))); -} - -LISP -lreadtk (char *buffer, long j) -{ - int flag; - LISP tmp; - int adigit; - char *p = buffer; - p[j] = 0; - if (user_readt != NULL) - { - tmp = (*user_readt) (p, j, &flag); - if (flag) - return (tmp); - } - if (*p == '-') - p += 1; - adigit = 0; - while (isdigit (*p)) - { - p += 1; - adigit = 1; - } - if (*p == '.') - { - p += 1; - while (isdigit (*p)) - { - p += 1; - adigit = 1; - } - } - if (!adigit) - goto a_symbol; - if (*p == 'e') - { - p += 1; - if (*p == '-' || *p == '+') - p += 1; - if (!isdigit (*p)) - goto a_symbol; - else - p += 1; - while (isdigit (*p)) - p += 1; - } - if (*p) - goto a_symbol; - return (flocons (g_ascii_strtod (buffer, NULL))); -a_symbol: - return (rintern (buffer)); -} - -LISP -copy_list (LISP x) -{ - if NULLP - (x) return (NIL); - STACK_CHECK (&x); - return (cons (car (x), copy_list (cdr (x)))); -} - -LISP -apropos (LISP matchl) -{ - LISP result = NIL, l, ml; - char *pname; - for (l = oblistvar; CONSP (l); l = CDR (l)) - { - pname = get_c_string (CAR (l)); - ml = matchl; - while (CONSP (ml) && strstr (pname, get_c_string (CAR (ml)))) - ml = CDR (ml); - if NULLP - (ml) - result = cons (CAR (l), result); - } - return (result); -} - -LISP -fopen_cg (FILE * (*fcn) (const char *, const char *), char *name, char *how) -{ - LISP sym; - long flag; - char errmsg[80]; - flag = no_interrupt (1); - sym = newcell (tc_c_file); - sym->storage_as.c_file.f = (FILE *) NULL; - sym->storage_as.c_file.name = (char *) NULL; - if (!(sym->storage_as.c_file.f = (*fcn) (name, how))) - { - SAFE_STRCPY (errmsg, "could not open "); - SAFE_STRCAT (errmsg, name); - my_err (errmsg, llast_c_errmsg (-1)); - } - sym->storage_as.c_file.name = (char *) must_malloc (strlen (name) + 1); - strcpy (sym->storage_as.c_file.name, name); - no_interrupt (flag); - return (sym); -} - -LISP -fopen_c (char *name, char *how) -{ - return (fopen_cg (fopen, name, how)); -} - -LISP -fopen_l (LISP name, LISP how) -{ - return (fopen_c (get_c_string (name), NULLP (how) ? "r" : get_c_string (how))); -} - -LISP -delq (LISP elem, LISP l) -{ - if NULLP - (l) return (l); - STACK_CHECK (&elem); - if EQ - (elem, car (l)) return (delq (elem, cdr (l))); - setcdr (l, delq (elem, cdr (l))); - return (l); -} - -LISP -fclose_l (LISP p) -{ - long flag; - flag = no_interrupt (1); - if NTYPEP - (p, tc_c_file) my_err ("not a file", p); - file_gc_free (p); - no_interrupt (flag); - return (NIL); -} - -LISP -vload (char *fname, long cflag, long rflag) -{ - LISP form, result, tail, lf, reader = NIL; - FILE *f; - int c, j; - char buffer[512], *key = "parser:", *start, *end, *ftype = ".scm"; - if (rflag) - { - int iflag; - iflag = no_interrupt (1); - if ((f = fopen (fname, "r"))) - fclose (f); - else if ((fname[0] != '/') && - ((strlen (siod_lib) + strlen (fname) + 1) - < sizeof (buffer))) - { - strcpy (buffer, siod_lib); - strcat (buffer, "/"); - strcat (buffer, fname); - if ((f = fopen (buffer, "r"))) - { - fname = buffer; - fclose (f); - } - } - no_interrupt (iflag); - } - if (siod_verbose_level >= 3) - { - put_st ("loading "); - put_st (fname); - put_st ("\n"); - } - lf = fopen_c (fname, "r"); - f = lf->storage_as.c_file.f; - result = NIL; - tail = NIL; - j = 0; - buffer[0] = 0; - c = getc (f); - while ((c == '#') || (c == ';')) - { - while (((c = getc (f)) != EOF) && (c != '\n')) - if ((j + 1) < sizeof (buffer)) - { - buffer[j] = c; - buffer[++j] = 0; - } - if (c == '\n') - c = getc (f); - } - if (c != EOF) - ungetc (c, f); - if ((start = strstr (buffer, key))) - { - for (end = &start[strlen (key)]; - *end && isalnum (*end); - ++end); - j = end - start; - g_memmove (buffer, start, j); - buffer[strlen (key) - 1] = '_'; - buffer[j] = 0; - strcat (buffer, ftype); - require (strcons (-1, buffer)); - buffer[j] = 0; - reader = rintern (buffer); - reader = funcall1 (leval (reader, NIL), reader); - if (siod_verbose_level >= 5) - { - put_st ("parser:"); - lprin1 (reader, NIL); - put_st ("\n"); - } - } - while (1) - { - form = NULLP (reader) ? lread (lf) : funcall1 (reader, lf); - if EQ - (form, eof_val) break; - if (siod_verbose_level >= 5) - lprint (form, NIL); - if (cflag) - { - form = cons (form, NIL); - if NULLP - (result) - result = tail = form; - else - tail = setcdr (tail, form); - } - else - leval (form, NIL); - } - fclose_l (lf); - if (siod_verbose_level >= 3) - put_st ("done.\n"); - return (result); -} - -LISP -load (LISP fname, LISP cflag, LISP rflag) -{ - return (vload (get_c_string (fname), NULLP (cflag) ? 0 : 1, NULLP (rflag) ? 0 : 1)); -} - -LISP -require (LISP fname) -{ - LISP sym; - sym = intern (string_append (cons (cintern ("*"), - cons (fname, - cons (cintern ("-loaded*"), NIL))))); - if (NULLP (symbol_boundp (sym, NIL)) || - NULLP (symbol_value (sym, NIL))) - { - load (fname, NIL, sym_t); - setvar (sym, sym_t, NIL); - } - return (sym); -} - -LISP -save_forms (LISP fname, LISP forms, LISP how) -{ - char *cname, *chow = NULL; - LISP l, lf; - FILE *f; - cname = get_c_string (fname); - if EQ - (how, NIL) chow = "w"; - else if EQ - (how, cintern ("a")) chow = "a"; - else - my_err ("bad argument to save-forms", how); - if (siod_verbose_level >= 3) - { - put_st ((*chow == 'a') ? "appending" : "saving"); - put_st (" forms to "); - put_st (cname); - put_st ("\n"); - } - lf = fopen_c (cname, chow); - f = lf->storage_as.c_file.f; - for (l = forms; NNULLP (l); l = cdr (l)) - { - lprin1f (car (l), f); - putc ('\n', f); - } - fclose_l (lf); - if (siod_verbose_level >= 3) - put_st ("done.\n"); - return (sym_t); -} - -LISP -quit (void) -{ - return (my_err (NULL, NIL)); -} - -LISP -nullp (LISP x) -{ - if EQ - (x, NIL) return (sym_t); - else - return (NIL); -} - -LISP -arglchk (LISP x) -{ -#if (!ENVLOOKUP_TRICK) - LISP l; - if SYMBOLP - (x) return (x); - for (l = x; CONSP (l); l = CDR (l)); - if NNULLP - (l) my_err ("improper formal argument list", x); -#endif - return (x); -} - -void -file_gc_free (LISP ptr) -{ - if (ptr->storage_as.c_file.f) - { - fclose (ptr->storage_as.c_file.f); - ptr->storage_as.c_file.f = (FILE *) NULL; - } - if (ptr->storage_as.c_file.name) - { - free (ptr->storage_as.c_file.name); - ptr->storage_as.c_file.name = NULL; - } -} - -void -file_prin1 (LISP ptr, struct gen_printio *f) -{ - char *name; - name = ptr->storage_as.c_file.name; - gput_st (f, "#storage_as.c_file.f); - gput_st (f, tkbuffer); - if (name) - { - gput_st (f, " "); - gput_st (f, name); - } - gput_st (f, ">"); -} - -FILE * -get_c_file (LISP p, FILE * deflt) -{ - if (NULLP (p) && deflt) - return (deflt); - if NTYPEP - (p, tc_c_file) my_err ("not a file", p); - if (!p->storage_as.c_file.f) - my_err ("file is closed", p); - return (p->storage_as.c_file.f); -} - -LISP -lgetc (LISP p) -{ - int i; - i = f_getc (get_c_file (p, stdin)); - return ((i == EOF) ? NIL : flocons ((double) i)); -} - -LISP -lungetc (LISP ii, LISP p) -{ - int i; - if NNULLP - (ii) - { - i = get_c_long (ii); - f_ungetc (i, get_c_file (p, stdin)); - } - return (NIL); -} - -LISP -lputc (LISP c, LISP p) -{ - long flag; - int i; - FILE *f; - f = get_c_file (p, siod_output); - if FLONUMP - (c) - i = (int) FLONM (c); - else - i = *get_c_string (c); - flag = no_interrupt (1); - putc (i, f); - no_interrupt (flag); - return (NIL); -} - -LISP -lputs (LISP str, LISP p) -{ - fput_st (get_c_file (p, siod_output), get_c_string (str)); - return (NIL); -} - -LISP -lftell (LISP file) -{ - return (flocons ((double) ftell (get_c_file (file, NULL)))); -} - -LISP -lfseek (LISP file, LISP offset, LISP direction) -{ - return ((fseek (get_c_file (file, NULL), get_c_long (offset), get_c_long (direction))) - ? NIL : sym_t); -} - -LISP -parse_number (LISP x) -{ - char *c; - c = get_c_string (x); - return (flocons (g_ascii_strtod (c, NULL))); -} - -void -init_subrs (void) -{ - init_subrs_1 (); - init_subrs_a (); -} - -LISP -closure_code (LISP exp) -{ - return (exp->storage_as.closure.code); -} - -LISP -closure_env (LISP exp) -{ - return (exp->storage_as.closure.env); -} - -LISP -lwhile (LISP form, LISP env) -{ - LISP l; - while (NNULLP (leval (car (form), env))) - for (l = cdr (form); NNULLP (l); l = cdr (l)) - leval (car (l), env); - return (NIL); -} - -LISP -nreverse (LISP x) -{ - LISP newp, oldp, nextp; - newp = NIL; - for (oldp = x; CONSP (oldp); oldp = nextp) - { - nextp = CDR (oldp); - CDR (oldp) = newp; - newp = oldp; - } - return (newp); -} - -LISP -siod_verbose (LISP arg) -{ - if NNULLP - (arg) - siod_verbose_level = get_c_long (car (arg)); - return (flocons (siod_verbose_level)); -} - -int -siod_verbose_check (int level) -{ - return ((siod_verbose_level >= level) ? 1 : 0); -} - -LISP -lruntime (void) -{ - return (cons (flocons (myruntime ()), - cons (flocons (gc_time_taken), NIL))); -} - -LISP -lrealtime (void) -{ - return (flocons (myrealtime ())); -} - -LISP -caar (LISP x) -{ - return (car (car (x))); -} - -LISP -cadr (LISP x) -{ - return (car (cdr (x))); -} - -LISP -cdar (LISP x) -{ - return (cdr (car (x))); -} - -LISP -cddr (LISP x) -{ - return (cdr (cdr (x))); -} - -LISP -lrand (LISP m) -{ - long res; - res = rand (); - if NULLP - (m) - return (flocons (res)); - else - return (flocons (res % get_c_long (m))); -} - -LISP -lsrand (LISP s) -{ - srand (get_c_long (s)); - return (NIL); -} - -LISP -a_true_value (void) -{ - return (sym_t); -} - -LISP -poparg (LISP * ptr, LISP defaultv) -{ - LISP value; - if NULLP - (*ptr) - return (defaultv); - value = car (*ptr); - *ptr = cdr (*ptr); - return (value); -} - -char * -last_c_errmsg (int num) -{ - int xerrno = (num < 0) ? errno : num; - static char serrmsg[100]; - const char *errmsg; - errmsg = g_strerror (xerrno); - if (!errmsg) - { - sprintf (serrmsg, "errno %d", xerrno); - errmsg = (const char *) serrmsg; - } - return ((char *) errmsg); -} - -LISP -llast_c_errmsg (int num) -{ - int xerrno = (num < 0) ? errno : num; - const char *errmsg = g_strerror (xerrno); - if (!errmsg) - return (flocons (xerrno)); - return (cintern ((char *) errmsg)); -} - -LISP -lllast_c_errmsg (void) -{ - return (llast_c_errmsg (-1)); -} - -LISP -help (void) -{ - fprintf (siod_output, "HELP for SIOD, Version %s\n", siod_version ()); - fprintf (siod_output, "For the latest Script-Fu tips, tutorials, & info:\n"); - fprintf (siod_output, "\thttp://www.gimp.org/scripts.html\n\n"); - - return NIL; -} - -size_t -safe_strlen (const char *s, size_t size) -{ - char *end; - if ((end = (char *) memchr (s, 0, size))) - return (end - s); - else - return (size); -} - -char * -safe_strcpy (char *s1, size_t size1, const char *s2) -{ - size_t len2; - if (size1 == 0) - return (s1); - len2 = strlen (s2); - if (len2 < size1) - { - if (len2) - memcpy (s1, s2, len2); - s1[len2] = 0; - } - else - { - memcpy (s1, s2, size1); - s1[size1 - 1] = 0; - } - return (s1); -} - -char * -safe_strcat (char *s1, size_t size1, const char *s2) -{ - size_t len1; - len1 = safe_strlen (s1, size1); - safe_strcpy (&s1[len1], size1 - len1, s2); - return (s1); -} - -static LISP -parser_read (LISP ignore) -{ - return (leval (cintern ("read"), NIL)); -} - -void -init_subrs_1 (void) -{ - init_subr_2 ("cons", cons); - init_subr_1 ("car", car); - init_subr_1 ("cdr", cdr); - init_subr_2 ("set-car!", setcar); - init_subr_2 ("set-cdr!", setcdr); - init_subr_2n ("+", plus); - init_subr_2n ("-", difference); - init_subr_2n ("*", ltimes); - init_subr_2n ("/", Quotient); - init_subr_2n ("min", lmin); - init_subr_2n ("max", lmax); - init_subr_1 ("abs", lllabs); - init_subr_1 ("sqrt", lsqrt); - init_subr_2 (">", greaterp); - init_subr_2 ("<", lessp); - init_subr_2 (">=", greaterEp); - init_subr_2 ("<=", lessEp); - init_subr_2 ("eq?", eq); - init_subr_2 ("eqv?", eql); - init_subr_2 ("=", eql); - init_subr_2 ("assq", assq); - init_subr_2 ("delq", delq); - init_subr_1 ("read", lread); - init_subr_1 ("parser_read", parser_read); - setvar (cintern ("*parser_read.scm-loaded*"), sym_t, NIL); - init_subr_0 ("eof-val", get_eof_val); - init_subr_2 ("print", lprint); - init_subr_2 ("prin1", lprin1); - init_subr_2 ("eval", leval); - init_subr_2 ("apply", lapply); - init_fsubr ("define", leval_define); - init_fsubr ("lambda", leval_lambda); - init_msubr ("if", leval_if); - init_fsubr ("while", leval_while); - init_msubr ("begin", leval_progn); - init_fsubr ("set!", leval_setq); - init_msubr ("or", leval_or); - init_msubr ("and", leval_and); - init_fsubr ("*catch", leval_catch); - init_subr_2 ("*throw", lthrow); - init_fsubr ("quote", leval_quote); - init_lsubr ("apropos", apropos); - init_lsubr ("verbose", siod_verbose); - init_subr_1 ("copy-list", copy_list); - init_lsubr ("gc-status", gc_status); - init_lsubr ("gc", user_gc); - init_subr_3 ("load", load); - init_subr_1 ("require", require); - init_subr_1 ("pair?", consp); - init_subr_1 ("symbol?", symbolp); - init_subr_1 ("number?", numberp); - init_msubr ("let-internal", leval_let); - init_subr_1 ("let-internal-macro", let_macro); - init_subr_1 ("let*-macro", letstar_macro); - init_subr_1 ("letrec-macro", letrec_macro); - init_subr_2 ("symbol-bound?", symbol_boundp); - init_subr_2 ("symbol-value", symbol_value); - init_subr_3 ("set-symbol-value!", setvar); - init_fsubr ("the-environment", leval_tenv); - init_subr_2 ("error", lerr); - init_subr_0 ("quit", quit); - init_subr_1 ("not", nullp); - init_subr_1 ("null?", nullp); - init_subr_2 ("env-lookup", envlookup); - init_subr_1 ("reverse", reverse); - init_lsubr ("symbolconc", symbolconc); - init_subr_3 ("save-forms", save_forms); - init_subr_2 ("fopen", fopen_l); - init_subr_1 ("fclose", fclose_l); - init_subr_1 ("getc", lgetc); - init_subr_2 ("ungetc", lungetc); - init_subr_2 ("putc", lputc); - init_subr_2 ("puts", lputs); - init_subr_1 ("ftell", lftell); - init_subr_3 ("fseek", lfseek); - init_subr_1 ("parse-number", parse_number); - init_subr_2 ("%%stack-limit", stack_limit); - init_subr_1 ("intern", intern); - init_subr_2 ("%%closure", closure); - init_subr_1 ("%%closure-code", closure_code); - init_subr_1 ("%%closure-env", closure_env); - init_fsubr ("while", lwhile); - init_subr_1 ("nreverse", nreverse); - init_subr_0 ("allocate-heap", allocate_aheap); - init_subr_1 ("gc-info", gc_info); - init_subr_0 ("runtime", lruntime); - init_subr_0 ("realtime", lrealtime); - init_subr_1 ("caar", caar); - init_subr_1 ("cadr", cadr); - init_subr_1 ("cdar", cdar); - init_subr_1 ("cddr", cddr); - init_subr_1 ("rand", lrand); - init_subr_1 ("srand", lsrand); - init_subr_0 ("last-c-error", lllast_c_errmsg); - init_subr_0 ("help", help); - init_slib_version (); -} - - -/* err0,pr,prp are convenient to call from the C-language debugger */ - -void -err0 (void) -{ - my_err ("0", NIL); -} - -void -pr (LISP p) -{ - if (looks_pointerp (p)) - lprint (p, NIL); - else - put_st ("invalid\n"); -} - -void -prp (LISP * p) -{ - if (!p) - return; - pr (*p); -} diff --git a/plug-ins/script-fu/interp_sliba.c b/plug-ins/script-fu/interp_sliba.c deleted file mode 100644 index 22fc0a94a6..0000000000 --- a/plug-ins/script-fu/interp_sliba.c +++ /dev/null @@ -1,2927 +0,0 @@ - - -/* - * COPYRIGHT (c) 1988-1994 BY * - * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * - * See the source file SLIB.C for more information. * - - Array-hacking code moved to another source file. - - */ - -#include -#include -#include -#include -#include -#include -#include - -#include - -#include "siod.h" -#include "siodp.h" - -static void -init_sliba_version (void) -{ - setvar (cintern ("*sliba-version*"), - cintern ("$Id$"), - NIL); -} - -static LISP sym_plists = NIL; -static LISP bashnum = NIL; -static LISP sym_e = NIL; -static LISP sym_f = NIL; - -void -init_storage_a1 (long type) -{ - long j; - struct user_type_hooks *p; - set_gc_hooks (type, - array_gc_relocate, - array_gc_mark, - array_gc_scan, - array_gc_free, - &j); - set_print_hooks (type, array_prin1); - p = get_user_type_hooks (type); - p->fast_print = array_fast_print; - p->fast_read = array_fast_read; - p->equal = array_equal; - p->c_sxhash = array_sxhash; -} - -void -init_storage_a (void) -{ - gc_protect (&bashnum); - bashnum = newcell (tc_flonum); - init_storage_a1 (tc_string); - init_storage_a1 (tc_double_array); - init_storage_a1 (tc_long_array); - init_storage_a1 (tc_lisp_array); - init_storage_a1 (tc_byte_array); -} - -LISP -array_gc_relocate (LISP ptr) -{ - LISP nw; - if ((nw = heap) >= heap_end) - gc_fatal_error (); - heap = nw + 1; - memcpy (nw, ptr, sizeof (struct obj)); - return (nw); -} - -void -array_gc_scan (LISP ptr) -{ - long j; - if TYPEP - (ptr, tc_lisp_array) - for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j) - ptr->storage_as.lisp_array.data[j] = - gc_relocate (ptr->storage_as.lisp_array.data[j]); -} - -LISP -array_gc_mark (LISP ptr) -{ - long j; - if TYPEP - (ptr, tc_lisp_array) - for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j) - gc_mark (ptr->storage_as.lisp_array.data[j]); - return (NIL); -} - -void -array_gc_free (LISP ptr) -{ - switch (ptr->type) - { - case tc_string: - case tc_byte_array: - free (ptr->storage_as.string.data); - break; - case tc_double_array: - free (ptr->storage_as.double_array.data); - break; - case tc_long_array: - free (ptr->storage_as.long_array.data); - break; - case tc_lisp_array: - free (ptr->storage_as.lisp_array.data); - break; - } -} - -void -array_prin1 (LISP ptr, struct gen_printio *f) -{ - int j; - switch (ptr->type) - { - case tc_string: - gput_st (f, "\""); - if (strcspn (ptr->storage_as.string.data, "\"\\\n\r\t") == - strlen (ptr->storage_as.string.data)) - gput_st (f, ptr->storage_as.string.data); - else - { - int n, c; - char cbuff[3]; - n = strlen (ptr->storage_as.string.data); - for (j = 0; j < n; ++j) - switch (c = ptr->storage_as.string.data[j]) - { - case '\\': - case '"': - cbuff[0] = '\\'; - cbuff[1] = c; - cbuff[2] = 0; - gput_st (f, cbuff); - break; - case '\n': - gput_st (f, "\\n"); - break; - case '\r': - gput_st (f, "\\r"); - break; - case '\t': - gput_st (f, "\\t"); - break; - default: - cbuff[0] = c; - cbuff[1] = 0; - gput_st (f, cbuff); - break; - } - } - gput_st (f, "\""); - break; - case tc_double_array: - gput_st (f, "#("); - for (j = 0; j < ptr->storage_as.double_array.dim; ++j) - { - g_ascii_formatd (tkbuffer, TKBUFFERN, "%g", - ptr->storage_as.double_array.data[j]); - gput_st (f, tkbuffer); - if ((j + 1) < ptr->storage_as.double_array.dim) - gput_st (f, " "); - } - gput_st (f, ")"); - break; - case tc_long_array: - gput_st (f, "#("); - for (j = 0; j < ptr->storage_as.long_array.dim; ++j) - { - sprintf (tkbuffer, "%ld", ptr->storage_as.long_array.data[j]); - gput_st (f, tkbuffer); - if ((j + 1) < ptr->storage_as.long_array.dim) - gput_st (f, " "); - } - gput_st (f, ")"); - case tc_byte_array: - sprintf (tkbuffer, "#%ld\"", ptr->storage_as.string.dim); - gput_st (f, tkbuffer); - for (j = 0; j < ptr->storage_as.string.dim; ++j) - { - sprintf (tkbuffer, "%02x", ptr->storage_as.string.data[j] & 0xFF); - gput_st (f, tkbuffer); - } - gput_st (f, "\""); - break; - case tc_lisp_array: - gput_st (f, "#("); - for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j) - { - lprin1g (ptr->storage_as.lisp_array.data[j], f); - if ((j + 1) < ptr->storage_as.lisp_array.dim) - gput_st (f, " "); - } - gput_st (f, ")"); - break; - } -} - -LISP -strcons (long length, char *data) -{ - long flag; - LISP s; - flag = no_interrupt (1); - s = cons (NIL, NIL); - s->type = tc_string; - if (length == -1) - length = strlen (data); - s->storage_as.string.data = must_malloc (length + 1); - s->storage_as.string.dim = length; - if (data) - memcpy (s->storage_as.string.data, data, length); - s->storage_as.string.data[length] = 0; - no_interrupt (flag); - return (s); -} - -int -rfs_getc (unsigned char **p) -{ - int i; - i = **p; - if (!i) - return (EOF); - *p = *p + 1; - return (i); -} - -void -rfs_ungetc (unsigned char c, unsigned char **p) -{ - *p = *p - 1; -} - -LISP -read_from_string (LISP x) -{ - char *p; - struct gen_readio s; - p = get_c_string (x); - s.getc_fcn = (int (*)(void *)) rfs_getc; - s.ungetc_fcn = (void (*)(int, void *)) rfs_ungetc; - s.cb_argument = (char *) &p; - return (readtl (&s)); -} - -int -pts_puts (char *from, void *cb) -{ - LISP into; - size_t fromlen, intolen, intosize, fitsize; - into = (LISP) cb; - fromlen = strlen (from); - intolen = strlen (into->storage_as.string.data); - intosize = into->storage_as.string.dim - intolen; - fitsize = (fromlen < intosize) ? fromlen : intosize; - memcpy (&into->storage_as.string.data[intolen], from, fitsize); - into->storage_as.string.data[intolen + fitsize] = 0; - if (fitsize < fromlen) - my_err ("print to string overflow", NIL); - return (1); -} - -LISP -err_wta_str (LISP exp) -{ - return (my_err ("not a string", exp)); -} - -LISP -print_to_string (LISP exp, LISP str, LISP nostart) -{ - struct gen_printio s; - if NTYPEP - (str, tc_string) err_wta_str (str); - s.putc_fcn = NULL; - s.puts_fcn = pts_puts; - s.cb_argument = str; - if NULLP - (nostart) - str->storage_as.string.data[0] = 0; - lprin1g (exp, &s); - return (str); -} - -LISP -aref1 (LISP a, LISP i) -{ - long k; - if NFLONUMP - (i) my_err ("bad index to aref", i); - k = (long) FLONM (i); - if (k < 0) - my_err ("negative index to aref", i); - switch TYPE - (a) - { - case tc_string: - case tc_byte_array: - if (k >= a->storage_as.string.dim) - my_err ("index too large", i); - return (flocons ((double) a->storage_as.string.data[k])); - case tc_double_array: - if (k >= a->storage_as.double_array.dim) - my_err ("index too large", i); - return (flocons (a->storage_as.double_array.data[k])); - case tc_long_array: - if (k >= a->storage_as.long_array.dim) - my_err ("index too large", i); - return (flocons (a->storage_as.long_array.data[k])); - case tc_lisp_array: - if (k >= a->storage_as.lisp_array.dim) - my_err ("index too large", i); - return (a->storage_as.lisp_array.data[k]); - default: - return (my_err ("invalid argument to aref", a)); - } -} - -void -err1_aset1 (LISP i) -{ - my_err ("index to aset too large", i); -} - -void -err2_aset1 (LISP v) -{ - my_err ("bad value to store in array", v); -} - -LISP -aset1 (LISP a, LISP i, LISP v) -{ - long k; - if NFLONUMP - (i) my_err ("bad index to aset", i); - k = (long) FLONM (i); - if (k < 0) - my_err ("negative index to aset", i); - switch TYPE - (a) - { - case tc_string: - case tc_byte_array: - if NFLONUMP - (v) err2_aset1 (v); - if (k >= a->storage_as.string.dim) - err1_aset1 (i); - a->storage_as.string.data[k] = (char) FLONM (v); - return (v); - case tc_double_array: - if NFLONUMP - (v) err2_aset1 (v); - if (k >= a->storage_as.double_array.dim) - err1_aset1 (i); - a->storage_as.double_array.data[k] = FLONM (v); - return (v); - case tc_long_array: - if NFLONUMP - (v) err2_aset1 (v); - if (k >= a->storage_as.long_array.dim) - err1_aset1 (i); - a->storage_as.long_array.data[k] = (long) FLONM (v); - return (v); - case tc_lisp_array: - if (k >= a->storage_as.lisp_array.dim) - err1_aset1 (i); - a->storage_as.lisp_array.data[k] = v; - return (v); - default: - return (my_err ("invalid argument to aset", a)); - } -} - -LISP -arcons (long typecode, long n, long initp) -{ - LISP a; - long flag, j; - flag = no_interrupt (1); - a = cons (NIL, NIL); - switch (typecode) - { - case tc_double_array: - a->storage_as.double_array.dim = n; - a->storage_as.double_array.data = (double *) must_malloc (n * - sizeof (double)); - if (initp) - for (j = 0; j < n; ++j) - a->storage_as.double_array.data[j] = 0.0; - break; - case tc_long_array: - a->storage_as.long_array.dim = n; - a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long)); - if (initp) - for (j = 0; j < n; ++j) - a->storage_as.long_array.data[j] = 0; - break; - case tc_string: - a->storage_as.string.dim = n; - a->storage_as.string.data = (char *) must_malloc (n + 1); - a->storage_as.string.data[n] = 0; - if (initp) - for (j = 0; j < n; ++j) - a->storage_as.string.data[j] = ' '; - case tc_byte_array: - a->storage_as.string.dim = n; - a->storage_as.string.data = (char *) must_malloc (n); - if (initp) - for (j = 0; j < n; ++j) - a->storage_as.string.data[j] = 0; - break; - case tc_lisp_array: - a->storage_as.lisp_array.dim = n; - a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP)); - for (j = 0; j < n; ++j) - a->storage_as.lisp_array.data[j] = NIL; - break; - default: - errswitch (); - } - a->type = typecode; - no_interrupt (flag); - return (a); -} - -LISP -mallocl (void *place, long size) -{ - long n, r; - LISP retval; - n = size / sizeof (long); - r = size % sizeof (long); - if (r) - ++n; - retval = arcons (tc_long_array, n, 0); - *(long **) place = retval->storage_as.long_array.data; - return (retval); -} - -LISP -cons_array (LISP dim, LISP kind) -{ - LISP a; - long flag, n, j; - if (NFLONUMP (dim) || (FLONM (dim) < 0)) - return (my_err ("bad dimension to cons-array", dim)); - else - n = (long) FLONM (dim); - flag = no_interrupt (1); - a = cons (NIL, NIL); - if EQ - (cintern ("double"), kind) - { - a->type = tc_double_array; - a->storage_as.double_array.dim = n; - a->storage_as.double_array.data = (double *) must_malloc (n * - sizeof (double)); - for (j = 0; j < n; ++j) - a->storage_as.double_array.data[j] = 0.0; - } - else if EQ - (cintern ("long"), kind) - { - a->type = tc_long_array; - a->storage_as.long_array.dim = n; - a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long)); - for (j = 0; j < n; ++j) - a->storage_as.long_array.data[j] = 0; - } - else if EQ - (cintern ("string"), kind) - { - a->type = tc_string; - a->storage_as.string.dim = n; - a->storage_as.string.data = (char *) must_malloc (n + 1); - a->storage_as.string.data[n] = 0; - for (j = 0; j < n; ++j) - a->storage_as.string.data[j] = ' '; - } - else if EQ - (cintern ("byte"), kind) - { - a->type = tc_byte_array; - a->storage_as.string.dim = n; - a->storage_as.string.data = (char *) must_malloc (n); - for (j = 0; j < n; ++j) - a->storage_as.string.data[j] = 0; - } - else if (EQ (cintern ("lisp"), kind) || NULLP (kind)) - { - a->type = tc_lisp_array; - a->storage_as.lisp_array.dim = n; - a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP)); - for (j = 0; j < n; ++j) - a->storage_as.lisp_array.data[j] = NIL; - } - else - my_err ("bad type of array", kind); - no_interrupt (flag); - return (a); -} - -LISP -string_append (LISP args) -{ - long size; - LISP l, s; - char *data; - size = 0; - for (l = args; NNULLP (l); l = cdr (l)) - size += strlen (get_c_string (car (l))); - s = strcons (size, NULL); - data = s->storage_as.string.data; - data[0] = 0; - for (l = args; NNULLP (l); l = cdr (l)) - strcat (data, get_c_string (car (l))); - return (s); -} - -LISP -bytes_append (LISP args) -{ - long size, n, j; - LISP l, s; - char *data, *ptr; - size = 0; - for (l = args; NNULLP (l); l = cdr (l)) - { - get_c_string_dim (car (l), &n); - size += n; - } - s = arcons (tc_byte_array, size, 0); - data = s->storage_as.string.data; - for (j = 0, l = args; NNULLP (l); l = cdr (l)) - { - ptr = get_c_string_dim (car (l), &n); - memcpy (&data[j], ptr, n); - j += n; - } - return (s); -} - -LISP -substring (LISP str, LISP start, LISP end) -{ - long s, e, n; - char *data; - data = get_c_string_dim (str, &n); - s = get_c_long (start); - if NULLP - (end) - e = n; - else - e = get_c_long (end); - if ((s < 0) || (s > e)) - my_err ("bad start index", start); - if ((e < 0) || (e > n)) - my_err ("bad end index", end); - return (strcons (e - s, &data[s])); -} - -LISP -string_search (LISP token, LISP str) -{ - char *s1, *s2, *ptr; - s1 = get_c_string (str); - s2 = get_c_string (token); - ptr = strstr (s1, s2); - if (ptr) - return (flocons (ptr - s1)); - else - return (NIL); -} - -#define IS_TRIM_SPACE(_x) (strchr(" \t\r\n",(_x))) - -LISP -string_trim (LISP str) -{ - char *start, *end; /*, *sp = " \t\r\n";*/ - start = get_c_string (str); - while (*start && IS_TRIM_SPACE (*start)) - ++start; - end = &start[strlen (start)]; - while ((end > start) && IS_TRIM_SPACE (*(end - 1))) - --end; - return (strcons (end - start, start)); -} - -LISP -string_trim_left (LISP str) -{ - char *start, *end; - start = get_c_string (str); - while (*start && IS_TRIM_SPACE (*start)) - ++start; - end = &start[strlen (start)]; - return (strcons (end - start, start)); -} - -LISP -string_trim_right (LISP str) -{ - char *start, *end; - start = get_c_string (str); - end = &start[strlen (start)]; - while ((end > start) && IS_TRIM_SPACE (*(end - 1))) - --end; - return (strcons (end - start, start)); -} - -LISP -string_upcase (LISP str) -{ - LISP result; - char *s1, *s2; - long j, n; - s1 = get_c_string (str); - n = strlen (s1); - result = strcons (n, s1); - s2 = get_c_string (result); - for (j = 0; j < n; ++j) - s2[j] = toupper (s2[j]); - return (result); -} - -LISP -string_downcase (LISP str) -{ - LISP result; - char *s1, *s2; - long j, n; - s1 = get_c_string (str); - n = strlen (s1); - result = strcons (n, s1); - s2 = get_c_string (result); - for (j = 0; j < n; ++j) - s2[j] = tolower (s2[j]); - return (result); -} - -LISP -lreadstring (struct gen_readio * f) -{ - int j, c, n, ndigits; - char *p; - j = 0; - p = tkbuffer; - while (((c = GETC_FCN (f)) != '"') && (c != EOF)) - { - if (c == '\\') - { - c = GETC_FCN (f); - if (c == EOF) - my_err ("eof after \\", NIL); - switch (c) - { - case '\\': - c = '\\'; - break; - case 'n': - c = '\n'; - break; - case 't': - c = '\t'; - break; - case 'r': - c = '\r'; - break; - case 'd': - c = 0x04; - break; - case 'N': - c = 0; - break; - case 's': - c = ' '; - break; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - n = c - '0'; - ndigits = 1; - while (ndigits < 3) - { - c = GETC_FCN (f); - if (c == EOF) - my_err ("eof after \\0", NIL); - if (c >= '0' && c <= '7') - { - n = n * 8 + c - '0'; - ndigits++; - } - else - { - UNGETC_FCN (c, f); - break; - } - } - c = n; - } - } - if ((j + 1) >= TKBUFFERN) - my_err ("read string overflow", NIL); - ++j; - *p++ = c; - } - *p = 0; - return (strcons (j, tkbuffer)); -} - - -LISP -lreadsharp (struct gen_readio * f) -{ - LISP obj, l, result; - long j, n; - int c; - c = GETC_FCN (f); - switch (c) - { - case '(': - UNGETC_FCN (c, f); - obj = lreadr (f); - n = nlength (obj); - result = arcons (tc_lisp_array, n, 1); - for (l = obj, j = 0; j < n; l = cdr (l), ++j) - result->storage_as.lisp_array.data[j] = car (l); - return (result); - case '.': - obj = lreadr (f); - return (leval (obj, NIL)); - case 'f': - return (NIL); - case 't': - return (flocons (1)); - default: - return (my_err ("readsharp syntax not handled", NIL)); - } -} - -#define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod)) - -long -c_sxhash (LISP obj, long n) -{ - long hash; - unsigned char *s; - LISP tmp; - struct user_type_hooks *p; - STACK_CHECK (&obj); - INTERRUPT_CHECK (); - switch TYPE - (obj) - { - case tc_nil: - return (0); - case tc_cons: - hash = c_sxhash (CAR (obj), n); - for (tmp = CDR (obj); CONSP (tmp); tmp = CDR (tmp)) - hash = HASH_COMBINE (hash, c_sxhash (CAR (tmp), n), n); - hash = HASH_COMBINE (hash, c_sxhash (tmp, n), n); - return (hash); - case tc_symbol: - for (hash = 0, s = (unsigned char *) PNAME (obj); *s; ++s) - hash = HASH_COMBINE (hash, *s, n); - return (hash); - case tc_subr_0: - case tc_subr_1: - case tc_subr_2: - case tc_subr_3: - case tc_subr_4: - case tc_subr_5: - case tc_lsubr: - case tc_fsubr: - case tc_msubr: - for (hash = 0, s = (unsigned char *) obj->storage_as.subr.name; *s; ++s) - hash = HASH_COMBINE (hash, *s, n); - return (hash); - case tc_flonum: - return (((unsigned long) FLONM (obj)) % n); - default: - p = get_user_type_hooks (TYPE (obj)); - if (p->c_sxhash) - return ((*p->c_sxhash) (obj, n)); - else - return (0); - } -} - -LISP -sxhash (LISP obj, LISP n) -{ - return (flocons (c_sxhash (obj, FLONUMP (n) ? (long) FLONM (n) : 10000))); -} - -LISP -equal (LISP a, LISP b) -{ - struct user_type_hooks *p; - long atype; - STACK_CHECK (&a); -loop: - INTERRUPT_CHECK (); - if EQ - (a, b) return (sym_t); - atype = TYPE (a); - if (atype != TYPE (b)) - return (NIL); - switch (atype) - { - case tc_cons: - if NULLP - (equal (car (a), car (b))) return (NIL); - a = cdr (a); - b = cdr (b); - goto loop; - case tc_flonum: - return ((FLONM (a) == FLONM (b)) ? sym_t : NIL); - case tc_symbol: - return (NIL); - default: - p = get_user_type_hooks (atype); - if (p->equal) - return ((*p->equal) (a, b)); - else - return (NIL); - } -} - -LISP -array_equal (LISP a, LISP b) -{ - long j, len; - switch (TYPE (a)) - { - case tc_string: - case tc_byte_array: - len = a->storage_as.string.dim; - if (len != b->storage_as.string.dim) - return (NIL); - if (memcmp (a->storage_as.string.data, b->storage_as.string.data, len) == 0) - return (sym_t); - else - return (NIL); - case tc_long_array: - len = a->storage_as.long_array.dim; - if (len != b->storage_as.long_array.dim) - return (NIL); - if (memcmp (a->storage_as.long_array.data, - b->storage_as.long_array.data, - len * sizeof (long)) == 0) - return (sym_t); - else - return (NIL); - case tc_double_array: - len = a->storage_as.double_array.dim; - if (len != b->storage_as.double_array.dim) - return (NIL); - for (j = 0; j < len; ++j) - if (a->storage_as.double_array.data[j] != - b->storage_as.double_array.data[j]) - return (NIL); - return (sym_t); - case tc_lisp_array: - len = a->storage_as.lisp_array.dim; - if (len != b->storage_as.lisp_array.dim) - return (NIL); - for (j = 0; j < len; ++j) - if NULLP - (equal (a->storage_as.lisp_array.data[j], - b->storage_as.lisp_array.data[j])) - return (NIL); - return (sym_t); - default: - return (errswitch ()); - } -} - -long -array_sxhash (LISP a, long n) -{ - long j, len, hash; - unsigned char *char_data; - unsigned long *long_data; - double *double_data; - switch (TYPE (a)) - { - case tc_string: - case tc_byte_array: - len = a->storage_as.string.dim; - for (j = 0, hash = 0, char_data = (unsigned char *) a->storage_as.string.data; - j < len; - ++j, ++char_data) - hash = HASH_COMBINE (hash, *char_data, n); - return (hash); - case tc_long_array: - len = a->storage_as.long_array.dim; - for (j = 0, hash = 0, long_data = (unsigned long *) a->storage_as.long_array.data; - j < len; - ++j, ++long_data) - hash = HASH_COMBINE (hash, *long_data % n, n); - return (hash); - case tc_double_array: - len = a->storage_as.double_array.dim; - for (j = 0, hash = 0, double_data = a->storage_as.double_array.data; - j < len; - ++j, ++double_data) - hash = HASH_COMBINE (hash, (unsigned long) *double_data % n, n); - return (hash); - case tc_lisp_array: - len = a->storage_as.lisp_array.dim; - for (j = 0, hash = 0; j < len; ++j) - hash = HASH_COMBINE (hash, - c_sxhash (a->storage_as.lisp_array.data[j], n), - n); - return (hash); - default: - errswitch (); - return (0); - } -} - -long -href_index (LISP table, LISP key) -{ - long index; - if NTYPEP - (table, tc_lisp_array) my_err ("not a hash table", table); - index = c_sxhash (key, table->storage_as.lisp_array.dim); - if ((index < 0) || (index >= table->storage_as.lisp_array.dim)) - { - my_err ("sxhash inconsistency", table); - return (0); - } - else - return (index); -} - -LISP -href (LISP table, LISP key) -{ - return (cdr (assoc (key, - table->storage_as.lisp_array.data[href_index (table, key)]))); -} - -LISP -hset (LISP table, LISP key, LISP value) -{ - long index; - LISP cell, l; - index = href_index (table, key); - l = table->storage_as.lisp_array.data[index]; - if NNULLP - (cell = assoc (key, l)) - return (setcdr (cell, value)); - cell = cons (key, value); - table->storage_as.lisp_array.data[index] = cons (cell, l); - return (value); -} - -LISP -assoc (LISP x, LISP alist) -{ - LISP l, tmp; - for (l = alist; CONSP (l); l = CDR (l)) - { - tmp = CAR (l); - if (CONSP (tmp) && equal (CAR (tmp), x)) - return (tmp); - INTERRUPT_CHECK (); - } - if EQ - (l, NIL) return (NIL); - return (my_err ("improper list to assoc", alist)); -} - -LISP -assv (LISP x, LISP alist) -{ - LISP l, tmp; - for (l = alist; CONSP (l); l = CDR (l)) - { - tmp = CAR (l); - if (CONSP (tmp) && NNULLP (eql (CAR (tmp), x))) - return (tmp); - INTERRUPT_CHECK (); - } - if EQ - (l, NIL) return (NIL); - return (my_err ("improper list to assv", alist)); -} - -void -put_long (long i, FILE * f) -{ - fwrite (&i, sizeof (long), 1, f); -} - -long -get_long (FILE * f) -{ - long i; - fread (&i, sizeof (long), 1, f); - return (i); -} - -long -fast_print_table (LISP obj, LISP table) -{ - FILE *f; - LISP ht, index; - f = get_c_file (car (table), (FILE *) NULL); - if NULLP - (ht = car (cdr (table))) - return (1); - index = href (ht, obj); - if NNULLP - (index) - { - putc (FO_fetch, f); - put_long (get_c_long (index), f); - return (0); - } - if NULLP - (index = car (cdr (cdr (table)))) - return (1); - hset (ht, obj, index); - FLONM (bashnum) = 1.0; - setcar (cdr (cdr (table)), plus (index, bashnum)); - putc (FO_store, f); - put_long (get_c_long (index), f); - return (1); -} - -LISP -fast_print (LISP obj, LISP table) -{ - FILE *f; - long len; - LISP tmp; - struct user_type_hooks *p; - STACK_CHECK (&obj); - f = get_c_file (car (table), (FILE *) NULL); - switch (TYPE (obj)) - { - case tc_nil: - putc (tc_nil, f); - return (NIL); - case tc_cons: - for (len = 0, tmp = obj; CONSP (tmp); tmp = CDR (tmp)) - { - INTERRUPT_CHECK (); - ++len; - } - if (len == 1) - { - putc (tc_cons, f); - fast_print (car (obj), table); - fast_print (cdr (obj), table); - } - else if NULLP - (tmp) - { - putc (FO_list, f); - put_long (len, f); - for (tmp = obj; CONSP (tmp); tmp = CDR (tmp)) - fast_print (CAR (tmp), table); - } - else - { - putc (FO_listd, f); - put_long (len, f); - for (tmp = obj; CONSP (tmp); tmp = CDR (tmp)) - fast_print (CAR (tmp), table); - fast_print (tmp, table); - } - return (NIL); - case tc_flonum: - putc (tc_flonum, f); - fwrite (&obj->storage_as.flonum.data, - sizeof (obj->storage_as.flonum.data), - 1, - f); - return (NIL); - case tc_symbol: - if (fast_print_table (obj, table)) - { - putc (tc_symbol, f); - len = strlen (PNAME (obj)); - if (len >= TKBUFFERN) - my_err ("symbol name too long", obj); - put_long (len, f); - fwrite (PNAME (obj), len, 1, f); - return (sym_t); - } - else - return (NIL); - default: - p = get_user_type_hooks (TYPE (obj)); - if (p->fast_print) - return ((*p->fast_print) (obj, table)); - else - return (my_err ("cannot fast-print", obj)); - } -} - -LISP -fast_read (LISP table) -{ - FILE *f; - LISP tmp, l; - struct user_type_hooks *p; - int c; - long len; - f = get_c_file (car (table), (FILE *) NULL); - c = getc (f); - if (c == EOF) - return (table); - switch (c) - { - case FO_comment: - while ((c = getc (f))) - switch (c) - { - case EOF: - return (table); - case '\n': - return (fast_read (table)); - } - case FO_fetch: - len = get_long (f); - FLONM (bashnum) = len; - return (href (car (cdr (table)), bashnum)); - case FO_store: - len = get_long (f); - tmp = fast_read (table); - hset (car (cdr (table)), flocons (len), tmp); - return (tmp); - case tc_nil: - return (NIL); - case tc_cons: - tmp = fast_read (table); - return (cons (tmp, fast_read (table))); - case FO_list: - case FO_listd: - len = get_long (f); - FLONM (bashnum) = len; - l = make_list (bashnum, NIL); - tmp = l; - while (len > 1) - { - CAR (tmp) = fast_read (table); - tmp = CDR (tmp); - --len; - } - CAR (tmp) = fast_read (table); - if (c == FO_listd) - CDR (tmp) = fast_read (table); - return (l); - case tc_flonum: - tmp = newcell (tc_flonum); - fread (&tmp->storage_as.flonum.data, - sizeof (tmp->storage_as.flonum.data), - 1, - f); - return (tmp); - case tc_symbol: - len = get_long (f); - if (len >= TKBUFFERN) - my_err ("symbol name too long", NIL); - fread (tkbuffer, len, 1, f); - tkbuffer[len] = 0; - return (rintern (tkbuffer)); - default: - p = get_user_type_hooks (c); - if (p->fast_read) - return (*p->fast_read) (c, table); - else - return (my_err ("unknown fast-read opcode", flocons (c))); - } -} - -LISP -array_fast_print (LISP ptr, LISP table) -{ - int j, len; - FILE *f; - f = get_c_file (car (table), (FILE *) NULL); - switch (ptr->type) - { - case tc_string: - case tc_byte_array: - putc (ptr->type, f); - len = ptr->storage_as.string.dim; - put_long (len, f); - fwrite (ptr->storage_as.string.data, len, 1, f); - return (NIL); - case tc_double_array: - putc (tc_double_array, f); - len = ptr->storage_as.double_array.dim * sizeof (double); - put_long (len, f); - fwrite (ptr->storage_as.double_array.data, len, 1, f); - return (NIL); - case tc_long_array: - putc (tc_long_array, f); - len = ptr->storage_as.long_array.dim * sizeof (long); - put_long (len, f); - fwrite (ptr->storage_as.long_array.data, len, 1, f); - return (NIL); - case tc_lisp_array: - putc (tc_lisp_array, f); - len = ptr->storage_as.lisp_array.dim; - put_long (len, f); - for (j = 0; j < len; ++j) - fast_print (ptr->storage_as.lisp_array.data[j], table); - return (NIL); - default: - return (errswitch ()); - } -} - -LISP -array_fast_read (int code, LISP table) -{ - long j, len, iflag; - FILE *f; - LISP ptr; - f = get_c_file (car (table), (FILE *) NULL); - switch (code) - { - case tc_string: - len = get_long (f); - ptr = strcons (len, NULL); - fread (ptr->storage_as.string.data, len, 1, f); - ptr->storage_as.string.data[len] = 0; - return (ptr); - case tc_byte_array: - len = get_long (f); - iflag = no_interrupt (1); - ptr = newcell (tc_byte_array); - ptr->storage_as.string.dim = len; - ptr->storage_as.string.data = - (char *) must_malloc (len); - fread (ptr->storage_as.string.data, len, 1, f); - no_interrupt (iflag); - return (ptr); - case tc_double_array: - len = get_long (f); - iflag = no_interrupt (1); - ptr = newcell (tc_double_array); - ptr->storage_as.double_array.dim = len; - ptr->storage_as.double_array.data = - (double *) must_malloc (len * sizeof (double)); - fread (ptr->storage_as.double_array.data, sizeof (double), len, f); - no_interrupt (iflag); - return (ptr); - case tc_long_array: - len = get_long (f); - iflag = no_interrupt (1); - ptr = newcell (tc_long_array); - ptr->storage_as.long_array.dim = len; - ptr->storage_as.long_array.data = - (long *) must_malloc (len * sizeof (long)); - fread (ptr->storage_as.long_array.data, sizeof (long), len, f); - no_interrupt (iflag); - return (ptr); - case tc_lisp_array: - len = get_long (f); - FLONM (bashnum) = len; - ptr = cons_array (bashnum, NIL); - for (j = 0; j < len; ++j) - ptr->storage_as.lisp_array.data[j] = fast_read (table); - return (ptr); - default: - return (errswitch ()); - } -} - -long -get_c_long (LISP x) -{ - if NFLONUMP - (x) my_err ("not a number", x); - return ((long) FLONM (x)); -} - -double -get_c_double (LISP x) -{ - if NFLONUMP - (x) my_err ("not a number", x); - return (FLONM (x)); -} - -LISP -make_list (LISP x, LISP v) -{ - long n; - LISP l; - n = get_c_long (x); - l = NIL; - while (n > 0) - { - l = cons (v, l); - --n; - } - return (l); -} - -LISP -lfread (LISP size, LISP file) -{ - long flag, n, ret, m; - char *buffer; - LISP s; - FILE *f; - f = get_c_file (file, stdin); - flag = no_interrupt (1); - switch (TYPE (size)) - { - case tc_string: - case tc_byte_array: - s = size; - buffer = s->storage_as.string.data; - n = s->storage_as.string.dim; - m = 0; - break; - default: - n = get_c_long (size); - buffer = (char *) must_malloc (n + 1); - buffer[n] = 0; - m = 1; - } - ret = fread (buffer, 1, n, f); - if (ret == 0) - { - if (m) - free (buffer); - no_interrupt (flag); - return (NIL); - } - if (m) - { - if (ret == n) - { - s = cons (NIL, NIL); - s->type = tc_string; - s->storage_as.string.data = buffer; - s->storage_as.string.dim = n; - } - else - { - s = strcons (ret, NULL); - memcpy (s->storage_as.string.data, buffer, ret); - free (buffer); - } - no_interrupt (flag); - return (s); - } - no_interrupt (flag); - return (flocons ((double) ret)); -} - -LISP -lfwrite (LISP string, LISP file) -{ - FILE *f; - long flag; - char *data; - long dim, len; - f = get_c_file (file, stdout); - data = get_c_string_dim (CONSP (string) ? car (string) : string, &dim); - len = CONSP (string) ? get_c_long (cadr (string)) : dim; - if (len <= 0) - return (NIL); - if (len > dim) - my_err ("write length too long", string); - flag = no_interrupt (1); - fwrite (data, 1, len, f); - no_interrupt (flag); - return (NIL); -} - -LISP -lfflush (LISP file) -{ - FILE *f; - long flag; - f = get_c_file (file, stdout); - flag = no_interrupt (1); - fflush (f); - no_interrupt (flag); - return (NIL); -} - -LISP -string_length (LISP string) -{ - if NTYPEP - (string, tc_string) err_wta_str (string); - return (flocons (strlen (string->storage_as.string.data))); -} - -LISP -string_dim (LISP string) -{ - if NTYPEP - (string, tc_string) err_wta_str (string); - return (flocons ((double) string->storage_as.string.dim)); -} - -long -nlength (LISP obj) -{ - LISP l; - long n; - switch TYPE - (obj) - { - case tc_string: - return (strlen (obj->storage_as.string.data)); - case tc_byte_array: - return (obj->storage_as.string.dim); - case tc_double_array: - return (obj->storage_as.double_array.dim); - case tc_long_array: - return (obj->storage_as.long_array.dim); - case tc_lisp_array: - return (obj->storage_as.lisp_array.dim); - case tc_nil: - return (0); - case tc_cons: - for (l = obj, n = 0; CONSP (l); l = CDR (l), ++n) - INTERRUPT_CHECK (); - if NNULLP - (l) my_err ("improper list to length", obj); - return (n); - default: - my_err ("wta to length", obj); - return (0); - } -} - -LISP -llength (LISP obj) -{ - return (flocons (nlength (obj))); -} - -LISP -number2string (LISP x, LISP b, LISP w, LISP p) -{ - char buffer[1000]; - double y; - long base, width, prec; - if NFLONUMP - (x) my_err ("wta", x); - y = FLONM (x); - width = NNULLP (w) ? get_c_long (w) : -1; - if (width > 100) - my_err ("width too long", w); - prec = NNULLP (p) ? get_c_long (p) : -1; - if (prec > 100) - my_err ("precision too large", p); - if (NULLP (b) || EQ (sym_e, b) || EQ (sym_f, b)) - { - char format[32]; - - if ((width >= 0) && (prec >= 0)) - sprintf (format, - NULLP (b) ? "%%%ld.%ldg" : - EQ (sym_e, b) ? "%%%ld.%ldd" : "%%%ld.%ldf", - width, prec); - else if (width >= 0) - sprintf (format, - NULLP (b) ? "%%%ldg" : EQ (sym_e, b) ? "%%%lde" : "%%%ldf", - width); - else if (prec >= 0) - sprintf (format, - NULLP (b) ? "%%.%ldg" : EQ (sym_e, b) ? "%%.%lde" : "%%.%ldf", - prec); - else - sprintf (format, NULLP (b) ? "%%g" : EQ (sym_e, b) ? "%%e" : "%%f"); - - g_ascii_formatd (buffer, sizeof(buffer), format, y); - } - else if (((base = get_c_long (b)) == 10) || (base == 8) || (base == 16)) - { - if (width >= 0) - sprintf (buffer, - (base == 10) ? "%0*ld" : (base == 8) ? "%0*lo" : "%0*lX", - (int) width, - (long) y); - else - sprintf (buffer, - (base == 10) ? "%ld" : (base == 8) ? "%lo" : "%lX", - (long) y); - } - else - my_err ("number base not handled", b); - return (strcons (strlen (buffer), buffer)); -} - -LISP -string2number (LISP x, LISP b) -{ - char *str; - long base, value = 0; - double result = 0.0; - str = get_c_string (x); - if NULLP - (b) - result = g_ascii_strtod (str, NULL); - else if ((base = get_c_long (b)) == 10) - { - sscanf (str, "%ld", &value); - result = (double) value; - } - else if (base == 8) - { - sscanf (str, "%lo", &value); - result = (double) value; - } - else if (base == 16) - { - sscanf (str, "%lx", &value); - result = (double) value; - } - else if ((base >= 1) && (base <= 16)) - { - for (result = 0.0; *str; ++str) - if (isdigit (*str)) - result = result * base + *str - '0'; - else if (isxdigit (*str)) - result = result * base + toupper (*str) - 'A' + 10; - } - else - my_err ("number base not handled", b); - return (flocons (result)); -} - -LISP -lstrcmp (LISP s1, LISP s2) -{ - return (flocons (strcmp (get_c_string (s1), get_c_string (s2)))); -} - -void -chk_string (LISP s, char **data, long *dim) -{ - if TYPEP - (s, tc_string) - { - *data = s->storage_as.string.data; - *dim = s->storage_as.string.dim; - } - else - err_wta_str (s); -} - -LISP -lstrcpy (LISP dest, LISP src) -{ - long ddim, slen; - char *d, *s; - chk_string (dest, &d, &ddim); - s = get_c_string (src); - slen = strlen (s); - if (slen > ddim) - my_err ("string too long", src); - memcpy (d, s, slen); - d[slen] = 0; - return (NIL); -} - -LISP -lstrcat (LISP dest, LISP src) -{ - long ddim, dlen, slen; - char *d, *s; - chk_string (dest, &d, &ddim); - s = get_c_string (src); - slen = strlen (s); - dlen = strlen (d); - if ((slen + dlen) > ddim) - my_err ("string too long", src); - memcpy (&d[dlen], s, slen); - d[dlen + slen] = 0; - return (NIL); -} - -LISP -lstrbreakup (LISP str, LISP lmarker) -{ - char *start, *end, *marker; - size_t k; - LISP result = NIL; - start = end = get_c_string (str); - marker = get_c_string (lmarker); - k = strlen (marker); - if (*marker) - { - while (*end) - { - if (!(end = strstr (start, marker))) - end = &start[strlen (start)]; - result = cons (strcons (end - start, start), result); - start = (*end) ? end + k : end; - } - return (nreverse (result)); - } - else - return (strcons (strlen (start), start)); -} - -LISP -lstrunbreakup (LISP elems, LISP lmarker) -{ - LISP result, l; - for (l = elems, result = NIL; NNULLP (l); l = cdr (l)) - if EQ - (l, elems) - result = cons (car (l), result); - else - result = cons (car (l), cons (lmarker, result)); - return (string_append (nreverse (result))); -} - -LISP -stringp (LISP x) -{ - return (TYPEP (x, tc_string) ? sym_t : NIL); -} - -static char *base64_encode_table = "\ -ABCDEFGHIJKLMNOPQRSTUVWXYZ\ -abcdefghijklmnopqrstuvwxyz\ -0123456789+/="; - -static char *base64_decode_table = NULL; - -static void -init_base64_table (void) -{ - int j; - base64_decode_table = (char *) malloc (256); - memset (base64_decode_table, -1, 256); - for (j = 0; j < 65; ++j) - base64_decode_table[(unsigned char) base64_encode_table[j]] = j; -} - -#define BITMSK(N) ((1 << (N)) - 1) - -#define ITEM1(X) (X >> 2) & BITMSK(6) -#define ITEM2(X,Y) ((X & BITMSK(2)) << 4) | ((Y >> 4) & BITMSK(4)) -#define ITEM3(X,Y) ((X & BITMSK(4)) << 2) | ((Y >> 6) & BITMSK(2)) -#define ITEM4(X) X & BITMSK(6) - -LISP -base64encode (LISP in) -{ - char *s, *t = base64_encode_table; - unsigned char *p1, *p2; - LISP out; - long j, m, n, chunks, leftover; - s = get_c_string_dim (in, &n); - chunks = n / 3; - leftover = n % 3; - m = (chunks + ((leftover) ? 1 : 0)) * 4; - out = strcons (m, NULL); - p2 = (unsigned char *) get_c_string (out); - for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 3) - { - *p2++ = t[ITEM1 (p1[0])]; - *p2++ = t[ITEM2 (p1[0], p1[1])]; - *p2++ = t[ITEM3 (p1[1], p1[2])]; - *p2++ = t[ITEM4 (p1[2])]; - } - switch (leftover) - { - case 0: - break; - case 1: - *p2++ = t[ITEM1 (p1[0])]; - *p2++ = t[ITEM2 (p1[0], 0)]; - *p2++ = base64_encode_table[64]; - *p2++ = base64_encode_table[64]; - break; - case 2: - *p2++ = t[ITEM1 (p1[0])]; - *p2++ = t[ITEM2 (p1[0], p1[1])]; - *p2++ = t[ITEM3 (p1[1], 0)]; - *p2++ = base64_encode_table[64]; - break; - default: - errswitch (); - } - return (out); -} - -LISP -base64decode (LISP in) -{ - char *s, *t = base64_decode_table; - LISP out; - unsigned char *p1, *p2; - long j, m, n, chunks, leftover, item1, item2, item3, item4; - s = get_c_string (in); - n = strlen (s); - if (n == 0) - return (strcons (0, NULL)); - if (n % 4) - my_err ("illegal base64 data length", in); - if (s[n - 1] == base64_encode_table[64]) - { - if (s[n - 2] == base64_encode_table[64]) - leftover = 1; - else - leftover = 2; - } - else - leftover = 0; - chunks = (n / 4) - ((leftover) ? 1 : 0); - m = (chunks * 3) + leftover; - out = strcons (m, NULL); - p2 = (unsigned char *) get_c_string (out); - for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 4) - { - if ((item1 = t[p1[0]]) & ~BITMSK (6)) - return (NIL); - if ((item2 = t[p1[1]]) & ~BITMSK (6)) - return (NIL); - if ((item3 = t[p1[2]]) & ~BITMSK (6)) - return (NIL); - if ((item4 = t[p1[3]]) & ~BITMSK (6)) - return (NIL); - *p2++ = (item1 << 2) | (item2 >> 4); - *p2++ = (item2 << 4) | (item3 >> 2); - *p2++ = (item3 << 6) | item4; - } - switch (leftover) - { - case 0: - break; - case 1: - if ((item1 = t[p1[0]]) & ~BITMSK (6)) - return (NIL); - if ((item2 = t[p1[1]]) & ~BITMSK (6)) - return (NIL); - *p2++ = (item1 << 2) | (item2 >> 4); - break; - case 2: - if ((item1 = t[p1[0]]) & ~BITMSK (6)) - return (NIL); - if ((item2 = t[p1[1]]) & ~BITMSK (6)) - return (NIL); - if ((item3 = t[p1[2]]) & ~BITMSK (6)) - return (NIL); - *p2++ = (item1 << 2) | (item2 >> 4); - *p2++ = (item2 << 4) | (item3 >> 2); - break; - default: - errswitch (); - } - return (out); -} - -LISP -memq (LISP x, LISP il) -{ - LISP l, tmp; - for (l = il; CONSP (l); l = CDR (l)) - { - tmp = CAR (l); - if EQ - (x, tmp) return (l); - INTERRUPT_CHECK (); - } - if EQ - (l, NIL) return (NIL); - return (my_err ("improper list to memq", il)); -} - -LISP -member (LISP x, LISP il) -{ - LISP l, tmp; - for (l = il; CONSP (l); l = CDR (l)) - { - tmp = CAR (l); - if NNULLP - (equal (x, tmp)) return (l); - INTERRUPT_CHECK (); - } - if EQ - (l, NIL) return (NIL); - return (my_err ("improper list to member", il)); -} - -LISP -memv (LISP x, LISP il) -{ - LISP l, tmp; - for (l = il; CONSP (l); l = CDR (l)) - { - tmp = CAR (l); - if NNULLP - (eql (x, tmp)) return (l); - INTERRUPT_CHECK (); - } - if EQ - (l, NIL) return (NIL); - return (my_err ("improper list to memv", il)); -} - - -LISP -nth (LISP x, LISP li) -{ - LISP l; - long j, n = get_c_long (x); - for (j = 0, l = li; (j < n) && CONSP (l); ++j) - l = CDR (l); - if CONSP - (l) - return (CAR (l)); - else - return (my_err ("bad arg to nth", x)); -} - -/* these lxxx_default functions are convenient for manipulating - command-line argument lists */ - -LISP -lref_default (LISP li, LISP x, LISP fcn) -{ - LISP l; - long j, n = get_c_long (x); - for (j = 0, l = li; (j < n) && CONSP (l); ++j) - l = CDR (l); - if CONSP - (l) - return (CAR (l)); - else if NNULLP - (fcn) - return (lapply (fcn, NIL)); - else - return (NIL); -} - -LISP -larg_default (LISP li, LISP x, LISP dval) -{ - LISP l = li, elem; - long j = 0, n = get_c_long (x); - while NNULLP - (l) - { - elem = car (l); - if (TYPEP (elem, tc_string) && strchr ("-:", *get_c_string (elem))) - l = cdr (l); - else if (j == n) - return (elem); - else - { - l = cdr (l); - ++j; - } - } - return (dval); -} - -LISP -lkey_default (LISP li, LISP key, LISP dval) -{ - LISP l = li, elem; - char *ckey, *celem; - long n; - ckey = get_c_string (key); - n = strlen (ckey); - while NNULLP - (l) - { - elem = car (l); - if (TYPEP (elem, tc_string) && (*(celem = get_c_string (elem)) == ':') && - (strncmp (&celem[1], ckey, n) == 0) && (celem[n + 1] == '=')) - return (strcons (strlen (&celem[n + 2]), &celem[n + 2])); - l = cdr (l); - } - return (dval); -} - - -LISP -llist (LISP l) -{ - return (l); -} - -LISP -writes1 (FILE * f, LISP l) -{ - LISP v; - STACK_CHECK (&v); - INTERRUPT_CHECK (); - for (v = l; CONSP (v); v = CDR (v)) - writes1 (f, CAR (v)); - switch TYPE - (v) - { - case tc_nil: - break; - case tc_symbol: - case tc_string: - fput_st (f, get_c_string (v)); - break; - default: - lprin1f (v, f); - break; - } - return (NIL); -} - -LISP -writes (LISP args) -{ - return (writes1 (get_c_file (car (args), stdout), cdr (args))); -} - -LISP -last (LISP l) -{ - LISP v1, v2; - v1 = l; - v2 = CONSP (v1) ? CDR (v1) : my_err ("bad arg to last", l); - while (CONSP (v2)) - { - INTERRUPT_CHECK (); - v1 = v2; - v2 = CDR (v2); - } - return (v1); -} - -LISP -butlast (LISP l) -{ - INTERRUPT_CHECK (); - STACK_CHECK (&l); - if NULLP - (l) my_err ("list is empty", l); - if CONSP (l) - { - if NULLP (CDR (l)) - return (NIL); - else - return (cons (CAR (l), butlast (CDR (l)))); - } - return (my_err ("not a list", l)); -} - -LISP -nconc (LISP a, LISP b) -{ - if NULLP - (a) - return (b); - setcdr (last (a), b); - return (a); -} - -LISP -funcall1 (LISP fcn, LISP a1) -{ - switch TYPE - (fcn) - { - case tc_subr_1: - STACK_CHECK (&fcn); - INTERRUPT_CHECK (); - return (SUBR1 (fcn) (a1)); - case tc_closure: - if TYPEP - (fcn->storage_as.closure.code, tc_subr_2) - { - STACK_CHECK (&fcn); - INTERRUPT_CHECK (); - return (SUBR2 (fcn->storage_as.closure.code) - (fcn->storage_as.closure.env, a1)); - } - default: - return (lapply (fcn, cons (a1, NIL))); - } -} - -LISP -funcall2 (LISP fcn, LISP a1, LISP a2) -{ - switch TYPE - (fcn) - { - case tc_subr_2: - case tc_subr_2n: - STACK_CHECK (&fcn); - INTERRUPT_CHECK (); - return (SUBR2 (fcn) (a1, a2)); - default: - return (lapply (fcn, cons (a1, cons (a2, NIL)))); - } -} - -LISP -lqsort (LISP l, LISP f, LISP g) - /* this is a stupid recursive qsort */ -{ - int j, n; - LISP v, mark, less, notless; - for (v = l, n = 0; CONSP (v); v = CDR (v), ++n) - INTERRUPT_CHECK (); - if NNULLP - (v) my_err ("bad list to qsort", l); - if (n == 0) - return (NIL); - j = rand () % n; - for (v = l, n = 0; n < j; ++n) - v = CDR (v); - mark = CAR (v); - for (less = NIL, notless = NIL, v = l, n = 0; NNULLP (v); v = CDR (v), ++n) - if (j != n) - { - if NNULLP - (funcall2 (f, - NULLP (g) ? CAR (v) : funcall1 (g, CAR (v)), - NULLP (g) ? mark : funcall1 (g, mark))) - less = cons (CAR (v), less); - else - notless = cons (CAR (v), notless); - } - return (nconc (lqsort (less, f, g), - cons (mark, - lqsort (notless, f, g)))); -} - -LISP -string_lessp (LISP s1, LISP s2) -{ - if (strcmp (get_c_string (s1), get_c_string (s2)) < 0) - return (sym_t); - else - return (NIL); -} - -LISP -benchmark_funcall1 (LISP ln, LISP f, LISP a1) -{ - long j, n; - LISP value = NIL; - n = get_c_long (ln); - for (j = 0; j < n; ++j) - value = funcall1 (f, a1); - return (value); -} - -LISP -benchmark_funcall2 (LISP l) -{ - long j, n; - LISP ln = car (l); - LISP f = car (cdr (l)); - LISP a1 = car (cdr (cdr (l))); - LISP a2 = car (cdr (cdr (cdr (l)))); - LISP value = NULL; - n = get_c_long (ln); - for (j = 0; j < n; ++j) - value = funcall2 (f, a1, a2); - return (value); -} - -LISP -benchmark_eval (LISP ln, LISP exp, LISP env) -{ - long j, n; - LISP value = NIL; - n = get_c_long (ln); - for (j = 0; j < n; ++j) - value = leval (exp, env); - return (value); -} - -LISP -mapcar1 (LISP fcn, LISP in) -{ - LISP res, ptr, l; - if NULLP - (in) return (NIL); - res = ptr = cons (funcall1 (fcn, car (in)), NIL); - for (l = cdr (in); CONSP (l); l = CDR (l)) - ptr = CDR (ptr) = cons (funcall1 (fcn, CAR (l)), CDR (ptr)); - return (res); -} - -LISP -mapcar2 (LISP fcn, LISP in1, LISP in2) -{ - LISP res, ptr, l1, l2; - if (NULLP (in1) || NULLP (in2)) - return (NIL); - res = ptr = cons (funcall2 (fcn, car (in1), car (in2)), NIL); - for (l1 = cdr (in1), l2 = cdr (in2); CONSP (l1) && CONSP (l2); l1 = CDR (l1), l2 = CDR (l2)) - ptr = CDR (ptr) = cons (funcall2 (fcn, CAR (l1), CAR (l2)), CDR (ptr)); - return (res); -} - -LISP -mapcar (LISP l) -{ - LISP fcn = car (l); - switch (get_c_long (llength (l))) - { - case 2: - return (mapcar1 (fcn, car (cdr (l)))); - case 3: - return (mapcar2 (fcn, car (cdr (l)), car (cdr (cdr (l))))); - default: - return (my_err ("mapcar case not handled", l)); - } -} - -LISP -lfmod (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to fmod", x); - if NFLONUMP - (y) my_err ("wta(2nd) to fmod", y); - return (flocons (fmod (FLONM (x), FLONM (y)))); -} - -LISP -lsubset (LISP fcn, LISP l) -{ - LISP result = NIL, v; - for (v = l; CONSP (v); v = CDR (v)) - if NNULLP - (funcall1 (fcn, CAR (v))) - result = cons (CAR (v), result); - return (nreverse (result)); -} - -LISP -ass (LISP x, LISP alist, LISP fcn) -{ - LISP l, tmp; - for (l = alist; CONSP (l); l = CDR (l)) - { - tmp = CAR (l); - if (CONSP (tmp) && NNULLP (funcall2 (fcn, CAR (tmp), x))) - return (tmp); - INTERRUPT_CHECK (); - } - if EQ - (l, NIL) return (NIL); - return (my_err ("improper list to ass", alist)); -} - -LISP -append2 (LISP l1, LISP l2) -{ - long n; - LISP result = NIL, p1, p2; - n = nlength (l1) + nlength (l2); - while (n > 0) - { - result = cons (NIL, result); - --n; - } - for (p1 = result, p2 = l1; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2)) - setcar (p1, car (p2)); - for (p2 = l2; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2)) - setcar (p1, car (p2)); - return (result); -} - -LISP -append (LISP l) -{ - STACK_CHECK (&l); - INTERRUPT_CHECK (); - if NULLP - (l) - return (NIL); - else if NULLP - (cdr (l)) - return (car (l)); - else if NULLP - (cddr (l)) - return (append2 (car (l), cadr (l))); - else - return (append2 (car (l), append (cdr (l)))); -} - -LISP -listn (long n,...) -{ - LISP result, ptr; - long j; - va_list args; - for (j = 0, result = NIL; j < n; ++j) - result = cons (NIL, result); - va_start (args, n); - for (j = 0, ptr = result; j < n; ptr = cdr (ptr), ++j) - setcar (ptr, va_arg (args, LISP)); - va_end (args); - return (result); -} - - -LISP -fast_load (LISP lfname, LISP noeval) -{ - char *fname; - LISP stream; - LISP result = NIL, form; - fname = get_c_string (lfname); - if (siod_verbose_level >= 3) - { - put_st ("fast loading "); - put_st (fname); - put_st ("\n"); - } - stream = listn (3, - fopen_c (fname, "rb"), - cons_array (flocons (100), NIL), - flocons (0)); - while (NEQ (stream, form = fast_read (stream))) - { - if (siod_verbose_level >= 5) - lprint (form, NIL); - if NULLP - (noeval) - leval (form, NIL); - else - result = cons (form, result); - } - fclose_l (car (stream)); - if (siod_verbose_level >= 3) - put_st ("done.\n"); - return (nreverse (result)); -} - -static void -shexstr (char *outstr, void *buff, size_t len) -{ - unsigned char *data = buff; - size_t j; - for (j = 0; j < len; ++j) - sprintf (&outstr[j * 2], "%02X", data[j]); -} - -LISP -fast_save (LISP fname, LISP forms, LISP nohash, LISP comment) -{ - char *cname, msgbuff[100], databuff[50]; - LISP stream, l; - FILE *f; - long l_one = 1; - double d_one = 1.0; - cname = get_c_string (fname); - if (siod_verbose_level >= 3) - { - put_st ("fast saving forms to "); - put_st (cname); - put_st ("\n"); - } - stream = listn (3, - fopen_c (cname, "wb"), - NNULLP (nohash) ? NIL : cons_array (flocons (100), NIL), - flocons (0)); - f = get_c_file (car (stream), NULL); - if NNULLP - (comment) - fput_st (f, get_c_string (comment)); - sprintf (msgbuff, "# Siod Binary Object Save File\n"); - fput_st (f, msgbuff); - sprintf (msgbuff, "# sizeof(long) = %d\n# sizeof(double) = %d\n", - (int) sizeof (long), (int) sizeof (double)); - fput_st (f, msgbuff); - shexstr (databuff, &l_one, sizeof (l_one)); - sprintf (msgbuff, "# 1 = %s\n", databuff); - fput_st (f, msgbuff); - shexstr (databuff, &d_one, sizeof (d_one)); - sprintf (msgbuff, "# 1.0 = %s\n", databuff); - fput_st (f, msgbuff); - for (l = forms; NNULLP (l); l = cdr (l)) - fast_print (car (l), stream); - fclose_l (car (stream)); - if (siod_verbose_level >= 3) - put_st ("done.\n"); - return (NIL); -} - -void -swrite1 (LISP stream, LISP data) -{ - FILE *f = get_c_file (stream, stdout); - switch TYPE - (data) - { - case tc_symbol: - case tc_string: - fput_st (f, get_c_string (data)); - break; - default: - lprin1f (data, f); - break; - } -} - -LISP -swrite (LISP stream, LISP table, LISP data) -{ - LISP value, key; - long j, k, m, n; - switch (TYPE (data)) - { - case tc_symbol: - value = href (table, data); - if CONSP - (value) - { - swrite1 (stream, CAR (value)); - if NNULLP - (CDR (value)) - hset (table, data, CDR (value)); - } - else - swrite1 (stream, value); - break; - case tc_lisp_array: - n = data->storage_as.lisp_array.dim; - if (n < 1) - my_err ("no object repeat count", data); - key = data->storage_as.lisp_array.data[0]; - if NULLP - (value = href (table, key)) - value = key; - else if CONSP - (value) - { - if NNULLP - (CDR (value)) - hset (table, key, CDR (value)); - value = CAR (value); - } - m = get_c_long (value); - for (k = 0; k < m; ++k) - for (j = 1; j < n; ++j) - swrite (stream, table, data->storage_as.lisp_array.data[j]); - break; - case tc_cons: - /* this should be handled similar to the array case */ - default: - swrite1 (stream, data); - } - return (NIL); -} - -LISP -ltrunc (LISP x) -{ - double cx = get_c_double (x); - return (flocons (cx < 0.0 ? ceil (cx) : floor (cx))); -} - -LISP -lpow (LISP x, LISP y) -{ - if NFLONUMP - (x) my_err ("wta(1st) to pow", x); - if NFLONUMP - (y) my_err ("wta(2nd) to pow", y); - return (flocons (pow (FLONM (x), FLONM (y)))); -} - -LISP -lexp (LISP x) -{ - return (flocons (exp (get_c_double (x)))); -} - -LISP -llog (LISP x) -{ - return (flocons (log (get_c_double (x)))); -} - -LISP -lsin (LISP x) -{ - return (flocons (sin (get_c_double (x)))); -} - -LISP -lcos (LISP x) -{ - return (flocons (cos (get_c_double (x)))); -} - -LISP -ltan (LISP x) -{ - return (flocons (tan (get_c_double (x)))); -} - -LISP -lasin (LISP x) -{ - return (flocons (asin (get_c_double (x)))); -} - -LISP -lacos (LISP x) -{ - return (flocons (acos (get_c_double (x)))); -} - -LISP -latan (LISP x) -{ - return (flocons (atan (get_c_double (x)))); -} - -LISP -latan2 (LISP x, LISP y) -{ - return (flocons (atan2 (get_c_double (x), get_c_double (y)))); -} - -LISP -hexstr (LISP a) -{ - unsigned char *in; - char *out; - LISP result; - long j, dim; - in = (unsigned char *) get_c_string_dim (a, &dim); - result = strcons (dim * 2, NULL); - for (out = get_c_string (result), j = 0; j < dim; ++j, out += 2) - sprintf (out, "%02x", in[j]); - return (result); -} - -static int -xdigitvalue (int c) -{ - if (isdigit (c)) - return (c - '0'); - if (isxdigit (c)) - return (toupper (c) - 'A' + 10); - return (0); -} - -LISP -hexstr2bytes (LISP a) -{ - char *in; - unsigned char *out; - LISP result; - long j, dim; - in = get_c_string (a); - dim = strlen (in) / 2; - result = arcons (tc_byte_array, dim, 0); - out = (unsigned char *) result->storage_as.string.data; - for (j = 0; j < dim; ++j) - out[j] = xdigitvalue (in[j * 2]) * 16 + xdigitvalue (in[j * 2 + 1]); - return (result); -} - -LISP -getprop (LISP plist, LISP key) -{ - LISP l; - for (l = cdr (plist); NNULLP (l); l = cddr (l)) - if EQ - (car (l), key) - return (cadr (l)); - else - INTERRUPT_CHECK (); - return (NIL); -} - -LISP -setprop (LISP plist, LISP key, LISP value) -{ - my_err ("not implemented", NIL); - return (NIL); -} - -LISP -putprop (LISP plist, LISP value, LISP key) -{ - return (setprop (plist, key, value)); -} - -LISP -ltypeof (LISP obj) -{ - long x; - x = TYPE (obj); - switch (x) - { - case tc_nil: - return (cintern ("tc_nil")); - case tc_cons: - return (cintern ("tc_cons")); - case tc_flonum: - return (cintern ("tc_flonum")); - case tc_symbol: - return (cintern ("tc_symbol")); - case tc_subr_0: - return (cintern ("tc_subr_0")); - case tc_subr_1: - return (cintern ("tc_subr_1")); - case tc_subr_2: - return (cintern ("tc_subr_2")); - case tc_subr_2n: - return (cintern ("tc_subr_2n")); - case tc_subr_3: - return (cintern ("tc_subr_3")); - case tc_subr_4: - return (cintern ("tc_subr_4")); - case tc_subr_5: - return (cintern ("tc_subr_5")); - case tc_lsubr: - return (cintern ("tc_lsubr")); - case tc_fsubr: - return (cintern ("tc_fsubr")); - case tc_msubr: - return (cintern ("tc_msubr")); - case tc_closure: - return (cintern ("tc_closure")); - case tc_free_cell: - return (cintern ("tc_free_cell")); - case tc_string: - return (cintern ("tc_string")); - case tc_byte_array: - return (cintern ("tc_byte_array")); - case tc_double_array: - return (cintern ("tc_double_array")); - case tc_long_array: - return (cintern ("tc_long_array")); - case tc_lisp_array: - return (cintern ("tc_lisp_array")); - case tc_c_file: - return (cintern ("tc_c_file")); - default: - return (flocons (x)); - } -} - -LISP -caaar (LISP x) -{ - return (car (car (car (x)))); -} - -LISP -caadr (LISP x) -{ - return (car (car (cdr (x)))); -} - -LISP -cadar (LISP x) -{ - return (car (cdr (car (x)))); -} - -LISP -caddr (LISP x) -{ - return (car (cdr (cdr (x)))); -} - -LISP -cdaar (LISP x) -{ - return (cdr (car (car (x)))); -} - -LISP -cdadr (LISP x) -{ - return (cdr (car (cdr (x)))); -} - -LISP -cddar (LISP x) -{ - return (cdr (cdr (car (x)))); -} - -LISP -cdddr (LISP x) -{ - return (cdr (cdr (cdr (x)))); -} - -LISP -ash (LISP value, LISP n) -{ - long m, k; - m = get_c_long (value); - k = get_c_long (n); - if (k > 0) - m = m << k; - else - m = m >> (-k); - return (flocons (m)); -} - -LISP -bitand (LISP a, LISP b) -{ - return (flocons (get_c_long (a) & get_c_long (b))); -} - -LISP -bitor (LISP a, LISP b) -{ - return (flocons (get_c_long (a) | get_c_long (b))); -} - -LISP -bitxor (LISP a, LISP b) -{ - return (flocons (get_c_long (a) ^ get_c_long (b))); -} - -LISP -bitnot (LISP a) -{ - return (flocons (~get_c_long (a))); -} - -LISP -leval_prog1 (LISP args, LISP env) -{ - LISP retval, l; - retval = leval (car (args), env); - for (l = cdr (args); NNULLP (l); l = cdr (l)) - leval (car (l), env); - return (retval); -} - -LISP -leval_cond (LISP * pform, LISP * penv) -{ - LISP args, env, clause, value, next; - args = cdr (*pform); - env = *penv; - if NULLP - (args) - { - *pform = NIL; - return (NIL); - } - next = cdr (args); - while NNULLP - (next) - { - clause = car (args); - value = leval (car (clause), env); - if NNULLP - (value) - { - clause = cdr (clause); - if NULLP - (clause) - { - *pform = value; - return (NIL); - } - else - { - next = cdr (clause); - while (NNULLP (next)) - { - leval (car (clause), env); - clause = next; - next = cdr (next); - } - *pform = car (clause); - return (sym_t); - } - } - args = next; - next = cdr (next); - } - clause = car (args); - next = cdr (clause); - if NULLP - (next) - { - *pform = car (clause); - return (sym_t); - } - value = leval (car (clause), env); - if NULLP - (value) - { - *pform = NIL; - return (NIL); - } - clause = next; - next = cdr (next); - while (NNULLP (next)) - { - leval (car (clause), env); - clause = next; - next = cdr (next); - } - *pform = car (clause); - return (sym_t); -} - -LISP -lstrspn (LISP str1, LISP str2) -{ - return (flocons (strspn (get_c_string (str1), get_c_string (str2)))); -} - -LISP -lstrcspn (LISP str1, LISP str2) -{ - return (flocons (strcspn (get_c_string (str1), get_c_string (str2)))); -} - -LISP -substring_equal (LISP str1, LISP str2, LISP start, LISP end) -{ - char *cstr1, *cstr2; - long len1, n, s, e; - cstr1 = get_c_string_dim (str1, &len1); - cstr2 = get_c_string_dim (str2, &n); - s = NULLP (start) ? 0 : get_c_long (start); - e = NULLP (end) ? n : get_c_long (end); - if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1)) - return (NIL); - return ((memcmp (cstr1, &cstr2[s], e - s) == 0) ? a_true_value () : NIL); -} - -LISP -set_eval_history (LISP len, LISP circ) -{ - LISP data; - data = NULLP (len) ? len : make_list (len, NIL); - if NNULLP - (circ) - data = nconc (data, data); - setvar (cintern ("*eval-history-ptr*"), data, NIL); - setvar (cintern ("*eval-history*"), data, NIL); - return (len); -} - -static LISP -parser_fasl (LISP ignore) -{ - return (closure (listn (3, - NIL, - cons_array (flocons (100), NIL), - flocons (0)), - leval (cintern ("parser_fasl_hook"), NIL))); -} - -static LISP -parser_fasl_hook (LISP env, LISP f) -{ - LISP result; - setcar (env, f); - result = fast_read (env); - if EQ - (result, env) - return (get_eof_val ()); - else - return (result); -} - -void -init_subrs_a (void) -{ - init_subr_2 ("aref", aref1); - init_subr_3 ("aset", aset1); - init_lsubr ("string-append", string_append); - init_lsubr ("bytes-append", bytes_append); - init_subr_1 ("string-length", string_length); - init_subr_1 ("string-dimension", string_dim); - init_subr_1 ("read-from-string", read_from_string); - init_subr_3 ("print-to-string", print_to_string); - init_subr_2 ("cons-array", cons_array); - init_subr_2 ("sxhash", sxhash); - init_subr_2 ("equal?", equal); - init_subr_2 ("href", href); - init_subr_3 ("hset", hset); - init_subr_2 ("assoc", assoc); - init_subr_2 ("assv", assv); - init_subr_1 ("fast-read", fast_read); - init_subr_2 ("fast-print", fast_print); - init_subr_2 ("make-list", make_list); - init_subr_2 ("fread", lfread); - init_subr_2 ("fwrite", lfwrite); - init_subr_1 ("fflush", lfflush); - init_subr_1 ("length", llength); - init_subr_4 ("number->string", number2string); - init_subr_2 ("string->number", string2number); - init_subr_3 ("substring", substring); - init_subr_2 ("string-search", string_search); - init_subr_1 ("string-trim", string_trim); - init_subr_1 ("string-trim-left", string_trim_left); - init_subr_1 ("string-trim-right", string_trim_right); - init_subr_1 ("string-upcase", string_upcase); - init_subr_1 ("string-downcase", string_downcase); - init_subr_2 ("strcmp", lstrcmp); - init_subr_2 ("strcat", lstrcat); - init_subr_2 ("strcpy", lstrcpy); - init_subr_2 ("strbreakup", lstrbreakup); - init_subr_2 ("unbreakupstr", lstrunbreakup); - init_subr_1 ("string?", stringp); - gc_protect_sym (&sym_e, "e"); - gc_protect_sym (&sym_f, "f"); - gc_protect_sym (&sym_plists, "*plists*"); - setvar (sym_plists, arcons (tc_lisp_array, 100, 1), NIL); - init_subr_3 ("lref-default", lref_default); - init_subr_3 ("larg-default", larg_default); - init_subr_3 ("lkey-default", lkey_default); - init_lsubr ("list", llist); - init_lsubr ("writes", writes); - init_subr_3 ("qsort", lqsort); - init_subr_2 ("string-lessp", string_lessp); - init_lsubr ("mapcar", mapcar); - init_subr_3 ("mapcar2", mapcar2); - init_subr_2 ("mapcar1", mapcar1); - init_subr_3 ("benchmark-funcall1", benchmark_funcall1); - init_lsubr ("benchmark-funcall2", benchmark_funcall2); - init_subr_3 ("benchmark-eval", benchmark_eval); - init_subr_2 ("fmod", lfmod); - init_subr_2 ("subset", lsubset); - init_subr_1 ("base64encode", base64encode); - init_subr_1 ("base64decode", base64decode); - init_subr_3 ("ass", ass); - init_subr_2 ("append2", append2); - init_lsubr ("append", append); - init_subr_4 ("fast-save", fast_save); - init_subr_2 ("fast-load", fast_load); - init_subr_3 ("swrite", swrite); - init_subr_1 ("trunc", ltrunc); - init_subr_2 ("pow", lpow); - init_subr_1 ("exp", lexp); - init_subr_1 ("log", llog); - init_subr_1 ("sin", lsin); - init_subr_1 ("cos", lcos); - init_subr_1 ("tan", ltan); - init_subr_1 ("asin", lasin); - init_subr_1 ("acos", lacos); - init_subr_1 ("atan", latan); - init_subr_2 ("atan2", latan2); - init_subr_1 ("typeof", ltypeof); - init_subr_1 ("caaar", caaar); - init_subr_1 ("caadr", caadr); - init_subr_1 ("cadar", cadar); - init_subr_1 ("caddr", caddr); - init_subr_1 ("cdaar", cdaar); - init_subr_1 ("cdadr", cdadr); - init_subr_1 ("cddar", cddar); - init_subr_1 ("cdddr", cdddr); - setvar (cintern ("*pi*"), flocons (atan (1.0) * 4), NIL); - init_base64_table (); - init_subr_1 ("array->hexstr", hexstr); - init_subr_1 ("hexstr->bytes", hexstr2bytes); - init_subr_3 ("ass", ass); - init_subr_2 ("bit-and", bitand); - init_subr_2 ("bit-or", bitor); - init_subr_2 ("bit-xor", bitxor); - init_subr_1 ("bit-not", bitnot); - init_msubr ("cond", leval_cond); - init_fsubr ("prog1", leval_prog1); - init_subr_2 ("strspn", lstrspn); - init_subr_2 ("strcspn", lstrcspn); - init_subr_4 ("substring-equal?", substring_equal); - init_subr_1 ("butlast", butlast); - init_subr_2 ("ash", ash); - init_subr_2 ("get", getprop); - init_subr_3 ("setprop", setprop); - init_subr_3 ("putprop", putprop); - init_subr_1 ("last", last); - init_subr_2 ("memq", memq); - init_subr_2 ("memv", memv); - init_subr_2 ("member", member); - init_subr_2 ("nth", nth); - init_subr_2 ("nconc", nconc); - init_subr_2 ("set-eval-history", set_eval_history); - init_subr_1 ("parser_fasl", parser_fasl); - setvar (cintern ("*parser_fasl.scm-loaded*"), a_true_value (), NIL); - init_subr_2 ("parser_fasl_hook", parser_fasl_hook); - init_sliba_version (); -} diff --git a/plug-ins/script-fu/interp_trace.c b/plug-ins/script-fu/interp_trace.c deleted file mode 100644 index 6c77472fbf..0000000000 --- a/plug-ins/script-fu/interp_trace.c +++ /dev/null @@ -1,192 +0,0 @@ - -/* COPYRIGHT (c) 1992-1994 BY - * MITECH CORPORATION, ACTON, MASSACHUSETTS. - * See the source file SLIB.C for more information. - - (trace procedure1 procedure2 ...) - (untrace procedure1 procedure2 ...) - - Currently only user-defined procedures can be traced. - Fancy printing features such as indentation based on - recursion level will also have to wait for a future version. - - - */ - -#include -#include -#include -#include "siod.h" -#include "siodp.h" - -static void -init_trace_version (void) -{ - setvar (cintern ("*trace-version*"), - cintern ("$Id$"), - NIL); -} - - -static long tc_closure_traced = 0; - -static LISP sym_traced = NIL; -static LISP sym_quote = NIL; -static LISP sym_begin = NIL; - -LISP ltrace_fcn_name (LISP body); -LISP ltrace_1 (LISP fcn_name, LISP env); -LISP ltrace (LISP fcn_names, LISP env); -LISP luntrace_1 (LISP fcn); -LISP luntrace (LISP fcns); -static void ct_gc_scan (LISP ptr); -static LISP ct_gc_mark (LISP ptr); -void ct_prin1 (LISP ptr, struct gen_printio *f); -LISP ct_eval (LISP ct, LISP * px, LISP * penv); - -LISP -ltrace_fcn_name (LISP body) -{ - LISP tmp; - if NCONSP - (body) return (NIL); - if NEQ - (CAR (body), sym_begin) return (NIL); - tmp = CDR (body); - if NCONSP - (tmp) return (NIL); - tmp = CAR (tmp); - if NCONSP - (tmp) return (NIL); - if NEQ - (CAR (tmp), sym_quote) return (NIL); - tmp = CDR (tmp); - if NCONSP - (tmp) return (NIL); - return (CAR (tmp)); -} - -LISP -ltrace_1 (LISP fcn_name, LISP env) -{ - LISP fcn, code; - fcn = leval (fcn_name, env); - if (TYPE (fcn) == tc_closure) - { - code = fcn->storage_as.closure.code; - if NULLP - (ltrace_fcn_name (cdr (code))) - setcdr (code, cons (sym_begin, - cons (cons (sym_quote, cons (fcn_name, NIL)), - cons (cdr (code), NIL)))); - fcn->type = tc_closure_traced; - } - else if (TYPE (fcn) == tc_closure_traced) - ; - else - my_err ("not a closure, cannot trace", fcn); - return (NIL); -} - -LISP -ltrace (LISP fcn_names, LISP env) -{ - LISP l; - for (l = fcn_names; NNULLP (l); l = cdr (l)) - ltrace_1 (car (l), env); - return (NIL); -} - -LISP -luntrace_1 (LISP fcn) -{ - if (TYPE (fcn) == tc_closure) - ; - else if (TYPE (fcn) == tc_closure_traced) - fcn->type = tc_closure; - else - my_err ("not a closure, cannot untrace", fcn); - return (NIL); -} - -LISP -luntrace (LISP fcns) -{ - LISP l; - for (l = fcns; NNULLP (l); l = cdr (l)) - luntrace_1 (car (l)); - return (NIL); -} - -static void -ct_gc_scan (LISP ptr) -{ - CAR (ptr) = gc_relocate (CAR (ptr)); - CDR (ptr) = gc_relocate (CDR (ptr)); -} - -static LISP -ct_gc_mark (LISP ptr) -{ - gc_mark (ptr->storage_as.closure.code); - return (ptr->storage_as.closure.env); -} - -void -ct_prin1 (LISP ptr, struct gen_printio *f) -{ - gput_st (f, "#storage_as.closure.code), f); - gput_st (f, " "); - lprin1g (cdr (ptr->storage_as.closure.code), f); - gput_st (f, ">"); -} - -LISP -ct_eval (LISP ct, LISP * px, LISP * penv) -{ - LISP fcn_name, args, env, result, l; - fcn_name = ltrace_fcn_name (cdr (ct->storage_as.closure.code)); - args = leval_args (CDR (*px), *penv); - fput_st (stdout, "->"); - lprin1f (fcn_name, stdout); - for (l = args; NNULLP (l); l = cdr (l)) - { - fput_st (stdout, " "); - lprin1f (car (l), stdout); - } - fput_st (stdout, "\n"); - env = extend_env (args, - car (ct->storage_as.closure.code), - ct->storage_as.closure.env); - result = leval (cdr (ct->storage_as.closure.code), env); - fput_st (stdout, "<-"); - lprin1f (fcn_name, stdout); - fput_st (stdout, " "); - lprin1f (result, stdout); - fput_st (stdout, "\n"); - *px = result; - return (NIL); -} - -void -init_trace (void) -{ - long j; - tc_closure_traced = allocate_user_tc (); - set_gc_hooks (tc_closure_traced, - NULL, - ct_gc_mark, - ct_gc_scan, - NULL, - &j); - gc_protect_sym (&sym_traced, "*traced*"); - setvar (sym_traced, NIL, NIL); - gc_protect_sym (&sym_begin, "begin"); - gc_protect_sym (&sym_quote, "quote"); - set_print_hooks (tc_closure_traced, ct_prin1); - set_eval_hooks (tc_closure_traced, ct_eval); - init_fsubr ("trace", ltrace); - init_lsubr ("untrace", luntrace); - init_trace_version (); -} diff --git a/plug-ins/script-fu/scheme-wrapper.c b/plug-ins/script-fu/scheme-wrapper.c index 66a7b614b2..9b3a316340 100644 --- a/plug-ins/script-fu/scheme-wrapper.c +++ b/plug-ins/script-fu/scheme-wrapper.c @@ -24,12 +24,13 @@ #include "libgimp/gimp.h" +#include "siod/siod.h" + #include "script-fu-constants.h" #include "script-fu-enums.h" #include "script-fu-scripts.h" #include "script-fu-server.h" -#include "siod.h" #include "siod-wrapper.h" diff --git a/plug-ins/script-fu/script-fu-constants.c b/plug-ins/script-fu/script-fu-constants.c index 3b2b2a2d6a..f0d1111c38 100644 --- a/plug-ins/script-fu/script-fu-constants.c +++ b/plug-ins/script-fu/script-fu-constants.c @@ -18,7 +18,7 @@ /* NOTE: This file is autogenerated by enumcode.pl. */ -#include "siod.h" +#include "siod/siod.h" void init_generated_constants (void) diff --git a/plug-ins/script-fu/script-fu-interface.c b/plug-ins/script-fu/script-fu-interface.c index 9b3717b398..4054d36b67 100644 --- a/plug-ins/script-fu/script-fu-interface.c +++ b/plug-ins/script-fu/script-fu-interface.c @@ -37,8 +37,10 @@ #include #include -#include "siod.h" +#include "siod/siod.h" + #include "script-fu-scripts.h" +#include "siod-wrapper.h" #include "script-fu-intl.h" @@ -210,7 +212,6 @@ static GTree *script_list = NULL; static SFInterface *sf_interface = NULL; /* there can only be at most one interactive interface */ -extern gchar siod_err_msg[]; /* * Function definitions @@ -1993,5 +1994,5 @@ static void script_fu_error_msg (const gchar *command) { g_message (_("Error while executing\n%s\n%s"), - command, siod_err_msg); + command, siod_get_error_msg ()); } diff --git a/plug-ins/script-fu/script-fu-scripts.c b/plug-ins/script-fu/script-fu-scripts.c index 9b3717b398..4054d36b67 100644 --- a/plug-ins/script-fu/script-fu-scripts.c +++ b/plug-ins/script-fu/script-fu-scripts.c @@ -37,8 +37,10 @@ #include #include -#include "siod.h" +#include "siod/siod.h" + #include "script-fu-scripts.h" +#include "siod-wrapper.h" #include "script-fu-intl.h" @@ -210,7 +212,6 @@ static GTree *script_list = NULL; static SFInterface *sf_interface = NULL; /* there can only be at most one interactive interface */ -extern gchar siod_err_msg[]; /* * Function definitions @@ -1993,5 +1994,5 @@ static void script_fu_error_msg (const gchar *command) { g_message (_("Error while executing\n%s\n%s"), - command, siod_err_msg); + command, siod_get_error_msg ()); } diff --git a/plug-ins/script-fu/script-fu-scripts.h b/plug-ins/script-fu/script-fu-scripts.h index 65c4394d38..c5cf16cad5 100644 --- a/plug-ins/script-fu/script-fu-scripts.h +++ b/plug-ins/script-fu/script-fu-scripts.h @@ -20,7 +20,6 @@ #define __SCRIPT_FU_SCRIPTS_H__ #include "script-fu-enums.h" -#include "siod.h" void script_fu_find_scripts (void); LISP script_fu_add_script (LISP a); diff --git a/plug-ins/script-fu/script-fu.c b/plug-ins/script-fu/script-fu.c index 607789302b..01aa8376f8 100644 --- a/plug-ins/script-fu/script-fu.c +++ b/plug-ins/script-fu/script-fu.c @@ -28,6 +28,8 @@ #include #include +#include "siod/siod.h" + #include "siod-wrapper.h" #include "script-fu-console.h" #include "script-fu-constants.h" diff --git a/plug-ins/script-fu/siod-wrapper.c b/plug-ins/script-fu/siod-wrapper.c index 66a7b614b2..9b3a316340 100644 --- a/plug-ins/script-fu/siod-wrapper.c +++ b/plug-ins/script-fu/siod-wrapper.c @@ -24,12 +24,13 @@ #include "libgimp/gimp.h" +#include "siod/siod.h" + #include "script-fu-constants.h" #include "script-fu-enums.h" #include "script-fu-scripts.h" #include "script-fu-server.h" -#include "siod.h" #include "siod-wrapper.h" diff --git a/plug-ins/script-fu/siod.h b/plug-ins/script-fu/siod.h deleted file mode 100644 index 86dd263b03..0000000000 --- a/plug-ins/script-fu/siod.h +++ /dev/null @@ -1,424 +0,0 @@ - -/* Scheme In One Defun, but in C this time. - - * COPYRIGHT (c) 1988-1994 BY * - * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * - * See the source file SLIB.C for more information. * - - $Id$ - - */ -#ifndef __SIOD_H__ -#define __SIOD_H__ - -#include - -struct obj - { - short gc_mark; - short type; - union - { - struct - { - struct obj *car; - struct obj *cdr; - } - cons; - struct - { - double data; - } - flonum; - struct - { - char *pname; - struct obj *vcell; - } - symbol; - struct - { - char *name; - struct obj *(*f) (void); - } - subr0; - struct - { - char *name; - struct obj *(*f) (struct obj *); - } - subr1; - struct - { - char *name; - struct obj *(*f) (struct obj *, struct obj *); - } - subr2; - struct - { - char *name; - struct obj *(*f) (struct obj *, struct obj *, struct obj *); - } - subr3; - struct - { - char *name; - struct obj *(*f) (struct obj *, struct obj *, struct obj *, - struct obj *); - } - subr4; - struct - { - char *name; - struct obj *(*f) (struct obj *, struct obj *, struct obj *, - struct obj *, struct obj *); - } - subr5; - struct - { - char *name; - struct obj *(*f) (struct obj **, struct obj **); - } - subrm; - struct - { - char *name; - struct obj *(*f) (void *,...); - } - subr; - struct - { - struct obj *env; - struct obj *code; - } - closure; - struct - { - long dim; - long *data; - } - long_array; - struct - { - long dim; - double *data; - } - double_array; - struct - { - long dim; - char *data; - } - string; - struct - { - long dim; - struct obj **data; - } - lisp_array; - struct - { - FILE *f; - char *name; - } - c_file; - } - storage_as; - }; - -#define CAR(x) ((*x).storage_as.cons.car) -#define CDR(x) ((*x).storage_as.cons.cdr) -#define PNAME(x) ((*x).storage_as.symbol.pname) -#define VCELL(x) ((*x).storage_as.symbol.vcell) -#define SUBR0(x) (*((*x).storage_as.subr0.f)) -#define SUBR1(x) (*((*x).storage_as.subr1.f)) -#define SUBR2(x) (*((*x).storage_as.subr2.f)) -#define SUBR3(x) (*((*x).storage_as.subr3.f)) -#define SUBR4(x) (*((*x).storage_as.subr4.f)) -#define SUBR5(x) (*((*x).storage_as.subr5.f)) -#define SUBRM(x) (*((*x).storage_as.subrm.f)) -#define SUBRF(x) (*((*x).storage_as.subr.f)) -#define FLONM(x) ((*x).storage_as.flonum.data) - -#define NIL ((struct obj *) 0) -#define EQ(x,y) ((x) == (y)) -#define NEQ(x,y) ((x) != (y)) -#define NULLP(x) EQ(x,NIL) -#define NNULLP(x) NEQ(x,NIL) - -#define TYPE(x) (((x) == NIL) ? 0 : ((*(x)).type)) - -#define TYPEP(x,y) (TYPE(x) == (y)) -#define NTYPEP(x,y) (TYPE(x) != (y)) - -#define tc_nil 0 -#define tc_cons 1 -#define tc_flonum 2 -#define tc_symbol 3 -#define tc_subr_0 4 -#define tc_subr_1 5 -#define tc_subr_2 6 -#define tc_subr_3 7 -#define tc_lsubr 8 -#define tc_fsubr 9 -#define tc_msubr 10 -#define tc_closure 11 -#define tc_free_cell 12 -#define tc_string 13 -#define tc_double_array 14 -#define tc_long_array 15 -#define tc_lisp_array 16 -#define tc_c_file 17 -#define tc_byte_array 18 -#define tc_subr_4 19 -#define tc_subr_5 20 -#define tc_subr_2n 21 -#define FO_comment 35 -#define tc_user_min 50 -#define tc_user_max 100 - -#define FO_fetch 127 -#define FO_store 126 -#define FO_list 125 -#define FO_listd 124 - -#define tc_table_dim 100 - -typedef struct obj *LISP; -typedef LISP (*SUBR_FUNC) (void); - -#define CONSP(x) TYPEP(x,tc_cons) -#define FLONUMP(x) TYPEP(x,tc_flonum) -#define SYMBOLP(x) TYPEP(x,tc_symbol) - -#define NCONSP(x) NTYPEP(x,tc_cons) -#define NFLONUMP(x) NTYPEP(x,tc_flonum) -#define NSYMBOLP(x) NTYPEP(x,tc_symbol) - -#define TKBUFFERN 5120 - -struct gen_readio - { - int (*getc_fcn) (void *); - void (*ungetc_fcn) (int, void *); - void *cb_argument; - }; - -struct gen_printio - { - int (*putc_fcn) (int, void *); - int (*puts_fcn) (char *, void *); - void *cb_argument; - }; - -#define GETC_FCN(x) (*((*x).getc_fcn))((*x).cb_argument) -#define UNGETC_FCN(c,x) (*((*x).ungetc_fcn))(c,(*x).cb_argument) -#define PUTC_FCN(c,x) (*((*x).putc_fcn))(c,(*x).cb_argument) -#define PUTS_FCN(c,x) (*((*x).puts_fcn))(c,(*x).cb_argument) - -struct repl_hooks - { - void (*repl_puts) (char *); - LISP (*repl_read) (void); - LISP (*repl_eval) (LISP); - void (*repl_print) (LISP); - }; - -void process_cla (int argc, char **argv, int warnflag); -void print_welcome (void); -void print_hs_1 (void); -void print_hs_2 (void); -long no_interrupt (long n); -LISP get_eof_val (void); -long repl_driver (long want_sigint, long want_init, struct repl_hooks *); -void set_repl_hooks (void (*puts_f) (char *), - LISP (*read_f) (void), - LISP (*eval_f) (LISP), - void (*print_f) (LISP)); -long repl (struct repl_hooks *); -LISP my_err (char *message, LISP x); -LISP errswitch (void); -char *get_c_string (LISP x); -char *get_c_string_dim (LISP x, long *); -char *try_get_c_string (LISP x); -long get_c_long (LISP x); -double get_c_double (LISP x); -LISP lerr (LISP message, LISP x); - -LISP newcell (long type); -LISP cons (LISP x, LISP y); -LISP consp (LISP x); -LISP car (LISP x); -LISP cdr (LISP x); -LISP setcar (LISP cell, LISP value); -LISP setcdr (LISP cell, LISP value); -LISP flocons (double x); -LISP numberp (LISP x); -LISP plus (LISP x, LISP y); -LISP ltimes (LISP x, LISP y); -LISP difference (LISP x, LISP y); -LISP Quotient (LISP x, LISP y); -LISP greaterp (LISP x, LISP y); -LISP lessp (LISP x, LISP y); -LISP eq (LISP x, LISP y); -LISP eql (LISP x, LISP y); -LISP symcons (char *pname, LISP vcell); -LISP symbolp (LISP x); -LISP symbol_boundp (LISP x, LISP env); -LISP symbol_value (LISP x, LISP env); -LISP cintern (char *name); -LISP rintern (char *name); -LISP subrcons (long type, char *name, SUBR_FUNC f); -LISP closure (LISP env, LISP code); -void gc_protect (LISP * location); -void gc_protect_n (LISP * location, long n); -void gc_protect_sym (LISP * location, char *st); -void gc_unprotect (LISP * location); - -void init_storage (void); -void init_slibu (void); - -void init_subr (char *name, long type, SUBR_FUNC fcn); -void init_subr_0 (char *name, LISP (*fcn) (void)); -void init_subr_1 (char *name, LISP (*fcn) (LISP)); -void init_subr_2 (char *name, LISP (*fcn) (LISP, LISP)); -void init_subr_2n (char *name, LISP (*fcn) (LISP, LISP)); -void init_subr_3 (char *name, LISP (*fcn) (LISP, LISP, LISP)); -void init_subr_4 (char *name, LISP (*fcn) (LISP, LISP, LISP, LISP)); -void init_subr_5 (char *name, LISP (*fcn) (LISP, LISP, LISP, LISP, LISP)); -void init_lsubr (char *name, LISP (*fcn) (LISP)); -void init_fsubr (char *name, LISP (*fcn) (LISP, LISP)); -void init_msubr (char *name, LISP (*fcn) (LISP *, LISP *)); - -LISP assq (LISP x, LISP alist); -LISP delq (LISP elem, LISP l); -void set_gc_hooks (long type, - LISP (*rel) (LISP), - LISP (*mark) (LISP), - void (*scan) (LISP), - void (*free) (LISP), - long *kind); -LISP gc_relocate (LISP x); -LISP user_gc (LISP args); -LISP gc_status (LISP args); -void set_eval_hooks (long type, LISP (*fcn) (LISP, LISP *, LISP *)); -LISP leval (LISP x, LISP env); -LISP symbolconc (LISP args); -void set_print_hooks (long type, void (*fcn) (LISP, struct gen_printio *)); -LISP lprin1g (LISP exp, struct gen_printio *f); -LISP lprin1f (LISP exp, FILE * f); -LISP lprint (LISP exp, LISP); -LISP lread (LISP); -LISP lreadtk (char *, long j); -LISP lreadf (FILE * f); -void set_read_hooks (char *all_set, char *end_set, - LISP (*fcn1) (int, struct gen_readio *), - LISP (*fcn2) (char *, long, int *)); -LISP apropos (LISP); -LISP vload (char *fname, long cflag, long rflag); -LISP load (LISP fname, LISP cflag, LISP rflag); -LISP require (LISP fname); -LISP save_forms (LISP fname, LISP forms, LISP how); -LISP quit (void); -LISP nullp (LISP x); -LISP strcons (long length, char *data); -LISP read_from_string (LISP x); -LISP aref1 (LISP a, LISP i); -LISP aset1 (LISP a, LISP i, LISP v); -LISP cons_array (LISP dim, LISP kind); -LISP arcons (long typecode, long n, long initp); -LISP string_append (LISP args); -LISP string_length (LISP string); -LISP string_search (LISP, LISP); -LISP substring (LISP, LISP, LISP); -LISP string_trim (LISP); -LISP string_trim_left (LISP); -LISP string_trim_right (LISP); -LISP string_upcase (LISP); -LISP string_downcase (LISP); -void init_subrs (void); -LISP copy_list (LISP); -long c_sxhash (LISP, long); -LISP sxhash (LISP, LISP); -LISP href (LISP, LISP); -LISP hset (LISP, LISP, LISP); -LISP fast_print (LISP, LISP); -LISP fast_read (LISP); -LISP equal (LISP, LISP); -LISP assoc (LISP x, LISP alist); -LISP make_list (LISP x, LISP v); -void set_fatal_exit_hook (void (*fcn) (void)); -LISP parse_number (LISP x); -LISP intern (LISP x); -void init_trace (void); -long repl_c_string (char *, long want_sigint, long want_init, long want_print); -char *siod_version (void); -LISP nreverse (LISP); -LISP number2string (LISP, LISP, LISP, LISP); -LISP string2number (LISP, LISP); -LISP siod_verbose (LISP); -int siod_verbose_check (int); -LISP setvar (LISP, LISP, LISP); -long allocate_user_tc (void); -LISP cadr (LISP); -LISP caar (LISP); -LISP cddr (LISP); -LISP caaar (LISP); -LISP caadr (LISP); -LISP cadar (LISP); -LISP caddr (LISP); -LISP cdaar (LISP); -LISP cdadr (LISP); -LISP cddar (LISP); -LISP cdddr (LISP); -void chk_string (LISP, char **, long *); -LISP a_true_value (void); -LISP lapply (LISP fcn, LISP args); -LISP mallocl (void *lplace, long size); -void gput_st (struct gen_printio *, char *); -void put_st (char *st); -LISP listn (long n,...); -char *must_malloc (unsigned long size); -LISP lstrbreakup (LISP str, LISP lmarker); -LISP lstrunbreakup (LISP elems, LISP lmarker); -LISP nconc (LISP, LISP); -LISP poparg (LISP *, LISP); -FILE *get_c_file (LISP p, FILE * deflt); -char *last_c_errmsg (int); -LISP llast_c_errmsg (int); - -#define SAFE_STRCPY(_to,_from) safe_strcpy((_to),sizeof(_to),(_from)) -#define SAFE_STRCAT(_to,_from) safe_strcat((_to),sizeof(_to),(_from)) -#define SAFE_STRLEN(_buff) safe_strlen((_buff),sizeof(_buff)) - -char *safe_strcpy (char *s1, size_t size1, const char *s2); -char *safe_strcat (char *s1, size_t size1, const char *s2); - -size_t safe_strlen (const char *s, size_t size); -LISP memq (LISP x, LISP il); -LISP lstrbreakup (LISP, LISP); -LISP lstrbreakup (LISP, LISP); -LISP nth (LISP, LISP); -LISP butlast (LISP); -LISP last (LISP); -LISP readtl (struct gen_readio *f); -LISP funcall1 (LISP, LISP); -LISP funcall2 (LISP, LISP, LISP); -LISP apply1 (LISP, LISP, LISP); -LISP lgetc (LISP p); -LISP lungetc (LISP i, LISP p); -LISP lputc (LISP c, LISP p); -LISP lputs (LISP str, LISP p); - -int assemble_options (LISP,...); -LISP ccall_catch (LISP tag, LISP (*fcn) (void *), void *); -LISP lref_default (LISP li, LISP x, LISP fcn); - - -LISP symalist (char *item,...); - -LISP encode_st_mode (LISP l); -LISP encode_open_flags (LISP l); - - -#endif /* __SIOD_H__ */ diff --git a/plug-ins/script-fu/siod/.cvsignore b/plug-ins/script-fu/siod/.cvsignore new file mode 100644 index 0000000000..5857a56b3e --- /dev/null +++ b/plug-ins/script-fu/siod/.cvsignore @@ -0,0 +1,6 @@ +Makefile.in +Makefile +.deps +_libs +.libs +libsiod.a diff --git a/plug-ins/script-fu/siod/Makefile.am b/plug-ins/script-fu/siod/Makefile.am new file mode 100644 index 0000000000..e19991c6c2 --- /dev/null +++ b/plug-ins/script-fu/siod/Makefile.am @@ -0,0 +1,16 @@ +## Process this file with automake to produce Makefile.in + +noinst_LIBRARIES = libsiod.a + +libsiod_a_SOURCES = \ + regex.c \ + slib.c \ + sliba.c \ + trace.c \ + siod.h \ + siodp.h + +INCLUDES = \ + -I$(top_srcdir) \ + $(GLIB_CFLAGS) \ + -I$(includedir) diff --git a/plug-ins/script-fu/siodp.h b/plug-ins/script-fu/siodp.h deleted file mode 100644 index 81228db346..0000000000 --- a/plug-ins/script-fu/siodp.h +++ /dev/null @@ -1,203 +0,0 @@ -/* Scheme In One Defun, but in C this time. - - * COPYRIGHT (c) 1988-1992 BY * - * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * - * See the source file SLIB.C for more information. * - - Declarations which are private to SLIB.C internals. - However, some of these should be moved to siod.h - - $Id$ - - */ - - -extern char *tkbuffer; -extern LISP heap, heap_end, heap_org; -extern LISP sym_t; - -extern long siod_verbose_level; -extern char *siod_lib; - -struct user_type_hooks - { - LISP (*gc_relocate) (LISP); - void (*gc_scan) (LISP); - LISP (*gc_mark) (LISP); - void (*gc_free) (LISP); - void (*prin1) (LISP, struct gen_printio *); - LISP (*leval) (LISP, LISP *, LISP *); - long (*c_sxhash) (LISP, long); - LISP (*fast_print) (LISP, LISP); - LISP (*fast_read) (int, LISP); - LISP (*equal) (LISP, LISP); - }; - -struct catch_frame - { - LISP tag; - LISP retval; - jmp_buf cframe; - struct catch_frame *next; - }; - -extern struct catch_frame *catch_framep; - -struct gc_protected - { - LISP *location; - long length; - struct gc_protected *next; - }; - -#define NEWCELL(_into,_type) \ -{if (gc_kind_copying == 1) \ - {if ((_into = heap) >= heap_end) \ - gc_fatal_error(); \ - heap = _into+1;} \ - else \ - {if NULLP(freelist) \ - gc_for_newcell(); \ - _into = freelist; \ - freelist = CDR(freelist); \ - ++gc_cells_allocated;} \ - (*_into).gc_mark = 0; \ - (*_into).type = (short) _type;} - -#ifdef THINK_C -extern int ipoll_counter; -void full_interrupt_poll (int *counter); -#define INTERRUPT_CHECK() if (--ipoll_counter < 0) full_interrupt_poll(&ipoll_counter) -#else -#define INTERRUPT_CHECK() -#endif - -extern char *stack_limit_ptr; - -#define STACK_LIMIT(_ptr,_amt) (((char *)_ptr) - (_amt)) - -#define STACK_CHECK(_ptr) \ - if (((char *) (_ptr)) < stack_limit_ptr) err_stack((char *) _ptr); - -void err_stack (char *); - -#if defined(VMS) && defined(VAX) -#define SIG_restargs ,... -#else -#define SIG_restargs -#endif - -void handle_sigfpe (int sig SIG_restargs); -void handle_sigint (int sig SIG_restargs); -void err_ctrl_c (void); -double myruntime (void); -void fput_st (FILE * f, char *st); -void put_st (char *st); -void grepl_puts (char *, void (*)(char *)); -void gc_fatal_error (void); -LISP gen_intern (char *name, long copyp); -void scan_registers (void); -void init_storage_1 (void); -struct user_type_hooks *get_user_type_hooks (long type); -LISP get_newspace (void); -void scan_newspace (LISP newspace); -void free_oldspace (LISP space, LISP end); -void gc_stop_and_copy (void); -void gc_for_newcell (void); -void gc_mark_and_sweep (void); -void gc_ms_stats_start (void); -void gc_ms_stats_end (void); -void gc_mark (LISP ptr); -void mark_protected_registers (void); -void mark_locations (LISP * start, LISP * end); -void mark_locations_array (LISP * x, long n); -void gc_sweep (void); -LISP leval_args (LISP l, LISP env); -LISP extend_env (LISP actuals, LISP formals, LISP env); -LISP envlookup (LISP var, LISP env); -LISP setvar (LISP var, LISP val, LISP env); -LISP leval_setq (LISP args, LISP env); -LISP syntax_define (LISP args); -LISP leval_define (LISP args, LISP env); -LISP leval_if (LISP * pform, LISP * penv); -LISP leval_lambda (LISP args, LISP env); -LISP leval_progn (LISP * pform, LISP * penv); -LISP leval_or (LISP * pform, LISP * penv); -LISP leval_and (LISP * pform, LISP * penv); -LISP leval_catch_1 (LISP forms, LISP env); -LISP leval_catch (LISP args, LISP env); -LISP lthrow (LISP tag, LISP value); -LISP leval_let (LISP * pform, LISP * penv); -LISP reverse (LISP l); -LISP let_macro (LISP form); -LISP leval_quote (LISP args, LISP env); -LISP leval_tenv (LISP args, LISP env); -int flush_ws (struct gen_readio *f, char *eoferr); -int f_getc (FILE * f); -void f_ungetc (int c, FILE * f); -LISP lreadr (struct gen_readio *f); -LISP lreadparen (struct gen_readio *f); -LISP arglchk (LISP x); -void init_storage_a1 (long type); -void init_storage_a (void); -LISP array_gc_relocate (LISP ptr); -void array_gc_scan (LISP ptr); -LISP array_gc_mark (LISP ptr); -void array_gc_free (LISP ptr); -void array_prin1 (LISP ptr, struct gen_printio *f); -long array_sxhaxh (LISP, long); -LISP array_fast_print (LISP, LISP); -LISP array_fast_read (int, LISP); -LISP array_equal (LISP, LISP); -long array_sxhash (LISP, long); - -int rfs_getc (unsigned char **p); -void rfs_ungetc (unsigned char c, unsigned char **p); -void err1_aset1 (LISP i); -void err2_aset1 (LISP v); -LISP lreadstring (struct gen_readio *f); -LISP lreadsharp (struct gen_readio *f); - -void file_gc_free (LISP ptr); -void file_prin1 (LISP ptr, struct gen_printio *f); -LISP fopen_c (char *name, char *how); -LISP fopen_cg (FILE * (*)(const char *, const char *), char *, char *); -LISP fopen_l (LISP name, LISP how); -LISP fclose_l (LISP p); -LISP lftell (LISP file); -LISP lfseek (LISP file, LISP offset, LISP direction); -LISP lfread (LISP size, LISP file); -LISP lfwrite (LISP string, LISP file); - - -LISP leval_while (LISP args, LISP env); - -void init_subrs_a (void); -void init_subrs_1 (void); - -long href_index (LISP table, LISP key); - -void put_long (long, FILE *); -long get_long (FILE *); - -long fast_print_table (LISP obj, LISP table); - -LISP stack_limit (LISP, LISP); - - -void err0 (void); -void pr (LISP); -void prp (LISP *); - -LISP closure_code (LISP exp); -LISP closure_env (LISP exp); -LISP lwhile (LISP form, LISP env); -long nlength (LISP obj); -LISP llength (LISP obj); -void gc_kind_check (void); -LISP allocate_aheap (void); -long looks_pointerp (LISP); -long nactive_heaps (void); -long freelist_length (void); -LISP gc_info (LISP); -LISP err_closure_code (LISP tmp); diff --git a/tools/pdbgen/enumcode.pl b/tools/pdbgen/enumcode.pl index 0e6e5996b5..e0bbd814f6 100755 --- a/tools/pdbgen/enumcode.pl +++ b/tools/pdbgen/enumcode.pl @@ -59,7 +59,7 @@ print ENUMFILE <<'GPL'; GPL print ENUMFILE <