From 3278b75942bdbe706f7a0fba87729bb1e935b68b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5d2 --- .gdbinit | 2 +- ANNOUNCE | 357 ++- COPYING | 2 +- ChangeLog | 1360 +++++++++- Iedline.scm | 14 +- Init5c3.scm | 966 ------- Init5d2.scm | 1092 ++++++++ Link.scm | 80 +- Macro.scm | 155 +- Macroexpand.scm | 370 +++ Makefile | 333 ++- README | 568 ++-- Transcen.scm | 13 +- Tscript.scm | 60 + Xlibscm.info | 1905 +++++++++++++ Xlibscm.texi | 1955 ++++++++++++++ bench.scm | 2 +- build | 72 +- build.bat | 5 +- build.scm | 2344 ++++++++-------- continue.c | 10 +- continue.h | 14 +- crs.c | 41 +- disarm.scm | 2 +- dynl.c | 44 +- edline.c | 2 +- eval.c | 1356 +++++++--- findexec.c | 5 +- gmalloc.c | 52 +- gsubr.c | 23 +- inc2scm | 190 ++ ioext.c | 92 +- mkimpcat.scm | 10 +- patchlvl.h | 15 +- pi.c | 2 +- pi.scm | 2 +- posix.c | 48 +- r4rstest.scm | 124 +- ramap.c | 383 ++- record.c | 197 +- repl.c | 856 +++--- requires.scm | 22 + rgx.c | 82 +- rope.c | 69 +- sc2.c | 10 +- scl.c | 341 ++- scm.1 | 15 +- scm.c | 455 ++-- scm.doc | 24 +- scm.h | 267 +- scm.info | 8099 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ scm.texi | 1947 +++++++------ scmfig.h | 105 +- scmmain.c | 145 + script.c | 49 +- setjump.h | 24 +- socket.c | 43 +- split.scm | 2 +- subr.c | 76 +- sys.c | 1201 +++++---- time.c | 27 +- unexsgi.c | 888 ++++++ unif.c | 345 +-- unix.c | 10 +- x.c | 2114 +++++++++++++++ x.h | 86 + x11.scm | 587 ++++ xevent.h | 217 ++ xevent.scm | 31 + xgen.scm | 297 ++ 70 files changed, 26612 insertions(+), 6089 deletions(-) delete mode 100644 Init5c3.scm create mode 100644 Init5d2.scm create mode 100644 Macroexpand.scm create mode 100644 Tscript.scm create mode 100644 Xlibscm.info create mode 100644 Xlibscm.texi create mode 100755 inc2scm create mode 100644 requires.scm create mode 100644 scm.info create mode 100644 scmmain.c create mode 100644 unexsgi.c create mode 100644 x.c create mode 100644 x.h create mode 100644 x11.scm create mode 100644 xevent.h create mode 100644 xevent.scm create mode 100755 xgen.scm diff --git a/.gdbinit b/.gdbinit index 343b7f1..3bfc8e0 100644 --- a/.gdbinit +++ b/.gdbinit @@ -12,7 +12,7 @@ # # You should have received a copy of the GNU General Public License # along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +# the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. # # As a special exception, the Free Software Foundation gives permission # for additional uses of the text contained in its release of GUILE. diff --git a/ANNOUNCE b/ANNOUNCE index 102b42c..176bf90 100644 --- a/ANNOUNCE +++ b/ANNOUNCE @@ -1,145 +1,144 @@ -This message announces the availability of Scheme release scm5c3. - -New in scm5c3: - - * patchlvl.h (SCMVERSION): Bumped from 5c2 to 5c3. - * gmalloc.c: Imported gmalloc.c from emacs 20.2.1. - (check_block): (check_frag_blocks): Debugging functions added. - * sys.c (scm_protect_temp): Added, is currently, and probably will - remain, a noop to force allocation of a SCM temporary on the - stack. - * scl.c (big2str): Added call to scm_protect_temp. - * eval.c (map): (for_each): Added calls to scm_protect_temp. - * rgx.c (lregcomp): Added call to scm_protect_temp. - * scl.c (big2str): Take address of SCM temporary as gc protection. - * dynl.c (l_dyn_link): - conditionalized message on verbose. Cleaned up message. - * Link.scm (link:link): - prepend ./ to non-absolute sun-dl library paths. - * scm.texi, scm.doc, scm.1, r4rstest.scm, README, Init5c2.scm, ANNOUNCE: - ...-swiss => swissnet - * scm.h (verbose): read only macro for scm_verbose. - * repl.c (scm_verbose): renamed from verbose. - * scmfig.h (VERIFY_INTS): Added macro to print warnings if - interrupts are improperly allowed and CAREFUL_INTS is #defined. - (VOLATILE): Expands to `volatile' keyword if __STDC__ is #defined. - * sys.c (sys_errp): Interrupt safe system output port added. - (scm_estk_reset): (must_malloc): (must_realloc): (scm_make_cont): - Now should be run with ints deferred, no longer ever allow ints. - scm-estk_reset builds a new stack if scm_estk is BOOL_F. - * scm.c (process_signals): Modified to print deferred output to - sys_errp. - * eval.c (SCM_ENV_SAVE): (SCM_ENV_RESTORE): now ENV_SAVE, - ENV_RESTORE, local to eval.c - (apply): (ceval_1): Ints deferred before call to scm_make_cont, - which no longer allows ints. - (closure): Now takes the number of required closure arguments as a - second argument. - (m_lambda): Computes and memoizes the number of required arguments. - * repl.c (iprlist): Uses GCCDR so that fatal error messages during - gc may print better. - (handle_it): Call to scm_egc made conditional on NO_ENV_CACHE. - (growth_mon): (gc_start): (gc_end): (heap_report): Now use - sys_errp. - (ints_warn): Added for interrupt warnings using VERIFY_INTS. - (scm_stack_trace): Now completely prints stacks up to 20 deep, - rather than 10. - (def_err_response): Prints errobj if error is fatal. - (lroom): Made subr_1o for easier calling from C. - * Init5c2.scm (array-shape): No longer signals an error when - passed a non-array -- now returns whatever ARRAY-DIMENSIONS - returned (currently #f). - * scm.c (scm_proftimer): Also conditional on SIGALRM. - * sys.c (init_storage): Fixed initialization of tmp_errp so that - it is always correctly aligned. - * scm.c (process_signals): Fixed braino in code to search for - deferred signals. - (scmable_signal): Added POSIX signal unblocking call, conditional - on SIG_UNBLOCK, so Scheme signal handlers may be interrupted - before they exit. - * scm.c (scmable_signal): (err_signal): (init_signals): - (ignore_signals): - (unignore_signals): (restore_signals): Abstracted signal handling. - (fpe_signal): (bus_signal): (segv_signal): (alrm_signal): - (prof_signal): Removed. - * repl.c (process_signals): Moved to scm.c - * sys.c (must_realloc_cell): Now returns void. - * scm.c (prof_signal): (scm_proftimer): (ignore_signals): - (unignore_signals): Added handler for SIGPROF, raised via call to - setitimer (Scheme function PROFILE-TIMER). - * repl.c (handle_it): No longer saves scm_env, scm_env_tmp to - estk, they are protected by doing ecache gc. - (process_signals): Handles SIGPROF. - * sys.c (scm_fill_freelist): No longer always does gc. - (gc_mark): No longer bashes cdr of `free' cells, handle_it now - bashes more selectively. - (scm_egc): DEFER/ALLOW_INTS moved to minimize debugging ints_viol - messages -- some will still occur. - (scm_egc): No longer saves scm_env and scm_env_ptr to estk, they - are protected separately. To improve interrupt safety. - * unif.c (resizuve): eliminated unused variable `ptr'. - * sys.c (freeprint): Now prints cdr of new cell. - * repl.c (input_waiting): Now checks return value of select and - restarts if interrupted. This was causing CHAR-READY? to return - #T when no input was actually readable. - * sys.c (scm_egc): (scm_egc_copy_roots): Eliminated extra root - argument, made safe because EGC_ROOT is always called with ints - deferred. - (gc_mark): Check for ecache broken heart during mark -- fatal error. - (gc_sweep): Now uses HUGE_LENGTH instead of LENGTH for string - termination check. - (must_malloc_cell): (must_realloc_cell): Added. - (gc_for_alloc): Static function abstracts gc calls for malloc/realloc. - * unif.c (make_uve): Removed call to makestr in order to support - huge strings. - (resizuve): Now uses must_realloc_cell. - * subr.c (make_vector): (mkbig): (adjbig): Now use - must_malloc_cell, must_realloc_cell. - * socket.c (maksknm): Now uses must_malloc_cell. - * scm.h (ISYMNUM): Use only 8 bits for number, freeing some bits - for other uses. - * scl.c (makdbl): Now uses must_malloc_cell. - * rgx.c (lrgecomp): Now uses must_malloc_cell. - * repl.c (handle_it): Keep pointers to discarded new cells. - * record.c (rec_constr1): (init_record): Now use must_malloc_cell. - * posix.c (scm_getgroups): Now uses must_malloc_cell. - * dynl.c (l_dyn_link): (l_dyn_call): Moved NEWCELL out of deferred - ints sections. For dlopen versions, print more error messages. - * eval.c (macroexp1): now prints name of unbound variable. - (s_unbnd s_wtap): abstracted error message strings. - * eval.c (ceval_1): No longer make extra environment frame for - LETREC, since internal DEFINE is now rewritten. - * sys.c (scm_fill_freelist): added. Assures that at least - MIN_GC_YIELD cells are in freelis. This is used before returning - from interrupts. - * repl.c (handle_it): Discard 2 cells (because of CDR in NEWCELL). - Call scm_fill_freelist(); - * Init5c2.scm: removed DEFINED? conditionals for old SCMs. - * sys.c (scm_estk_grow): Now pushes estk ptr, with ints deferred. - * eval.c (ENV_PUSH): (ENV_POP): Now done with DEFER_INTS_EGC to - prevent problems with interrupt handlers that run Scheme code. - * sys.c (scm_estk_grow): Protected critical section with - DEFER/ALLOW_INTS - (must_malloc): (must_realloc): Protected igc call with - DEFER/ALLOW_INTS. - (scm_egc): Added DEFER/ALLOW_INTS around call to igc -- prevents - interrupts violation message in debug mode. - (igc): Now SCM_ENV_SAVE before any gc marking to fix gc bug - tickled by running Scheme code from interrupts. - (scm_egc): (scm_egc_copy_roots): Now take a single argument, a gc - root. Simplifies handling of the case where scm_egc calls igc, - and possibly itself. - * repl.c (growth_mon): Now prints "shrank" instead of "grew" if - the relevant limit decreased. - (handle_it): Do env cache gc before applying interrupt - handler, to protect data on the estk, which might move. +This message announces the availability of Scheme release scm5d2. + +New in scm5d2: + + * Makefile (install): Make sure $(libscmdir)require.scm exists. + (libscmdir): Use instead of IMPLPATH. + * repl.c (scm_top_level): Corrected error test on exit in case 0 + is not success. + (repl): Return MAKINUM(EXIT_SUCCESS) when exiting an interactive + session on EOF, this should not be an error. + * build.scm (define-compile-commands): Added. + (defcommand): Added. + (platform): formatted; simplified names. + * Makefile (features.txi): Added. + * scm.texi (Build Options): take feature documentation from + "features.txi". + * build (make-features-txi): Creates documentation of build + features from 'features table. + * build.scm (build:define-feature): Added. Feature definitions + moved to top level. + * Init5d1.scm (comment): Added. + (read:sharp): Added `#;' comment syntax, *feature* SHARP:SEMI. + * sys.c (scm_env_v2lst): Made tolerant to argc of zero, + since ecache_evalx may call it thus for DO loops binding + no values. + * eval.c (debug_env_save): Function for use in ENV_SAVE when the + CAREFUL_INTS paranoid debugging flag is #defined. + (ecache_eval_args): Now calls ecache_evalx(), which + evaluates a list of expressions and returns a list allocated on + the ecache in scm_env_tmp. + (m_do): (m_letrec1): (ceval_1): LET, LETREC, and DO now call + ecache_evalx instead of using inline loops, this seems to improve + speed by 5% - 10% for jacal and for simsynch simulation. C stack + usage will increase somewhat for large env frames. + (lookupcar): Added support for constant bindings, to be created by + LET, LETREC, LET*. + * scl.c (dbl_prec): Use dbl_mant_dig in preference of potentially + undefined DBL_MANT_DIG. + * gmalloc.c: include "getpagesize.h" conditionalized on __svr4__. + * build.scm (batch:chop-to-fit-system): Removed. Use new + batch:try-chopped-command instead. + (mysql): Added to features. + (build:build): Added comments describing stages and errors. + * Makefile: Added platform.txi dependency where dependent on + scm.texi. + * Makefile (scm.info require.scm): "cp -p" more portable than "cp -a"? + * sys.c (mode_bits): Fix for null output string case. + * unif.c (make_sh_array): Reduced consing by using scm_cvapply + instead of apply. + *sys.c (mode_bits): Now takes an optional buffer which, on exit, + will hold a mode string suitable to pass to fopen(), without any + SCM extension characters. + * r4rstest.scm (float-print-test): stop after first error. + * sys.c (try_open_file): Insure that only 'r', 'w', 'b', or '+' + may be included in mode strings passed to fopen. + * repl.c (scm_freshline): Added FRESHLINE. + * sys.c (init_storage): Make def_outp tracked, so freshline will + work with it. + * ramap.c (cind): Now takes C vector of indices, which may be + allocated on the C stack, rather than a uve. + (ramapc): (ramap): (ramap_cxr): (array_imap): (array_for_each): (rafe): + Use scm_cvapply instead of apply, allocate index and argument vectors + on the C stack for array ranks < 5. + * record.c (makrectyp): (recprin1): Use scm_cvapply instead of + apply. + (rec_prinset): Checks arity of argument procedure. + * sys.c (sfputc): (sfwrite): (sfgetc): Use scm_cvapply instead of + apply. + (mksfpt): Checks arities of soft port procedures when the port is made. + * eval.c (scm_cvapply): (scm_arity_check): Exported. + (makacro): (makmacro): (makmmacro): Call scm_cvapply rather than + consing up argument lists. Check arity of macro transformers + once, when syntax is defined. + * subr.c (make_vector): Fixed broken length argument test. + * sys.c (scm_env_v2lst): Now takes list tail in scm_env_tmp, so + tail can be allocated on ecache. + * repl.c (scm_top_level): Print out supplied program arguments for + failure exits to simplify debugging scripts. + * eval.c (varcheck): Fixed for RECKLESS case. + * eval.c (scm_arity_check): (macroexp1): Argument number checking + in macroexp1 abstracted as scm_arity_check, for use in map, + for-each ... + (scm_cvapply): Apply a function to a C vector of arguments, used by + map and for-each. + (scm_v2lst): Added for use in scm_cvapply. + (map): (for_each): Speed considerably improved: No longer allocate + Scheme vector temporaries for up to 5 list arguments. No longer + allocate unnecessary argument lists, allocate on ecache if + possible. + * repl.c (iprin1): Print out first elt of cclo environment -- + makes record procedures more identifiable. + * sys.c (scm_env_v2lst): Now takes last cdr of list as argument. + * sys.c (scm_port_entry): Make 16-bit safe. + * Tscript.scm: File added to implement transcript-on, + transcript-off without burdening normal i/o. + * Init5d1.scm (transcript-on): (transcript-off): Now autoloads + from SCM/Tscript.scm + (_TRACKED): Added. + * socket.c (l_socket): (l_connect): (l_listen): Modified to use + port table. + (l_shutdown): (l_getpeername): (l_getsockname): Test for OPFPORTP, not + just OPPORTP. + * posix.c (l_pipe): Modified to use port table. + (prinpipe): Removed. + * ioext.c (reopen_file): (l_dup): (l_dup2): Modified to use port + table. + * crs.c (prinwindow): Removed. + (mkwindow): Uses scm_port_entry. + * repl.c (iprin1): Uses "name" field for printing ports. + (input_waiting): (wait_for_input): + (trans_on): (trans_off): Removed in favor of soft-port implementation. + (lputc): (lgetc): (lputs): (lfwrite): (lungetc): Removed check for + transcript, added line and column number support. Unread char now + kept in port table rather than CAR. + (lreadpr): (line_num): Removed line counting for load port, now done + using general line and column counting. + (scm_port_line): (scm_port_column): (scm_port_filename): Added. + (err_head): Now prints out multiple filenames for nested loads. + Tries to recover from recursive errors if current-error-port is a + soft-port. + * unif.c (uve_read): Removed ungetc call, if there is an unread + character, just call lgetc repeatedly for the first elt. + * sys.c (must_malloc): (must_realloc): Now check whether the heap + is initialized or not, so may be called earlier. + (scm_init_gra): (scm_grow_gra): Use above feature. + (scm_port_entry): Added, allocates entry in a port table used to store + unread characters, file names, line & column numbers, &c. + (mark_port_table): (sweep_port_table): Gc support for port table. + ptobfuns now has a "name" element, used for printing. + (prinfport): (prinstpt): (prinsfpt): Removed. + + From David Yeh: + * scl.c (makdbl): Mods to compile using MSVC. + * scmfig.h: Don't #define SINGLES for MSC. -=-=- Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Scm is written in C and runs under -Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and -similar systems. ASCII and EBCDIC are supported. +Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Windows, +Unix, and similar systems. ASCII and EBCDIC are supported. Documentation is included explaining the many Scheme Language extensions in scm, the internal representations, and how to extend or @@ -147,89 +146,75 @@ include SCM in other programs. Documentation is online at: http://swissnet.ai.mit.edu/~jaffer/SCM.html -SCM can be obtained via FTP (detailed instructions follow) from: - swissnet.ai.mit.edu:pub/scm/scm5c3.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/scm5c3.tar.gz +SCM source is available from: + http://swissnet.ai.mit.edu/ftpdir/scm/scm5d2.zip + ftp.gnu.org:pub/gnu/jacal/scm5d2.zip (FTP instructions follow) SLIB is a portable Scheme library which SCM uses: - swissnet.ai.mit.edu:pub/scm/slib2c3.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/slib2c3.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip + ftp.gnu.org:pub/gnu/jacal/slib2c7.zip JACAL is a symbolic math system written in Scheme: - swissnet.ai.mit.edu:pub/scm/jacal1a7.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/jacal1a7.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b0.zip + ftp.gnu.org:pub/gnu/jacal/jacal1b0.zip HOBBIT is a compiler for SCM code: - swissnet.ai.mit.edu:pub/scm/hobbit4d.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/hobbit5x.tar.gz + ftp.gnu.org:pub/gnu/jacal/hobbit5x.tar.gz SLIB-PSD is a portable debugger for Scheme (requires emacs editor): - swissnet.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz SMG-SCM is an SMG interface package which works with SCM on VMS. - swissnet.ai.mit.edu:pub/scm/smg-scm2a1.zip - prep.ai.mit.edu:pub/gnu/jacal/smg-scm2a1.zip + http://swissnet.ai.mit.edu/ftpdir/scm/smg-scm2a1.zip + ftp.gnu.org:pub/gnu/jacal/smg-scm2a1.zip A VMS version of Unzip is available by anonymous FTP from ftp.spc.edu:[ANONYMOUS.MACRO32]UNZIP.EXE. TURTLSCM is a turtle graphics package which works with SCM on MS-DOS or X11 machines: - swissnet.ai.mit.edu:pub/scm/turtlegr.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/turtlegr.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/turtlegr.tar.gz + ftp.gnu.org:pub/gnu/jacal/turtlegr.tar.gz XSCM is a X windows interface package which works with SCM: - swissnet.ai.mit.edu:pub/scm/xscm-2.01.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/xscm-2.01.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/xscm-2.01.tar.gz + ftp.gnu.org:pub/gnu/jacal/xscm-2.01.tar.gz MacSCM is a Macintosh applications building package which works with SCM (similar to XSCM). - swissnet.ai.mit.edu:pub/scm/macscm.tar.Z + http://swissnet.ai.mit.edu/ftpdir/scm/macscm.tar.Z WB is a disk based, sorted associative array (B-tree) library for SCM. Using WB, large databases can be created and managed from SCM. - swissnet.ai.mit.edu:pub/scm/wb1a2.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/wb1a2.tar.gz SIMSYNCH is a digital logic simulation system written in SCM. - swissnet.ai.mit.edu:pub/scm/synch1a2.tar.gz - prep.ai.mit.edu:pub/gnu/jacal/synch1a3.tar.gz + http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip + ftp.gnu.org:pub/gnu/jacal/synch1b0.zip DLD is a C library package allowing SCM to dynamically load object files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), Atari ST, and a.out Linux systems. - prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz + ftp.gnu.org:pub/gnu/dld/dld-3.3.tar.gz + +SCM.EXE (265k) is a SCM executable for DOS and MS-Windows. +Note: SCM.EXE still requires slib2c7 and scm5d2 above. + http://swissnet.ai.mit.edu/ftpdir/scm/scm.exe #! implements "#!" (POSIX) shell-scripts for MS-DOS batch files. - swissnet.ai.mit.edu:pub/scm/#!.zip + http://swissnet.ai.mit.edu/ftpdir/scm/sharpbang.zip + http://swissnet.ai.mit.edu/ftpdir/scm/#!.zip + +Programs for printing and viewing TexInfo documentation (which SCM +has) come with GNU Emacs or can be obtained via ftp from: + ftp.gnu.org:pub/gnu/texinfo/texinfo-4.0.tar.gz -=-=- - ftp swissnet.ai.mit.edu (anonymous) - bin - cd pub/scm - get scm5c3.tar.gz - get slib2c3.tar.gz -or - ftp prep.ai.mit.edu (anonymous) + ftp ftp.gnu.org (anonymous) bin cd pub/gnu/jacal - get scm5c3.tar.gz - get slib2c3.tar.gz - - `scm5c3.tar.gz' is a gzipped tar file of the C code distribution. - `slib2c3.tar.gz' is a gzipped tar file of a Scheme Library. - -Files in these directories with the ".gz" suffix are compressed with -patent-free gzip (no relation to zip). The program to uncompress them -is available from - prep.ai.mit.edu:pub/gnu/gzip-1.2.4.tar - prep.ai.mit.edu:pub/gnu/gzip-1.2.4.shar - prep.ai.mit.edu:pub/gnu/gzip-1.2.4.msdos.exe - -Remember to use binary mode when transferring the files. -Be sure to get and read the GNU General Public License (COPYING). -It is included in scm5c3.tar.gz. - -I sell IBM PC floppy disk sets with the source files, documentation, -and MS-DOS and i386 MS-DOS executables for $99.00. To order, send -e-mail to jaffer @ rice-chex.ai.mit.edu. + get slib2c7.zip + get scm5d2.zip diff --git a/COPYING b/COPYING index 60549be..eeb586b 100644 --- a/COPYING +++ b/COPYING @@ -2,7 +2,7 @@ Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. diff --git a/ChangeLog b/ChangeLog index e9e3e19..56ca861 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,1349 @@ +Sun Dec 5 22:04:18 EST 1999 Aubrey Jaffer + + * patchlvl.h (SCMVERSION): Bumped from 5d1 to 5d2. + +1999-12-02 Aubrey Jaffer + + * Makefile (install): Make sure $(libscmdir)require.scm exists. + (libscmdir): Use instead of IMPLPATH. + +1999-12-02 Radey Shouman + + * scmfig.h: Don't #define SINGLES for MSC, per suggestion of David + Yeh + +1999-12-01 Radey Shouman + + * repl.c (scm_top_level): Corrected error test on exit in case 0 + is not success. + + (repl): Return MAKINUM(EXIT_SUCCESS) when exiting an interactive + session on EOF, this should not be an error. + +1999-11-14 Aubrey Jaffer + + * build.scm (define-compile-commands): Added. + (defcommand): Added. + (platform): formatted; simplified names. + + * Makefile (features.txi): Added. + + * scm.texi (Build Options): take feature documentation from + "features.txi". + + * build (make-features-txi): Creates documentation of build + features from 'features table. + + * build.scm (build:define-feature): Added. Feature definitions + moved to top level. + + * Init5d1.scm (comment): Added. + (read:sharp): Added `#;' comment syntax, *feature* SHARP:SEMI. + +1999-11-09 Radey Shouman + + * sys.c (scm_env_v2lst): Made tolerant to argc of zero, + since ecache_evalx may call it thus for DO loops binding + no values. + + * eval.c (debug_env_save): Function for use in ENV_SAVE when the + CAREFUL_INTS paranoid debugging flag is #defined. + + (ecache_eval_args): Now calls ecache_evalx(), which + evaluates a list of expressions and returns a list allocated on + the ecache in scm_env_tmp. + + (m_do): (m_letrec1): (ceval_1): LET, LETREC, and DO now call + ecache_evalx instead of using inline loops, this seems to improve + speed by 5% - 10% for jacal and for simsynch simulation. C stack + usage will increase somewhat for large env frames. + + (lookupcar): Added support for constant bindings, to be created by + LET, LETREC, LET*. + +1999-11-04 Radey Shouman + + * scl.c (dbl_prec): Use dbl_mant_dig in preference of potentially + undefined DBL_MANT_DIG. + +1999-11-04 David Yeh + * scl.c (makdbl): Mods to compile using MSVC + +1999-11-01 Aubrey Jaffer + + * gmalloc.c: include "getpagesize.h" conditionalized on __svr4__. + +1999-10-31 Aubrey Jaffer + + * build.scm (batch:chop-to-fit-system): Removed. Use new + batch:try-chopped-command instead. + (mysql): Added to features. + (build:build): Added comments describing stages and errors. + +1999-10-17 Aubrey Jaffer + + * Makefile: Added platform.txi dependency where dependent on + scm.texi. + +1999-10-16 Aubrey Jaffer + + * Makefile (scm.info require.scm): "cp -p" more portable than "cp -a"? + +1999-10-15 Radey Shouman + + * sys.c (mode_bits): Fix for null output string case. + +1999-10-14 Radey Shouman + + * unif.c (make_sh_array): Reduced consing by using scm_cvapply + instead of apply. + +1999-10-13 Radey Shouman + + *sys.c (mode_bits): Now takes an optional buffer which, on exit, + will hold a mode string suitable to pass to fopen(), without any + SCM extension characters. + +1999-10-13 Aubrey Jaffer + + * r4rstest.scm (float-print-test): stop after first error. + +1999-10-13 Radey Shouman + + * sys.c (try_open_file): Insure that only 'r', 'w', 'b', or '+' + may be included in mode strings passed to fopen. + +1999-10-11 Radey Shouman + + * repl.c (scm_freshline): Added FRESHLINE. + * sys.c (init_storage): Make def_outp tracked, so freshline will + work with it. + +1999-10-10 Radey Shouman + + * ramap.c (cind): Now takes C vector of indices, which may be + allocated on the C stack, rather than a uve. + + (ramapc): (ramap): (ramap_cxr): (array_imap): (array_for_each): (rafe): + Use scm_cvapply instead of apply, allocate index and argument vectors + on the C stack for array ranks < 5. + + * record.c (makrectyp): (recprin1): Use scm_cvapply instead of + apply. + (rec_prinset): Checks arity of argument procedure. + + * sys.c (sfputc): (sfwrite): (sfgetc): Use scm_cvapply instead of + apply. + (mksfpt): Checks arities of soft port procedures when the port is made. + + * eval.c (scm_cvapply): (scm_arity_check): Exported. + (makacro): (makmacro): (makmmacro): Call scm_cvapply rather than + consing up argument lists. Check arity of macro transformers + once, when syntax is defined. + +1999-10-09 Radey Shouman + + * subr.c (make_vector): Fixed broken length argument test. + +1999-10-08 Radey Shouman + + * sys.c (scm_env_v2lst): Now takes list tail in scm_env_tmp, so + tail can be allocated on ecache. + +1999-10-06 Radey Shouman + + * repl.c (scm_top_level): Print out supplied program arguments for + failure exits to simplify debugging scripts. + + * eval.c (varcheck): Fixed for RECKLESS case. + +1999-10-04 Radey Shouman + + * eval.c (scm_arity_check): (macroexp1): Argument number checking + in macroexp1 abstracted as scm_arity_check, for use in map, + for-each ... + (scm_cvapply): Apply a function to a C vector of arguments, used by + map and for-each. + (scm_v2lst): Added for use in scm_cvapply. + (map): (for_each): Speed considerably improved: No longer allocate + Scheme vector temporaries for up to 5 list arguments. No longer + allocate unnecessary argument lists, allocate on ecache if + possible. + + * repl.c (iprin1): Print out first elt of cclo environment -- + makes record procedures more identifiable. + + * sys.c (scm_env_v2lst): Now takes last cdr of list as argument. + +1999-09-21 Aubrey Jaffer + + * sys.c (scm_port_entry): Make 16-bit safe. + +1999-09-19 Radey Shouman + + * Tscript.scm: File added to implement transcript-on, + transcript-off without burdening normal i/o. + + * Init5d1.scm (transcript-on): (transcript-off): Now autoloads + from SCM/Tscript.scm + + (_TRACKED): Added. + + * socket.c (l_socket): (l_connect): (l_listen): Modified to use + port table. + + (l_shutdown): (l_getpeername): (l_getsockname): Test for OPFPORTP, not + just OPPORTP. + + * posix.c (l_pipe): Modified to use port table. + (prinpipe): Removed. + + * ioext.c (reopen_file): (l_dup): (l_dup2): Modified to use port + table. + + * crs.c (prinwindow): Removed. + + (mkwindow): Uses scm_port_entry. + + * repl.c (iprin1): Uses "name" field for printing ports. + + (input_waiting): (wait_for_input): + + (trans_on): (trans_off): Removed in favor of soft-port implementation. + + (lputc): (lgetc): (lputs): (lfwrite): (lungetc): Removed check for + transcript, added line and column number support. Unread char now + kept in port table rather than CAR. + + (lreadpr): (line_num): Removed line counting for load port, now done + using general line and column counting. + + (scm_port_line): (scm_port_column): (scm_port_filename): Added. + + (err_head): Now prints out multiple filenames for nested loads. + Tries to recover from recursive errors if current-error-port is a + soft-port. + + * unif.c (uve_read): Removed ungetc call, if there is an unread + character, just call lgetc repeatedly for the first elt. + + * sys.c (must_malloc): (must_realloc): Now check whether the heap + is initialized or not, so may be called earlier. + + (scm_init_gra): (scm_grow_gra): Use above feature. + + (scm_port_entry): Added, allocates entry in a port table used to store + unread characters, file names, line & column numbers, &c. + + (mark_port_table): (sweep_port_table): Gc support for port table. + + ptobfuns now has a "name" element, used for printing. + (prinfport): (prinstpt): (prinsfpt): Removed. + +Sun Sep 12 22:54:58 EDT 1999 Aubrey Jaffer + + * patchlvl.h (SCMVERSION): Bumped from 5d0 to 5d1. + +1999-09-12 Aubrey Jaffer + + * x.c (init_x): Load "xevent.scm". + + * xtest.scm: Test key-press event. + + * xevent.h: Generated by "xgen.scm" + + * xevent.scm: Generated by "xgen.scm" + + * requires.scm: Sample "require.scm". + +1999-09-11 Aubrey Jaffer + + * Xlibscm.texi (Event): Documented x:event-ref. + +1999-08-26 Radey Shouman + + * sys.c (scm_egc): More robust test for sufficient cells in + freelist. + +1999-08-24 Radey Shouman + + * eval.c (wrapenv): Will no longer wrap an already wrapped + environment. + + * repl.c (def_err_response): Now prints "expand-time environment" + message only when relevant. + +1999-08-21 Aubrey Jaffer + + * xgen.scm (event-map): Added. + + * x.c: Absorbed event_names into "xevent.h". + +1999-08-20 Radey Shouman + + * repl.c (def_err_response): Error message for expand-time only + environment. + + * eval.c (lookupcar): (id_denote): Now handle environment objects + in scm_env, lookupcar will complain if this happens in a run-time + (rather than expand-time) context. + + (eval_syntax): Added, to be used in Macroexpand.scm for LET-SYNTAX, + LETREC-SYNTAX. + + (ceval_1): Fixed bug in eval. + + * scm.h (ENVP): exported macro from eval.c. + +1999-08-18 Radey Shouman + + * eval.c (apply): Removed some unreached statements, merged + duplicate code in tc7_specfun case. + +1999-08-17 Radey Shouman + + * eval.c: (ceval_1): Made EVAL tail recursive. + Cleaned up some stack tracing cases, renamed POP_TRACE + to TOP_TRACE, since POP_TRACE sounds as though it should be the + inverse of PUSH_TRACE. + + (ceval_1): Now modifies stack trace only after an estk + frame may be pushed, that is, when some invocation of eval may + modify the environment. The bottom of the stack trace (the form + being evaluated during a call to a subr) is kept in a global + `scm_trace'. Nested expressions involving primitives now give + more accurate stack traces, without a speed penalty. + + (map): (for_each): Always push an estk frame for the sake of stack + tracing. + + * repl.c (scm_stack_trace): Now may print out the value of the + global `scm_trace' as the top of the stack trace. + +1999-08-13 Radey Shouman + + * repl.c: Include for Cygwin, needed for select + support macros. + * scmfig.h: Define HAVE_SELECT for the Cygwin environment. + +1999-07-23 Radey Shouman + + * repl.c (scm_stack_trace): Put semi colons after frame numbers in + stack trace, rather than colons so emacs will not try to balance + parens. + +1999-07-20 Radey Shouman + + * build: Require build.scm in program-vicinity, since build.scm + may not be installed in implementation-vicinity. + +1999-07-19 + + * repl.c (def_err_response): Changed setjump to setjmp when + setting up safeport. + +1999-07-11 Aubrey Jaffer + + * Makefile (incdir): Added to abstract include directory location. + + * xgen.scm: Rewritten. generates xevent.h and xevent.scm from + . + + * inc2scm (scm<-usr/includes): System include path can be passed + as argument. + +1999-07-07 Radey Shouman + + * unif.c (arrayp): Fixed problem with immediate arguments. + + (scm_prot2type): Added, abstracts prototype -> + internal-array-type mapping. Accepts positive bignums as uvect + prototypes if they are small enough to be elements of a uvect, + similarly for negative bignums and ivects. + + (make_uve): (arrayp): Now use scm_prot2type. + + SINGLES no longer need to be #DEFINEd in order to allow fvects. + + * ramap.c: Modifications for fvects if SINGLES not #DEFINEd. + +1999-07-06 Radey Shouman + + * r4rstest.scm: Added named LET test for scope of init forms. + * eval.c (m_let): Changed scope of init forms in named LET, to + conform to R5RS, in response to posting of Allegro Petrofsky + to comp.lang.scheme + +1999-07-04 Aubrey Jaffer + + * crs.c (lwinsch): Renamed from lwinsert. Why were idlok and + nodelay commented out? + +1999-07-02 "Dai INUKAI(GAF05" + + * rgx.c: __FreeBSD__ include should be "gnuregex.h". + +1999-05-31 Aubrey Jaffer + + * Xlibscm.texi: Pulled out of "scm.texi". + +1999-05-29 Aubrey Jaffer + + * scl.c (llog2 lpow10): renamed from log2 and lpow10, which + conflicted with djgpp include file /d/djgpp/include/math.h. + +1999-05-15 Dai INUKAI + + * Transcen.scm (expt): R5RS: 0^z is 1 if z = 0 and 0 otherwise. + * r4rstest.scm (test-inexact): Added tests for EXPT of zero. + +1999-05-12 Radey Shouman + + * eval.c (lookupcar): Combined some error checking cases. + + (scm_macroexpand1): + (scm_extended_env): + (scm_env_ref): Low level support for hygienic macro expansion. + + * Macroexpand.scm (macro:expand): Added for hygienic macro expansion. + + * Macro.scm (renaming-transformer): Now passes a memoizing RENAME + procedure, so that renaming the same identifier results in renamed + identifiers that are EQV? per "Hygienic Macros Through Explicit + Renaming". + + * Init5d0.scm (defconst): Now allows redefinitions without effect + in the sense of EQUAL? rather than EQV? to allow reloading code + defining constant list structure. + +1999-05-09 Aubrey Jaffer + + * r4rstest.scm (test-eq?-eqv?-agreement): Added tests for eqv? + vs. eq? agreement discussed in section "Equivalence predicates". + +1999-05-09 Arne Glenstrup + + * Makefile (udscm5): Added '-s $(IMPLPATH)' for executable builds. + +1999-04-26 Radey Shouman + + * scl.c (inex_divbigbig): Was broken (did not return valid SCM) + for some cases. + +1999-04-22 Radey Shouman + + * r4rstest.scm (test-inexact-printing): Added to check that + (EQV? X (STRING->NUMBER (NUMBER->STRING X))) holds for inexact X. + + * scl.c (iflo2str): Revamped so that (EQV? X (STRING->NUMBER + (NUMBER->STRING X))) holds for floating point X. Somewhat as in: + Burger & Dybvig + "Printing Floating-Point Numbers Quickly and Accurately" + + But floating point rather than bignum arithmetic is used -- due to + this state of sin one slop factor was introduced. It would be + good to check this on non-IEEE-754 architectures. + + (istr2flo): Now reads floating point numbers with exponents somewhat + below -MAXEXP, since this such numbers can be represented with + gradually underflowing denormals. + +1999-04-15 Aubrey Jaffer + + * Makefile (require.scm): Added constructor. + +1999-04-01 Radey Shouman + + * sys.c (scm_maksubr): Added, returns a subr not (yet) bound to an + interned symbol, abstracts the addition of the subr_table entry. + (make_subr): Now uses scm_maksubr. + + * gsubr.c (make_gsubr): Now uses scm_maksubr (was buggily using + old subr name encoding.) + + * eval.c (make_synt): Now uses scm_maksubr. + + * scm.h: Added prototypes for make_gsubr, scm_maksubr. + +1999-03-26 Arne John Glenstrup + + * scm.h (ptobfuns): added const to puts() and fwrite() prototypes. + + * gmalloc.c: fixed compilation on hpux. + +1999-03-26 Radey Shouman + + * Init5d0.scm (identity): Now a subr: CR. + * eval.c + * gsubr.c + * repl.c + * scm.h + * subr.c + * sys.c (SNAME): Pointers to subr names now kept in a mallocated + data structure, the top 16 bits of the CAR of a subr is an index + into this table. Eventually this should help support eg generic + arithmetic. + +1999-03-25 Radey Shouman + + * sys.c (scm_grow_gra): Fixed error in mallocated accounting, made + increment grow with allocated size. + +1999-03-22 Aubrey Jaffer + + * Init5d0.scm (exec-self): Undo *script* meta-argument processing. + +1999-03-18 Radey Shouman + + * Init5d0.scm (read:sharp): Simplified somewhat; again accepts + '#2((a b c) (1 2 3)) as array read syntax, with warning. + +1999-03-17 Radey Shouman + + * unif.c (raprin1): New write syntax for uniform vectors and arrays. + (array2list): (list2ura): Fixed for zero-rank arrays. + + * Init5d0.scm (read:sharp): New read syntax for uniform vectors + and arrays. + +1999-03-16 Radey Shouman + + * x.c (scm2int_pair): Generalized to accept uniform vectors and + arrays. + + * eval.c + * ramap.c + * repl.c + * rope.c + * scl.c + * scm.h + * sys.c + * unif.c + Added uniform vector type for signed short integers, tc7_svect. + The prototype is the symbol 'short, the print representation is + not currently readable. (Both items subject to change.) + +1999-03-11 Aubrey Jaffer + + * x.c (x:close): Merged from x:close-display and x:destroy-window. + Flushes after closing window. + + * x.c: Use OPN and other bits in type-word. Fixed GC of closed + windows and displays. + +1999-03-10 Aubrey Jaffer + + * x.c: Added copyright notice. + +1999-03-07 Aubrey Jaffer + + * mkimpcat.scm (edit-line): editline -> readline. + + * Makefile (mydlls): build edit-line separately to link in + libraries correctly. + +1999-02-17 Aubrey Jaffer + + * build.scm, mkimpcat.scm, x.c, x.h, x11.scm, xgen.scm, xscm.doc, + xtest.scm: Xlib interface from xscm-2.01 + +1999-02-12 Hakan L. Younes + + * build.scm, findexec.c, scm.c, scm.texi, scmfig.h, time.c: + amiga-gcc port. + +1999-02-11 Aubrey Jaffer + + * repl.c (scm_warn): renamed from warn(). + +1999-02-04 Radey Shouman + + * setjump.h + * repl.c (scm_stack_trace): + * sys.c (safewrite): + Made all safeport operations consistently use the standard C + setjmp, longjmp, and jmp_buf. + +1999-01-27 Aubrey Jaffer + + * build.scm (build): -Dfreebsd no longer necessary for freebsd + builds. + + * findexec.c: freebsd -> __FreeBSD__. + * ioext.c: freebsd -> __FreeBSD__. + * time.c: freebsd -> __FreeBSD__. + +1999-01-27 Bakul Shah + + * sys.c (add_final): Fixed call to scm_grow_gra. + + * subr.c (promisep): Added PROMISE? + +1999-01-23 Aubrey Jaffer + + * build.scm (obj->): Added (was called but not defined). + +1999-01-17 Aubrey Jaffer + + * build.scm (read-version): 5d0 READ as a number; Assemble + characters till whitespace. + +Sun Jan 17 14:52:11 EST 1999 Aubrey Jaffer + + * patchlvl.h (SCMVERSION): Bumped from 5c4 to 5d0. + +1999-01-16 Aubrey Jaffer + + * ramap.c (init_ramap): definition for ARRAY-INDEXES added. + + * scmmain.c (generic_name): Added (local char** init wasn't + portable). + +1999-01-12 Aubrey Jaffer + + * Makefile (version.txi): support added. + + * scm.texi (SCM_VERSION): abstracted to version.txi. + +1999-01-12 Aubrey Jaffer + + * build (make-readme): moved (require 'posix) here. + +1999-01-11 Aubrey Jaffer + + * build.scm (read-version): simplified. + + * build (make-readme): added. Makes README from scm5c4.info. + +1999-01-11 Aubrey Jaffer + + * Makefile (README): added target. + + * build (print-manifest): added. + + * scm.texi: Added spacing workaround for Texinfo @deftypefun bugs. + (Problems *): @table --> @multitable. + (Standards Compliance): Updated for R5RS. + (SCM Options): fixed - and --; @minus{} breaks TeX! + +1999-01-10 Aubrey Jaffer + + * scm.texi (Scripting): renamed from Shell Scripts. Reorganized; + rewrote examples. + (SCM Options): fixed -- as well as texinfo can. + + * Init5c4.scm (boot-tail): load *script* if not done by options. + + * script.c (script_process_argv): Allow space between #! and + pathname. + + * scm.c (scm_init_from_argv): gets additional argument + `script_arg', which becomes the value of *script*. + + * ioext.c (director-for-each): fail gracefully if can't open + directory. + +1999-01-08 Aubrey Jaffer + + * scm.texi (Smob Cells): Explained NUMDIGS_MAX limit. + + * sys.c (init_storage): Added check for NUMDIGS_MAX. + + * scmfig.h (NUMDIGS_MAX): moved from "scm.h". Reduced to 1000 + (4816 decimal digits). + +1999-01-04 Aubrey Jaffer + + * scm.texi (Embedding SCM): Added libtest.c example. + + * Makefile (libtest): Added target. + + * scm.c (dirsep): added variable. + + * repl.c (heap_report): Only call scm_brk_report() if scm_init_brk + has been set. + +1999-01-04 Aubrey Jaffer + + * scm.texi (Unix Shell Scripts): merged in "SCSH scripts". + Removed description of single non-\ argument on first script line. + +1999-01-03 Aubrey Jaffer + + * scm.texi (Embedding SCM): Rewrote. + + * repl.c (scm_top_level): Pass initpath string to boot-tail + (rather than #t) for dumped executables. + + * scmfig.h (RTL): removed. main() is now in scmmain.c. + + * build.scm (C-libraries): Added `lib', which excludes + "scmmain.c"; Removed RTL flag. + + * dynl.c (init_dynl): Don't try to compute execpath. + + * script.c (find_impl_file): Renamed from scm_find_impl_file. + Fixed reduntant "lib" check. Added tests for executable-name peer + and generic peer directories. + + * Init5c4.scm (set-vicinities!): Simplified. Now takes init-file + argument. + + * scmmain.c: created, stealing main() and scm_find_implpath() from + "scm.c". + + * scm.c (scm_find_impl RTL main): removed. + +1999-01-02 Aubrey Jaffer + + * repl.c, scm.c: moved initpath==0 argument handling from main to + scm_top_level(). + + * Makefile: Redundant DFLAG = -DIMPLINIT=\"$(IMPLINIT)\" removed. + IMPLINIT still #defined by scmflags.h. + +1998-12-18 Aubrey Jaffer + + * Link.scm (compile-file): Converted from replace-suffix to + filename:substitute??. + + * build.scm (c->): Added. + (c->o): Added. + (c->obj): Added. + (obj->exe): Converted from replace-suffix to filename:substitute??. + +1998-12-15 Radey Shouman + + * eval.c (ecache_eval_args): Added, allocates an environment frame + in the ecache and does argument number checking for closures with + >= 3 arguments (and no rest argument). + (asubr_apply): Added to apply multiargument rpsubrs and asubrs without + consing. + + * sys.c (scm_env_v2lst): Added for ecache_eval_args, builds a list + of ecache cells from an argument vector. + +1998-12-14 Radey Shouman + + * eval.c (m_lambda): (closure): Now checks that argc <= 3 during + memoization instead of each time a closure is made. + (macroexp1): Gives more sensible error messages when a + non-identifier non-list is in the function position. + +1998-12-10 Radey Shouman + + * (scm_top_level): (repl): Made repl an acceptable second argument to + scm_top_level. + +1998-12-09 Aubrey Jaffer + + * sys.c (VERIFY_INTS): Pass 0L rather than 0 for null pointer args. + + * scm.c: Pass 0L rather than 0 for null pointer args. + + * rgx.c (lregerror): Pass 0L rather than 0 for null pointer args. + +1998-12-09 Radey Shouman + + * repl.c (scm_top_level): Now takes a second argument, toplvl_fun, + which is a function of no arguments returning SCM. If this + variable is non-null, it will be called instead of repl(), if + toplvl_fun returns BOOL_T, it may be called again, otherwise + scm_top_level will return. + + Now checks that BOOT-TAIL is non-immediate before applying it, so + that it becomes optional. + + * scm.c (run_scm): Deleted, subsumed by main(). + + * patchlvl.h (INIT_FILE_NAME): #defined even for RTL case. The + init file is probably useful even if the default top level is not + used. + + * eval.c (varcheck): Now counts required arguments so m_lambda + doesn't have to. + +1998-12-08 Radey Shouman + + * Macro.scm (Macro:compile-syntax-rules) Check that car of each + rule is a pair. + +1998-12-08 Aubrey Jaffer + + * scm.c (main): Changed argc==0 argv[0] from "scm" to + GENERIC_NAME. + +1998-12-06 Aubrey Jaffer + + * scm.texi (Embedding SCM): Changed from "Calling Scheme From C". + + * scm.c (scm_execpath scm_find_executable): moved from repl.c. + (init_banner): Changed to use pre-processor concatenation. + (main): modularized. + (run_scm): freeall argument added to control calling of + free_storage(). + + * repl.c (scm_top_level): initpath with leading '(', ';', or + whitespace taken as string to load (rather than filename). + (init_sbrk): extracted from main(). + + * dynl.c (init_dynl): ifdef RTL removed. + +1998-12-06 Radey Shouman + + * subr.c + * scl.c (scm_intexpt): Special cases for arithmetic that can be + done with native C types. Moved from subr.c to scl.c because of + FLOAT dependencies. + + * eval.c (lookupcar): (ceval_1): Added MEMOIZE_LOCALS cpp macro to + control memoization of local variables to ilocs. + +1998-12-05 Aubrey Jaffer + + * repl.c (tryload): Removed TAIL_RECURSIVE_LOAD version. + (scm_top_level): If string argument starts with whitespace, `)', or + `;', then call scm_ldstr() with argument rather than scm_ldfile(). + + * build.scm (compile-dll-c-files linux): delete .o after making .so. + + * scm.c (init_scm): Rest of inits moved into. + (final_scm): Handles finals. + (scm_init_from_argv): Handles universal argv processing; + platform-dependent argv processing remains in main(). + +1998-12-04 Radey Shouman + + * repl.c (def_err_response): Fixed to print stack trace even if + err_exp is not defined. + + * repl.c + * sys.c + * scm.h errjmp_bad is now a pointer to a string, rather than an + int, so that the final error message can say in which critical + code section the error occured. + +1998-12-03 Aubrey Jaffer + + * repl.c (scm_top_level): renamed from repl_driver. + +1998-12-03 Radey Shouman + + * scl.c (makdbl): Combined some DEFER_INTS and ALLOW_INTS, + possible because NEWCELL is now callable with ints deferred. + (product): (divide): Now scale bignums if necessary before + converting them to doubles for calculating inexact results. + (big2scaldbl): (bigdblop): (inex_divbigbig): Auxiliary functions + added. + (idbl2str): Decrease minimum exponent to allow printing of + gradually underflowing IEEE doubles. + + * scm.c (setitimer): Made each option individually controlled by #ifdef, + now returns #f instead of error if given an unsupported option. + + * Init5c4.scm This is used to initialize the appropriate alarm + procedures. + +1998-12-02 Radey Shouman + + * scm.h (NUMDIGS): Added cast so that NALLOC error reports would + print correctly. + +1998-12-02 Aubrey Jaffer + + * setjump.h: windframe removed -- dowinds could only be processed + while (possibly oversize) stack was intact. + + * scm.h (ARGn .. PROF_SIGNAL): Special err_pos values renumbered + from 1; this allows 0 to indicate message has been printed. + (dynwinds): restored to sys_protects. + + * repl.c (repl_driver): dowinds() call moved from abrt(), quit(), + and restart(); dowinds() now done after longjump. + (repl_driver): cur_inp being closed now indicates that SCM should + exit -- after printing error messages. + (def_err_response): err_pos = 0 after printing message. If + err_pos==0, don't print message. + + * Init5c4.scm (fluid-let): Shrunk using multi_set returns. + + * eval.c (scm_multi_set): Now returns new list of old values. + + * scm.c (l_pause): DJGPP2.0 lacks ITIMER_VIRTUAL; can't quit SCM! + #undef SIGPROF if ITIMER_VIRTUAL not defined. + + * sys.c (reset_safeport): fixed 16-bit argument to + must_malloc_cell. + (dowinds): fixed limit case behavior. + +1998-12-01 Aubrey Jaffer + + * Init5c4.scm (fluid-let): defmacro added. + + * eval.c (scm_multi_set): Added. (set! (a b c) (list 10 20 30)) + sets 3 variables. + + * sys.c (dowinds): Eliminated second argument. + (dynwinds): No longer a sysprotect. + + * setjump.h (windframe): Dynamic wind information now kept in + linked struct windframe on C-stack. + +1998-12-01 Radey Shouman + + * sys.c safeport now includes jmp_buf, to which it will longjump + after writing its character limit. This makes it safe to print + out possibly circular structures in error handling routines. + (reset_safeport): Now returns non-zero only if its argument + really was a safeport. + + * setjump.h (SAFEP_JMPBUF): Macro accessor for the jmp_buf, + setjump *must* be called with this argument before using a + safeport. + + * repl.c (scm_stack_trace): (def_err_response): Use new + safeport features. + + * Macro.scm (substitute-in-template): Added check that all pattern + variables combined in an ellipsis template have the same length. + +1998-11-29 Aubrey Jaffer + + * scm.texi (Socket): examples updated to use wait-for-input; no + longer spin-wait. + + * repl.c (wait_for_input): `select'-like procedure added. + (char_readyp): now supported by DJGPP. + + * ioext.c (l_putenv lexec*): DJGPP now supports. + + * scm.c (l_raise SIGALRM): DJGPP now supports. + + * scmfig.h: include now seems safe for DJGPP. + +1998-11-28 Aubrey Jaffer + + * scm.texi (Data Type Representations): PTOBs had wrong code and + lsubr was missing! + +1998-11-26 Aubrey Jaffer + + * repl.c (def_err_response): Now truncates ALL long expressions + being printed. + + * sys.c (must_malloc must_malloc_cell): 0 -> 0L to fix 16-bit + scmlit. + +1998-11-26 Radey Shouman + + * eval.c (ceval): (env2tree): (ident_eqp): Removed redundant + DEFER_INTS_EGC before ENV_PUSH. + (ceval_1): Removed label retunspec, replaced by jumps to + retx. Seems to run a tad faster, be a little easier to look at. + (copy_list): Now takes second argument giving minimum length of + list, allowing the removal of several calls to ilength. + (m_case): (m_cond): (ceval_1): ilength checks replaced. + +1998-11-25 Radey Shouman + + * repl.c (scm_stack_trace): Changed numbering of stack frames. + (def_err_response): Now prints erring expression before + stack trace. + (init_tables): Removed unnecessary assignment to + scm_verbose, which was already 1 under any circumstances. + (def_err_response): Now truncates long expressions being + printed. + (err_head): More robust test for output to stderr, to + decide whether to call perror or not. + + * sys.c (init_types): Initialize sys_safep to tmp_errp. + (reset_safeport): Now does exactly nothing if handed a + non-safe-port. + (init_types): (init_storage): Moved initialization of tmp_errp and + sys_protects earlier, in case allocating ptobs or smobs causes + errors to be thrown. + +1998-11-24 Radey Shouman + + * scm.h (NUM_IFLAGS): Added to make COOKIE, UNCOOK definitions a + little easier to read. + + * sys.c (reset_safeport): Added, resets count and optionally + parent port on a safe-port. + (sys_safep): New sys_protect, so stack-trace doesn't have to + allocate pairs for a safe-port. + + * repl.c (scm_stack_trace): Now uses sys_safep and reset_safeport. + (def_err_response): (handle_it): (repl_driver): (everr): + Now checks and dies horribly but predictably if def_err_response + is recursively entered. + +1998-11-20 Radey Shouman + + * eval.c (env2tree): Check for undefineds in environment to + prevent endless loop, substitute #. + * repl.c (stack_trace): Now uses safe ports, prints "STACK TRACE" + message (I don't remember when that disappeared) and prints at + most 12 traced frames. + + * sys.c (makesafeport): (safewrite): (safeputs): (safeputc): + (safeflush): Added support for `safe' ports for error messages, + which will accept and re-output only a fixed number of + characters. Subsequent characters are simply discarded. + +1998-11-19 Radey Shouman + + * record.c (rec_error): (rec_accessor1): (rec_modifier1): + (rec_constr1): Better error reporting, including the name of the + expected record type and the relevant field. + + (rec_prinset): Added PRINTER field to RTDs so they may be printed + by a user- specified procedure. Scheme signature: + (RECORD-PRINTER-SET! RTD PRINT-PROCEDURE) where PRINT-PROCEDURE + takes as arguments the record and a port. + + Added local accessor macros for record & rtd fields, removed + questionable union type declarations. + +1998-11-18 Radey Shouman + + * Macro.scm (macro:compile-syntax-rules): Minor cleanup, made + internal rule representation a record type rather than list. + (renaming-transformer): Added to support `explicit + renaming' low-level macros. + + * eval.c (varcheck): (m_lambda): Some checks moved from m_lambda + to varcheck, argument added to varcheck to give different message + (about "formals") in case of lambda. + (ENVP): Added predicate macro local to eval.c. + +1998-11-16 Radey Shouman + + * eval.c (varcheck): Renamed from uniqcheck, now checks that + elements are identifiers so m_do, m_lambda, m_letrec1 don't have to. + + * Init5c4.scm (alarm-interrupt) (profile-alarm-interrupt) + (virtual-alarm-interrupt) Now initially defined to turn off their + respective alarms, so that restarting does not cause an error when + an alarm is pending. + + * sys.c (gc_mark): Now marks the header of smobs and ptobs, so the + mark function doesn't have to. + * unif.c: + * record.c: + * rgx.c: + * rope.c: + * scm.h: Ptob and smob mark functions modified to not mark headers. + +1998-11-15 Radey Shouman + + * eval.c (bodycheck): Removed, was only used in m_do. + (m_do): No longer calls bodycheck. + (lookupcar): No longer memoizes if no checking is to be done, eg + if doing speculative expansion. + (macroexp1): Now saves car in local variable to avoid calling + unmemocar. + (uniqcheck): Added, checks for non-unique identifiers in a binding + list. + (m_lambda): (m_letrec1): (m_do): Now check for duplicate bound + names. + +1998-11-13 Radey Shouman + + * unif.c (shap2ra): better error checking of dimension specs + +1998-11-12 Aubrey Jaffer + + * scmfig.h (SCM_NEED_FDS SCM_INTERRUPTED): added argument to make + clear that this is not a constant. + +1998-11-11 Radey Shouman + + * scmfig.h (SCM_INTERRUPTED): Abstracted the interrupted test from + SYSCALL. + (SCM_OPENCALL): Similar to SYSCALL, but will gc to reclaim + file descriptors. + + * sys.c (try_open_file): Now uses SCM_OPENCALL. + (gc_for_open_files): Added. + + * ioext.c: + * posix.c: + * socket.c: File opening system calls now use SCM_OPENCALL. + If an open fails because there are no unused file handles, GC for + for file handles. + +1998-11-11 Aubrey Jaffer + + * Init5c4.scm (vicinity:suffix?): Abstracted from + pathname->vicinity and "Link.scm". + +1998-11-08 Aubrey Jaffer + + * sys.c, scm.c, record.c, ramap.c: Changed some intern -> sysintern. + + * build.scm (compile-c-files linux): gcc -O2 produces unreliable + objects for Cyrix 6x86 processor; -O2 option removed. + +1998-11-05 Aubrey Jaffer + + * ioext.c (init_ioext): (provide 'directory-for-each) changed to + add_feature("directory-for-each"); so ioext.o can be statically + linked. + +1998-11-04 Radey Shouman + + * scm.h (ESTK_PARENT): (ESTK_PARENT_WRITABLEP): + (ESTK_PARENT_INDEX): SCM_ prepended, definition moved to scm.h, + now used in repl.c. + + * repl.c (handle_it): Fixed so stack traces extend before + interrupt handler calls. + (scm_stack_trace): Fixed for segmented environment stack. + +1998-11-03 Aubrey Jaffer + + * repl.c (def_err_response): print out errobj if short string; if + long string, print out first 57 characters and "...". This makes + messages about not finding Init???.scm more informative. + +Tue Nov 3 17:41:40 EST 1998 Aubrey Jaffer + + * patchlvl.h (SCMVERSION): Bumped from 5c3 to 5c4. + +1998-11-03 Aubrey Jaffer + + * ioext.c (directory-for-each): Added. + + * Makefile (build): Added to TAGS. + +1998-11-02 Radey Shouman + + * sys.c (makcclo): Fixed argument to ASSERT. + +1998-11-02 Aubrey Jaffer + + * record.c rgx.c scm.texi socket.c subr.c sys.c unif.c: Callers to + must_malloc and friends now check that length will fit in field. + + * scmfig.h sys.c (SHORT_SIZET): Added to detect whether sizet + width or LENGTH field more restrictive. + + * rope.c (must_free_argv): changed to use must_free. + + * scm.h (LENGTH_MAX): Changed from fixed constant to cpp computed. + (NUMDIGS_MAX): Added. + +1998-11-01 Aubrey Jaffer + + * sys.c (gc_sweep): Continuation storage was not being counted + when freed. + + * time.c (your_time): fixed scaling so numbers returned use full + INUM range. + +1998-10-29 Radey Shouman + + * eval.c (m_and): (m_or): Special case for one argument. + +1998-10-28 Radey Shouman + + * setjump.h + * sys.c (scm_make_cont): (scm_dynthrow): (egc_copy_roots): + No longer copy scm_estk if CHEAP_CONTINUATIONS is #defined. + + * eval.c (ceval_1): Fix up environment stack accounting for + CHEAP_CONTINUATIONS. + +1998-10-27 Aubrey Jaffer + + * scm.c (scm_init_extensions): Added call to init_user_scm + for RTL case. + Moved #ifndef RTL to insure DIRSEP and GENERIC_NAME are #defined + for RTL case. + + * build.scm Now builds archive called libscm.a rather than scm.a + +1998-10-20 Aubrey Jaffer + + * Init5c3.scm (with-XXX-to-port): Oops. fixed earlier change. + +1998-10-19 Aubrey Jaffer + + * scm.texi (Build Options): Build platform table in Makefile and + @include. + +1998-10-19 Radey Shouman + * dynl.c (l_dyn_call): (l_dyn_main_call): Now use new P_SHL macro, + prevents compiler warning under hpux. + + * sys.c (scm_free_gra): Now sets elts pointer to zero. + (free_storage): scm_free_gra now sets smobs and ptobs to zero. + (egc_sweep): Give dead cells immediate values, prevents obscure + gc bug seen in hpux. + + * sys.c (scm_estk_grow): (scm_estk_shrink): Deleted incorrect + DEFER/ALLOW_INTS. + + (init_storage): SHORT_INT fixconfig message now suggests changing + scmfig.h rather than setjump.h + +1998-10-16 Basile STARYNKEVITCH + + * repl.c (lreadr): linum now incremented for LINE_INCREMENTORS + within strings. + +1998-10-16 Aubrey Jaffer + + * scmfig.h (SHORT_INT): __alpha is. + +1998-10-14 Radey Shouman + + * eval.c (apply): Deleted redundant DEFER_INTS_EGC, added + ALLOW_INTS_EGC to closure apply case. + +1998-10-13 Radey Shouman + + * sys.c (egc_copy_stack): Provide strict bound on live locations. + + * eval.c (apply): Added default case for tc7_specfun type, + replaces special handling for (apply apply ...) and (apply + call-with-current-continuation ...) + +1998-10-12 Radey Shouman + + * scm.h (ISYMSETVAL): renamed to MAKISYMVAL. + + * sys.c (scm_estk_reset): Now takes an argument giving the size of + the environment stack to create, 0 gives a default size. + + (scm_estk_grow): (scm_estk_shrink): Rewritten to use segmented + stack, so all of the stack need not be copied when the stack grows + or when a continuation is captured. + + (scm_env_cons): (scm_env_cons2): (scm_env_cons_tmp): + (scm_extend_env): Rewritten using local temporary for indexing + into ecache. + +1998-10-06 Radey Shouman + + * scm.c: SIGPROF #undefined if LACK_SETITIMER is #defined, needed + to build profiling version of SCM. + +1998-10-06 Aubrey Jaffer + + * build.scm (read-version): Will use implementation-vicinity if + scm-srcdir does not contain "patchlvl.h". + +1998-10-03 Radey Shouman + + * scm.c (run_scm): Fixed finals call loop + +1998-10-02 Aubrey Jaffer + + * unif.c, sys.c, subr.c, socket.c, scm.h, scl.c, rgx.c, posix.c: + Fixed argument types in calls to must_malloc_cell(). + + * scm.h, repl.c, dynl.c, continue.h: + CodeWarrior-Pro-3 port from Bob Schumaker + +1998-10-01 Bob Schumaker + + * dynl.c: must_free_argv() was called with extra argument! + + * continue.h (SHORT_ALIGN): Port for `CodeWarrior Pro 3'. + + * repl.c, scm.h: declarations added for `CodeWarrior Pro 3'. + +1998-09-29 Aubrey Jaffer + + * Link.scm (link-named-scm): simplified; prepping for hobbit5. + +1998-09-29 Radey Shouman + + * scm.c Added SIGVTALRM callback. + + * Init5c3.scm (profile-alarm-timer): Renamed from profile-timer, + (virtual-alarm-timer): added. + + * sys.c (must_malloc_cell): Takes an argument specifying the CAR + of the cell to be returned. + + * scm.h (MAKE_LENGTH): (MAKE_NUMDIGS): Preprocessor macros added. + +1998-09-29 Aubrey Jaffer + + * build (build-from-argv): slib:warns if not successful. + (bi): Exits with error indication when build not successful. + + * build.scm (build): Sense was wrong; heap-can-shrink renamed + no-heap-shrink + (batch:rebuild-catalog): always return #t. + +1998-09-22 Radey Shouman + + * sys.c (scm_init_gra): (scm_grow_gra): (scm_free_gra): GRowable + Array type. + (newsmob): (newptob): (add_final): Implemented using scm_gra type. + +1998-09-18 Radey Shouman + + * Init5c3.scm (profile-timer): (milli-alarm): Defined in terms of + SETITIMER. + + * sys.c (sysintern): No longer changes the CDR of an existing + symhash value cell if second argument is UNDEFINED. For use with + scm_setitimer, which uses symbols as keys, but not as identifiers. + + * scm.c (scm_proftimer): Removed. + (scm_setitimer): Added, interface to setitimer/getitimer allowing + use of ITIMER_REAL, ITIMER_VIRTUAL, ITIMER_PROF. + +1998-09-18 Aubrey Jaffer + + * posix.c (scm_getgroups): added scm_protect_temp(&grps); + +1998-09-17 Aubrey Jaffer + + * Init5c3.scm (with-input-from-port): (with-output-to-port): + (with-error-to-port): Replicated procedure rather than using + SWAPPORTS twice. This in combo with repl.c change fixes Radey's + strange multi-process bug! + + * repl.c (set_inp set_outp set_errp): Made variable swap atomic. + Also changed so port argument can be closed. + +1998-09-17 Radey Shouman + + * sys.c (init_storage): Fixed estk initialization to work when + restarted. + +1998-09-16 Radey Shouman + + * Init5c3.scm (read:sharp-char): Added, parses emacs style meta + and control char syntax. + + * repl.c (lreadpr): Added callout to READ:SHARP-CHAR for otherwise + undefined #\ read sequences, memoized references to READ:SHARP. + + * unif.c (resizuve): Fixed accounting of mallocated storage for + strings and bitvectors. + + * sys.c (igc_for_alloc): (must_malloc): (must_realloc): + (must_malloc_cell): + (must_realloc_cell): Fixed accounting of mallocated storage. + + (igc): Added malloc consistency check for patched gmalloc, conditional + on #define DEBUG_GMALLOC. + + (gc_sweep): Fixed accounting of bignum storage for DIGSTOOBIG case. + + (intern): Avoid possible race condition by deferring ints during + search. + + * scm.c (process_signals): Process from low numbers to higher, ala + Unix signals. More fatal errors should come earlier in the list. + Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer * patchlvl.h (SCMVERSION): Bumped from 5c2 to 5c3. @@ -5,7 +1351,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer 1998-09-11 Radey Shouman * gmalloc.c: Imported gmalloc.c from emacs 20.2.1. - + (check_block): (check_frag_blocks): Debugging functions added. * sys.c (scm_protect_temp): Added, is currently, and probably will @@ -15,7 +1361,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer * scl.c (big2str): Added call to scm_protect_temp. * eval.c (map): (for_each): Added calls to scm_protect_temp. - + * rgx.c (lregcomp): Added call to scm_protect_temp. 1998-09-04 Radey Shouman @@ -41,7 +1387,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer * scmfig.h (VERIFY_INTS): Added macro to print warnings if interrupts are improperly allowed and CAREFUL_INTS is #defined. - + (VOLATILE): Expands to `volatile' keyword if __STDC__ is #defined. * sys.c (sys_errp): Interrupt safe system output port added. @@ -59,7 +1405,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer (closure): Now takes the number of required closure arguments as a second argument. (m_lambda): Computes and memoizes the number of required arguments. - + * repl.c (iprlist): Uses GCCDR so that fatal error messages during gc may print better. (handle_it): Call to scm_egc made conditional on NO_ENV_CACHE. @@ -76,7 +1422,7 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer * Init5c2.scm (array-shape): No longer signals an error when passed a non-array -- now returns whatever ARRAY-DIMENSIONS returned (currently #f). - + 1998-08-26 Aubrey Jaffer * scm.c (scm_proftimer): Also conditional on SIGALRM. @@ -435,7 +1781,7 @@ Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer 1998-06-22 Radey Shouman * eval.c (ENV_PUSH): Fixed problem introduced during last change: - estk was overstepping its bounds. + estk was overstepping its bounds. 1998-06-19 Radey Shouman @@ -638,7 +1984,7 @@ Wed May 20 17:53:52 EDT 1998 Aubrey Jaffer 1998-05-14 Radey Shouman * Init.scm (bit-extract): (logical:bit-field): - (logical:bitwise-if): (logical:copy-bit): + (logical:bitwise-if): (logical:copy-bit): (logical:copy-bit-field): definitions added for SLIB compatibility. * subr.c (scm_bitfield): renamed BIT-EXTRACT to BIT-FIELD, diff --git a/Iedline.scm b/Iedline.scm index cbeb265..8c076a0 100644 --- a/Iedline.scm +++ b/Iedline.scm @@ -1,18 +1,18 @@ ;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. -;; +;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; +;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. -;; +;; ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission ;; for additional uses of the text contained in its release of GUILE. @@ -36,14 +36,14 @@ ;; ;; If you write modifications of your own for GUILE, it is your choice ;; whether to permit this exception to apply to your modifications. -;; If you do not wish that, delete this exception notice. +;; If you do not wish that, delete this exception notice. ;; "Iedline.scm" Scheme interface to readline library ;; Author: Radey Shouman ;; Change both current-input-port and current-output-port to ;; allow line editing of input. -;; All output goes through a soft port in order to detect prompt +;; All output goes through a soft port in order to detect prompt ;; lines, i.e. lines unterminated by a newline. (define (make-edited-line-port) @@ -96,7 +96,7 @@ (set! edit-port #f))) past))) -(and +(and (if (provided? 'unix) (isatty? (current-input-port)) #t) (eq? (current-input-port) (default-input-port)) (not (getenv "EMACS")) diff --git a/Init5c3.scm b/Init5c3.scm deleted file mode 100644 index 903003e..0000000 --- a/Init5c3.scm +++ /dev/null @@ -1,966 +0,0 @@ -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;; -;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. -;; -;; The exception is that, if you link the GUILE library with other files -;; to produce an executable, this does not by itself cause the -;; resulting executable to be covered by the GNU General Public License. -;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. -;; -;; This exception does not however invalidate any other reasons why -;; the executable file might be covered by the GNU General Public License. -;; -;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy -;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does -;; not apply to the code that you add in this way. To avoid misleading -;; anyone as to the status of such modified files, you must delete -;; this exception notice from them. -;; -;; If you write modifications of your own for GUILE, it is your choice -;; whether to permit this exception to apply to your modifications. -;; If you do not wish that, delete this exception notice. - -;;;; "Init.scm", Scheme initialization code for SCM. -;;; Author: Aubrey Jaffer. - -(define (scheme-implementation-type) 'SCM) -(define (scheme-implementation-version) "5c3") - -(define pathname->vicinity - (let ((*vicinity-suffix* - (case (software-type) - ((AMIGA) '(#\: #\/)) - ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) - ((MACOS THINKC) '(#\:)) - ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT) '(#\/)) - ((VMS) '(#\: #\]))))) - (lambda (pathname) - ;;Go up one level if PATHNAME ends in a vicinity suffix. - (let loop ((i (- (string-length pathname) 2))) - (cond ((negative? i) "") - ((memv (string-ref pathname i) *vicinity-suffix*) - (substring pathname 0 (+ i 1))) - (else (loop (- i 1)))))))) - -;;; This definition of PROGRAM-VICINITY is equivalent to the one defined -;;; SLIB/require.scm. It is used here to bootstrap -;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY. - -(define (program-vicinity) - (if *load-pathname* - (pathname->vicinity *load-pathname*) - (error "not loading but called" 'program-vicinity))) - -(define in-vicinity string-append) - -;;; This is the vicinity where this file resides. -(define implementation-vicinity #f) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use -;;; (implementation-vicinity) as (library-vicinity). "require.scm", -;;; the first file loaded from (library-vicinity), can redirect it. - -(define library-vicinity #f) -(define home-vicinity #f) -(define (set-vicinities!) - (set! implementation-vicinity - (let ((vic (if *load-pathname* ;Happens when not dumped. - (program-vicinity) - (let ((path - (or (getenv "SCM_INIT_PATH") - (find-init-file (execpath #t))))) - (if path - (pathname->vicinity path) - (or (and (procedure? implementation-vicinity) - (implementation-vicinity)) - (error "Can't find SCM_INIT_PATH"))))))) - (lambda () vic))) - (set! library-vicinity - (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) - (if library-path - (lambda () library-path) - (lambda () - (let ((olv library-vicinity) - (oload load)) - (dynamic-wind - (lambda () (set! load identity)) - (lambda () - (try-load (in-vicinity (implementation-vicinity) - "require.scm"))) - (lambda () (set! load oload))) - (if (eq? olv library-vicinity) - (error "Can't find library-vicinity")) - (library-vicinity)))))) - (set! home-vicinity - (let ((home (getenv "HOME"))) - (and home - (case (software-type) - ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME - (if (not - (char=? #\/ - (string-ref home (+ -1 (string-length home))))) - (set! home (string-append home "/")))))) - (lambda () home)))) -(set-vicinities!) - -;;; Here for backward compatability -(define scheme-file-suffix - (case (software-type) - ((NOSVE) (lambda () "_scm")) - (else (lambda () ".scm")))) - -(set! *features* - (append '(getenv tmpnam abort transcript with-file - ieee-p1178 rev4-report rev4-optional-procedures - hash object-hash delay dynamic-wind - multiarg-apply multiarg/and- logical defmacro - string-port source current-time) - *features*)) - -(define (exec-self) - (require 'i/o-extensions) - (execv (execpath) (program-arguments))) - -(define (terms) - (list-file (in-vicinity (implementation-vicinity) "COPYING"))) - -(define (list-file file) - (call-with-input-file file - (lambda (inport) - (do ((c (read-char inport) (read-char inport))) - ((eof-object? c)) - (write-char c))))) - -(define (read:array digit port) - (define chr0 (char->integer #\0)) - (let ((rank (let readnum ((val (- (char->integer digit) chr0))) - (if (char-numeric? (peek-char port)) - (readnum (+ (* 10 val) - (- (char->integer (read-char port)) chr0))) - val))) - (prot (if (eq? #\( (peek-char port)) - '() - (let ((c (read-char port))) - (case c ((#\b) #t) - ((#\a) #\a) - ((#\u) 1) - ((#\e) -1) - ((#\s) 1.0) - ((#\i) 1/3) - ((#\c) 0+i) - (else (error "read:array unknown option " c))))))) - (if (eq? (peek-char port) #\() - (list->uniform-array rank prot (read port)) - (error "read:array list not found")))) - -(define (read:uniform-vector proto port) - (if (eq? #\( (peek-char port)) - (list->uniform-array 1 proto (read port)) - (error "read:uniform-vector list not found"))) - -(define (read:sharp c port) - (define (barf) (error "unknown # object" c)) - (define (feature? exp) - (cond ((symbol? exp) - (or (memq exp *features*) (eq? exp (software-type)))) - ((and (pair? exp) (list? exp)) - (case (car exp) - ((not) (not (feature? (cadr exp)))) - ((or) (if (null? (cdr exp)) #f - (or (feature? (cadr exp)) - (feature? (cons 'or (cddr exp)))))) - ((and) (if (null? (cdr exp)) #t - (and (feature? (cadr exp)) - (feature? (cons 'and (cddr exp)))))) - (else (error "read:sharp+ invalid expression " exp)))))) - (case c ((#\') (read port)) - ((#\.) (eval (read port))) - ((#\+) (if (feature? (read port)) - (read port) - (begin (read port) (if #f #f)))) - ((#\-) (if (not (feature? (read port))) - (read port) - (begin (read port) (if #f #f)))) - ((#\b) (read:uniform-vector #t port)) - ((#\a) (read:uniform-vector #\a port)) - ((#\u) (read:uniform-vector 1 port)) - ((#\e) (read:uniform-vector -1 port)) - ((#\s) (read:uniform-vector 1.0 port)) - ((#\i) (read:uniform-vector 1/3 port)) - ((#\c) (read:uniform-vector 0+i port)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (read:array c port)) - ((#\!) (if (= 1 (line-number)) - (let skip ((metarg? #f)) - (case (read-char port) - ((#\newline) (if metarg? (skip #t))) - ((#\\) (skip #t)) - ((#\!) (if (not (and (eqv? #\# (peek-char port)) - (read-char port))) - (skip metarg?))) - (else (skip metarg?)))) - (barf))) - (else (barf)))) - -(define type 'type) ;for /bin/sh hack. -(define : ':) -(define !#(if #f #f)) ;for scsh hack. - -;;;; Here are some Revised^2 Scheme functions: -(define 1+ - (let ((+ +)) - (lambda (n) (+ n 1)))) -(define -1+ - (let ((+ +)) - (lambda (n) (+ n -1)))) -(define 1- -1+) -(define ? >) -(define >=? >=) -(define t #t) -(define nil #f) -(define (identity x) x) - -(if (not (defined? the-macro)) - (define the-macro identity)) -(define sequence (the-macro begin)) -(define copy-tree @copy-tree) - -;;; VMS does something strange when output is sent to both -;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT. -(case (software-type) ((VMS) (set-current-error-port (current-output-port)))) - -;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper -;;; mode to open files in. MS-DOS does carriage return - newline -;;; translation if not opened in `b' mode. - -(define OPEN_READ (case (software-type) - ((MS-DOS WINDOWS ATARIST) "rb") - (else "r"))) -(define OPEN_WRITE (case (software-type) - ((MS-DOS WINDOWS ATARIST) "wb") - (else "w"))) -(define OPEN_BOTH (case (software-type) - ((MS-DOS WINDOWS ATARIST) "r+b") - (else "r+"))) -(define (_IONBF mode) (string-append mode "0")) - -(define could-not-open #f) - -(define (open-input-file str) - (or (open-file str OPEN_READ) - (and (procedure? could-not-open) (could-not-open) #f) - (error "OPEN-INPUT-FILE couldn't open file " str))) -(define (open-output-file str) - (or (open-file str OPEN_WRITE) - (and (procedure? could-not-open) (could-not-open) #f) - (error "OPEN-OUTPUT-FILE couldn't open file " str))) -(define (open-io-file str) (open-file str OPEN_BOTH)) - -(define close-input-port close-port) -(define close-output-port close-port) -(define close-io-port close-port) - -(define (call-with-input-file str proc) - (let* ((file (open-input-file str)) - (ans (proc file))) - (close-input-port file) - ans)) - -(define (call-with-output-file str proc) - (let* ((file (open-output-file str)) - (ans (proc file))) - (close-output-port file) - ans)) - -(define (with-input-from-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-input-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-output-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-output-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-error-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-error-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-input-from-file file thunk) - (let* ((nport (open-input-file file)) - (ans (with-input-from-port nport thunk))) - (close-port nport) - ans)) - -(define (with-output-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-output-to-port nport thunk))) - (close-port nport) - ans)) - -(define (with-error-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-error-to-port nport thunk))) - (close-port nport) - ans)) - -(define (warn . args) - (define cep (current-error-port)) - (perror "WARN") - (errno 0) - (display "WARN: " cep) - (if (not (null? args)) - (begin (display (car args) cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) - (cdr args)))) - (newline cep) - (force-output cep)) - -(define (error . args) - (define cep (current-error-port)) - (perror "ERROR") - (errno 0) - (display "ERROR: " cep) - (if (not (null? args)) - (begin (display (car args) cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) - (cdr args)))) - (newline cep) - (force-output cep) - (abort)) - -(define set-errno errno) -(define slib:exit quit) -(define exit quit) - -(define (print . args) - (define result #f) - (for-each (lambda (x) (set! result x) (write x) (display #\ )) args) - (newline) - result) - -(define (file-exists? str) - (let ((port (open-file str OPEN_READ))) - (and port (close-port port) #t))) -(define (file-readable? str) - (let ((port (open-file str OPEN_READ))) - (and port - (char-ready? port) - (do ((c (read-char port) - (and (char-ready? port) (read-char port))) - (i 0 (+ 1 i)) - (l '() (cons c l))) - ((or (not c) (eof-object? c) (<= 2 i)) - (if (null? l) #f (list->string (reverse l)))))))) - -(define difftime -) -(define offset-time +) - -(if (not (memq 'ed *features*)) - (begin - (define (ed . args) - (system (apply string-append - (or (getenv "EDITOR") "ed") - (map (lambda (s) (string-append " " s)) args)))) - (set! *features* (cons 'ed *features*)))) - -(if (not (defined? output-port-width)) - (define (output-port-width . arg) 80)) - -(if (not (defined? output-port-height)) - (define (output-port-height . arg) 24)) - -(if (not (defined? last-pair)) - (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))) - -(define (has-suffix? str suffix) - (let ((sufl (string-length suffix)) - (sl (string-length str))) - (and (> sl sufl) - (string=? (substring str (- sl sufl) sl) suffix)))) - -(define slib:error error) -(define slib:warn warn) -(define slib:tab #\tab) -(define slib:form-feed #\page) -(define slib:eval eval) - -;;; Load. -(define load:indent 0) -(define (load:pre file) - (define cep (current-error-port)) - (cond ((> (verbose) 1) - (display - (string-append ";" (make-string load:indent #\ ) "loading " file) - cep) - (set! load:indent (modulo (+ 2 load:indent) 16)) - (newline cep))) - (force-output cep)) - -(define (load:post filesuf) - (define cep (current-error-port)) - (errno 0) - (cond ((> (verbose) 1) - (set! load:indent (modulo (+ -2 load:indent) 16)) - (display (string-append ";" (make-string load:indent #\ ) - "done loading " filesuf) - cep) - (newline cep) - (force-output cep)))) - -(define (scm:load file . libs) - (define filesuf file) - (define hss (has-suffix? file (scheme-file-suffix))) - (load:pre file) - (or (and (defined? link:link) (not hss) - (or (let ((s2 (file-readable? file))) - (and s2 (not (equal? "#!" s2)) (apply link:link file libs))) - (and link:able-suffix - (let* ((fs (string-append file link:able-suffix)) - (fs2 (file-readable? fs))) - (and fs2 (apply link:link fs libs) (set! filesuf fs) #t) - )))) - (and (null? libs) (try-load file)) - ;;HERE is where the suffix gets specified - (and (not hss) (errno 0) ; clean up error from TRY-LOAD above - (set! filesuf (string-append file (scheme-file-suffix))) - (try-load filesuf)) - (and (procedure? could-not-open) (could-not-open) #f) - (begin (set! load:indent 0) - (error "LOAD couldn't find file " file))) - (load:post filesuf)) -(define load scm:load) -(define slib:load load) - -(define (scm:load-source file) - (define sfs (scheme-file-suffix)) - (define filesuf file) - (load:pre file) - (or (and (or (try-load file) - ;;HERE is where the suffix gets specified - (and (not (has-suffix? file sfs)) - (begin (set! filesuf (string-append file sfs)) - (try-load filesuf))))) - (and (procedure? could-not-open) (could-not-open) #f) - (error "LOAD couldn't find file " file)) - (load:post filesuf)) -(define slib:load-source scm:load-source) - -(load (in-vicinity (library-vicinity) "require")) - -;;; DO NOT MOVE! This must be done after "require.scm" is loaded. -(define slib:load-source scm:load-source) -(define slib:load scm:load) - -(cond ((or (defined? dyn:link) - (defined? vms:dynamic-link-call) - (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms"))) - (load (in-vicinity (implementation-vicinity) "Link")))) - -(cond ((defined? link:link) - (define (slib:load-compiled . args) - (or (apply link:link args) - (error "Couldn't link files " args))) - (provide 'compiled))) - -(define (string-upcase str) (string-upcase! (string-copy str))) -(define (string-downcase str) (string-downcase! (string-copy str))) -(define (string-capitalize str) (string-capitalize! (string-copy str))) -(define string-ci->symbol - (if (equal? "a" (symbol->string 'a)) - (lambda (str) (string->symbol (string-downcase str))) - (lambda (str) (string->symbol (string-upcase str))))) - -(define logical:logand logand) -(define logical:logior logior) -(define logical:logxor logxor) -(define logical:lognot lognot) -(define logical:ash ash) -(define logical:logcount logcount) -(define logical:integer-length integer-length) -(define logical:integer-expt integer-expt) - -(define logical:bit-field bit-field) -(define bit-extract bit-field) -(define logical:bitwise-if bitwise-if) -(define logical:copy-bit copy-bit) -(define logical:copy-bit-field copy-bit-field) - -(define (logical:ipow-by-squaring x k acc proc) - (cond ((zero? k) acc) - ((= 1 k) (proc acc x)) - (else (logical:ipow-by-squaring (proc x x) - (quotient k 2) - (if (even? k) acc (proc acc x)) - proc)))) - -;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer): -(define *defmacros* '()) -(define (defmacro? m) (and (assq m *defmacros*) #t)) - -(define defmacro:transformer - (lambda (f) - (procedure->memoizing-macro - (lambda (exp env) - (@copy-tree (apply f (cdr exp))))))) - -(define defmacro - (let ((defmacro-transformer - (lambda (name parms . body) - `(define ,name - (let ((transformer (lambda ,parms ,@body))) - (set! *defmacros* (acons ',name transformer *defmacros*)) - (defmacro:transformer transformer)))))) - (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*)) - (defmacro:transformer defmacro-transformer))) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) (set! a (assq a *defmacros*)) - (if a (apply (cdr a) (cdr e)) e)) - (else e))) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (cond ((symbol? a) - (set! a (assq a *defmacros*)) - (if a (macroexpand (apply (cdr a) (cdr e))) e)) - (else e))) - e)) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "scm:G" (number->string *gensym-counter*)))))) - -(define defmacro:eval slib:eval) -(define defmacro:load load) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -;;; Autoloads for SLIB procedures. - -(define (tracef . args) (require 'trace) (apply tracef args)) -(define (trace:tracef . args) (require 'trace) (apply trace:tracef args)) -(define (trace-all . args) (require 'debug) (apply trace-all args)) -(define (pretty-print . args) (require 'pretty-print) - (apply pretty-print args)) - -;;; Macros. - -;;; Trace gets redefmacroed when tracef autoloads. -(defmacro trace x - (if (null? x) '() - `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x)))) -(defmacro break x - (if (null? x) '() - `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) x)))) - -(defmacro defvar (var val) - `(if (not (defined? ,var)) (define ,var ,val))) -(defmacro defconst (name value) - (cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value))) - (else (cond ((not (slib:eval `(defined? ,name)))) - ((and (symbol? name) (eqv? (slib:eval value) - (slib:eval name)))) - (else (slib:error 'trying-to-defconst name - 'to-different-value value))) - `(define ,name ,value)))) -(defmacro casev (key . clauses) - (let ((clauses - (map (lambda (clause) - (if (list? (car clause)) - (cons (apply - append - (map (lambda (elt) - (case elt - ((unquote) '(unquote)) - ((unquote-splicing) '(unquote-splicing)) - (else - (eval (list 'quasiquote (list elt)))))) - (car clause))) - (cdr clause)) - clause)) - clauses))) - `(case ,key ,@clauses))) - -(define print-args - (procedure->syntax - (lambda (sexp env) - (set! env (environment->tree env)) - (let ((frame (and (not (null? env)) (car env)))) - (cond ((not (null? (cdr sexp))) - (display "In") - (for-each (lambda (exp) (display #\ ) (display exp)) (cdr sexp)) - (display ": "))) - (do ((vars (car frame) (cdr vars)) - (vals (cdr frame) (cdr vals))) - ((not (pair? vars)) - (cond ((not (null? vars)) - (write vars) - (display " := ") - (write vals))) - (newline)) - (write (car vars)) - (display " = ") - (write (car vals)) - (display "; ")))))) - -(cond - ((defined? stack-trace) - - #+breakpoint-error;; remove line to enable breakpointing on calls to ERROR - (define (error . args) - (define cep (current-error-port)) - (perror "ERROR") - (errno 0) - (display "ERROR: " cep) - (if (not (null? args)) - (begin (display (car args) cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) - (cdr args)))) - (newline cep) - (cond ((stack-trace) (newline cep))) - (display " * Breakpoint established: (continue ) to return." cep) - (newline cep) (force-output cep) - (require 'debug) (apply breakpoint args)) - - (define (user-interrupt . args) - (define cep (current-error-port)) - (newline cep) (display "ERROR: user interrupt" cep) - (newline cep) - (cond ((stack-trace) (newline cep))) - (display " * Breakpoint established: (continue ) to return." cep) - (newline cep) (force-output cep) - (require 'debug) (apply breakpoint args)) - )) - -;;; ABS and MAGNITUDE can be the same. -(cond ((and (inexact? (string->number "0.0")) (not (defined? exp))) - (or (and (defined? usr:lib) - (usr:lib "m") - (load (in-vicinity (implementation-vicinity) "Transcen") - (usr:lib "m"))) - (load (in-vicinity (implementation-vicinity) "Transcen"))) - (set! abs magnitude))) - -(if (defined? array?) - (begin - (define uniform-vector? array?) - (define make-uniform-vector dimensions->uniform-array) -; (define uniform-vector-ref array-ref) - (define (uniform-vector-set! u i o) - (uniform-vector-set1! u o i)) -; (define uniform-vector-fill! array-fill!) -; (define uniform-vector-read! uniform-array-read!) -; (define uniform-vector-write uniform-array-write) - - (define (make-array fill . args) - (dimensions->uniform-array args () fill)) - (define (make-uniform-array prot . args) - (dimensions->uniform-array args prot)) - (define (list->array ndim lst) - (list->uniform-array ndim '() lst)) - (define (list->uniform-vector prot lst) - (list->uniform-array 1 prot lst)) - (define (array-shape a) - (let ((dims (array-dimensions a))) - (if (pair? dims) - (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) - dims) - dims))))) - -;;;; Initialize statically linked add-ons -(cond ((defined? scm_init_extensions) - (scm_init_extensions) - (set! scm_init_extensions #f))) - -;;; Use *argv* instead of (program-arguments), to allow option -;;; processing to be done on it. "ScmInit.scm" must -;;; (set! *argv* (program-arguments)) -;;; if it wants to alter the arguments which BOOT-TAIL processes. -(define *argv* #f) - -(if (not (defined? *R4RS-macro*)) - (define *R4RS-macro* #f)) -(if (not (defined? *interactive*)) - (define *interactive* #f)) - -(define (boot-tail dumped?) - (cond ((not *argv*) - (set! *argv* (program-arguments)) - (cond (dumped? - (set-vicinities!) - (verbose (if (and (isatty? (current-input-port)) - (isatty? (current-output-port))) - (if (<= (length *argv*) 1) 2 1) - 0)))) - (cond ((provided? 'getopt) - (set! *optind* 1) - (set! *optarg* #f))))) - -;;; This loads the user's initialization file, or files named in -;;; program arguments. - (or (eq? (software-type) 'THINKC) - (member "-no-init-file" (program-arguments)) - (member "--no-init-file" (program-arguments)) - (try-load (in-vicinity (or (home-vicinity) (user-vicinity)) - (string-append "ScmInit") (scheme-file-suffix))) - (errno 0)) - - (cond - ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) - (require 'getopt) -;;; (else -;;; (define *optind* 1) -;;; (define getopt:opt #f) -;;; (define (getopt argc argv optstring) #f)) - - (let* ((simple-opts "muqvbis") - (arg-opts '("a kbytes" "no-init-file" "-no-init-file" - "-version" "-help" "p number" - "r feature" "f filename" "l filename" - "d filename" "c string" "e string" - "o filename")) - (opts (apply string-append ":" simple-opts - (map (lambda (o) - (string-append (string (string-ref o 0)) ":")) - arg-opts))) - (argc (length *argv*)) - (didsomething #f) - (moreopts #t) - (exe-name (symbol->string (scheme-implementation-type))) - (up-name (apply string (map char-upcase (string->list exe-name))))) - - (define (do-thunk thunk) - (if *interactive* - (thunk) - (let ((complete #f)) - (dynamic-wind - (lambda () #f) - (lambda () - (thunk) - (set! complete #t)) - (lambda () (if (not complete) (quit #f))))))) - - (define (do-string-arg) - (require 'string-port) - (do-thunk - (lambda () - ((if *R4RS-macro* macro:eval eval) - (call-with-input-string - (string-append "(begin " *optarg* ")") - read)))) - (set! didsomething #t)) - - (define (do-load file) - (do-thunk - (lambda () - (cond (*R4RS-macro* (require 'macro) (macro:load file)) - (else (load file))))) - (set! didsomething #t)) - - (define (usage preopt opt postopt success?) - (define cep (if success? (current-output-port) (current-error-port))) - (define indent (make-string 6 #\ )) - (define i 3) - (cond ((char? opt) (set! opt (string opt))) - ;;((symbol? opt) (set! opt (symbol->string opt))) - ) - (display (string-append preopt opt postopt) cep) - (newline cep) - (display (string-append "Usage: " - exe-name - " [-a kbytes] [-" simple-opts "]") cep) - (for-each - (lambda (o) - (display (string-append " [-" o "]") cep) - (set! i (+ 1 i)) - (cond ((zero? (modulo i 4)) (newline cep) (display indent cep)))) - (cdr arg-opts)) - (display " [-- | -s | -] [file] [args...]" cep) (newline cep) - (if success? (display success? cep) (quit #f))) - - ;; -a int => ignore (handled by run_scm) - ;; -c str => (eval str) - ;; -e str => (eval str) - ;; -d str => (require 'database-utilities) (open-database str) - ;; -f str => (load str) - ;; -l str => (load str) - ;; -r str => (require str) - ;; -o str => (dump str) - ;; -p int => (verbose int) - ;; -m => (set! *R4RS-macro* #t) - ;; -u => (set! *R4RS-macro* #f) - ;; -v => (verbose 3) - ;; -q => (verbose 0) - ;; -i => (set! *interactive* #t) - ;; -b => (set! *interactive* #f) - ;; -s => set argv, don't execute first one - ;; -no-init-file => don't load init file - ;; --no-init-file => don't load init file - ;; --help => print and exit - ;; --version => print and exit - ;; -- => last option - - (let loop ((option (getopt-- argc *argv* opts))) - (case option - ((#\a) - (cond ((> *optind* 3) - (usage "scm: option `-" getopt:opt "' must be first" #f)) - ((or (not (exact? (string->number *optarg*))) - (not (<= 1 (string->number *optarg*) 10000))) - ;; This size limit should match scm.c ^^ - (usage "scm: option `-" getopt:opt - (string-append *optarg* "' unreasonable") #f)))) - ((#\e #\c) (do-string-arg)) ;sh-like - ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*) - ((#\d) (require 'database-utilities) - (open-database *optarg*)) - ((#\o) (require 'dump) - (if (< *optind* (length *argv*)) - (dump *optarg* #t) - (dump *optarg*))) - ((#\r) (do-thunk (lambda () - (if (and (= 1 (string-length *optarg*)) - (char-numeric? (string-ref *optarg* 0))) - (case (string-ref *optarg* 0) - ((#\2) (require 'rev3-procedures) - (require 'rev2-procedures)) - ((#\3) (require 'rev3-procedures)) - ((#\4) (require 'rev4-optional-procedures)) - ((#\5) (require 'dynamic-wind) - (require 'values) - (require 'macro) - (require 'eval) - (set! *R4RS-macro* #t)) - (else (require (string->symbol *optarg*)))) - (require (string->symbol *optarg*)))))) - ((#\p) (verbose (string->number *optarg*))) - ((#\q) (verbose 0)) - ((#\v) (verbose 3)) - ((#\i) (set! *interactive* #t) ;sh-like - (verbose (max 2 (verbose)))) - ((#\b) (set! didsomething #t) - (set! *interactive* #f)) - ((#\s) (set! moreopts #f) ;sh-like - (set! didsomething #t) - (set! *interactive* #t)) - ((#\m) (set! *R4RS-macro* #t)) - ((#\u) (set! *R4RS-macro* #f)) - ((#\n) (if (not (string=? "o-init-file" *optarg*)) - (usage "scm: unrecognized option `-n" *optarg* "'" #f))) - ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f)) - ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f)) - ((#f) (set! moreopts #f) ;sh-like - (cond ((and (< *optind* (length *argv*)) - (string=? "-" (list-ref *argv* *optind*))) - (set! *optind* (+ 1 *optind*))))) - (else - (or (cond ((not (string? option)) #f) - ((string-ci=? "no-init-file" option)) - ((string-ci=? "version" option) - (display - (string-append exe-name " " - (scheme-implementation-version) - " -Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. -" - up-name - " may be distributed under the terms of" - " the GNU General Public Licence; -certain other uses are permitted as well." - " For details, see the file `COPYING', -which is included in the " - up-name " distribution. -There is no warranty, to the extent permitted by law. -" - )) - (cond ((execpath) - (display " This executable was loaded from ") - (display (execpath)) - (newline))) - (quit #t)) - ((string-ci=? "help" option) - (usage "This is " - up-name - ", a Scheme interpreter." - (string-append - "Latest info: " - "http://swissnet.ai.mit.edu/~jaffer/" - up-name ".html -" - )) - (quit #t)) - (else #f)) - (usage "scm: unknown option `--" option "'" #f)))) - - (cond ((and moreopts (< *optind* (length *argv*))) - (loop (getopt-- argc *argv* opts))) - ((< *optind* (length *argv*)) ;No more opts - (set! *argv* (list-tail *argv* *optind*)) - (set! *optind* 1) - (cond ((not didsomething) (do-load (car *argv*)) - (set! *optind* (+ 1 *optind*)))) - (cond ((and (> (verbose) 2) - (not (= (+ -1 *optind*) (length *argv*)))) - (display "scm: extra command arguments unused:" - (current-error-port)) - (for-each (lambda (x) (display (string-append " " x) - (current-error-port))) - (list-tail *argv* (+ -1 *optind*))) - (newline (current-error-port))))) - ((and (not didsomething) (= *optind* (length *argv*))) - (set! *interactive* #t))))) - - (cond ((not *interactive*) (quit)) - ((and *R4RS-macro* (not (provided? 'macro))) - (require 'repl) - (require 'macro) - (let* ((oquit quit)) - (set! quit (lambda () (repl:quit))) - (set! exit quit) - (repl:top-level macro:eval) - (oquit)))) - ;;otherwise, fall into natural SCM repl. - ) - (else - (begin (errno 0) - (set! *interactive* #t) - (for-each load (cdr (program-arguments))))))) diff --git a/Init5d2.scm b/Init5d2.scm new file mode 100644 index 0000000..946e6d7 --- /dev/null +++ b/Init5d2.scm @@ -0,0 +1,1092 @@ +;; Copyright (C) 1991-1999 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "Init.scm", Scheme initialization code for SCM. +;;; Author: Aubrey Jaffer. + +(define (scheme-implementation-type) 'SCM) +(define (scheme-implementation-version) "5d2") +(define (scheme-implementation-home-page) + "http://swissnet.ai.mit.edu/~jaffer/SCM.html") + +(define vicinity:suffix? + (let ((suffi + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MACOS THINKC) '(#\:)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda (chr) (memv chr suffi)))) + +(define (pathname->vicinity pathname) + ;;Go up one level if PATHNAME ends in a vicinity suffix. + (let loop ((i (- (string-length pathname) 2))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) + +;;; This definition of PROGRAM-VICINITY is equivalent to the one defined +;;; SLIB/require.scm. It is used here to bootstrap +;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY. + +(define (program-vicinity) + (if *load-pathname* + (pathname->vicinity *load-pathname*) + (error "not loading but called" 'program-vicinity))) + +(define in-vicinity string-append) + +;;; This is the vicinity where this file resides. +(define implementation-vicinity #f) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use +;;; (implementation-vicinity) as (library-vicinity). "require.scm", +;;; the first file loaded from (library-vicinity), can redirect it. + +(define library-vicinity #f) +(define home-vicinity #f) +(define (set-vicinities! init-file) + (set! implementation-vicinity + (let ((vic (pathname->vicinity init-file))) + (lambda () vic))) + (set! library-vicinity + (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) + (if library-path + (lambda () library-path) + (lambda () + (let ((olv library-vicinity) + (oload load)) + (dynamic-wind + (lambda () (set! load identity)) + (lambda () + (try-load (in-vicinity (implementation-vicinity) + "require.scm"))) + (lambda () (set! load oload))) + (if (eq? olv library-vicinity) + (error "Can't find library-vicinity")) + (library-vicinity)))))) + (set! home-vicinity + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (not + (char=? #\/ + (string-ref home (+ -1 (string-length home))))) + (set! home (string-append home "/")))))) + (lambda () home)))) +(set-vicinities! *load-pathname*) + +;;; Here for backward compatability +(define scheme-file-suffix + (case (software-type) + ((NOSVE) (lambda () "_scm")) + (else (lambda () ".scm")))) + +(set! *features* + (append '(getenv tmpnam abort transcript with-file + ieee-p1178 rev4-report rev4-optional-procedures + hash object-hash delay dynamic-wind fluid-let + multiarg-apply multiarg/and- logical defmacro + string-port source current-time sharp:semi) + *features*)) + +(define (exec-self) + (require 'i/o-extensions) + (execv (execpath) (if *script* + (cons (car (program-arguments)) + (cons "\\" + (member *script* (program-arguments)))) + (program-arguments)))) + +(define (display-file file) + (call-with-input-file file + (lambda (inport) + (do ((c (read-char inport) (read-char inport))) + ((eof-object? c)) + (write-char c))))) +(define (terms) + (display-file (in-vicinity (implementation-vicinity) "COPYING"))) + +;; Array syntax: +;; n is a decimal number, which may be elided for a default value of 1. +;; #nA\( ... ) character array +;; #nAt( ... ) boolean array +;; #nAe[sfdl]( ... ) exact number array +;; #nAu[sfdl]( ... ) positive exact number array +;; #nAi[sfdl]( ... ) inexact real number array +;; #nAic[sfdl]( ... ) inexact complex number array + +(define (read:array rank port) + (let ((prot + (case (char-downcase (peek-char port)) + ((#\\) (read-char port) #\a) + ((#\t) (read-char port) #t) + ((#\e) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\s) (read-char port) 'exact-short) + ((#\f #\d #\l) (read-char port) -2) + (else -2))) + ((#\u) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\s #\f #\d #\l) (read-char port) 2) + (else 2))) + ((#\i) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\c) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\s #\f #\d #\l) (read-char port))) + 0+1.0i) + ((#\s #\f) (read-char port) 1.0) + ((#\d #\l) (read-char port) 1/3) + (else 1/3))) + (else #f)))) + (list->uniform-array rank prot (read port)))) + +(define (read:sharp c port) + (define (barf c) + (error "unknown # object" c)) + (define chr0 (char->integer #\0)) + (define (feature? exp) + (cond ((symbol? exp) + (or (memq exp *features*) (eq? exp (software-type)))) + ((and (pair? exp) (list? exp)) + (case (car exp) + ((not) (not (feature? (cadr exp)))) + ((or) (if (null? (cdr exp)) #f + (or (feature? (cadr exp)) + (feature? (cons 'or (cddr exp)))))) + ((and) (if (null? (cdr exp)) #t + (and (feature? (cadr exp)) + (feature? (cons 'and (cddr exp)))))) + (else (error "read:sharp+ invalid expression " exp)))))) + (case c + ((#\') (read port)) + ((#\.) (eval (read port))) + ((#\+) (if (feature? (read port)) + (read port) + (begin (read port) (if #f #f)))) + ((#\-) (if (not (feature? (read port))) + (read port) + (begin (read port) (if #f #f)))) + ((#\a #\A) (read:array 1 port)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let loop ((arg (- (char->integer c) chr0))) + (let ((c (peek-char port))) + (cond ((char-numeric? c) + (loop (+ (* 10 arg) + (- (char->integer (read-char port)) chr0)))) + ((memv c '(#\a #\A)) + (read-char port) + (read:array arg port)) + (else + (warn "obsolete array read syntax") + (read:array arg port)))))) + ((#\!) (if (= 1 (line-number)) + (let skip ((metarg? #f)) + (case (read-char port) + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (if (not (and (eqv? #\# (peek-char port)) + (read-char port))) + (skip metarg?))) + (else (skip metarg?)))) + (barf c))) + (else (barf c)))) + +;; We can assume TOK has at least 2 characters. +(define read:sharp-char + (letrec ((control (lambda (c) + (and (char? c) + (if (eqv? c #\?) + (integer->char 127) + (integer->char + (logand 31 (char->integer c))))))) + (meta (lambda (c) + (and (char? c) + (integer->char + (logior 128 (char->integer c))))))) + (lambda (tok) + (case (string-ref tok 0) + ((#\C #\c) + (and (char=? #\- (string-ref tok 1)) + (if (= 3 (string-length tok)) + (control (string-ref tok 2)) + (let ((c (read:sharp-char + (substring tok 2 (string-length tok))))) + (and c (control c)))))) + ((#\^) + (and (= 2 (string-length tok)) + (control (string-ref tok 1)))) + ((#\M #\m) + (and (char=? #\- (string-ref tok 1)) + (if (= 3 (string-length tok)) + (meta (string-ref tok 2)) + (let ((c (read:sharp-char + (substring tok 2 (string-length tok))))) + (and c (meta c)))))))))) + +;;;; Function used to accumulate comments before a definition. +(define comment + (let ((*accumulated-comments* '())) + (lambda args + (cond ((null? args) + (let ((ans + (apply string-append + (map (lambda (comment) + (string-append (or comment "") "\n")) + (reverse *accumulated-comments*))))) + (set! *accumulated-comments* '()) + (if (equal? "" ans) + "no-comment" ;#f + (substring ans 0 (+ -1 (string-length ans)))))) + (else (set! *accumulated-comments* + (append (reverse args) *accumulated-comments*))))))) + +;; Make #; convert the rest of the line to a (comment ...) form. +;; "build.scm" uses this. +(define read:sharp + (let ((rdsharp read:sharp)) + (lambda (c port) + (if (eqv? c #\;) + (let skip-semi () + (cond ((eqv? #\; (peek-char port)) + (read-char port) + (skip-semi)) + (else `(comment ,(read-line port))))) + (rdsharp c port))))) + + +(define type 'type) ;for /bin/sh hack. +(define : ':) +(define !#(if #f #f)) ;for scsh hack. + +;;;; Here are some Revised^2 Scheme functions: +(define 1+ + (let ((+ +)) + (lambda (n) (+ n 1)))) +(define -1+ + (let ((+ +)) + (lambda (n) (+ n -1)))) +(define 1- -1+) +(define ? >) +(define >=? >=) +(define t #t) +(define nil #f) +(define identity + (if (defined? cr) cr (lambda (x) x))) + +(if (not (defined? the-macro)) + (define the-macro identity)) +(define sequence (the-macro begin)) +(define copy-tree @copy-tree) + +;;; VMS does something strange when output is sent to both +;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT. +(case (software-type) ((VMS) (set-current-error-port (current-output-port)))) + +;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper +;;; mode to open files in. MS-DOS does carriage return - newline +;;; translation if not opened in `b' mode. + +(define OPEN_READ (case (software-type) + ((MS-DOS WINDOWS ATARIST) "rb") + (else "r"))) +(define OPEN_WRITE (case (software-type) + ((MS-DOS WINDOWS ATARIST) "wb") + (else "w"))) +(define OPEN_BOTH (case (software-type) + ((MS-DOS WINDOWS ATARIST) "r+b") + (else "r+"))) +(define (_IONBF mode) (string-append mode "0")) +(define (_TRACKED mode) (string-append mode "?")) + +(define could-not-open #f) + +(define (open-input-file str) + (or (open-file str OPEN_READ) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))) +(define (open-output-file str) + (or (open-file str OPEN_WRITE) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-OUTPUT-FILE couldn't open file " str))) +(define (open-io-file str) (open-file str OPEN_BOTH)) + +(define close-input-port close-port) +(define close-output-port close-port) +(define close-io-port close-port) + +(define (call-with-input-file str proc) + (let* ((file (open-input-file str)) + (ans (proc file))) + (close-input-port file) + ans)) + +(define (call-with-output-file str proc) + (let* ((file (open-output-file str)) + (ans (proc file))) + (close-output-port file) + ans)) + +(define (with-input-from-port port thunk) + (dynamic-wind (lambda () (set! port (set-current-input-port port))) + thunk + (lambda () (set! port (set-current-input-port port))))) + +(define (with-output-to-port port thunk) + (dynamic-wind (lambda () (set! port (set-current-output-port port))) + thunk + (lambda () (set! port (set-current-output-port port))))) + +(define (with-error-to-port port thunk) + (dynamic-wind (lambda () (set! port (set-current-error-port port))) + thunk + (lambda () (set! port (set-current-error-port port))))) + +(define (with-input-from-file file thunk) + (let* ((nport (open-input-file file)) + (ans (with-input-from-port nport thunk))) + (close-port nport) + ans)) + +(define (with-output-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-output-to-port nport thunk))) + (close-port nport) + ans)) + +(define (with-error-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-error-to-port nport thunk))) + (close-port nport) + ans)) + +(define (warn . args) + (define cep (current-error-port)) + (perror "WARN") + (errno 0) + (display "WARN: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (force-output cep)) + +(define (error . args) + (define cep (current-error-port)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (force-output cep) + (abort)) + +(define set-errno errno) +(define slib:exit quit) +(define exit quit) + +(define (print . args) + (define result #f) + (for-each (lambda (x) (set! result x) (write x) (display #\ )) args) + (newline) + result) +(define (pp . args) + (for-each pretty-print args) + (if #f #f)) + +(define (file-exists? str) + (let ((port (open-file str OPEN_READ))) + (and port (close-port port) #t))) +(define (file-readable? str) + (let ((port (open-file str OPEN_READ))) + (and port + (char-ready? port) + (do ((c (read-char port) + (and (char-ready? port) (read-char port))) + (i 0 (+ 1 i)) + (l '() (cons c l))) + ((or (not c) (eof-object? c) (<= 2 i)) + (if (null? l) #f (list->string (reverse l)))))))) + +(define difftime -) +(define offset-time +) + +(if (not (memq 'ed *features*)) + (begin + (define (ed . args) + (system (apply string-append + (or (getenv "EDITOR") "ed") + (map (lambda (s) (string-append " " s)) args)))) + (set! *features* (cons 'ed *features*)))) + +(if (not (defined? output-port-width)) + (define (output-port-width . arg) 80)) + +(if (not (defined? output-port-height)) + (define (output-port-height . arg) 24)) + +(if (not (defined? last-pair)) + (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))) + +(define slib:error error) +(define slib:warn warn) +(define slib:tab #\tab) +(define slib:form-feed #\page) +(define slib:eval eval) + +;;; Load. +(define load:indent 0) +(define (load:pre file) + (define cep (current-error-port)) + (cond ((> (verbose) 1) + (display + (string-append ";" (make-string load:indent #\ ) "loading " file) + cep) + (set! load:indent (modulo (+ 2 load:indent) 16)) + (newline cep))) + (force-output cep)) + +(define (load:post filesuf) + (define cep (current-error-port)) + (errno 0) + (cond ((> (verbose) 1) + (set! load:indent (modulo (+ -2 load:indent) 16)) + (display (string-append ";" (make-string load:indent #\ ) + "done loading " filesuf) + cep) + (newline cep) + (force-output cep)))) + +(define (has-suffix? str suffix) + (let ((sufl (string-length suffix)) + (sl (string-length str))) + (and (> sl sufl) + (string=? (substring str (- sl sufl) sl) suffix)))) + +(define (scm:load file . libs) + (define filesuf file) + (define hss (has-suffix? file (scheme-file-suffix))) + (load:pre file) + (or (and (defined? link:link) (not hss) + (or (let ((s2 (file-readable? file))) + (and s2 (not (equal? "#!" s2)) (apply link:link file libs))) + (and link:able-suffix + (let* ((fs (string-append file link:able-suffix)) + (fs2 (file-readable? fs))) + (and fs2 (apply link:link fs libs) (set! filesuf fs) #t) + )))) + (and (null? libs) (try-load file)) + ;;HERE is where the suffix gets specified + (and (not hss) (errno 0) ; clean up error from TRY-LOAD above + (set! filesuf (string-append file (scheme-file-suffix))) + (try-load filesuf)) + (and (procedure? could-not-open) (could-not-open) #f) + (begin (set! load:indent 0) + (error "LOAD couldn't find file " file))) + (load:post filesuf)) +(define load scm:load) +(define slib:load load) + +(define (scm:load-source file) + (define sfs (scheme-file-suffix)) + (define filesuf file) + (load:pre file) + (or (and (or (try-load file) + ;;HERE is where the suffix gets specified + (and (not (has-suffix? file sfs)) + (begin (set! filesuf (string-append file sfs)) + (try-load filesuf))))) + (and (procedure? could-not-open) (could-not-open) #f) + (error "LOAD couldn't find file " file)) + (load:post filesuf)) +(define slib:load-source scm:load-source) + +(load (in-vicinity (library-vicinity) "require")) + +;;; DO NOT MOVE! This must be done after "require.scm" is loaded. +(define slib:load-source scm:load-source) +(define slib:load scm:load) + +(cond ((or (defined? dyn:link) + (defined? vms:dynamic-link-call) + (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms"))) + (load (in-vicinity (implementation-vicinity) "Link")))) + +(cond ((defined? link:link) + (define (slib:load-compiled . args) + (or (apply link:link args) + (error "Couldn't link files " args))) + (provide 'compiled))) + +(define (string-upcase str) (string-upcase! (string-copy str))) +(define (string-downcase str) (string-downcase! (string-copy str))) +(define (string-capitalize str) (string-capitalize! (string-copy str))) +(define string-ci->symbol + (if (equal? "a" (symbol->string 'a)) + (lambda (str) (string->symbol (string-downcase str))) + (lambda (str) (string->symbol (string-upcase str))))) + +(define logical:logand logand) +(define logical:logior logior) +(define logical:logxor logxor) +(define logical:lognot lognot) +(define logical:ash ash) +(define logical:logcount logcount) +(define logical:integer-length integer-length) +(define logical:integer-expt integer-expt) + +(define logical:bit-field bit-field) +(define bit-extract bit-field) +(define logical:bitwise-if bitwise-if) +(define logical:copy-bit copy-bit) +(define logical:copy-bit-field copy-bit-field) + +(define (logical:ipow-by-squaring x k acc proc) + (cond ((zero? k) acc) + ((= 1 k) (proc acc x)) + (else (logical:ipow-by-squaring (proc x x) + (quotient k 2) + (if (even? k) acc (proc acc x)) + proc)))) + +;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer): +(define *defmacros* '()) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define defmacro:transformer + (lambda (f) + (procedure->memoizing-macro + (lambda (exp env) + (@copy-tree (apply f (cdr exp))))))) + +(define defmacro + (let ((defmacro-transformer + (lambda (name parms . body) + `(define ,name + (let ((transformer (lambda ,parms ,@body))) + (set! *defmacros* (acons ',name transformer *defmacros*)) + (defmacro:transformer transformer)))))) + (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*)) + (defmacro:transformer defmacro-transformer))) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "scm:G" (number->string *gensym-counter*)))))) + +(define defmacro:eval slib:eval) +(define defmacro:load load) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; Autoloads for SLIB procedures. + +(define (tracef . args) (require 'trace) (apply tracef args)) +(define (trace:tracef . args) (require 'trace) (apply trace:tracef args)) +(define (trace-all . args) (require 'debug) (apply trace-all args)) +(define (pretty-print . args) (require 'pretty-print) + (apply pretty-print args)) + +;; (require 'transcript) would get us SLIB transcript -- not what we want. +(define (transcript-on arg) + (load (in-vicinity (implementation-vicinity) + (string-append "Tscript" (scheme-file-suffix)))) + (transcript-on arg)) +(define (transcript-off) + (error "No transcript active")) + +;;; Macros. + +;;; Trace gets redefmacroed when tracef autoloads. +(defmacro trace x + (if (null? x) '() + `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x)))) +(defmacro break x + (if (null? x) '() + `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) x)))) + +(defmacro defvar (var val) + `(if (not (defined? ,var)) (define ,var ,val))) +(defmacro defconst (name value) + (cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value))) + (else (cond ((not (slib:eval `(defined? ,name)))) + ((and (symbol? name) (equal? (slib:eval value) + (slib:eval name)))) + (else (slib:error 'trying-to-defconst name + 'to-different-value value))) + `(define ,name ,value)))) +(defmacro casev (key . clauses) + `(case ,key + ,@(map (lambda (clause) + (if (list? (car clause)) + (cons (apply + append + (map (lambda (elt) + (case elt + ((unquote) '(unquote)) + ((unquote-splicing) '(unquote-splicing)) + (else + (eval (list 'quasiquote (list elt)))))) + (car clause))) + (cdr clause)) + clause)) + clauses))) + +(defmacro fluid-let (clauses . body) + (let ((ids (map car clauses)) + (temp (gentemp)) + (swap (gentemp))) + `(let* ((,temp (list ,@(map cadr clauses))) + (,swap (lambda () (set! ,temp (set! ,ids ,temp))))) + (dynamic-wind + ,swap + (lambda () ,@body) + ,swap)))) + +(define print-args + (procedure->syntax + (lambda (sexp env) + (set! env (environment->tree env)) + (let ((frame (and (not (null? env)) (car env)))) + (cond ((not (null? (cdr sexp))) + (display "In") + (for-each (lambda (exp) (display #\ ) (display exp)) (cdr sexp)) + (display ": "))) + (do ((vars (car frame) (cdr vars)) + (vals (cdr frame) (cdr vals))) + ((not (pair? vars)) + (cond ((not (null? vars)) + (write vars) + (display " := ") + (write vals))) + (newline)) + (write (car vars)) + (display " = ") + (write (car vals)) + (display "; ")))))) + +(cond + ((defined? stack-trace) + + #+breakpoint-error;; remove line to enable breakpointing on calls to ERROR + (define (error . args) + (define cep (current-error-port)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue ) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + + (define (user-interrupt . args) + (define cep (current-error-port)) + (newline cep) (display "ERROR: user interrupt" cep) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue ) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + )) + +;;; ABS and MAGNITUDE can be the same. +(cond ((and (inexact? (string->number "0.0")) (not (defined? exp))) + (or (and (defined? usr:lib) + (usr:lib "m") + (load (in-vicinity (implementation-vicinity) "Transcen") + (usr:lib "m"))) + (load (in-vicinity (implementation-vicinity) "Transcen"))) + (set! abs magnitude))) + +(if (defined? array?) + (begin + (define uniform-vector? array?) + (define make-uniform-vector dimensions->uniform-array) +; (define uniform-vector-ref array-ref) + (define (uniform-vector-set! u i o) + (uniform-vector-set1! u o i)) +; (define uniform-vector-fill! array-fill!) +; (define uniform-vector-read! uniform-array-read!) +; (define uniform-vector-write uniform-array-write) + + (define (make-array fill . args) + (dimensions->uniform-array args () fill)) + (define (make-uniform-array prot . args) + (dimensions->uniform-array args prot)) + (define (list->array ndim lst) + (list->uniform-array ndim '() lst)) + (define (list->uniform-vector prot lst) + (list->uniform-array 1 prot lst)) + (define (array-shape a) + (let ((dims (array-dimensions a))) + (if (pair? dims) + (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) + dims) + dims))))) + +(define (alarm-interrupt) (alarm 0)) +(if (defined? setitimer) + (begin + (define profile-alarm #f) + (define (profile-alarm-interrupt) (profile-alarm 0)) + (define virtual-alarm #f) + (define (virtual-alarm-interrupt) (virtual-alarm 0)) + (define milli-alarm #f) + (let ((make-alarm + (lambda (sym) + (and (setitimer sym 0 0) ;DJGPP supports only REAL and PROFILE + (lambda (value . interval) + (cadr + (setitimer sym value + (if (pair? interval) (car interval) 0)))))))) + (set! profile-alarm (make-alarm 'profile)) + (set! virtual-alarm (make-alarm 'virtual)) + (set! milli-alarm (make-alarm 'real))))) + +;;;; Initialize statically linked add-ons +(cond ((defined? scm_init_extensions) + (scm_init_extensions) + (set! scm_init_extensions #f))) + +;;; Use *argv* instead of (program-arguments), to allow option +;;; processing to be done on it. "ScmInit.scm" must +;;; (set! *argv* (program-arguments)) +;;; if it wants to alter the arguments which BOOT-TAIL processes. +(define *argv* #f) + +(if (not (defined? *R4RS-macro*)) + (define *R4RS-macro* #f)) +(if (not (defined? *interactive*)) + (define *interactive* #f)) + +(define (boot-tail dumped?) + (cond ((not *argv*) + (set! *argv* (program-arguments)) + (cond (dumped? + (set-vicinities! dumped?) + (verbose (if (and (isatty? (current-input-port)) + (isatty? (current-output-port))) + (if (<= (length *argv*) 1) 2 1) + 0)))) + (cond ((provided? 'getopt) + (set! *optind* 1) + (set! *optarg* #f))))) + +;;; This loads the user's initialization file, or files named in +;;; program arguments. + (or (eq? (software-type) 'THINKC) + (member "-no-init-file" (program-arguments)) + (member "--no-init-file" (program-arguments)) + (try-load (in-vicinity (or (home-vicinity) (user-vicinity)) + (string-append "ScmInit") (scheme-file-suffix))) + (errno 0)) + + (cond + ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) + (require 'getopt) +;;; (else +;;; (define *optind* 1) +;;; (define getopt:opt #f) +;;; (define (getopt argc argv optstring) #f)) + + (let* ((simple-opts "muqvbis") + (arg-opts '("a kbytes" "no-init-file" "-no-init-file" + "-version" "-help" "p number" + "r feature" "f filename" "l filename" + "d filename" "c string" "e string" + "o filename")) + (opts (apply string-append ":" simple-opts + (map (lambda (o) + (string-append (string (string-ref o 0)) ":")) + arg-opts))) + (argc (length *argv*)) + (didsomething #f) + (moreopts #t) + (exe-name (symbol->string (scheme-implementation-type))) + (up-name (apply string (map char-upcase (string->list exe-name))))) + + (define (do-thunk thunk) + (if *interactive* + (thunk) + (let ((complete #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (thunk) + (set! complete #t)) + (lambda () + (if (not complete) (close-port (current-input-port)))))))) + + (define (do-string-arg) + (require 'string-port) + (do-thunk + (lambda () + ((if *R4RS-macro* macro:eval eval) + (call-with-input-string + (string-append "(begin " *optarg* ")") + read)))) + (set! didsomething #t)) + + (define (do-load file) + (do-thunk + (lambda () + (cond (*R4RS-macro* (require 'macro) (macro:load file)) + (else (load file))))) + (set! didsomething #t)) + + (define (usage preopt opt postopt success?) + (define cep (if success? (current-output-port) (current-error-port))) + (define indent (make-string 6 #\ )) + (define i 3) + (cond ((char? opt) (set! opt (string opt))) + ;;((symbol? opt) (set! opt (symbol->string opt))) + ) + (display (string-append preopt opt postopt) cep) + (newline cep) + (display (string-append "Usage: " + exe-name + " [-a kbytes] [-" simple-opts "]") cep) + (for-each + (lambda (o) + (display (string-append " [-" o "]") cep) + (set! i (+ 1 i)) + (cond ((zero? (modulo i 4)) (newline cep) (display indent cep)))) + (cdr arg-opts)) + (display " [-- | -s | -] [file] [args...]" cep) (newline cep) + (if success? (display success? cep) (quit #f))) + + ;; -a int => ignore (handled by scm_init_from_argv) + ;; -c str => (eval str) + ;; -e str => (eval str) + ;; -d str => (require 'database-utilities) (open-database str) + ;; -f str => (load str) + ;; -l str => (load str) + ;; -r str => (require str) + ;; -o str => (dump str) + ;; -p int => (verbose int) + ;; -m => (set! *R4RS-macro* #t) + ;; -u => (set! *R4RS-macro* #f) + ;; -v => (verbose 3) + ;; -q => (verbose 0) + ;; -i => (set! *interactive* #t) + ;; -b => (set! *interactive* #f) + ;; -s => set argv, don't execute first one + ;; -no-init-file => don't load init file + ;; --no-init-file => don't load init file + ;; --help => print and exit + ;; --version => print and exit + ;; -- => last option + + (let loop ((option (getopt-- argc *argv* opts))) + (case option + ((#\a) + (cond ((> *optind* 3) + (usage "scm: option `-" getopt:opt "' must be first" #f)) + ((or (not (exact? (string->number *optarg*))) + (not (<= 1 (string->number *optarg*) 10000))) + ;; This size limit should match scm.c ^^ + (usage "scm: option `-" getopt:opt + (string-append *optarg* "' unreasonable") #f)))) + ((#\e #\c) (do-string-arg)) ;sh-like + ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*) + ((#\d) (require 'database-utilities) + (open-database *optarg*)) + ((#\o) (require 'dump) + (if (< *optind* (length *argv*)) + (dump *optarg* #t) + (dump *optarg*))) + ((#\r) (do-thunk (lambda () + (if (and (= 1 (string-length *optarg*)) + (char-numeric? (string-ref *optarg* 0))) + (case (string-ref *optarg* 0) + ((#\2) (require 'rev3-procedures) + (require 'rev2-procedures)) + ((#\3) (require 'rev3-procedures)) + ((#\4) (require 'rev4-optional-procedures)) + ((#\5) (require 'values) + (require 'macro) + (require 'eval) + (set! *R4RS-macro* #t)) + (else (require (string->symbol *optarg*)))) + (require (string->symbol *optarg*)))))) + ((#\p) (verbose (string->number *optarg*))) + ((#\q) (verbose 0)) + ((#\v) (verbose 3)) + ((#\i) (set! *interactive* #t) ;sh-like + (verbose (max 2 (verbose)))) + ((#\b) (set! didsomething #t) + (set! *interactive* #f)) + ((#\s) (set! moreopts #f) ;sh-like + (set! didsomething #t) + (set! *interactive* #t)) + ((#\m) (set! *R4RS-macro* #t)) + ((#\u) (set! *R4RS-macro* #f)) + ((#\n) (if (not (string=? "o-init-file" *optarg*)) + (usage "scm: unrecognized option `-n" *optarg* "'" #f))) + ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f)) + ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f)) + ((#f) (set! moreopts #f) ;sh-like + (cond ((and (< *optind* (length *argv*)) + (string=? "-" (list-ref *argv* *optind*))) + (set! *optind* (+ 1 *optind*))))) + (else + (or (cond ((not (string? option)) #f) + ((string-ci=? "no-init-file" option)) + ((string-ci=? "version" option) + (display + (string-append exe-name " " + (scheme-implementation-version) + " +Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. +" + up-name + " may be distributed under the terms of" + " the GNU General Public Licence; +certain other uses are permitted as well." + " For details, see the file `COPYING', +which is included in the " + up-name " distribution. +There is no warranty, to the extent permitted by law. +" + )) + (cond ((execpath) => + (lambda (path) + (display " This executable was loaded from ") + (write path) + (newline)))) + (quit #t)) + ((string-ci=? "help" option) + (usage "This is " + up-name + ", a Scheme interpreter." + (let ((sihp (scheme-implementation-home-page))) + (if sihp + (string-append "Latest info: " sihp " +") + ""))) + (quit #t)) + (else #f)) + (usage "scm: unknown option `--" option "'" #f)))) + + (cond ((and moreopts (< *optind* (length *argv*))) + (loop (getopt-- argc *argv* opts))) + ((< *optind* (length *argv*)) ;No more opts + (set! *argv* (list-tail *argv* *optind*)) + (set! *optind* 1) + (cond ((and (not didsomething) *script*) + (do-load *script*) + (set! *optind* (+ 1 *optind*)))) + (cond ((and (> (verbose) 2) + (not (= (+ -1 *optind*) (length *argv*)))) + (display "scm: extra command arguments unused:" + (current-error-port)) + (for-each (lambda (x) (display (string-append " " x) + (current-error-port))) + (list-tail *argv* (+ -1 *optind*))) + (newline (current-error-port))))) + ((and (not didsomething) (= *optind* (length *argv*))) + (set! *interactive* #t))))) + + (cond ((not *interactive*) (quit)) + ((and *R4RS-macro* (not (provided? 'macro))) + (require 'repl) + (require 'macro) + (let* ((oquit quit)) + (set! quit (lambda () (repl:quit))) + (set! exit quit) + (repl:top-level macro:eval) + (oquit)))) + ;;otherwise, fall into natural SCM repl. + ) + (else + (begin (errno 0) + (set! *interactive* #t) + (for-each load (cdr (program-arguments))))))) diff --git a/Link.scm b/Link.scm index a60fd02..c34d56e 100644 --- a/Link.scm +++ b/Link.scm @@ -1,18 +1,18 @@ -;; Copyright (C) 1993, 1994, 1995, 1997 Free Software Foundation, Inc. -;; +;; Copyright (C) 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc. +;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; +;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. -;; +;; ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission ;; for additional uses of the text contained in its release of GUILE. @@ -36,29 +36,11 @@ ;; ;; If you write modifications of your own for GUILE, it is your choice ;; whether to permit this exception to apply to your modifications. -;; If you do not wish that, delete this exception notice. +;; If you do not wish that, delete this exception notice. ;;;; "Link.scm", Compiling and dynamic linking code for SCM. ;;; Author: Aubrey Jaffer. -(define cc:command - (let ((default "cc -c")) ;-O removed for HP-UX self-compile - (case (software-type) - ((unix) (if (memq 'sun-dl *features*) - "gcc -g -O -fpic -c" ; If you have problems change -fpic to - ; -fPIC (see GCC info pages). - default)) - (else default)))) - -(define link:command - (case (software-type) - (else "cc"))) - -(define scm:object-suffix - (case (software-type) - ((MSDOS VMS) ".OBJ") - (else ".o"))) - ;;; This is an unusual autoload because it should load either the ;;; source or compiled version if present. (if (not (defined? hobbit)) ;Autoload for hobbit @@ -74,30 +56,34 @@ (string-append "--compiler-options=-I" (implementation-vicinity)) "-c" (begin (require 'glob) - (replace-suffix file (scheme-file-suffix) ".c")) + ((filename:substitute?? (scheme-file-suffix) ".c") file)) "-hsystem" ))) -(define (link-named-scm name . modules) - (load (in-vicinity (implementation-vicinity) "build")) - (let* ((iv (implementation-vicinity)) - (oss (string-append scm:object-suffix " ")) - (command - (list "build" "--type=exe" "-cscm.c" "-hsystem" - (string-append "--linker-options=-L" (implementation-vicinity)) - (apply string-append - "-i" - (map (lambda (n) - (string-append "init_" n)) - modules)) +(define link-named-scm + (let ((scm:object-suffix (case (software-type) + ((MSDOS VMS) ".obj") + (else ".o")))) + (lambda (name . modules) + (load (in-vicinity (implementation-vicinity) "build")) + (let* ((iv (implementation-vicinity)) + (oss (string-append scm:object-suffix " ")) + (command + (append + (list "build" "--type=exe" "-cscm.c" "-hsystem" + ;; "-F" "compiled-closure" "inexact" + (string-append "--linker-options=-L" + (implementation-vicinity))) + (map (lambda (n) (string-append "-iinit_" n)) modules) + (list (apply string-append "-j" (map (lambda (n) (string-append n oss)) modules)) - "-o" name))) - (cond ((>= (verbose) 3) - (write command) (newline))) - (build-from-whole-argv command))) + "-o" name)))) + (cond ((>= (verbose) 3) + (write command) (newline))) + (build-from-whole-argv command))))) ;;;; Dynamic linking/loading @@ -114,17 +100,9 @@ (define oloadpath *load-pathname*) (let* ((sl (string-length file)) (lasl (string-length link:able-suffix)) - (*vicinity-suffix* - (case (software-type) - ((NOSVE) '(#\: #\.)) - ((AMIGA) '(#\: #\/)) - ((UNIX) '(#\/)) - ((VMS) '(#\: #\])) - ((MSDOS ATARIST OS/2) '(#\\)) - ((MACOS THINKC) '(#\:)))) (fname (let loop ((i (- sl 1))) (cond ((negative? i) file) - ((memv (string-ref file i) *vicinity-suffix*) + ((vicinity:suffix? (string-ref file i)) (substring file (+ i 1) sl)) (else (loop (- i 1)))))) (nsl (string-length fname)) @@ -166,7 +144,7 @@ (define fil "") (let loop ((i (- (string-length file) 1))) (cond ((negative? i) (set! dir file)) - ((memv (string-ref file i) '(#\: #\])) + ((vicinity:suffix? (string-ref file i)) (set! dir (substring file 0 (+ i 1))) (set! fil (substring file (+ i 1) (string-length file)))) (else (loop (- i 1))))) diff --git a/Macro.scm b/Macro.scm index 76fc495..0ddccc1 100644 --- a/Macro.scm +++ b/Macro.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1997, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 1999 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -12,7 +12,7 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission ;; for additional uses of the text contained in its release of GUILE. @@ -41,20 +41,20 @@ ;;;; "Macro.scm", Support for syntax-rules macros. ;;; Author: Radey Shouman ;; -;; As in SYNTAX-CASE, the identifier ... may be quoted in a +;; As in SYNTAX-CASE, the identifier ... may be quoted in a ;; SYNTAX-RULES pattern or template as (... ...). ;; ;; THE-MACRO may be used to define macros, eg ;; (define-syntax foo (the-macro and)) -;; defines the syntactic keyword FOO to have the same transformer +;; defines the syntactic keyword FOO to have the same transformer ;; as the macro AND. (require 'rev2-procedures) ;append! (require 'record) (define macro:compile-syntax-rules - ;; We keep local copies of these standard special forms, otherwise, - ;; redefining them before they are memoized below can lead to + ;; We keep local copies of these standard special forms, otherwise, + ;; redefining them before they are memoized below can lead to ;; infinite recursion. (@let-syntax ((lambda (the-macro lambda)) (let (the-macro let)) @@ -63,8 +63,9 @@ (and (the-macro and)) (or (the-macro or))) (let ((var-rtd (make-record-type '? '(name rank))) - (e-pat-rtd (make-record-type '... '(pattern vars)))) - + (e-pat-rtd (make-record-type '... '(pattern vars))) + (rule-rtd (make-record-type 'rule '(pattern inserted template)))) + (define pattern-variable (record-constructor var-rtd '(name rank))) (define pattern-variable? (record-predicate var-rtd)) (define pattern-variable->name @@ -82,10 +83,15 @@ (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern)) (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars)) + (define rule (record-constructor rule-rtd '(pattern inserted template))) + (define rule->pattern (record-accessor rule-rtd 'pattern)) + (define rule->inserted (record-accessor rule-rtd 'inserted)) + (define rule->template (record-accessor rule-rtd 'template)) + (define (append2 x y) (if (null? y) x (append x y))) - + (define ellipsis? (let (($... (renamed-identifier '... #f))) (lambda (x env) @@ -101,25 +107,26 @@ (car vars) (duplicates? (cdr vars))))) - (define (compile-pattern literals rule env-def) - (let recur ((pat (cdar rule)) + (define (compile-pattern literals rule-exp env-def) + (let recur ((pat (cdar rule-exp)) (vars '()) (rank 0) (k (lambda (compiled vars) (let ((dup (duplicates? (map car vars)))) (if dup - (error + (error "syntax-rules: duplicate pattern variable:" - dup " in rule " rule))) - (cons compiled - (rewrite-template - (cadr rule) vars env-def))))) + dup " in rule " rule-exp))) + (apply rule + compiled + (rewrite-template + (cadr rule-exp) vars env-def))))) (cond ((null? pat) (k pat vars)) ((identifier? pat) (let ((lit (memq pat literals))) (if lit - (k pat vars) + (k (renamed-identifier pat env-def) vars) (let ((var (pattern-variable pat rank))) (k var (cons (cons pat var) vars)))))) ((pair? pat) @@ -146,7 +153,7 @@ (k (list->vector comp) vars)))) (else (k pat vars))))) - + (define (rewrite-template template vars env-def) (let recur ((tmpl template) (rank 0) @@ -173,7 +180,7 @@ (or (null? (cddr tmpl)) (error "bad ellipsis:" tmpl))) ;; (... ...) escape - (k (car tmpl) (list (car tmpl)) '()) + (k (car tmpl) (list (car tmpl)) '()) (recur (car tmpl) (+ rank 1) '() (lambda (comp1 ins1 op1) (if (null? op1) @@ -203,14 +210,14 @@ ;;; Match EXP to RULE, returning alist of variable bindings or #f. - (define (match literals rule exp env-def env-use) - (let recur ((r rule) + (define (match rule exp env-use) + (let recur ((r (rule->pattern rule)) (x (cdr exp))) (cond ((null? r) (and (null? x) '())) ((pair? r) (if (ellipsis-pattern? (car r)) - (and + (and (list? x) (let ((pat (ellipsis-pattern->pattern (car r)))) (let match1 ((x x) @@ -233,9 +240,7 @@ (let ((v2 (recur (cdr r) (cdr x)))) (and v2 (append2 v1 v2)))))))) ((identifier? r) ;literal - (and (identifier? x) - (identifier-equal? (cdr (assq r literals)) x env-use) - '())) + (and (identifier? x) (identifier-equal? r x env-use) '())) ((pattern-variable? r) (list (cons r x))) ((vector? r) @@ -244,30 +249,35 @@ (else (and (equal? r x) '()))))) - (define (substitute-in-template inserted template vars env-def) + (define (substitute-in-template rule vars env-def) (let ((ins (map (lambda (id) (cons id (renamed-identifier id env-def))) - inserted))) - (let recur ((tmpl template) + (rule->inserted rule)))) + (let recur ((tmpl (rule->template rule)) (vars vars)) (cond ((null? tmpl) tmpl) ((pair? tmpl) (if (ellipsis-pattern? (car tmpl)) - (let ((enames (ellipsis-pattern->vars (car tmpl))) - (etmpl (ellipsis-pattern->pattern (car tmpl)))) - (let ((evals (apply map list - (map (lambda (nam) - (cdr (assq nam vars))) - enames)))) - (append! - (map (lambda (eval) - (recur etmpl - (append! - (map cons enames eval) - vars))) - evals) - (recur (cdr tmpl) vars)))) + (let* ((enames (ellipsis-pattern->vars (car tmpl))) + (etmpl (ellipsis-pattern->pattern (car tmpl))) + (evals (map (lambda (nam) + (cdr (assq nam vars))) + enames)) + (n (length (car evals)))) + (let check ((es (cdr evals))) + (if (pair? es) + (if (= n (length (car es))) + (check (cdr es)) + (error "syntax-rules: pattern variable length mismatch:")))) + (append! + (map (lambda (eval) + (recur etmpl + (append! + (map cons enames eval) + vars))) + (apply map list evals)) + (recur (cdr tmpl) vars))) (cons (recur (car tmpl) vars) (recur (cdr tmpl) vars)))) ((identifier? tmpl) @@ -291,33 +301,22 @@ (or (identifier? x) (error "Bad literals list:" x-def))) literals) + (let ((rules (map (lambda (rule-expr) + (or (and (list? rule-expr) + (= 2 (length rule-expr)) + (pair? (car rule-expr))) + (error "Bad rule:" rule-expr)) + (compile-pattern literals rule-expr env-def)) + (cddr x-def)))) - ;;Rules have the form: (