From ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:31 -0800 Subject: Import Upstream version 5e2 --- ANNOUNCE | 306 ++-- ChangeLog | 166 +++ Init5e1.scm | 1555 -------------------- Init5e2.scm | 1557 ++++++++++++++++++++ Makefile | 11 +- README | 20 +- Transcen.scm | 134 +- bench.scm | 2 +- build.scm | 4 +- byte.c | 6 +- continue.c | 4 +- crs.c | 26 +- debug.c | 2 +- differ.c | 7 +- dynl.c | 28 +- eval.c | 192 +-- grtest.scm | 82 ++ gsubr.c | 6 +- hobbit.info | 4 +- hobbit.scm | 6 +- ioext.c | 25 +- patchlvl.h | 4 +- posix.c | 8 +- r4rstest.scm | 2 +- ramap.c | 78 +- record.c | 10 +- repl.c | 80 +- rope.c | 51 +- rwb-isam.scm | 616 ++++++++ sc2.c | 8 +- scl.c | 749 +++++----- scm.1 | 12 +- scm.c | 20 +- scm.doc | 319 ++--- scm.h | 80 +- scm.info | 4483 +++++++++++++++++++++++++++++----------------------------- scm.spec | 2 +- scm.texi | 31 +- scmfig.h | 36 +- scmmain.c | 6 +- script.c | 8 +- socket.c | 43 +- subr.c | 165 +-- sys.c | 150 +- time.c | 6 +- turtle | 20 + turtlegr.c | 1298 +++++++++++++++++ unexelf.c | 1093 +++++++++----- unif.c | 104 +- unix.c | 2 +- version.txi | 4 +- wbtab.scm | 525 +++++++ x.c | 54 +- 53 files changed, 8589 insertions(+), 5621 deletions(-) delete mode 100644 Init5e1.scm create mode 100644 Init5e2.scm create mode 100644 grtest.scm create mode 100644 rwb-isam.scm create mode 100644 turtle create mode 100644 turtlegr.c create mode 100644 wbtab.scm diff --git a/ANNOUNCE b/ANNOUNCE index 1effd27..2146f92 100644 --- a/ANNOUNCE +++ b/ANNOUNCE @@ -1,190 +1,136 @@ -This message announces the availability of Scheme release scm5e1. - -New in scm5e1: - - * r4rstest.scm: Removed tests for 0^0 in anticipation of SRFI-70. - * r4rstest.scm (test-numeric-predicates): Raised exponent so - intransitive 128-bit-float implementations are caught. - * r4rstest.scm (SECTION 6 5 5): Removed tests for (EXPT 0 -255) - so Common-Lisp compatible EXPT won't bomb. - Test EXPT inexactness contagion of zero cases. - * r4rstest.scm (SECTION 6 5 5): Added exact tests for EXPT. - Inexact EXPT corner cases should return inexacts. - * r4rstest.scm: Added URLs. - - * Transcen.scm (limit): Check and report input errors. - * Transcen.scm (limit): Added srfi-70 procedure. - * Transcen.scm (expt, quotient, remainder, modulo): SRFI-70 extensions. - * Transcen.scm (expt): Changed so (expt 0 -5) signals error. - EXPT of zero returns zero or one matching input exactness. - - * Link.scm (link:link): Converted to use with-load-pathname. - - * Init5d9.scm (numerator, denominator): Check rational. - * Init5d9.scm (numerator, denominator): Added. - * Init5d9.scm (with-load-pathname): Moved from slib/require.scm. - * Init5d9.scm (any-bits-set?, first-set-bit, bitwise-merge): Added - remaining SRFI-33 aliases. - * Init5d9.scm (read-array-type): Handle A:char. - * Init5d9.scm (list->array, vector->array, array->vector): Added. - * Init5d9.scm: Updated per SRFI-60. - * Init5d9.scm (arithmetic-shift): Aliases ASH. - * Init5d9.scm (read:array, read:sharp): Accept whole boatload of - SRFI-58 sytnaxes. - * Init5d9.scm (inexact->exact, exact->inexact): Identity when - exacts-only. - * Init5d9.scm (slib:eval-load): Converted to use (SLIB) - with-load-pathname. - * Init5d9.scm (slib:eval-load): Define moved to "slib/require.scm" - * Init5d9.scm (read:array): Ignore third argument; line-numbers - were hosing array reading. - - * build.scm (dlll gnu-win32): Changed flag to "-DSCM_WIN_DLL". - (dlll microsoft-c-nt): Changed flag to "-DSCM_WIN_DLL". - * build.scm (wb): Added for source in ../wb/. - (build:command): Assume c-files are relative to cd; don't prefix - c-files with scm-srcdir. - (compile-dll-c-files): Many were missing include-spec "-I" call. - * build.scm (compile-dll-c-files): For those platforms supporting - shared object files, generate just one combining all FILES. - * build.scm (compile-dll-c-files): Fixed -I for netbsd, openbsd. - (compile-dll-c-files): Added -I for svr4-gcc-sun-ld. - (file-categories): Renamed CORE from REQUIRED. - - * mkimpcat.scm: Support WB compiled in implementation-vicinity. - * mkimpcat.scm: Added 'DIFF. - - * xgen.scm, build.bat, inc2scm: Replaced %0 ... %9 with %~f0 %* - - * scmhob.scm: Moved LOGICAL: aliases from logical.scm. - - * Makefile (install): Added db.so. - (uninstall): Beefed up. - * Makfile (scm5): Added target for undumpable architectures (FC3). - * Makefile (SETARCH): Workaround for unexec on Fedora Linux i386. - * Makefile (mydlls): Call BUILD separately for each dll. - * Makefile (srcdir.mk): Include after target. - Separated shell assignments and exports. - * Makefile: (SHOBJS): Abstracted *.sl and *.so. - * Makefile (db.so, rwb-isam.scm, wbtab.scm): Added. - * Makefile (differ.so): Added target. - - * scm.spec (differ.so, Idiffer.scm): Added to %files. - - * scm.texi (MS-DOS Compatible Scripts): Replaced %0 ... %9 with %~f0 %* - * scm.texi (SCMDB): Added section with link. - (Hobbit): Moved notinfo stuff after Xlib so it appears same place - in all products. - * scm.texi (Sequence Comparison): Added. - * scm.texi (SIOD copyright): Put in subsection. - (The SCM License): Parallel Guile License text. - * scm.texi (Automatic C Preprocessor Definitions): Added "sun". - - * scm.h (infi): Nonreal infinity added to sys_protects. - * scm.h (SCM_WIN_DLL): renamed from SCM_DLL and DLLSCM. - - * scmfig.h (IS_INF): Removed. - - * scl.c (scm_complex_p): 0/0 is not complex. - * scl.c (inf2str): Renamed from NaN2str(). - (makdbl): Returns `infi' for unreal infinities. - (scm_rationalp): Added (infinities not). - * scl.c (scm_intexpt): EXPT of zero behaves like Common-Lisp. - * scl.c (scm_intexpt): Bombed given (integer-expt 0 25). - - * subr.c (scm_copybitfield): Changed argument order (SRFI-60). - - * unif.c (scm_prot2type): Was not defaulting correctly. - * unif.c (raprin1): Don't elide 1 from #1A. - * unif.c, sys.c: Sun cc doesn't like fwrite declaration. - - * byte.c (scm_write_byte): Was hosed for even number of bytes. - * byte.c (scm_substring_read): Fixed off-by-one reading backwards. - - * ramap.c (array:copy!): Renamed from array-copy!. - (array_copy): Arguments reversed. - * ramap.c (init_ramap): Its tc7_subr_2 not tc7_subr2! - * ramap.c (rafe): Removed unused variables inc and base. - - * repl.c (err_head): Fixed "loaded from" messages and formatting. - * repl.c (iprin1): Slashify uppercase chars in symbols. - * repl.c (read_token, iprin1, lreadr): Handle slashified symbols. - * repl.c (handle_it): Added comments. Call scm_fill_freelist() if - interrupt lacks handler. - * repl.c (scm_top_level): Default value of toplvl_fun just once. - - * differ.c, Idiffer.scm: Linear-space O(PN) sequence comparison. - - * eval.c (definedp): Added third (dummy) argument. - -From Radey Shouman: - - * Init5d9.scm (read:array): Make default rank one, not zero. - (as before). - * Init5d9.scm (read:array): (read:sharp): (load:sharp): Use read - argument passed to READ:SHARP only for eval, otherwise unexpected - line numbers cause trouble. eg #+(or) in load file. - - * script.c (find_impl_file): Find executable path accurately - on MS windows. - - * scm.texi (Debugging Continuations): Added documenting - frame-trace, frame->environment, scope-trace, frame-eval. - - * eval.c (toplevel_define) (scm_arity_check) (ceval_1) - (scm_cvapply) (apply): Pass multiple arguments to captured - continuations, eg: - (call-with-values (lambda () (call/cc (lambda (k) 1 2))) list) - Better error checking for multiple-value returns in repl. - - * sys.c (scm_dynthrow): Allow passing multiple arguments - to a continuation captured in the producer argument of - call-with-values. - - * subr.c (scm_logbitp): Fixed bug in range check for fixnum - case. Eg (logbit? 10 #xffff) now correctly returns #t. +This message announces the availability of Scheme release scm5e2. - * eval.c (macroexp1): Catch more syntax errors: ('f . f) - * eval.c (m_case) (definedp): Avoid segfault in cases of syntax - error. +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, Windows, +Unix, and similar systems. -From Wim Lewis: +SCM is free software. It is released under the GNU Public License +(GPL) with an exception allowing it to be linked with non-GPL +programs (see http://swiss.csail.mit.edu/~jaffer/SCM_LICENSE). - * Makefile (scmflags): Use "cmp -s" instead of "diff". - (x.h): Use -x $CPROTO to test for cproto's existence. +Documentation and distributions in several formats are linked from +SCM's home page: - -=-=- + http://swissnet.ai.mit.edu/~jaffer/SCM.html -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, Windows, -Unix, and similar systems. ASCII and EBCDIC are supported. +Links to distributions of SCM and related softwares are at the end of +this message. -Documentation is included explaining the many Scheme Language -extensions in scm, the internal representations, and how to extend or -include SCM in other programs. Documentation is online at: + -=-=- +scm5e2 news: + +Hinting GCC branch-predictions nets 10% speed improvement for SCM +running the JACAL symbolic mathematics system. + + * scmfig.h (SCM_EXPECT_TRUE, SCM_EXPECT_FALSE): Added. + (POSFIXABLE, NEGFIXABLE, UNEGFIXABLE): SCM_EXPECT_TRUE. + * scmfig.h (__builtin_expect): Added stub for non-gcc compilers. + + * scm.h: SCM_EXPECT_TRUE and SCM_EXPECT_FALSE replace + __builtin_expect(). + (ASRTER, ASRTGO): SCM_EXPECT_FALSE. + * scm.h (INUMP, IMP, SINGP): Added __builtin_expect() netting more + than 9% speed improvement in JACAL. + + * Makefile (scm5.opt, udscm4.opt): Commented out + -fno-guess-branch-probability flag. + * Makefile (udscm4.opt, scm5.opt): Condition + -fno-guess-branch-probability on `type gcc'. + * Makefile (scm5.opt, udscm4.opt): -fno-guess-branch-probability + improves benchmark speed 10% on i686. + (hfiles): Moved to top of file so that dependencies work. + + * byte.c, continue.c, crs.c, dynl.c, eval.c, gsubr.c, ioext.c, + posix.c, ramap.c, record.c, repl.c, rope.c, sc2.c, scl.c, scm.c, + scm.h, socket.c, subr.c, sys.c, time.c, unif.c, unix.c, x.c: + Regularized `if' syntax. + + * scm.c (l_pause): __CYGWIN__ now has pause(). + * scmfig.h (LACK_FTIME): __CYGWIN__ now has ftime(). + * socket.c (l_lna, l_hostinfo, l_netinfo, l_setnet): Made + conditional on __CYGWIN__. + * ioext.c: __CYGWIN__ has . + + * scl.c (lasinh, lacosh, latanh): Replaced by libc functions. + * scl.c (sum, difference, divide): Added BIGDIG* cast to &z. + * scl.c (numident): Don't bomb given bignums. + * scl.c (makdbl): (+ -1/0 +5i) ==> -1/0; not 0/0. + * scl.c (apx_log10): Removed unused variable. + * scl.c (scm_magnitude): Renamed from magnitude(). + (scm_abs): Added, real-only. + * scl.c (safe_add_1): Replaces add1. + (scm_truncate): Renamed from ltrunc. + * scm.h (scm_truncate): Renamed from ltrunc. + (scm_floor, scm_ceiling): Added. + * subr.c (absval): Moved to scl.c. + * rope.c (num2dbl): Handle 0/0. + * scl.c (inf2str): Changed to "+inf.0" and "-inf.0". + (istr2flo): Parse "+inf.0", "-inf.0", and + COMPACT_INFINITY_NOTATION. + (istr2flo, inf2str): COMPACT_INFINITY_NOTATION flag enables +/0 + and -/0 infinity notations. + + * Transcen.scm (quo, rem, mod): New names for inexact quotient, + remainder, and modulo. + * Init5e1.scm (abs): Is no longer synonym for magnitude. + * Transcen.scm (exact-round, exact-floor, exact-ceiling) + (exact-truncate): Added SRFI-70 convenience functions. + (limit): Removed. + * Transcen.scm (sequence->limit): Removed use of 1/0 literal. + * Transcen.scm (expt): 0^0 ==> 1. + * scl.c (scm_intexpt): 0^0 ==> 1. + * Transcen.scm, Init5e1.scm (infinite?, finite?): Added. + * scl.c (makdbl, init_scl): Don't bother with scm_narn for MSC. + (scm_finitep): Removed to Transcen.scm and Init5e1.scm. + * scm.h (scm_narn): Renamed from infi. + + * r4rstest.scm (SECTION 6 5 5): Restored 0^0 test. + + * hobbit.scm (*c-keywords*): absval --> scm_abs; magnitude --> + scm_magnitude. + + * rope.c, scm.c, scm.texi, scmmain.c, script.c, socket.c: Added + const to argv. + * scmmain.c, scm.h, scm.c, rope.c, repl.c: Added const decls. + + * build.scm (build:command): Comment to script: [-p ]. + * Makefile (turfiles): Added turtle-graphics files. + * Makefile (DOSCM): Abstracted DOS zip creation. + + * unexelf.c: Imported from emacs-22.0.50 to fix FC4 build. + + * differ.c (diff_mid_split): Unused `m' argument removed. + + * scm.spec (slibpath, dumparch): Added. + +From: Steve VanDevender + * scmfig.h (SHORT_INT, CDR_DOUBLES): For __x86_64 (AMD Opteron). + +From: Thomas Bushnell + * scm.doc, scm.1: Corrected spelling errors. - http://swissnet.ai.mit.edu/~jaffer/SCM.html + -=-=- SCM source is available from: - http://swissnet.ai.mit.edu/ftpdir/scm/scm5e1.zip - swissnet.ai.mit.edu:/pub/scm/scm5e1.zip - http://swissnet.ai.mit.edu/ftpdir/scm/scm-5e1-1.src.rpm - swissnet.ai.mit.edu:/pub/scm/scm-5e1-1.src.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/scm5e2.zip + swissnet.ai.mit.edu:/pub/scm/scm5e2.zip + http://swissnet.ai.mit.edu/ftpdir/scm/scm-5e2-1.src.rpm + swissnet.ai.mit.edu:/pub/scm/scm-5e2-1.src.rpm Also available as i386 binary RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/scm-5e1-1.i386.rpm - swissnet.ai.mit.edu:/pub/scm/scm-5e1-1.i386.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/scm-5e2-1.i386.rpm + swissnet.ai.mit.edu:/pub/scm/scm-5e2-1.i386.rpm SLIB is a portable Scheme library which SCM uses: - http://swissnet.ai.mit.edu/ftpdir/scm/slib3a2.zip - swissnet.ai.mit.edu:/pub/scm/slib3a2.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib3a3.zip + swissnet.ai.mit.edu:/pub/scm/slib3a3.zip Also available as RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a2-1.noarch.rpm - swissnet.ai.mit.edu:/pub/scm/slib-3a2-1.noarch.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a3-1.noarch.rpm + swissnet.ai.mit.edu:/pub/scm/slib-3a3-1.noarch.rpm JACAL is a symbolic math system written in Scheme: - http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b5.zip - swissnet.ai.mit.edu:/pub/scm/jacal1b5.zip + http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b6.zip + swissnet.ai.mit.edu:/pub/scm/jacal1b6.zip SLIB-PSD is a portable debugger for Scheme (requires emacs editor): http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz @@ -212,13 +158,13 @@ SCM (similar to XSCM). WB is a disk based, sorted associative array (B-tree) library for SCM. Using WB, large databases can be created and managed from SCM. - http://swissnet.ai.mit.edu/ftpdir/scm/wb1c1.zip - swissnet.ai.mit.edu:/pub/scm/wb1c1.zip - http://swissnet.ai.mit.edu/ftpdir/scm/wb-1c1-1.src.rpm - swissnet.ai.mit.edu:/pub/scm/wb-1c1-1.src.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/wb1c2.zip + swissnet.ai.mit.edu:/pub/scm/wb1c2.zip + http://swissnet.ai.mit.edu/ftpdir/scm/wb-1c2-1.src.rpm + swissnet.ai.mit.edu:/pub/scm/wb-1c2-1.src.rpm Also available as i386 binary RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/wb-1c1-1.i386.rpm - swissnet.ai.mit.edu:/pub/scm/wb-1c1-1.i386.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/wb-1c2-1.i386.rpm + swissnet.ai.mit.edu:/pub/scm/wb-1c2-1.i386.rpm SIMSYNCH is a digital logic simulation system written in SCM. http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip @@ -230,8 +176,8 @@ files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation systems. ftp.gnu.org:pub/gnu/dld/dld-3.3.tar.gz -SCM.EXE (282k) is a SCM executable for DOS and MS-Windows. -Note: SCM.EXE still requires slib3a2 and scm5e1 above. +SCM.EXE (314k) is a SCM executable for DOS and MS-Windows. +Note: SCM.EXE still requires slib3a3 and scm5e2 above. http://swissnet.ai.mit.edu/ftpdir/scm/scm.exe swissnet.ai.mit.edu:/pub/scm/scm.exe diff --git a/ChangeLog b/ChangeLog index df2ebd4..8acdf96 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,169 @@ +2006-02-19 Aubrey Jaffer + + * scl.c (atanh, acosh, asinh): define if #ifndef HAVE_ATANH. + + * scmfig.h (HAVE_ATANH): Decides whether atanh, asinh, and acosh + are supported. + +2006-02-16 Radey Shouman + + * scl.c: Changes to allow compilation with MinGW (gnu-win32); + asinh, acosh, and atanh are not yet supported. + +2006-02-13 Aubrey Jaffer + + * patchlvl.h (SCMVERSION): Bumped from 5e1 to 5e2. + +2006-02-08 Aubrey Jaffer + + * scl.c (lasinh, lacosh, latanh): Replaced by libc functions. + +2006-02-08 Steve VanDevender + + * scmfig.h (SHORT_INT, CDR_DOUBLES): For __x86_64 (AMD Opteron). + +2006-01-23 Aubrey Jaffer + + * Transcen.scm (exact-round, exact-floor, exact-ceiling) + (exact-truncate): Returned inexacts. + +2006-01-14 Aubrey Jaffer + + * Transcen.scm (quo, rem, mod): New names for inexact quotient, + remainder, and modulo. + + * scmfig.h (SCM_EXPECT_TRUE, SCM_EXPECT_FALSE): Added. + (POSFIXABLE, NEGFIXABLE, UNEGFIXABLE): SCM_EXPECT_TRUE. + + * scm.h: SCM_EXPECT_TRUE and SCM_EXPECT_FALSE replace + __builtin_expect(). + (ASRTER, ASRTGO): SCM_EXPECT_FALSE. + + * scl.c (sum, difference, divide): Added BIGDIG* cast to &z. + + * scmfig.h (__builtin_expect): Added stub for non-gcc compilers. + + * scm.h (INUMP, IMP, SINGP): Added __builtin_expect() netting more + than 9% speed improvement in JACAL. + + * Makefile (scm5.opt, udscm4.opt): Commented out + -fno-guess-branch-probability flag. + +2006-01-09 Aubrey Jaffer + + * Makefile (udscm4.opt, scm5.opt): Condition + -fno-guess-branch-probability on `type gcc'. + +2006-01-06 Aubrey Jaffer + + * byte.c, continue.c, crs.c, dynl.c, eval.c, gsubr.c, ioext.c, + posix.c, ramap.c, record.c, repl.c, rope.c, sc2.c, scl.c, scm.c, + scm.h, socket.c, subr.c, sys.c, time.c, unif.c, unix.c, x.c: + Regularized `if' syntax. + + * Makefile (scm5.opt, udscm4.opt): -fno-guess-branch-probability + improves benchmark speed 10% on i686. + (hfiles): Moved to top of file so that dependencies work. + +2006-01-04 Aubrey Jaffer + + * scl.c (numident): Don't bomb given bignums. + + * scm.c (l_pause): __CYGWIN__ now has pause(). + + * scmfig.h (LACK_FTIME): __CYGWIN__ now has ftime(). + + * ioext.c: __CYGWIN__ has . + + * build.scm (build:command): Comment to script: [-p ]. + +2005-12-18 Aubrey Jaffer + + * socket.c (l_lna, l_hostinfo, l_netinfo, l_setnet): Made + conditional on __CYGWIN__. + +2005-12-07 Aubrey Jaffer + + * scl.c (makdbl): (+ -1/0 +5i) ==> -1/0; not 0/0. + +2005-12-01 Aubrey Jaffer + + * scmmain.c, scm.h, scm.c, rope.c, repl.c: Added const decls. + + * scl.c (apx_log10): Removed unused variable. + +2005-10-29 Aubrey Jaffer + + * scl.c (scm_magnitude): Renamed from magnitude(). + (scm_abs): Added, real-only. + + * subr.c (absval): Moved to scl.c. + + * hobbit.scm (*c-keywords*): absval --> scm_abs; magnitude --> + scm_magnitude. + + * rope.c, scm.c, scm.texi, scmmain.c, script.c, socket.c: Added + const to argv. + + * Init5e1.scm (abs): Is no longer synonym for magnitude. + +2005-10-28 Aubrey Jaffer + + * Makefile (turfiles): Added turtle-graphics files. + +2005-10-27 Thomas Bushnell + + * scm.doc, scm.1: Corrected spelling errors. + +2005-10-02 Aubrey Jaffer + + * unexelf.c: Imported from emacs-22.0.50 to fix FC4 build. + +2005-09-22 Aubrey Jaffer + + * rope.c (num2dbl): Handle 0/0. + +2005-08-16 Aubrey Jaffer + + * Transcen.scm (exact-round, exact-floor, exact-ceiling) + (exact-truncate): Renamed from xxx->exact. + (limit): Removed. + + * scl.c (inf2str): Changed to "+inf.0" and "-inf.0". + (istr2flo): Parse "+inf.0", "-inf.0", and + COMPACT_INFINITY_NOTATION. + +2005-08-07 Aubrey Jaffer + + * Transcen.scm (round->exact, floor->exact, ceiling->exact, + truncate->exact): Added SRFI-70 convenience functions. + + * differ.c (diff_mid_split): Unused `m' argument removed. + +2005-07-17 Aubrey Jaffer + + * scl.c (safe_add_1): Replaces add1. + (scm_truncate): Renamed from ltrunc. + + * scm.h (scm_truncate): Renamed from ltrunc. + (scm_floor, scm_ceiling): Added. + +2005-07-02 Aubrey Jaffer + + * Transcen.scm (sequence->limit): Removed use of 1/0 literal. + + * scl.c (inf2str): Prefix "1/0" with '+'. + (istr2flo, inf2str): COMPACT_INFINITY_NOTATION flag enables +/0 + and -/0 infinity notations. + +2005-06-30 Aubrey Jaffer + + * r4rstest.scm (SECTION 6 5 5): Restored 0^0 test. + + * Transcen.scm (expt): 0^0 ==> 1. + + * scl.c (scm_intexpt): 0^0 ==> 1. + 2005-06-25 Aubrey Jaffer * scm.spec (slibpath, dumparch): Added. diff --git a/Init5e1.scm b/Init5e1.scm deleted file mode 100644 index ae2f591..0000000 --- a/Init5e1.scm +++ /dev/null @@ -1,1555 +0,0 @@ -;; Copyright (C) 1991-2005 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 SCM. -;; -;; The exception is that, if you link the SCM 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 SCM 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 SCM. If you copy -;; code from other Free Software Foundation releases into a copy of -;; SCM, 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 SCM, 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) "5e1") -(define (scheme-implementation-home-page) - "http://swiss.csail.mit.edu/~jaffer/SCM") - -;@ -(define in-vicinity string-append) -;@ -(define (user-vicinity) - (case (software-type) - ((VMS) "[.]") - (else ""))) -;@ -(define vicinity:suffix? - (let ((suffi - (case (software-type) - ((AMIGA) '(#\: #\/)) - ((MACOS THINKC) '(#\:)) - ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) - ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT PLAN9) '(#\/)) - ((VMS) '(#\: #\])) - (else - (slib:warn "require.scm" 'unknown 'software-type (software-type)) - "/")))) - (lambda (chr) (and (memv chr suffi) #t)))) -;@ -(define (pathname->vicinity pathname) - (let loop ((i (- (string-length pathname) 1))) - (cond ((negative? i) "") - ((vicinity:suffix? (string-ref pathname i)) - (substring pathname 0 (+ i 1))) - (else (loop (- i 1)))))) -(define (program-vicinity) - (if *load-pathname* - (pathname->vicinity *load-pathname*) - (slib:error 'program-vicinity " called; use slib:load to load"))) -;@ -(define sub-vicinity - (case (software-type) - ((VMS) (lambda - (vic name) - (let ((l (string-length vic))) - (if (or (zero? (string-length vic)) - (not (char=? #\] (string-ref vic (- l 1))))) - (string-append vic "[" name "]") - (string-append (substring vic 0 (- l 1)) - "." name "]"))))) - (else (let ((*vicinity-suffix* - (case (software-type) - ((NOSVE) ".") - ((MACOS THINKC) ":") - ((MS-DOS WINDOWS ATARIST OS/2) "\\") - ((UNIX COHERENT PLAN9 AMIGA) "/")))) - (lambda (vic name) - (string-append vic name *vicinity-suffix*)))))) -;@ -(define (make-vicinity ) ) -;@ -(define with-load-pathname - (let ((exchange - (lambda (new) - (let ((old *load-pathname*)) - (set! *load-pathname* new) - old)))) - (lambda (path thunk) - (let ((old #f)) - (dynamic-wind - (lambda () (set! old (exchange path))) - thunk - (lambda () (exchange old))))))) - -(set! *features* - (append '(ed 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 - vicinity srfi-59 - srfi-60) ;logical - *features*)) - -(define eval - (let ((@eval @eval) - (@copy-tree @copy-tree)) - (lambda (x) (@eval (@copy-tree x))))) - -(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 . port) - (call-with-input-file file - (lambda (inport) - (do ((c (read-char inport) (read-char inport))) - ((eof-object? c)) - (apply write-char c port))))) -(define (terms) - (display-file (in-vicinity (implementation-vicinity) "COPYING"))) - -;;; Read integer up to first non-digit -(define (read:try-number port . ic) - (define chr0 (char->integer #\0)) - (let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0)))) - (let ((c (peek-char port))) - (cond ((eof-object? c) #f) - ((char-numeric? c) - (loop (+ (* 10 (or arg 0)) - (- (char->integer (read-char port)) chr0)))) - (else arg))))) - -(define (read-array-type port) - (define (bomb pc wid) - (error 'array 'syntax? (symbol-append "#" rank "A" pc wid))) - (case (char-downcase (peek-char port)) - ((#\:) (read-char port) - (let ((typ (let loop ((arg '())) - (if (= 4 (length arg)) - (string->symbol (list->string (reverse arg))) - (let ((c (read-char port))) - (and (not (eof-object? c)) - (loop (cons (char-downcase c) arg)))))))) - (define wid (and typ (not (eq? 'bool typ)) (read:try-number port))) - (define (check-suffix chrs) - (define chr (read-char port)) - (if (and (char? chr) (not (memv (char-downcase chr) chrs))) - (error 'array-type? (symbol-append ":" typ wid chr)))) - (define prot (assq typ '((floc (128 . +64.0i) - (64 . +64.0i) - (32 . +32.0i) - (16 . +32.0i)) - (flor (128 . 64.0) - (64 . 64.0) - (32 . 32.0) - (16 . 32.0)) - (fixz (64 . -64) - (32 . -32) - (16 . -16) - (8 . -8)) - (fixn (64 . 64) - (32 . 32) - (16 . 16) - (8 . 8)) - (char . #\a) - (bool . #t)))) - (if prot (set! prot (cdr prot))) - (cond ((pair? prot) - (set! prot (assv wid (cdr prot))) - (if (pair? prot) (set! prot (cdr prot))) - (if wid (check-suffix (if (and (inexact? prot) (real? prot)) - '(#\b #\d) - '(#\b))))) - (prot) - (else (check-suffix '()))) - prot)) - ((#\\) (read-char port) #\a) - ((#\t) (read-char port) #t) - ((#\c #\r) (let* ((pc (read-char port)) (wid (read:try-number port))) - (case wid - ((64 32) (case pc - ((#\c) (* +i wid)) - (else (exact->inexact wid)))) - (else (bomb pc wid))))) - ((#\s #\u) (let* ((pc (read-char port)) (wid (read:try-number port))) - (case (or wid (peek-char port)) - ((32 16 8) (case pc - ((#\s) (- wid)) - (else wid))) - (else (bomb pc wid))))) - (else #f))) - -;;; We come into read:array with number or #f for RANK. -(define (read:array rank dims port) - (define (make-it rank dims typ) - (list->uniform-array (cond (rank) - ((null? dims) 1) - (else (length dims))) - typ - (read port))) - (let loop ((dims dims)) - (define dim (read:try-number port)) - (if dim - (loop (cons dim dims)) - (case (peek-char port) - ((#\*) (read-char port) (loop dims)) - ((#\: #\\ #\t #\c #\r #\s #\u #\T #\C #\R #\S #\U) - (make-it rank dims (read-array-type port))) - (else - (make-it rank dims #f)))))) - -;;; read-macros valid for LOAD and READ. -(define (read:sharp c port reader) ; ignore reader - (case c - ;; Used in "implcat" and "slibcat" - ((#\+) (if (slib:provided? (read port)) - (read port) - (begin (read port) (if #f #f)))) - ;; Used in "implcat" and "slibcat" - ((#\-) (if (slib:provided? (read port)) - (begin (read port) (if #f #f)) - (read port))) - ((#\a #\A) (read:array #f '() port)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (let* ((num (read:try-number port c)) - (chr (peek-char port))) - (case chr - ((#\a #\A) (read-char port) - (read:array num '() port)) - ((#\*) (read-char port) - (read:array #f (list num) port)) - (else - (read:array 1 (list num) port)) - ;;(else (error 'sharp 'syntax? (symbol-append "#" num chr))) - ))) - (else (error "unknown # object" c)))) - -;;; read-macros valid only in LOAD. -(define (load:sharp c port reader) ;reader used only for #. - (case c - ((#\') (read port)) - ((#\.) (eval (reader port))) - ((#\!) (let skip ((metarg? #f)) - (let ((c (read-char port))) - (case c - ((#\newline) (if metarg? (skip #t))) - ((#\\) (skip #t)) - ((#\!) (cond ((eqv? #\# (peek-char port)) - (read-char port) - (if #f #f)) - (else (skip metarg?)))) - (else (if (char? c) (skip metarg?) c)))))) - ;; Make #; convert the rest of the line to a (comment ...) form. - ;; "build.scm" uses this. - ((#\;) (let skip-semi () - (cond ((eqv? #\; (peek-char port)) - (read-char port) - (skip-semi)) - (else (require 'line-i/o) - `(comment ,(read-line port)))))) - ((#\?) (case (read port) - ((line) (port-line port)) - ((column) (port-column port)) - ((file) (port-filename port)) - (else #f))) - (else (read:sharp c port read)))) - -;;; We can assume TOK has at least 2 characters. -(define char:sharp - (letrec ((numeric-1 - (lambda (tok radix) - (numeric (substring tok 1 (string-length tok)) radix))) - (numeric - (lambda (tok radix) - (cond ((string->number tok radix) => integer->char)))) - (compose - (lambda (modifier tok) - (and (char=? #\- (string-ref tok 1)) - (if (= 3 (string-length tok)) - (modifier (string-ref tok 2)) - (let ((c (char:sharp - (substring tok 2 (string-length tok))))) - (and c (modifier c))))))) - (control - (lambda (c) - (and (char? c) - (if (eqv? c #\?) - (integer->char 127) - (integer->char (logand #o237 (char->integer c))))))) - (meta - (lambda (c) - (and (char? c) - (integer->char (logior 128 (char->integer c))))))) - (lambda (tok) - (case (string-ref tok 0) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) (numeric tok 8)) - ((#\O #\o) (numeric-1 tok 8)) - ((#\D #\d) (numeric-1 tok 10)) - ((#\X #\x) (numeric-1 tok 16)) - ((#\C #\c) (compose control tok)) - ((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1)))) - ((#\M #\m) (compose meta tok)))))) - -;;;; 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*))))))) - -(define : ':) ;for /bin/sh hack. -(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 cr) - -(cond ((defined? defsyntax) -(defsyntax define-syntax (the-macro defsyntax))) - (else -(define defsyntax define) -(define the-macro identity))) -(defsyntax 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) 'wbc) - ((ATARIST) 'wb) - (else 'w))) -(define OPEN_BOTH (case (software-type) - ((MS-DOS WINDOWS) 'r+bc) - ((ATARIST) 'r+b) - (else 'r+))) -(define ((make-moder str) mode) - (if (symbol? mode) - (string->symbol (string-append (symbol->string mode) str)) - (string-append mode str))) -(define _IONBF (make-moder "0")) -(define _TRACKED (make-moder "?")) -(define _EXCLUSIVE (make-moder "x")) - -(define could-not-open #f) - -(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-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 (string-index str chr) - (define len (string-length str)) - (do ((pos 0 (+ 1 pos))) - ((or (>= pos len) (char=? chr (string-ref str pos))) - (and (< pos len) pos)))) - -(if (not (defined? try-create-file)) -(define (try-create-file str modes . perms) - (if (symbol? modes) (set! modes (symbol->string modes))) - (let ((idx (string-index modes #\x))) - (cond ((slib:in-catalog? 'i/o-extensions) - (require 'i/o-extensions) - (apply try-create-file str modes perms)) - ((not idx) - (warn "not exclusive modes?" modes str) - (try-open-file str modes)) - (else (set! modes (string-append (substring modes 0 idx) - (substring modes (+ 1 idx) - (string-length modes)))) - (cond ((not (string-index modes #\w)) - (warn 'try-create-file "not writing?" modes str) - (try-open-file str modes)) - (else - (cond ((and (not (null? perms)) - (not (eqv? #o666 (car perms)))) - (warn "perms?" (car perms) str))) - (cond ((file-exists? str) #f) - (else (try-open-file str modes)))))))))) - -(define close-input-port close-port) -(define close-output-port close-port) - -(define (call-with-open-ports . ports) - (define proc (car ports)) - (cond ((procedure? proc) (set! ports (cdr ports))) - (else (set! ports (reverse ports)) - (set! proc (car ports)) - (set! ports (reverse (cdr ports))))) - (let ((ans (apply proc ports))) - (for-each close-port ports) - ans)) - -(define (call-with-input-file str proc) - (call-with-open-ports (open-input-file str) proc)) - -(define (call-with-output-file str proc) - (call-with-open-ports (open-output-file str) proc)) - -(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 (call-with-outputs thunk proc) - (define stdout #f) - (define stderr #f) - (define status #f) - (set! stdout - (call-with-output-string - (lambda (stdout) - (set! stderr - (call-with-output-string - (lambda (stderr) - (call-with-current-continuation - (lambda (escape) - (dynamic-wind - (lambda () - (set! status #f) - (set! stdout (set-current-output-port stdout)) - (set! stderr (set-current-error-port stderr))) - (lambda () (set! status (list (thunk)))) - (lambda () - (set! stdout (set-current-output-port stdout)) - (set! stderr (set-current-error-port stderr)) - (if (not status) (escape #f)))))))))))) - (apply proc stdout stderr (or status '()))) - -(define browse-url - (case (software-type) - ((UNIX COHERENT PLAN9) - (lambda (url) - (define (try cmd end) (zero? (system (string-append cmd url end)))) - (or (try "netscape-remote -remote 'openURL(" ")'") - (try "netscape -remote 'openURL(" ")'") - (try "netscape '" "'&") - (try "netscape '" "'")))) - (else - (lambda (url) - (slib:warn 'define (software-type) 'case 'of 'browse-url 'in - *load-pathname*))))) - -(define (warn . args) - (define cep (current-error-port)) - (if (defined? print-call-stack) (print-call-stack cep)) - (perror "WARN") - (errno 0) - (display "WARN:" cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) args) - (newline cep) - (force-output cep)) - -(define (error . args) - (define cep (current-error-port)) - (if (defined? print-call-stack) (print-call-stack cep)) - (perror "ERROR") - (errno 0) - (display "ERROR:" cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) 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 (pprint . args) - (define result #f) - (for-each (lambda (x) (set! result x) (pretty-print x)) args) - result) -(define (pp . args) - (for-each pretty-print args) - (if #f #f)) - -(if (not (defined? file-exists?)) -(define (file-exists? str) - (let ((port (open-file str OPEN_READ))) - (errno 0) - (and port (close-port port) #t)))) -(define (file-readable? str) - (let ((port (open-file str OPEN_READ))) - (errno 0) - (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 (defined? ed)) -(define (ed . args) - (system (apply string-append - (or (getenv "EDITOR") "ed") - (map (lambda (s) (string-append " " s)) args))))) - -(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) - -(define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep))) - -;;;; 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)))) - -;;; Here for backward compatibility -(define scheme-file-suffix - (case (software-type) - ((NOSVE) (lambda () "_scm")) - (else (lambda () ".scm")))) - -(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 *load-reader* #f) -(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 *load-reader*)) - ;;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 *load-reader*)) - (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 *load-reader*) - ;;HERE is where the suffix gets specified - (and (not (has-suffix? file sfs)) - (begin (set! filesuf (string-append file sfs)) - (try-load filesuf *load-reader*))))) - (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) - -;;; 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. -(define library-vicinity #f) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. -(define home-vicinity #f) - -(define (login->home-directory login) - (cond ((defined? getpw) - (let ((pwvect (getpw login))) - (and pwvect (vector-ref pwvect 5)))) - ((not (file-exists? "/etc/passwd")) #f) - (else - (call-with-input-file "/etc/passwd" - (lambda (iprt) - (require 'string-search) - (require 'line-i/o) - (let tryline () - (define line (read-line iprt)) - (define (get-field) - (define idx (string-index line #\:)) - (and idx - (let ((fld (substring line 0 idx))) - (set! line (substring line (+ 1 idx) - (string-length line))) - fld))) - (cond ((eof-object? line) #f) - ((string-index line #\:) - => (lambda (idx) - (define name (substring line 0 idx)) - (cond ((equal? login name) - (do ((ans (get-field) (get-field)) - (cnt 4 (+ -1 cnt))) - ((or (negative? cnt) (not ans)) ans))) - (else (tryline)))))))))))) - -(define (getlogin) (or (getenv "USER") (getenv "LOGNAME"))) - -;;; 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 (set-vicinities! init-file) - (set! implementation-vicinity - (let ((vic (substring - init-file - 0 - (- (string-length init-file) - (string-length "Init.scm") - (string-length (scheme-implementation-version)))))) - (lambda () vic))) - (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) - (if library-path - (set! library-vicinity (lambda () library-path)) - (let ((filename (in-vicinity (implementation-vicinity) "require.scm"))) - (or (try-load filename) - (try-load (in-vicinity (implementation-vicinity) "requires.scm")) - (error "Can't load" filename)) - (if (not library-vicinity) (error "Can't find library-vicinity"))))) - (set! home-vicinity - (let ((home (getenv "HOME"))) - (and (not home) login->home-directory - (let ((login (getlogin))) - (and login (set! home (login->home-directory login))))) - (and home - (case (software-type) - ((UNIX COHERENT PLAN9 MS-DOS) ;V7 unix has a / on HOME - (if (not - (eqv? #\/ (string-ref home (+ -1 (string-length home))))) - (set! home (string-append home "/")))))) - (lambda () home)))) -;;; SET-VICINITIES! is also called from BOOT-TAIL -(set-vicinities! *load-pathname*) - -;;;; Initialize SLIB -(load (in-vicinity (library-vicinity) "require")) - -;;; This enables line-numbering for SLIB loads. -(define *slib-load-reader* (and (defined? read-numbered) read-numbered)) - -;;; DO NOT MOVE! SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after -;;; "require.scm" is loaded. -(define (slib:load-source file . libs) - (fluid-let ((*load-reader* *slib-load-reader*)) - (apply scm:load file libs))) -(define slib:load slib:load-source) - -;;; Legacy grease -(if (not (defined? slib:in-catalog?)) - (define slib:in-catalog? require:feature->path)) - -;;; Dynamic link-loading -(cond ((or (defined? dyn:link) - (defined? vms:dynamic-link-call)) - (load (in-vicinity (implementation-vicinity) "Link")))) - -(cond ((defined? link:link) -(define (slib:load-compiled . args) - (cond ((symbol? (car args)) - (require (car args)) - (apply slib:load-compiled (cdr args))) - ((apply link:link args)) - (else (error "Couldn't link files " args)))) -(provide 'compiled))) - -;;; Complete the function set for feature STRING-CASE. -(cond - ((defined? string-upcase!) -(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 - (let ((s2cis (if (equal? "x" (symbol->string 'x)) - string-downcase string-upcase))) - (lambda (str) (string->symbol (s2cis str))))) -(define symbol-append - (let ((s2cis (if (equal? "x" (symbol->string 'x)) - string-downcase string-upcase))) - (lambda args - (string->symbol - (apply string-append - (map - (lambda (obj) - (cond ((char? obj) (string obj)) - ((string? obj) (s2cis obj)) - ((number? obj) (s2cis (number->string obj))) - ((symbol? obj) (symbol->string obj)) - ((not obj) "") - (else (error 'wrong-type-to 'symbol-append obj)))) - args)))))) -(define (StudlyCapsExpand nstr . delimitr) - (set! delimitr - (cond ((null? delimitr) "-") - ((char? (car delimitr)) (string (car delimitr))) - (else (car delimitr)))) - (do ((idx (+ -1 (string-length nstr)) (+ -1 idx))) - ((> 1 idx) nstr) - (cond ((and (> idx 1) - (char-upper-case? (string-ref nstr (+ -1 idx))) - (char-lower-case? (string-ref nstr idx))) - (set! nstr - (string-append (substring nstr 0 (+ -1 idx)) - delimitr - (substring nstr (+ -1 idx) - (string-length nstr))))) - ((and (char-lower-case? (string-ref nstr (+ -1 idx))) - (char-upper-case? (string-ref nstr idx))) - (set! nstr - (string-append (substring nstr 0 idx) - delimitr - (substring nstr idx - (string-length nstr)))))))) -(provide 'string-case))) - -;;;; Bit order and lamination - -;;(define (logical:ones deg) (lognot (ash -1 deg))) - -;;; New with SRFI-60 -(define (rotate-bit-field n count start end) - (define width (- end start)) - (set! count (modulo count width)) - (let ((mask (lognot (ash -1 width)))) - (define azn (logand mask (arithmetic-shift n (- start)))) - (logior (arithmetic-shift - (logior (logand mask (arithmetic-shift azn count)) - (arithmetic-shift azn (- count width))) - start) - (logand (lognot (ash mask start)) n)))) -;;; Legacy -;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len)) - -(define (log2-binary-factors n) - (+ -1 (integer-length (logand n (- n))))) - -(define (bit-reverse k n) - (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1)) - (k (+ -1 k) (+ -1 k)) - (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m)))) - ((negative? k) (if (negative? n) (lognot rvs) rvs)))) -(define (reverse-bit-field n start end) - (define width (- end start)) - (let ((mask (lognot (ash -1 width)))) - (define zn (logand mask (arithmetic-shift n (- start)))) - (logior (arithmetic-shift (bit-reverse width zn) start) - (logand (lognot (ash mask start)) n)))) - -(define (integer->list k . len) - (if (null? len) - (do ((k k (arithmetic-shift k -1)) - (lst '() (cons (odd? k) lst))) - ((<= k 0) lst)) - (do ((idx (+ -1 (car len)) (+ -1 idx)) - (k k (arithmetic-shift k -1)) - (lst '() (cons (odd? k) lst))) - ((negative? idx) lst)))) - -(define (list->integer bools) - (do ((bs bools (cdr bs)) - (acc 0 (+ acc acc (if (car bs) 1 0)))) - ((null? bs) acc))) -(define (booleans->integer . bools) - (list->integer bools)) - -;;;; SRFI-60 aliases -(define arithmetic-shift ash) -(define bitwise-ior logior) -(define bitwise-xor logxor) -(define bitwise-and logand) -(define bitwise-not lognot) -;;(define bit-count logcount) ;Aliases bit-vector function -(define bit-set? logbit?) -(define any-bits-set? logtest) -(define first-set-bit log2-binary-factors) -(define bitwise-merge bitwise-if) - -(define @case-aux - (let ((integer-jump-table 1) - (char-jump-table 2)) - (lambda (keys actions else-action) - (let ((n (length keys))) - (define (every-key pred) - (let test ((keys keys)) - (or (null? keys) - (and (pred (car keys)) (test (cdr keys)))))) - (define (jump-table keys) - (let ((minkey (apply min keys)) - (maxkey (apply max keys))) - (and (< (- maxkey minkey) (* 4 n)) - (let ((actv (make-vector - (+ 2 (- maxkey minkey)) else-action))) - (for-each - (lambda (key action) - (vector-set! actv (+ 1 (- key minkey)) action)) - keys actions) - (list integer-jump-table minkey actv))))) - (cond ((< n 5) #f) - ((every-key integer?) - (jump-table keys)) - ((every-key char?) - (let* ((int-keys (map char->integer keys))) - (cond ((jump-table int-keys) => - (lambda (x) - (cons char-jump-table - (cons (integer->char (cadr x)) - (cddr x))))) - (else #f))))))))) - -;;;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 (remove-line-numbers! (cdr exp)))))))) - -(define defmacro:get-destructuring-bind-pairs - (lambda (s e) - (let loop ((s s) (e e) (r '())) - (cond ((pair? s) - (loop (car s) `(car ,e) - (loop (cdr s) `(cdr ,e) r))) - ((null? s) r) - ((symbol? s) (cons `(,s ,e) r)) - (else (error 'destructuring-bind "illegal syntax")))))) - -(defsyntax destructuring-bind - (let ((destructuring-bind-transformer - (lambda (s x . ff) - (let ((tmp (gentemp))) - `(let ((,tmp ,x)) - (let ,(defmacro:get-destructuring-bind-pairs s tmp) - ,@ff)))))) - (set! *defmacros* - (acons 'destructuring-bind - destructuring-bind-transformer *defmacros*)) - (defmacro:transformer destructuring-bind-transformer))) - -(defsyntax defmacro:simple-defmacro - (let ((defmacro-transformer - (lambda (name parms . body) - `(defsyntax ,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))) - -(defmacro:simple-defmacro defmacro (name . body) - (define (expn name pattern body) - (let ((args (gentemp))) - `(defmacro:simple-defmacro ,name ,args - (destructuring-bind ,pattern ,args ,@body)))) - (if (pair? name) - (expn (car name) (cdr name) body) - (expn name (car body) (cdr body)))) - -(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) -;; slib:eval-load definition moved to "slib/require.scm" - -;;;; Autoloads for SLIB procedures. - -(define (trace-all . args) (require 'debug) (apply trace-all args)) -(define (track-all . args) (require 'debug) (apply track-all args)) -(define (stack-all . args) (require 'debug) (apply stack-all args)) -(define (break-all . args) (require 'debug) (apply break-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 re-defmacroed when tracef autoloads. -(defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x)))) -(defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x)))) -(defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x)))) -(defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@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 (error 'trying-to-defconst name - 'to-different-value value))) - `(define ,name ,value)))) -(defmacro qase (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 (casev . args) `(qase ,@args)) - -(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 (scm:print-binding sexp frame) - (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 (car vals)))) - (newline)) - (write (car vars)) (display " = ") (write (car vals)) (display "; "))) - -(define print-args - (procedure->memoizing-macro - (lambda (sexp env) - (define (fix-list frm) - (cond ((pair? frm) (cons (car frm) (fix-list (cdr frm)))) - ((null? frm) '()) - ((symbol? frm) (list frm)) - (else '()))) - (define frm (car env)) - `(scm:print-binding - ',sexp - ,(cond ((symbol? frm) `(list ',frm ,frm)) - ((list? frm) `(list ',frm ,@frm)) - ((pair? frm) - (let ((jlp (fix-list frm))) - `(list ',(if (symbol? (cdr (last-pair frm))) frm jlp) - ,@jlp)))))))) - -(cond - ((defined? stack-trace) - -;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR -(define error - (letrec ((oerror error) - (nerror - (lambda args - (dynamic-wind - (lambda () (set! error oerror)) - (lambda () - (define cep (current-error-port)) - (if (defined? print-call-stack) - (print-call-stack cep)) - (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)) - (lambda () (set! error nerror)))))) - nerror)) - -(define (user-interrupt . args) - (define cep (current-error-port)) - (newline cep) - (if (defined? print-call-stack) - (print-call-stack 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)) - (else - (define (infinite? z) #f) - (define finite? number?) - (define inexact->exact identity) - (define exact->inexact identity) - (define expt integer-expt))) - -(define (numerator q) - (if (not (rational? q)) (error 'numerator q)) - (do ((num q (* 2 num))) - ((integer? num) num))) - -(define (denominator q) - (if (not (rational? q)) (error 'denominator q)) - (do ((num q (* 2 num)) - (den (- q q -1) (* 2 den))) - ((integer? num) den))) - -(if (defined? array?) -(begin - -(define (array-null? array) - (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd))) - (array-shape array))))) -(define (create-array prot . args) - (if (array-null? prot) - (dimensions->uniform-array args (array-prototype prot)) - (dimensions->uniform-array args (array-prototype prot) - (apply array-ref prot - (map car (array-shape prot)))))) -(define make-array create-array) -(define (list->array rank proto lst) - (list->uniform-array rank (array-prototype proto) lst)) -(define (vector->array vect prototype . dimensions) - (define vdx (vector-length vect)) - (if (not (eqv? vdx (apply * dimensions))) - (slib:error 'vector->array vdx '<> (cons '* dimensions))) - (let ((ra (apply make-array prototype dimensions))) - (define (v2ra dims idxs) - (cond ((null? dims) - (set! vdx (+ -1 vdx)) - (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) - (else - (do ((idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) vect) - (v2ra (cdr dims) (cons idx idxs)))))) - (v2ra dimensions '()) - ra)) -(define (array->vector ra) - (define dims (array-dimensions ra)) - (let* ((vdx (apply * dims)) - (vect (make-vector vdx))) - (define (ra2v dims idxs) - (if (null? dims) - (let ((val (apply array-ref ra (reverse idxs)))) - (set! vdx (+ -1 vdx)) - (vector-set! vect vdx val) - vect) - (do ((idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) vect) - (ra2v (cdr dims) (cons idx idxs))))) - (ra2v dims '()))) -(define (make-uniform-wrapper prot) - (if (string? prot) (set! prot (string->number prot))) - (if prot - (lambda opt (if (null? opt) - (list->uniform-array 1 prot '()) - (list->uniform-array 0 prot (car opt)))) - vector)) -(define Ac64 (make-uniform-wrapper "+64i")) -(define Ac32 (make-uniform-wrapper "+32i")) -(define Ar64 (make-uniform-wrapper "64.")) -(define Ar32 (make-uniform-wrapper "32.")) -(define As64 (make-uniform-wrapper -64)) -(define As32 (make-uniform-wrapper -32)) -(define As16 (make-uniform-wrapper -16)) -(define As8 (make-uniform-wrapper -8)) -(define Au64 (make-uniform-wrapper 64)) -(define Au32 (make-uniform-wrapper 32)) -(define Au16 (make-uniform-wrapper 16)) -(define Au8 (make-uniform-wrapper 8)) -(define At1 (make-uniform-wrapper #t)) - -;;; New SRFI-58 names -;; flonums -(define A:floC128b ac64) -(define A:floC64b ac64) -(define A:floC32b ac32) -(define A:floC16b ac32) -(define A:floR128b ar64) -(define A:floR64b ar64) -(define A:floR32b ar32) -(define A:floR16b ar32) -;; decimal flonums -(define A:floQ128d ar64) -(define A:floQ64d ar64) -(define A:floQ32d ar32) -;; fixnums -(define A:fixZ64b as64) -(define A:fixZ32b as32) -(define A:fixZ16b as16) -(define A:fixZ8b as8) -(define A:fixN64b au64) -(define A:fixN32b au32) -(define A:fixN16b au16) -(define A:fixN8b au8) -(define A:bool at1) - -(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 array=? equal?) -(provide 'srfi-47) -(provide 'srfi-58) -(provide 'srfi-63) -)) - -(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? *syntax-rules*)) - (define *syntax-rules* #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)) - *load-reader*) - (errno 0)) - - ;; Include line numbers in loaded code. - (if (defined? read-numbered) - (set! *load-reader* read-numbered)) - - (cond - ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) - (require 'getopt) -;;; (else -;;; (define *optind* 1) -;;; (define getopt:opt #f) -;;; (define (getopt optstring) #f)) - - (let* ((simple-opts "muvqibs") - (arg-opts '("a kbytes" "-version" "-help" - "no-init-file" "-no-init-file" "p number" - "h feature" "r feature" "d filename" - "f filename" "l 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))) - (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 *syntax-rules* macro:eval eval) - (call-with-input-string - (string-append "(begin " *optarg* ")") - read)))) - (set! didsomething #t)) - - (define (do-load file) - (do-thunk - (lambda () - (cond (*syntax-rules* (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 5)) (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 'databases) (open-database str) - ;; -f str => (load str) - ;; -l str => (load str) - ;; -r sym => (require sym) - ;; -h sym => (provide sym) - ;; -o str => (dump str) - ;; -p int => (verbose int) - ;; -m => (set! *syntax-rules* #t) - ;; -u => (set! *syntax-rules* #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-- 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 'databases) - (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 'r2rs)) - ((#\3) (require 'r3rs)) - ((#\4) (require 'r4rs)) - ((#\5) (require 'r5rs) - (set! *syntax-rules* #t)) - (else (require (string->symbol *optarg*)))) - (require (string->symbol *optarg*)))))) - ((#\h) (do-thunk (lambda () (provide (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! *syntax-rules* #t)) - ((#\u) (set! *syntax-rules* #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-- 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 *syntax-rules* (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 (errno 0) - (set! *interactive* #t) - (for-each load (cdr (program-arguments)))))) diff --git a/Init5e2.scm b/Init5e2.scm new file mode 100644 index 0000000..447e721 --- /dev/null +++ b/Init5e2.scm @@ -0,0 +1,1557 @@ +;; Copyright (C) 1991-2005 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 SCM. +;; +;; The exception is that, if you link the SCM 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 SCM 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 SCM. If you copy +;; code from other Free Software Foundation releases into a copy of +;; SCM, 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 SCM, 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) "5e2") +(define (scheme-implementation-home-page) + "http://swiss.csail.mit.edu/~jaffer/SCM") + +;@ +(define in-vicinity string-append) +;@ +(define (user-vicinity) + (case (software-type) + ((VMS) "[.]") + (else ""))) +;@ +(define vicinity:suffix? + (let ((suffi + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MACOS THINKC) '(#\:)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT PLAN9) '(#\/)) + ((VMS) '(#\: #\])) + (else + (slib:warn "require.scm" 'unknown 'software-type (software-type)) + "/")))) + (lambda (chr) (and (memv chr suffi) #t)))) +;@ +(define (pathname->vicinity pathname) + (let loop ((i (- (string-length pathname) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) +(define (program-vicinity) + (if *load-pathname* + (pathname->vicinity *load-pathname*) + (slib:error 'program-vicinity " called; use slib:load to load"))) +;@ +(define sub-vicinity + (case (software-type) + ((VMS) (lambda + (vic name) + (let ((l (string-length vic))) + (if (or (zero? (string-length vic)) + (not (char=? #\] (string-ref vic (- l 1))))) + (string-append vic "[" name "]") + (string-append (substring vic 0 (- l 1)) + "." name "]"))))) + (else (let ((*vicinity-suffix* + (case (software-type) + ((NOSVE) ".") + ((MACOS THINKC) ":") + ((MS-DOS WINDOWS ATARIST OS/2) "\\") + ((UNIX COHERENT PLAN9 AMIGA) "/")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))))) +;@ +(define (make-vicinity ) ) +;@ +(define with-load-pathname + (let ((exchange + (lambda (new) + (let ((old *load-pathname*)) + (set! *load-pathname* new) + old)))) + (lambda (path thunk) + (let ((old #f)) + (dynamic-wind + (lambda () (set! old (exchange path))) + thunk + (lambda () (exchange old))))))) + +(set! *features* + (append '(ed 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 + vicinity srfi-59 + srfi-60) ;logical + *features*)) + +(define eval + (let ((@eval @eval) + (@copy-tree @copy-tree)) + (lambda (x) (@eval (@copy-tree x))))) + +(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 . port) + (call-with-input-file file + (lambda (inport) + (do ((c (read-char inport) (read-char inport))) + ((eof-object? c)) + (apply write-char c port))))) +(define (terms) + (display-file (in-vicinity (implementation-vicinity) "COPYING"))) + +;;; Read integer up to first non-digit +(define (read:try-number port . ic) + (define chr0 (char->integer #\0)) + (let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0)))) + (let ((c (peek-char port))) + (cond ((eof-object? c) #f) + ((char-numeric? c) + (loop (+ (* 10 (or arg 0)) + (- (char->integer (read-char port)) chr0)))) + (else arg))))) + +(define (read-array-type port) + (define (bomb pc wid) + (error 'array 'syntax? (symbol-append "#" rank "A" pc wid))) + (case (char-downcase (peek-char port)) + ((#\:) (read-char port) + (let ((typ (let loop ((arg '())) + (if (= 4 (length arg)) + (string->symbol (list->string (reverse arg))) + (let ((c (read-char port))) + (and (not (eof-object? c)) + (loop (cons (char-downcase c) arg)))))))) + (define wid (and typ (not (eq? 'bool typ)) (read:try-number port))) + (define (check-suffix chrs) + (define chr (read-char port)) + (if (and (char? chr) (not (memv (char-downcase chr) chrs))) + (error 'array-type? (symbol-append ":" typ wid chr)))) + (define prot (assq typ '((floc (128 . +64.0i) + (64 . +64.0i) + (32 . +32.0i) + (16 . +32.0i)) + (flor (128 . 64.0) + (64 . 64.0) + (32 . 32.0) + (16 . 32.0)) + (fixz (64 . -64) + (32 . -32) + (16 . -16) + (8 . -8)) + (fixn (64 . 64) + (32 . 32) + (16 . 16) + (8 . 8)) + (char . #\a) + (bool . #t)))) + (if prot (set! prot (cdr prot))) + (cond ((pair? prot) + (set! prot (assv wid (cdr prot))) + (if (pair? prot) (set! prot (cdr prot))) + (if wid (check-suffix (if (and (inexact? prot) (real? prot)) + '(#\b #\d) + '(#\b))))) + (prot) + (else (check-suffix '()))) + prot)) + ((#\\) (read-char port) #\a) + ((#\t) (read-char port) #t) + ((#\c #\r) (let* ((pc (read-char port)) (wid (read:try-number port))) + (case wid + ((64 32) (case pc + ((#\c) (* +i wid)) + (else (exact->inexact wid)))) + (else (bomb pc wid))))) + ((#\s #\u) (let* ((pc (read-char port)) (wid (read:try-number port))) + (case (or wid (peek-char port)) + ((32 16 8) (case pc + ((#\s) (- wid)) + (else wid))) + (else (bomb pc wid))))) + (else #f))) + +;;; We come into read:array with number or #f for RANK. +(define (read:array rank dims port) + (define (make-it rank dims typ) + (list->uniform-array (cond (rank) + ((null? dims) 1) + (else (length dims))) + typ + (read port))) + (let loop ((dims dims)) + (define dim (read:try-number port)) + (if dim + (loop (cons dim dims)) + (case (peek-char port) + ((#\*) (read-char port) (loop dims)) + ((#\: #\\ #\t #\c #\r #\s #\u #\T #\C #\R #\S #\U) + (make-it rank dims (read-array-type port))) + (else + (make-it rank dims #f)))))) + +;;; read-macros valid for LOAD and READ. +(define (read:sharp c port reader) ; ignore reader + (case c + ;; Used in "implcat" and "slibcat" + ((#\+) (if (slib:provided? (read port)) + (read port) + (begin (read port) (if #f #f)))) + ;; Used in "implcat" and "slibcat" + ((#\-) (if (slib:provided? (read port)) + (begin (read port) (if #f #f)) + (read port))) + ((#\a #\A) (read:array #f '() port)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let* ((num (read:try-number port c)) + (chr (peek-char port))) + (case chr + ((#\a #\A) (read-char port) + (read:array num '() port)) + ((#\*) (read-char port) + (read:array #f (list num) port)) + (else + (read:array 1 (list num) port)) + ;;(else (error 'sharp 'syntax? (symbol-append "#" num chr))) + ))) + (else (error "unknown # object" c)))) + +;;; read-macros valid only in LOAD. +(define (load:sharp c port reader) ;reader used only for #. + (case c + ((#\') (read port)) + ((#\.) (eval (reader port))) + ((#\!) (let skip ((metarg? #f)) + (let ((c (read-char port))) + (case c + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (cond ((eqv? #\# (peek-char port)) + (read-char port) + (if #f #f)) + (else (skip metarg?)))) + (else (if (char? c) (skip metarg?) c)))))) + ;; Make #; convert the rest of the line to a (comment ...) form. + ;; "build.scm" uses this. + ((#\;) (let skip-semi () + (cond ((eqv? #\; (peek-char port)) + (read-char port) + (skip-semi)) + (else (require 'line-i/o) + `(comment ,(read-line port)))))) + ((#\?) (case (read port) + ((line) (port-line port)) + ((column) (port-column port)) + ((file) (port-filename port)) + (else #f))) + (else (read:sharp c port read)))) + +;;; We can assume TOK has at least 2 characters. +(define char:sharp + (letrec ((numeric-1 + (lambda (tok radix) + (numeric (substring tok 1 (string-length tok)) radix))) + (numeric + (lambda (tok radix) + (cond ((string->number tok radix) => integer->char)))) + (compose + (lambda (modifier tok) + (and (char=? #\- (string-ref tok 1)) + (if (= 3 (string-length tok)) + (modifier (string-ref tok 2)) + (let ((c (char:sharp + (substring tok 2 (string-length tok))))) + (and c (modifier c))))))) + (control + (lambda (c) + (and (char? c) + (if (eqv? c #\?) + (integer->char 127) + (integer->char (logand #o237 (char->integer c))))))) + (meta + (lambda (c) + (and (char? c) + (integer->char (logior 128 (char->integer c))))))) + (lambda (tok) + (case (string-ref tok 0) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) (numeric tok 8)) + ((#\O #\o) (numeric-1 tok 8)) + ((#\D #\d) (numeric-1 tok 10)) + ((#\X #\x) (numeric-1 tok 16)) + ((#\C #\c) (compose control tok)) + ((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1)))) + ((#\M #\m) (compose meta tok)))))) + +;;;; 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*))))))) + +(define : ':) ;for /bin/sh hack. +(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 cr) + +(cond ((defined? defsyntax) +(defsyntax define-syntax (the-macro defsyntax))) + (else +(define defsyntax define) +(define the-macro identity))) +(defsyntax 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) 'wbc) + ((ATARIST) 'wb) + (else 'w))) +(define OPEN_BOTH (case (software-type) + ((MS-DOS WINDOWS) 'r+bc) + ((ATARIST) 'r+b) + (else 'r+))) +(define ((make-moder str) mode) + (if (symbol? mode) + (string->symbol (string-append (symbol->string mode) str)) + (string-append mode str))) +(define _IONBF (make-moder "0")) +(define _TRACKED (make-moder "?")) +(define _EXCLUSIVE (make-moder "x")) + +(define could-not-open #f) + +(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-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 (string-index str chr) + (define len (string-length str)) + (do ((pos 0 (+ 1 pos))) + ((or (>= pos len) (char=? chr (string-ref str pos))) + (and (< pos len) pos)))) + +(if (not (defined? try-create-file)) +(define (try-create-file str modes . perms) + (if (symbol? modes) (set! modes (symbol->string modes))) + (let ((idx (string-index modes #\x))) + (cond ((slib:in-catalog? 'i/o-extensions) + (require 'i/o-extensions) + (apply try-create-file str modes perms)) + ((not idx) + (warn "not exclusive modes?" modes str) + (try-open-file str modes)) + (else (set! modes (string-append (substring modes 0 idx) + (substring modes (+ 1 idx) + (string-length modes)))) + (cond ((not (string-index modes #\w)) + (warn 'try-create-file "not writing?" modes str) + (try-open-file str modes)) + (else + (cond ((and (not (null? perms)) + (not (eqv? #o666 (car perms)))) + (warn "perms?" (car perms) str))) + (cond ((file-exists? str) #f) + (else (try-open-file str modes)))))))))) + +(define close-input-port close-port) +(define close-output-port close-port) + +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) + +(define (call-with-input-file str proc) + (call-with-open-ports (open-input-file str) proc)) + +(define (call-with-output-file str proc) + (call-with-open-ports (open-output-file str) proc)) + +(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 (call-with-outputs thunk proc) + (define stdout #f) + (define stderr #f) + (define status #f) + (set! stdout + (call-with-output-string + (lambda (stdout) + (set! stderr + (call-with-output-string + (lambda (stderr) + (call-with-current-continuation + (lambda (escape) + (dynamic-wind + (lambda () + (set! status #f) + (set! stdout (set-current-output-port stdout)) + (set! stderr (set-current-error-port stderr))) + (lambda () (set! status (list (thunk)))) + (lambda () + (set! stdout (set-current-output-port stdout)) + (set! stderr (set-current-error-port stderr)) + (if (not status) (escape #f)))))))))))) + (apply proc stdout stderr (or status '()))) + +(define browse-url + (case (software-type) + ((UNIX COHERENT PLAN9) + (lambda (url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'")))) + (else + (lambda (url) + (slib:warn 'define (software-type) 'case 'of 'browse-url 'in + *load-pathname*))))) + +(define (warn . args) + (define cep (current-error-port)) + (if (defined? print-call-stack) (print-call-stack cep)) + (perror "WARN") + (errno 0) + (display "WARN:" cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) args) + (newline cep) + (force-output cep)) + +(define (error . args) + (define cep (current-error-port)) + (if (defined? print-call-stack) (print-call-stack cep)) + (perror "ERROR") + (errno 0) + (display "ERROR:" cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) 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 (pprint . args) + (define result #f) + (for-each (lambda (x) (set! result x) (pretty-print x)) args) + result) +(define (pp . args) + (for-each pretty-print args) + (if #f #f)) + +(if (not (defined? file-exists?)) +(define (file-exists? str) + (let ((port (open-file str OPEN_READ))) + (errno 0) + (and port (close-port port) #t)))) +(define (file-readable? str) + (let ((port (open-file str OPEN_READ))) + (errno 0) + (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 (defined? ed)) +(define (ed . args) + (system (apply string-append + (or (getenv "EDITOR") "ed") + (map (lambda (s) (string-append " " s)) args))))) + +(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) + +(define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep))) + +;;;; 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)))) + +;;; Here for backward compatibility +(define scheme-file-suffix + (case (software-type) + ((NOSVE) (lambda () "_scm")) + (else (lambda () ".scm")))) + +(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 *load-reader* #f) +(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 *load-reader*)) + ;;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 *load-reader*)) + (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 *load-reader*) + ;;HERE is where the suffix gets specified + (and (not (has-suffix? file sfs)) + (begin (set! filesuf (string-append file sfs)) + (try-load filesuf *load-reader*))))) + (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) + +;;; 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. +(define library-vicinity #f) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. +(define home-vicinity #f) + +(define (login->home-directory login) + (cond ((defined? getpw) + (let ((pwvect (getpw login))) + (and pwvect (vector-ref pwvect 5)))) + ((not (file-exists? "/etc/passwd")) #f) + (else + (call-with-input-file "/etc/passwd" + (lambda (iprt) + (require 'string-search) + (require 'line-i/o) + (let tryline () + (define line (read-line iprt)) + (define (get-field) + (define idx (string-index line #\:)) + (and idx + (let ((fld (substring line 0 idx))) + (set! line (substring line (+ 1 idx) + (string-length line))) + fld))) + (cond ((eof-object? line) #f) + ((string-index line #\:) + => (lambda (idx) + (define name (substring line 0 idx)) + (cond ((equal? login name) + (do ((ans (get-field) (get-field)) + (cnt 4 (+ -1 cnt))) + ((or (negative? cnt) (not ans)) ans))) + (else (tryline)))))))))))) + +(define (getlogin) (or (getenv "USER") (getenv "LOGNAME"))) + +;;; 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 (set-vicinities! init-file) + (set! implementation-vicinity + (let ((vic (substring + init-file + 0 + (- (string-length init-file) + (string-length "Init.scm") + (string-length (scheme-implementation-version)))))) + (lambda () vic))) + (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) + (if library-path + (set! library-vicinity (lambda () library-path)) + (let ((filename (in-vicinity (implementation-vicinity) "require.scm"))) + (or (try-load filename) + (try-load (in-vicinity (implementation-vicinity) "requires.scm")) + (error "Can't load" filename)) + (if (not library-vicinity) (error "Can't find library-vicinity"))))) + (set! home-vicinity + (let ((home (getenv "HOME"))) + (and (not home) login->home-directory + (let ((login (getlogin))) + (and login (set! home (login->home-directory login))))) + (and home + (case (software-type) + ((UNIX COHERENT PLAN9 MS-DOS) ;V7 unix has a / on HOME + (if (not + (eqv? #\/ (string-ref home (+ -1 (string-length home))))) + (set! home (string-append home "/")))))) + (lambda () home)))) +;;; SET-VICINITIES! is also called from BOOT-TAIL +(set-vicinities! *load-pathname*) + +;;;; Initialize SLIB +(load (in-vicinity (library-vicinity) "require")) + +;;; This enables line-numbering for SLIB loads. +(define *slib-load-reader* (and (defined? read-numbered) read-numbered)) + +;;; DO NOT MOVE! SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after +;;; "require.scm" is loaded. +(define (slib:load-source file . libs) + (fluid-let ((*load-reader* *slib-load-reader*)) + (apply scm:load file libs))) +(define slib:load slib:load-source) + +;;; Legacy grease +(if (not (defined? slib:in-catalog?)) + (define slib:in-catalog? require:feature->path)) + +;;; Dynamic link-loading +(cond ((or (defined? dyn:link) + (defined? vms:dynamic-link-call)) + (load (in-vicinity (implementation-vicinity) "Link")))) + +(cond ((defined? link:link) +(define (slib:load-compiled . args) + (cond ((symbol? (car args)) + (require (car args)) + (apply slib:load-compiled (cdr args))) + ((apply link:link args)) + (else (error "Couldn't link files " args)))) +(provide 'compiled))) + +;;; Complete the function set for feature STRING-CASE. +(cond + ((defined? string-upcase!) +(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 + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda (str) (string->symbol (s2cis str))))) +(define symbol-append + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda args + (string->symbol + (apply string-append + (map + (lambda (obj) + (cond ((char? obj) (string obj)) + ((string? obj) (s2cis obj)) + ((number? obj) (s2cis (number->string obj))) + ((symbol? obj) (symbol->string obj)) + ((not obj) "") + (else (error 'wrong-type-to 'symbol-append obj)))) + args)))))) +(define (StudlyCapsExpand nstr . delimitr) + (set! delimitr + (cond ((null? delimitr) "-") + ((char? (car delimitr)) (string (car delimitr))) + (else (car delimitr)))) + (do ((idx (+ -1 (string-length nstr)) (+ -1 idx))) + ((> 1 idx) nstr) + (cond ((and (> idx 1) + (char-upper-case? (string-ref nstr (+ -1 idx))) + (char-lower-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 (+ -1 idx)) + delimitr + (substring nstr (+ -1 idx) + (string-length nstr))))) + ((and (char-lower-case? (string-ref nstr (+ -1 idx))) + (char-upper-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 idx) + delimitr + (substring nstr idx + (string-length nstr)))))))) +(provide 'string-case))) + +;;;; Bit order and lamination + +;;(define (logical:ones deg) (lognot (ash -1 deg))) + +;;; New with SRFI-60 +(define (rotate-bit-field n count start end) + (define width (- end start)) + (set! count (modulo count width)) + (let ((mask (lognot (ash -1 width)))) + (define azn (logand mask (arithmetic-shift n (- start)))) + (logior (arithmetic-shift + (logior (logand mask (arithmetic-shift azn count)) + (arithmetic-shift azn (- count width))) + start) + (logand (lognot (ash mask start)) n)))) +;;; Legacy +;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len)) + +(define (log2-binary-factors n) + (+ -1 (integer-length (logand n (- n))))) + +(define (bit-reverse k n) + (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1)) + (k (+ -1 k) (+ -1 k)) + (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m)))) + ((negative? k) (if (negative? n) (lognot rvs) rvs)))) +(define (reverse-bit-field n start end) + (define width (- end start)) + (let ((mask (lognot (ash -1 width)))) + (define zn (logand mask (arithmetic-shift n (- start)))) + (logior (arithmetic-shift (bit-reverse width zn) start) + (logand (lognot (ash mask start)) n)))) + +(define (integer->list k . len) + (if (null? len) + (do ((k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((<= k 0) lst)) + (do ((idx (+ -1 (car len)) (+ -1 idx)) + (k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((negative? idx) lst)))) + +(define (list->integer bools) + (do ((bs bools (cdr bs)) + (acc 0 (+ acc acc (if (car bs) 1 0)))) + ((null? bs) acc))) +(define (booleans->integer . bools) + (list->integer bools)) + +;;;; SRFI-60 aliases +(define arithmetic-shift ash) +(define bitwise-ior logior) +(define bitwise-xor logxor) +(define bitwise-and logand) +(define bitwise-not lognot) +;;(define bit-count logcount) ;Aliases bit-vector function +(define bit-set? logbit?) +(define any-bits-set? logtest) +(define first-set-bit log2-binary-factors) +(define bitwise-merge bitwise-if) + +(define @case-aux + (let ((integer-jump-table 1) + (char-jump-table 2)) + (lambda (keys actions else-action) + (let ((n (length keys))) + (define (every-key pred) + (let test ((keys keys)) + (or (null? keys) + (and (pred (car keys)) (test (cdr keys)))))) + (define (jump-table keys) + (let ((minkey (apply min keys)) + (maxkey (apply max keys))) + (and (< (- maxkey minkey) (* 4 n)) + (let ((actv (make-vector + (+ 2 (- maxkey minkey)) else-action))) + (for-each + (lambda (key action) + (vector-set! actv (+ 1 (- key minkey)) action)) + keys actions) + (list integer-jump-table minkey actv))))) + (cond ((< n 5) #f) + ((every-key integer?) + (jump-table keys)) + ((every-key char?) + (let* ((int-keys (map char->integer keys))) + (cond ((jump-table int-keys) => + (lambda (x) + (cons char-jump-table + (cons (integer->char (cadr x)) + (cddr x))))) + (else #f))))))))) + +;;;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 (remove-line-numbers! (cdr exp)))))))) + +(define defmacro:get-destructuring-bind-pairs + (lambda (s e) + (let loop ((s s) (e e) (r '())) + (cond ((pair? s) + (loop (car s) `(car ,e) + (loop (cdr s) `(cdr ,e) r))) + ((null? s) r) + ((symbol? s) (cons `(,s ,e) r)) + (else (error 'destructuring-bind "illegal syntax")))))) + +(defsyntax destructuring-bind + (let ((destructuring-bind-transformer + (lambda (s x . ff) + (let ((tmp (gentemp))) + `(let ((,tmp ,x)) + (let ,(defmacro:get-destructuring-bind-pairs s tmp) + ,@ff)))))) + (set! *defmacros* + (acons 'destructuring-bind + destructuring-bind-transformer *defmacros*)) + (defmacro:transformer destructuring-bind-transformer))) + +(defsyntax defmacro:simple-defmacro + (let ((defmacro-transformer + (lambda (name parms . body) + `(defsyntax ,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))) + +(defmacro:simple-defmacro defmacro (name . body) + (define (expn name pattern body) + (let ((args (gentemp))) + `(defmacro:simple-defmacro ,name ,args + (destructuring-bind ,pattern ,args ,@body)))) + (if (pair? name) + (expn (car name) (cdr name) body) + (expn name (car body) (cdr body)))) + +(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) +;; slib:eval-load definition moved to "slib/require.scm" + +;;;; Autoloads for SLIB procedures. + +(define (trace-all . args) (require 'debug) (apply trace-all args)) +(define (track-all . args) (require 'debug) (apply track-all args)) +(define (stack-all . args) (require 'debug) (apply stack-all args)) +(define (break-all . args) (require 'debug) (apply break-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 re-defmacroed when tracef autoloads. +(defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x)))) +(defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x)))) +(defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x)))) +(defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@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 (error 'trying-to-defconst name + 'to-different-value value))) + `(define ,name ,value)))) +(defmacro qase (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 (casev . args) `(qase ,@args)) + +(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 (scm:print-binding sexp frame) + (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 (car vals)))) + (newline)) + (write (car vars)) (display " = ") (write (car vals)) (display "; "))) + +(define print-args + (procedure->memoizing-macro + (lambda (sexp env) + (define (fix-list frm) + (cond ((pair? frm) (cons (car frm) (fix-list (cdr frm)))) + ((null? frm) '()) + ((symbol? frm) (list frm)) + (else '()))) + (define frm (car env)) + `(scm:print-binding + ',sexp + ,(cond ((symbol? frm) `(list ',frm ,frm)) + ((list? frm) `(list ',frm ,@frm)) + ((pair? frm) + (let ((jlp (fix-list frm))) + `(list ',(if (symbol? (cdr (last-pair frm))) frm jlp) + ,@jlp)))))))) + +(cond + ((defined? stack-trace) + +;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR +(define error + (letrec ((oerror error) + (nerror + (lambda args + (dynamic-wind + (lambda () (set! error oerror)) + (lambda () + (define cep (current-error-port)) + (if (defined? print-call-stack) + (print-call-stack cep)) + (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)) + (lambda () (set! error nerror)))))) + nerror)) + +(define (user-interrupt . args) + (define cep (current-error-port)) + (newline cep) + (if (defined? print-call-stack) + (print-call-stack 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)) + )) + +(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")))) + (else + (define (infinite? z) #f) + (define finite? number?) + (define inexact->exact identity) + (define exact->inexact identity) + (define round->exact identity) + (define floor->exact identity) + (define ceiling->exact identity) + (define truncate->exact identity) + (define expt integer-expt))) + +(define (numerator q) + (if (not (rational? q)) (error 'numerator q)) + (do ((num q (* 2 num))) + ((integer? num) num))) + +(define (denominator q) + (if (not (rational? q)) (error 'denominator q)) + (do ((num q (* 2 num)) + (den (- q q -1) (* 2 den))) + ((integer? num) den))) + +(if (defined? array?) +(begin + +(define (array-null? array) + (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd))) + (array-shape array))))) +(define (create-array prot . args) + (if (array-null? prot) + (dimensions->uniform-array args (array-prototype prot)) + (dimensions->uniform-array args (array-prototype prot) + (apply array-ref prot + (map car (array-shape prot)))))) +(define make-array create-array) +(define (list->array rank proto lst) + (list->uniform-array rank (array-prototype proto) lst)) +(define (vector->array vect prototype . dimensions) + (define vdx (vector-length vect)) + (if (not (eqv? vdx (apply * dimensions))) + (slib:error 'vector->array vdx '<> (cons '* dimensions))) + (let ((ra (apply make-array prototype dimensions))) + (define (v2ra dims idxs) + (cond ((null? dims) + (set! vdx (+ -1 vdx)) + (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) + (else + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (v2ra (cdr dims) (cons idx idxs)))))) + (v2ra dimensions '()) + ra)) +(define (array->vector ra) + (define dims (array-dimensions ra)) + (let* ((vdx (apply * dims)) + (vect (make-vector vdx))) + (define (ra2v dims idxs) + (if (null? dims) + (let ((val (apply array-ref ra (reverse idxs)))) + (set! vdx (+ -1 vdx)) + (vector-set! vect vdx val) + vect) + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (ra2v (cdr dims) (cons idx idxs))))) + (ra2v dims '()))) +(define (make-uniform-wrapper prot) + (if (string? prot) (set! prot (string->number prot))) + (if prot + (lambda opt (if (null? opt) + (list->uniform-array 1 prot '()) + (list->uniform-array 0 prot (car opt)))) + vector)) +(define Ac64 (make-uniform-wrapper "+64i")) +(define Ac32 (make-uniform-wrapper "+32i")) +(define Ar64 (make-uniform-wrapper "64.")) +(define Ar32 (make-uniform-wrapper "32.")) +(define As64 (make-uniform-wrapper -64)) +(define As32 (make-uniform-wrapper -32)) +(define As16 (make-uniform-wrapper -16)) +(define As8 (make-uniform-wrapper -8)) +(define Au64 (make-uniform-wrapper 64)) +(define Au32 (make-uniform-wrapper 32)) +(define Au16 (make-uniform-wrapper 16)) +(define Au8 (make-uniform-wrapper 8)) +(define At1 (make-uniform-wrapper #t)) + +;;; New SRFI-58 names +;; flonums +(define A:floC128b ac64) +(define A:floC64b ac64) +(define A:floC32b ac32) +(define A:floC16b ac32) +(define A:floR128b ar64) +(define A:floR64b ar64) +(define A:floR32b ar32) +(define A:floR16b ar32) +;; decimal flonums +(define A:floQ128d ar64) +(define A:floQ64d ar64) +(define A:floQ32d ar32) +;; fixnums +(define A:fixZ64b as64) +(define A:fixZ32b as32) +(define A:fixZ16b as16) +(define A:fixZ8b as8) +(define A:fixN64b au64) +(define A:fixN32b au32) +(define A:fixN16b au16) +(define A:fixN8b au8) +(define A:bool at1) + +(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 array=? equal?) +(provide 'srfi-47) +(provide 'srfi-58) +(provide 'srfi-63) +)) + +(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? *syntax-rules*)) + (define *syntax-rules* #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)) + *load-reader*) + (errno 0)) + + ;; Include line numbers in loaded code. + (if (defined? read-numbered) + (set! *load-reader* read-numbered)) + + (cond + ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) + (require 'getopt) +;;; (else +;;; (define *optind* 1) +;;; (define getopt:opt #f) +;;; (define (getopt optstring) #f)) + + (let* ((simple-opts "muvqibs") + (arg-opts '("a kbytes" "-version" "-help" + "no-init-file" "-no-init-file" "p number" + "h feature" "r feature" "d filename" + "f filename" "l 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))) + (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 *syntax-rules* macro:eval eval) + (call-with-input-string + (string-append "(begin " *optarg* ")") + read)))) + (set! didsomething #t)) + + (define (do-load file) + (do-thunk + (lambda () + (cond (*syntax-rules* (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 5)) (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 'databases) (open-database str) + ;; -f str => (load str) + ;; -l str => (load str) + ;; -r sym => (require sym) + ;; -h sym => (provide sym) + ;; -o str => (dump str) + ;; -p int => (verbose int) + ;; -m => (set! *syntax-rules* #t) + ;; -u => (set! *syntax-rules* #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-- 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 'databases) + (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 'r2rs)) + ((#\3) (require 'r3rs)) + ((#\4) (require 'r4rs)) + ((#\5) (require 'r5rs) + (set! *syntax-rules* #t)) + (else (require (string->symbol *optarg*)))) + (require (string->symbol *optarg*)))))) + ((#\h) (do-thunk (lambda () (provide (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! *syntax-rules* #t)) + ((#\u) (set! *syntax-rules* #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-- 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 *syntax-rules* (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 (errno 0) + (set! *interactive* #t) + (for-each load (cdr (program-arguments)))))) diff --git a/Makefile b/Makefile index a59ddbc..b483503 100644 --- a/Makefile +++ b/Makefile @@ -88,6 +88,7 @@ IMPLINIT = $(IMPLPATH)Init$(VERSION).scm # SCM_INIT_PATH is the environment variable whose value is the # pathname where InitXXX.scm resides. +hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h cfiles = scmmain.c scm.c time.c repl.c ioext.c scl.c sys.c eval.c \ subr.c sc2.c unif.c rgx.c crs.c dynl.c record.c posix.c socket.c\ unix.c rope.c ramap.c gsubr.c edline.c continue.c \ @@ -98,6 +99,7 @@ ofiles = scm.o time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \ ifiles = Init$(VERSION).scm Transcen.scm Link.scm Macro.scm Macexp.scm \ Tscript.scm compile.scm Iedline.scm Idiffer.scm hobfiles = hobbit.scm scmhob.scm scmhob.h +turfiles = turtlegr.c turtle grtest.scm xafiles = xatoms.scm x11.scm xevent.scm keysymdef.scm xfiles = x.c x.h xgen.scm xevent.h inc2scm $(xafiles) @@ -147,6 +149,7 @@ scm5.opt: echo "-F cautious bignums arrays inexact" >> scm5.opt echo "-F engineering-notation dynamic-linking" >> scm5.opt echo "-F macro" >> scm5.opt +# if type gcc; then echo "--compiler-options=\"-fno-guess-branch-probability\"" >> scm5.opt; fi scm5: $(cfiles) $(hfiles) build.scm build scm5.opt $(BUILD) -f scm5.opt -o scm -s $(IMPLPATH) rm $(ofiles) scmmain.o @@ -157,6 +160,7 @@ scm5: $(cfiles) $(hfiles) build.scm build scm5.opt udscm4.opt: echo "-F cautious bignums arrays inexact" >> udscm4.opt echo "-F engineering-notation dump dynamic-linking" >> udscm4.opt +# if type gcc; then echo "--compiler-options=\"-fno-guess-branch-probability\"" >> udscm4.opt; fi udscm4: $(cfiles) $(hfiles) build.scm build udscm4.opt $(BUILD) -f udscm4.opt -o udscm4 -s $(IMPLPATH) rm $(ofiles) scmmain.o @@ -166,7 +170,8 @@ dscm4: udscm4 $(ifiles) require.scm echo "(quit)" | $(SETARCH) ./udscm4 -no-init-file -o scm # dumpable R5RS interpreter -udscm5.opt: udscm4.opt +udscm5.opt: + $(MAKE) udscm4.opt cat udscm4.opt >> udscm5.opt echo "-F macro" >> udscm5.opt # echo "-DNO_SYM_GC" >> udscm5.opt @@ -511,7 +516,6 @@ ufiles = pre-crt0.c ecrt0.c gmalloc.c unexec.c unexelf.c unexhp9k800.c \ confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \ configure configure.in Makefile.in COPYING README.unix -hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm \ syntest2.scm syntest1.scm dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \ @@ -520,8 +524,9 @@ dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \ mfiles = Makefile build.scm build build.bat requires.scm \ .gdbinit mkimpcat.scm disarm.scm scm.spec vfiles = setjump.mar setjump.s +wbfiles = wbtab.scm rwb-isam.scm afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \ - $(hobfiles) $(vfiles) $(ufiles) $(xfiles) + $(hobfiles) $(vfiles) $(ufiles) $(xfiles) $(turfiles) $(wbfiles) makedev = make -f $(HOME)/makefile.dev CHPAT=$(HOME)/bin/chpat diff --git a/README b/README index 6a1ba84..d22b8cf 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -This directory contains the distribution of scm5e1. Scm conforms to +This directory contains the distribution of scm5e2. Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. SCM runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and similar systems. @@ -104,18 +104,18 @@ SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and install it. Bug reports about running SCM without SLIB have very low priority. SLIB is available from the same sites as SCM: - * swiss.csail.mit.edu:/pub/scm/slib3a2.tar.gz + * swiss.csail.mit.edu:/pub/scm/slib3a3.tar.gz - * ftp.gnu.org:/pub/gnu/jacal/slib3a2.tar.gz + * ftp.gnu.org:/pub/gnu/jacal/slib3a3.tar.gz - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a2.tar.gz + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a3.tar.gz -Unpack SLIB (`tar xzf slib3a2.tar.gz' or `unzip -ao slib3a2.zip') in an +Unpack SLIB (`tar xzf slib3a3.tar.gz' or `unzip -ao slib3a3.zip') in an appropriate directory for your system; both `tar' and `unzip' will create the directory `slib'. Then create a file `require.scm' in the SCM "implementation-vicinity" -(this is the same directory as where the file `Init5e1.scm' is +(this is the same directory as where the file `Init5e2.scm' is installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -280,17 +280,17 @@ remove in scmfig.h and Do so and recompile files. recompile scm. add in scmfig.h and recompile scm. -ERROR: Init5e1.scm not found. Assign correct IMPLINIT in makefile +ERROR: Init5e2.scm not found. Assign correct IMPLINIT in makefile or scmfig.h. Define environment variable SCM_INIT_PATH to be the full - pathname of Init5e1.scm. + pathname of Init5e2.scm. WARNING: require.scm not found. Define environment variable SCHEME_LIBRARY_PATH to be the full pathname of the scheme library [SLIB]. Change library-vicinity in - Init5e1.scm to point to library or + Init5e2.scm to point to library or remove. Make sure the value of (library-vicinity) has a trailing @@ -351,7 +351,7 @@ Some symbol names print incorrectly. Change memory model option to C than HEAP_SEG_SIZE). ERROR: Rogue pointer in Heap. See above under machine crashes. Newlines don't appear correctly in Check file mode (define OPEN_... in -output files. `Init5e1.scm'). +output files. `Init5e2.scm'). Spaces or control characters appear Check character defines in in symbol names. `scmfig.h'. Negative numbers turn positive. Check SRS in `scmfig.h'. diff --git a/Transcen.scm b/Transcen.scm index dd869a7..3b87837 100644 --- a/Transcen.scm +++ b/Transcen.scm @@ -133,119 +133,39 @@ (define expt (let ((integer-expt integer-expt)) (lambda (z1 z2) - (cond ((and (exact? z2) (not (and (zero? z1) (not (positive? z2))))) + (cond ((and (exact? z2) (not (and (zero? z1) (negative? z2)))) (integer-expt z1 z2)) + ((zero? z2) (+ 1 (* z1 z2))) ((and (real? z2) (real? z1) (positive? z1)) ($expt z1 z2)) (else (exp (* (if (zero? z1) (real-part z2) z2) (log z1)))))))) -(set! quotient - (let ((integer-quotient quotient)) - (lambda (x1 x2) - (if (and (exact? x1) (exact? x2)) - (integer-quotient x1 x2) - (truncate (/ x1 x2)))))) - -(set! remainder - (let ((integer-remainder remainder)) - (lambda (x1 x2) - (if (and (exact? x1) (exact? x2)) - (integer-remainder x1 x2) - (- x1 (* x2 (quotient x1 x2))))))) - -(set! modulo - (let ((integer-modulo modulo)) - (lambda (x1 x2) - (if (and (exact? x1) (exact? x2)) - (integer-modulo x1 x2) - (- x1 (* x2 (floor (/ x1 x2)))))))) +(define quo + (let ((integer-quotient quotient)) + (lambda (x1 x2) + (if (and (exact? x1) (exact? x2)) + (integer-quotient x1 x2) + (truncate (/ x1 x2)))))) + +(define rem + (let ((integer-remainder remainder)) + (lambda (x1 x2) + (if (and (exact? x1) (exact? x2)) + (integer-remainder x1 x2) + (- x1 (* x2 (quotient x1 x2))))))) + +(define mod + (let ((integer-modulo modulo)) + (lambda (x1 x2) + (if (and (exact? x1) (exact? x2)) + (integer-modulo x1 x2) + (- x1 (* x2 (floor (/ x1 x2)))))))) + +(define (exact-round x) (inexact->exact (round x))) +(define (exact-floor x) (inexact->exact (floor x))) +(define (exact-ceiling x) (inexact->exact (ceiling x))) +(define (exact-truncate x) (inexact->exact (truncate x))) (define (infinite? z) (and (= z (* 2 z)) (not (zero? z)))) (define (finite? z) (not (infinite? z))) - -(define (invintp f1 f2 f3) - (define f1^2 (* f1 f1)) - (define f2^2 (* f2 f2)) - (define f3^2 (expt f3 2)) - (let ((c (+ (* -3 f1^2 f2) - (* 3 f1 f2^2) - (* (- (* 2 f1^2) f2^2) f3) - (* (- f2 (* 2 f1)) f3^2))) - (b (+ (- f1^2 (* 2 f2^2)) f3^2)) - (a (- (* 2 f2) f1 f3))) - (define disc (- (* b b) (* 4 a c))) - (if (negative? (real-part disc)) - (/ b -2 a) - (let ((sqrt-disc (sqrt disc))) - (define root+ (/ (- sqrt-disc b) 2 a)) - (define root- (/ (+ sqrt-disc b) -2 a)) - (if (< (magnitude (- root+ f1)) (magnitude (- root- f1))) - root+ - root-))))) - -(define (extrapolate-0 fs) - (define n (length fs)) - (define (choose n k) - (do ((kdx 1 (+ 1 kdx)) - (prd 1 (/ (* (- n kdx -1) prd) kdx))) - ((> kdx k) prd))) - (do ((k 1 (+ 1 k)) - (lst fs (cdr lst)) - (L 0 (+ (* -1 (expt -1 k) (choose n k) (car lst)) L))) - ((null? lst) L))) - -(define (sequence->limit proc sequence) - (define lval (proc (car sequence))) - (if (finite? lval) - (let ((val (proc (cadr sequence)))) - (define h_n*nsamps (* (length sequence) (magnitude (- val lval)))) - (if (finite? val) - (let loop ((sequence (cddr sequence)) - (fxs (list val lval)) - (trend #f) - (ldelta (- val lval)) - (jdx (+ -1 (length sequence)))) - (cond ((null? sequence) - (case trend - ((diverging) (and (real? val) (* ldelta 1/0))) - ((bounded) (invintp val lval (caddr fxs))) - (else (cond ((zero? ldelta) val) - ((not (real? val)) #f) - (else (extrapolate-0 fxs)))))) - (else - (set! lval val) - (set! val (proc (car sequence))) - (if (finite? val) - (let ((delta (- val lval))) - (define h_j (/ h_n*nsamps jdx)) - (cond ((case trend - ((converging) (<= (magnitude delta) h_j)) - ((bounded) (<= (magnitude ldelta) (magnitude delta))) - ((diverging) (>= (magnitude delta) h_j)) - (else #f)) - (loop (cdr sequence) (cons val fxs) trend delta (+ -1 jdx))) - (trend #f) - (else - (loop (cdr sequence) (cons val fxs) - (cond ((> (magnitude delta) h_j) 'diverging) - ((< (magnitude ldelta) (magnitude delta)) 'bounded) - (else 'converging)) - delta (+ -1 jdx))))) - (and (eq? trend 'diverging) val))))) - (and (real? val) val))) - (and (real? lval) lval))) - -(define (limit proc x1 x2 . k) - (set! k (if (null? k) 8 (car k))) - (cond ((not (finite? x2)) (slib:error 'limit 'infinite 'x2 x2)) - ((not (finite? x1)) - (or (positive? (* x1 x2)) (slib:error 'limit 'start 'mismatch x1 x2)) - (limit (lambda (x) (proc (/ x))) 0.0 (/ x2) k)) - ((= x1 (+ x1 x2)) (slib:error 'limit 'null 'range x1 (+ x1 x2))) - (else (let ((dec (/ x2 k))) - (do ((x (+ x1 x2 0.0) (- x dec)) - (cnt (+ -1 k) (+ -1 cnt)) - (lst '() (cons x lst))) - ((negative? cnt) - (sequence->limit proc (reverse lst)))))))) diff --git a/bench.scm b/bench.scm index 4262564..0bcac0a 100644 --- a/bench.scm +++ b/bench.scm @@ -98,7 +98,7 @@ )))))) (define (prng samples modu sta) - (define sra (create-array (Au32) samples)) + (define sra (create-array (A:fixN32b) samples)) (do ((cnt (+ -1 samples) (+ -1 cnt)) (num (random modu sta) (random modu sta)) (sum 0 (+ sum num))) diff --git a/build.scm b/build.scm index a467a52..664eb28 100644 --- a/build.scm +++ b/build.scm @@ -1934,7 +1934,9 @@ (lambda (batch-port) (define o-files #f) (adjoin-parameters! parms (list 'batch-port batch-port)) - + (batch:comment + parms + (string-append "[-p " (symbol->string platform) "]")) (let ((options-file (parameter-list-ref parms 'options-file))) (and (not (null? options-file)) (batch:comment diff --git a/byte.c b/byte.c index 457d878..416c78f 100644 --- a/byte.c +++ b/byte.c @@ -131,7 +131,7 @@ SCM scm_write_byte(chr, port) SCM chr, port; { int k = INUM(chr); - if UNBNDP(port) port = cur_outp; + if (UNBNDP(port)) port = cur_outp; else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_byte); ASRTER(INUMP(chr) && 0 <= k && k <= 255, chr, ARG1, s_write_byte); lputc(k, port); @@ -142,7 +142,7 @@ SCM scm_read_byte(port) SCM port; { int c; - if UNBNDP(port) port = cur_inp; + if (UNBNDP(port)) port = cur_inp; ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_byte); c = lgetc(port); if (EOF==c) return EOF_VAL; @@ -173,7 +173,7 @@ SCM scm_substring_read(sstr, start, args) long ans = 0; /* An ungetc before an fread will not work on some systems if setbuf(0), so we read one element char by char. */ - if CRDYP(port) { + if (CRDYP(port)) { CHARS(sstr)[start] = lgetc(port); start += 1; len -= 1; diff --git a/continue.c b/continue.c index a72ce4b..ec0097b 100644 --- a/continue.c +++ b/continue.c @@ -191,7 +191,7 @@ void dynthrow(a) puts("grow_throw: check if long growth[]; being optimized out"); # endif /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */ - if PTR_GE(dst + (cont->length), (STACKITEM *)&a) grow_throw(a); + if (PTR_GE(dst + (cont->length), (STACKITEM *)&a)) grow_throw(a); # else # ifndef hpux if (a[2] && (((long *)a[3]) - a < SCM_GROWTH)) @@ -199,7 +199,7 @@ void dynthrow(a) # endif /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */ dst -= cont->length; - if PTR_LE(dst, (STACKITEM *)&a) grow_throw(a); + if (PTR_LE(dst, (STACKITEM *)&a)) grow_throw(a); # endif/* def STACK_GROWS_UP */ FLUSH_REGISTER_WINDOWS; src = (STACKITEM *)(cont + 1); diff --git a/crs.c b/crs.c index 0b4fe5f..9a45493 100644 --- a/crs.c +++ b/crs.c @@ -112,7 +112,7 @@ SCM *loc_stdscr = 0; SCM linitscr() { WINDOW *win; - if NIMP(*loc_stdscr) { + if (NIMP(*loc_stdscr)) { refresh(); return *loc_stdscr; } @@ -121,7 +121,7 @@ SCM linitscr() } SCM lendwin() { - if IMP(*loc_stdscr) return BOOL_F; + if (IMP(*loc_stdscr)) return BOOL_F; return ERR==endwin() ? BOOL_F : BOOL_T; } @@ -204,9 +204,9 @@ SCM lwadd(win, obj) SCM win, obj; { ASRTER(NIMP(win) && WINP(win), win, ARG1, s_wadd); - if ICHRP(obj) + if (ICHRP(obj)) return ERR==waddch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T; - if INUMP(obj) + if (INUMP(obj)) return ERR==waddch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T; ASRTER(NIMP(obj) && STRINGP(obj), obj, ARG2, s_wadd); return ERR==waddstr(WIN(win), CHARS(obj)) ? BOOL_F : BOOL_T; @@ -216,7 +216,7 @@ SCM lwinsch(win, obj) SCM win, obj; { ASRTER(NIMP(win) && WINP(win), win, ARG1, s_winsch); - if INUMP(obj) + if (INUMP(obj)) return ERR==winsch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T; ASRTER(ICHRP(obj), obj, ARG2, s_winsch); return ERR==winsch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T; @@ -227,12 +227,12 @@ SCM lbox(win, vertch, horch) { int v, h; ASRTER(NIMP(win) && WINP(win), win, ARG1, s_box); - if INUMP(vertch) v = INUM(vertch); + if (INUMP(vertch)) v = INUM(vertch); else { ASRTER(ICHRP(vertch), vertch, ARG2, s_box); v = ICHR(vertch); } - if INUMP(horch) h = INUM(horch); + if (INUMP(horch)) h = INUM(horch); else { ASRTER(ICHRP(horch), horch, ARG3, s_box); h = ICHR(horch); @@ -271,20 +271,20 @@ static char s_oheight[] = "output-port-height"; SCM owidth(arg) SCM arg; { - if UNBNDP(arg) arg = cur_outp; + if (UNBNDP(arg)) arg = cur_outp; ASRTER(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth); - if NIMP(*loc_stdscr) - if WINP(arg) return MAKINUM(WIN(arg)->_maxx+1); + if (NIMP(*loc_stdscr)) + if (WINP(arg)) return MAKINUM(WIN(arg)->_maxx+1); else return MAKINUM(COLS); return MAKINUM(80); } SCM oheight(arg) SCM arg; { - if UNBNDP(arg) arg = cur_outp; + if (UNBNDP(arg)) arg = cur_outp; ASRTER(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth); - if NIMP(*loc_stdscr) - if WINP(arg) return MAKINUM(WIN(arg)->_maxy+1); + if (NIMP(*loc_stdscr)) + if (WINP(arg)) return MAKINUM(WIN(arg)->_maxy+1); else return MAKINUM(LINES); return MAKINUM(24); } diff --git a/debug.c b/debug.c index aff8251..e270a7a 100644 --- a/debug.c +++ b/debug.c @@ -54,7 +54,7 @@ static void prinbindings P((SCM names, SCM inits, SCM init_env, SCM scm_env_rlookup(addr, stenv, what) SCM addr, stenv; - char *what; + const char *what; { SCM env, fr; int icdrp; diff --git a/differ.c b/differ.c index 43b2c3f..cb8cf8f 100644 --- a/differ.c +++ b/differ.c @@ -61,7 +61,7 @@ int fp_compare(int *fp,int fpoff,int *cc,void *a,int m,void *b,int n,int_functio int fp_run(int *fp,int fpoff,int k,void *a,int m,void *b,int n,int_function array_refsEql_P,int *cc,int p); -int diff_mid_split(int m,int n,int *rr,int *cc,int cost); +int diff_mid_split(int n,int *rr,int *cc,int cost); void fp_init(int *fp,int fpoff,int fill,int mindx,int maxdx); @@ -234,8 +234,7 @@ L_snloop: } } -int diff_mid_split(m, n, rr, cc, cost) - int m; +int diff_mid_split(n, rr, cc, cost) int n; int *rr; int *cc; @@ -313,7 +312,7 @@ int diff_divide_and_conquer(fp, fpoff, ccrr, a, start_a, end_a, b, start_b, end_ fp_init(fp, fpoff, -1, -(1+(p_lim)), 1+(p_lim)+((len_b)-(m2))); fp_compare(fp, fpoff, rr, procs->subarray(a, mid_a, end_a), m2, procs->subarray(b, start_b, end_b), len_b, procs->array_refs_revEql_P, MIN(p_lim, len_a)); { - int b_splt = diff_mid_split(len_a, len_b, rr, cc, tcst); + int b_splt = diff_mid_split(len_b, rr, cc, tcst); int est_c = cc[b_splt]; int est_r = rr[(len_b)-(b_splt)]; check_cost("cc", est_c, diff2et(fp, fpoff, ccrr, a, start_a, mid_a, b, start_b, (start_b)+(b_splt), edits, edx, epo, procs, ((est_c)-((b_splt)-((mid_a)-(start_a))))/2)); diff --git a/dynl.c b/dynl.c index a1a0c37..d8eeae4 100644 --- a/dynl.c +++ b/dynl.c @@ -110,14 +110,14 @@ SCM l_dyn_main_call(symb, shl, args) SCM symb, shl, args; { int i; - int (*func)(int argc, char **argv) = 0; - char **argv; + int (*func)(int argc, const char **argv) = 0; + const char **argv; /* SCM oloadpath = *loc_loadpath; */ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); DEFER_INTS; argv = makargvfrmstrs(args, s_main_call); if ((i = dld_function_executable_p(CHARS(symb)))) - func = (int (*) (int argc, char **argv)) dld_get_func(CHARS(symb)); + func = (int (*) (int argc, const char **argv)) dld_get_func(CHARS(symb)); else dld_perror("DLDP"); if (!i) listundefs(); if (!func) { @@ -235,8 +235,8 @@ SCM l_dyn_main_call(symb, shl, args) SCM symb, shl, args; { int i; - int (*func)P((int argc, char **argv)) = 0; - char **argv; + int (*func)P((int argc, const char **argv)) = 0; + const char **argv; /* SCM oloadpath = *loc_loadpath; */ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call); @@ -369,7 +369,7 @@ sizet frshl(ptr) # if 0 /* Should freeing a shl close and possibly unmap the object file it */ /* refers to? */ - if(SHL(ptr)) + if (SHL(ptr)) dlclose(SHL(ptr)); # endif return 0; @@ -392,7 +392,7 @@ SCM l_dyn_link(fname) { SCM z; void *handle; - if FALSEP(fname) return fname; + if (FALSEP(fname)) return fname; ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link); NEWCELL(z); DEFER_INTS; @@ -447,8 +447,8 @@ SCM l_dyn_main_call(symb, shl, args) SCM symb, shl, args; { int i; - int (*func)P((int argc, char **argv)) = 0; - char **argv; + int (*func)P((int argc, const char **argv)) = 0; + const char **argv; /* SCM oloadpath = *loc_loadpath; */ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call); @@ -519,7 +519,7 @@ sizet frshl(ptr) # if 0 /* Should freeing a shl close and possibly unmap the object file it */ /* refers to? */ - if(SHL(ptr)) + if (SHL(ptr)) dlclose(SHL(ptr)); # endif return 0; @@ -548,7 +548,7 @@ SCM l_dyn_link(fname) Ptr mainAddr; Str255 errMessage; - if FALSEP(fname) return fname; + if (FALSEP(fname)) return fname; ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link); NEWCELL(z); DEFER_INTS; @@ -602,8 +602,8 @@ SCM l_dyn_main_call(symb, shl, args) SCM symb, shl, args; { int i; - int (*func)P((int argc, char **argv)) = 0; - char **argv; + int (*func)P((int argc, const char **argv)) = 0; + const char **argv; OSErr err; CFragSymbolClass symClass; Str255 symName; @@ -734,7 +734,7 @@ SCM scm_dyn_main_call(symb, shl, args) { int i; FARPROC func; - char **argv; + const char **argv; ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call); DEFER_INTS; diff --git a/eval.c b/eval.c index 3e39bee..778d7e4 100644 --- a/eval.c +++ b/eval.c @@ -174,7 +174,7 @@ static SCM m_binding P((SCM name, SCM value, SCM env, SCM ctxt)); static SCM m_bindings P((SCM name, SCM value, SCM env, SCM ctxt)); static SCM m_seq P((SCM x, SCM env, SCM ctxt)); static SCM m_expr P((SCM x, SCM env, SCM ctxt)); -static void checked_define P((SCM name, SCM val, char *what)); +static void checked_define P((SCM name, SCM val, const char *what)); static int topdenote_eq P((SCM sym, SCM id, SCM env)); static int constant_p P((SCM x)); static int prinenv P((SCM exp, SCM port, int writing)); @@ -188,9 +188,9 @@ static void env_tail P((int depth)); static void unpaint P((SCM *p)); static void ecache_evalx P((SCM x)); static int ecache_eval_args P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM x)); -static int varcheck P((SCM vars, SCM op, char *what)); +static int varcheck P((SCM vars, SCM op, const char *what)); #ifdef CAREFUL_INTS -static void debug_env_warn P((char *fnam, int line, char *what)); +static void debug_env_warn P((char *fnam, int line, const char *what)); static void debug_env_save P((char *fnam, int line)); #endif @@ -233,7 +233,7 @@ SCM scm_trace, scm_trace_env; #endif #define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;} #define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;} -#define SIDEVAL_1(x) if NIMP(x) ceval_1(x) +#define SIDEVAL_1(x) if (NIMP(x)) ceval_1(x) #define STATIC_ENV (scm_estk_ptr[2]) #ifdef CAUTIOUS # define TRACE(x) {scm_estk_ptr[3]=(x);} @@ -342,7 +342,7 @@ int ecache_p(x) SCM x; { register CELLPTR ptr; - if NCELLP(x) return 0; + if (NCELLP(x)) return 0; ptr = (CELLPTR)SCM2PTR(x); if (PTR_LE(scm_ecache, ptr) && PTR_GT(scm_ecache+scm_ecache_len, ptr)) @@ -352,7 +352,7 @@ int ecache_p(x) static void debug_env_warn(fnam, line, what) char *fnam; int line; - char *what; + const char *what; { lputs(fnam, cur_errp); lputc(':', cur_errp); @@ -419,7 +419,7 @@ SCM *ilookup(iloc) eloc = &CAR(er); for (ir = IDIST(iloc); 0 != ir; --ir) eloc = &CDR(*eloc); - if ICDRP(iloc) return eloc; + if (ICDRP(iloc)) return eloc; return &CAR(*eloc); } SCM *farlookup(farloc) @@ -641,7 +641,7 @@ static SCM evalatomcar(x, toplevelp) return CAR(CDR(ret)); case tc7_smob: #ifdef MACRO - if M_IDENTP(CAR(x)) goto lookup; + if (M_IDENTP(CAR(x))) goto lookup; #endif /* fall through */ case tcs_uves: @@ -818,10 +818,10 @@ static int ecache_eval_args(proc, arg1, arg2, arg3, x) proc = CDR(proc); proc = CDR(proc); for (; NIMP(proc); proc=CDR(proc)) { - if IMP(x) return 0; + if (IMP(x)) return 0; x = CDR(x); } - if NIMP(x) return 0; + if (NIMP(x)) return 0; #endif return 1; } @@ -839,10 +839,10 @@ static SCM asubr_apply(proc, arg1, arg2, arg3, args) } return arg1; case tc7_rpsubr: - if FALSEP(SUBRF(proc)(arg1, arg2)) return BOOL_F; + if (FALSEP(SUBRF(proc)(arg1, arg2))) return BOOL_F; while (!0) { - if FALSEP(SUBRF(proc)(arg2, arg3)) return BOOL_F; - if IMP(args) return BOOL_T; + if (FALSEP(SUBRF(proc)(arg2, arg3))) return BOOL_F; + if (IMP(args)) return BOOL_T; arg2 = arg3; arg3 = CAR(args); args = CDR(args); @@ -855,7 +855,7 @@ static char s_values[] = "values"; static char s_call_wv[] = "call-with-values"; SCM scm_values(arg1, arg2, rest, what) SCM arg1, arg2, rest; - char *what; + const char *what; { DEFER_INTS_EGC; ASRTER(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what); @@ -877,7 +877,7 @@ static char s_clauses[] = "bad or missing clauses"; static char s_formals[] = "bad formals"; static char s_expr[] = "bad expression"; #define ASSYNT(_cond, _arg, _pos, _subr)\ - if(!(_cond))scm_experr(_arg, (char *)_pos, _subr); + if (!(_cond))scm_experr(_arg, (char *)_pos, _subr); /* These symbols are needed by the reader, in repl.c */ SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; @@ -888,7 +888,7 @@ static SCM i_bind, i_anon, i_side_effect, i_test, i_procedure, static SCM f_begin, f_define; -#define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what); +#define ASRTSYNTAX(cond_, msg_) if (!(cond_))wta(xorig, (msg_), what); #ifdef MACRO # define TOPLEVELP(x, env) (topdenote_eq(UNDEFINED, (x), (env))) # define TOPDENOTE_EQ topdenote_eq @@ -907,7 +907,7 @@ static int topdenote_eq(sym, id, env) static SCM id2sym(id) SCM id; { - if NIMP(id) + if (NIMP(id)) while M_IDENTP(id) id = IDENT_PARENT(id); return id; @@ -924,7 +924,7 @@ static void unpaint(p) { SCM x; while NIMP((x = *p)) { - if CONSP(x) { + if (CONSP(x)) { if (NIMP(CAR(x))) unpaint(&CAR(x)); else if (SCM_LINUMP(CAR(x))) { @@ -933,7 +933,7 @@ static void unpaint(p) } p = &CDR(*p); } - else if VECTORP(x) { + else if (VECTORP(x)) { sizet i = LENGTH(x); if (0==i) return; while (i-- > 1) unpaint(&(VELTS(x)[i])); @@ -1144,7 +1144,7 @@ SCM m_cond(xorig, env, ctxt) static int varcheck(vars, op, what) SCM vars, op; - char *what; + const char *what; { SCM v1, vs; char *opstr = ISYMCHARS(op) + 2; @@ -1351,15 +1351,15 @@ static SCM iqq(form) SCM form; { SCM tmp; - if IMP(form) return form; - if VECTORP(form) { + if (IMP(form)) return form; + if (VECTORP(form)) { long i = LENGTH(form); SCM *data = VELTS(form); tmp = EOL; for(;--i >= 0;) tmp = cons(data[i], tmp); return vector(iqq(tmp)); } - if NCONSP(form) return form; + if (NCONSP(form)) return form; tmp = CAR(form); if (IM_UNQUOTE==tmp) return evalcar(CDR(form)); @@ -1374,8 +1374,8 @@ static SCM m_iqq(form, depth, env, ctxt) { SCM tmp; int edepth = depth; - if IMP(form) return form; - if VECTORP(form) { + if (IMP(form)) return form; + if (VECTORP(form)) { long i = LENGTH(form); SCM *data = VELTS(form); tmp = EOL; @@ -1387,7 +1387,7 @@ static SCM m_iqq(form, depth, env, ctxt) } return form; } - if NCONSP(form) { + if (NCONSP(form)) { #ifdef MACRO while M_IDENTP(form) form = IDENT_PARENT(form); #endif @@ -1395,8 +1395,8 @@ static SCM m_iqq(form, depth, env, ctxt) } form = scm_check_linum(form, 0L); /* needed? */ tmp = scm_check_linum(CAR(form), 0L); - if NIMP(tmp) { - if IDENTP(tmp) { + if (NIMP(tmp)) { + if (IDENTP(tmp)) { #ifdef MACRO while M_IDENTP(tmp) tmp = IDENT_PARENT(tmp); #endif @@ -1447,11 +1447,11 @@ SCM m_delay(xorig, env, ctxt) static int built_inp(name, x) SCM name, x; { - if NIMP(x) { + if (NIMP(x)) { tail: switch TYP7(x) { case tcs_subrs: return CHARS(name)==SNAME(x); - case tc7_smob: if MACROP(x) {x = CDR(x); goto tail;} + case tc7_smob: if (MACROP(x)) {x = CDR(x); goto tail;} /* else fall through */ } } @@ -1465,7 +1465,7 @@ char s_built_in_syntax[] = "built-in syntax "; #endif static void checked_define(name, val, what) SCM name, val; - char *what; + const char *what; { SCM old, vcell; #ifdef MACRO @@ -1519,9 +1519,9 @@ static SCM m_parse_let(imm, xorig, x, vars, inits) SCM clause, bdgs, *varloc = vars, *initloc = inits; int len = ilength(x); #ifdef MACRO - char *what = CHARS(ident2sym(CAR(xorig))); + const char *what = CHARS(ident2sym(CAR(xorig))); #else - char *what = CHARS(CAR(xorig)); + const char *what = CHARS(CAR(xorig)); #endif *varloc = imm; *initloc = EOL; @@ -1613,12 +1613,12 @@ static SCM m_body(xorig, env, ctxt) SCM xorig, env, ctxt; { SCM form, denv = env, x = xorig, defs = EOL; - char *what = 0; /* Should this be passed in? */ + const char *what = 0; /* Should this be passed in? */ ASRTSYNTAX(ilength(xorig) >= 1, s_expression); while NIMP(x) { form = scm_check_linum(CAR(x), 0L); if (IMP(form) || NCONSP(form)) break; - if IMP(CAR(form)) break; + if (IMP(CAR(form))) break; if (! IDENTP(CAR(form))) break; form = macroexp1(CAR(x), denv, i_check_defines, 1); if (IM_DEFINE==CAR(form)) { @@ -1635,7 +1635,7 @@ static SCM m_body(xorig, env, ctxt) else x = append(cons2(form, x, EOL)); } - else if NIMP(defs) { + else if (NIMP(defs)) { break; } else { @@ -1736,7 +1736,7 @@ static SCM macroexp1(xorig, env, ctxt, mode) #ifndef RECKLESS SCM trace = scm_trace, trace_env = scm_trace_env; long argc; - char *what = s_wtap; + const char *what = s_wtap; MACROEXP_TRACE(xorig, env); #endif x = scm_check_linum(xorig, &linum); @@ -1914,8 +1914,8 @@ int badargsp(formals, args) SCM formals, args; { while NIMP(formals) { - if NCONSP(formals) return 0; - if IMP(args) return 1; + if (NCONSP(formals)) return 0; + if (IMP(args)) return 1; formals = CDR(formals); args = CDR(args); } @@ -1925,7 +1925,7 @@ int badargsp(formals, args) int scm_arity_check(proc, argc, what) SCM proc; long argc; - char *what; + const char *what; { SCM p = proc; if (IMP(p) || argc < 0) goto badproc; @@ -1991,7 +1991,7 @@ char s_call_cc[] = "call-with-current-continuation"; /* s_apply[] = "apply"; */ /* {return (NIMP(ctxt) && i_check_defines==CAR(ctxt));} */ /* static SCM wrapenv() */ /* {register SCM z; */ -/* DEFER_INTS_EGC; if NULLP(scm_env) return EOL; */ +/* DEFER_INTS_EGC; if (NULLP(scm_env)) return EOL; */ /* NEWCELL(z); DEFER_INTS_EGC; */ /* if (NIMP(scm_env) && ENVP(scm_env)) return scm_env; */ /* CDR(z) = scm_env; CAR(z) = tc16_env; */ @@ -2101,11 +2101,11 @@ static SCM ceval_1(x) x = arg1; } carloop: /* eval car of last form in list */ - if NCELLP(CAR(x)) { + if (NCELLP(CAR(x))) { x = CAR(x); x = IMP(x) ? EVALIMP(x) : I_VAL(x); } - else if ATOMP(CAR(x)) + else if (ATOMP(CAR(x))) x = evalatomcar(x, 0); else { x = CAR(x); @@ -2123,9 +2123,9 @@ static SCM ceval_1(x) while(NIMP(x = CDR(x))) { proc = CAR(x); arg1 = EVALCAR(proc); - if NFALSEP(arg1) { + if (NFALSEP(arg1)) { x = CDR(proc); - if NULLP(x) { + if (NULLP(x)) { x = arg1; goto retx; } @@ -2156,12 +2156,12 @@ static SCM ceval_1(x) EXTEND_VALENV; } x = CDR(proc); - if NULLP(x) {x = UNSPECIFIED; goto retx;} + if (NULLP(x)) {x = UNSPECIFIED; goto retx;} goto begin; case (127 & IM_IF): x = CDR(x); - if NFALSEP(EVALCAR(x)) x = CDR(x); - else if IMP(x = CDR(CDR(x))) {x = UNSPECIFIED; goto retx;} + if (NFALSEP(EVALCAR(x))) x = CDR(x); + else if (IMP(x = CDR(CDR(x)))) {x = UNSPECIFIED; goto retx;} goto carloop; case (127 & IM_LET): ENV_MAY_PUSH(envpp); @@ -2198,7 +2198,7 @@ static SCM ceval_1(x) x = CDR(x); proc = CDR(CAR(x)); /* No longer happens. - if IMP(proc) { + if (IMP(proc)) { scm_env_tmp = EOL; EXTEND_VALENV; goto cdrxbegin; @@ -2218,7 +2218,7 @@ static SCM ceval_1(x) arg1 = x; while(NNULLP(arg1 = CDR(arg1))) { x = EVALCAR(x); - if NFALSEP(x) goto retx; + if (NFALSEP(x)) goto retx; x = arg1; } goto carloop; @@ -2234,8 +2234,8 @@ static SCM ceval_1(x) proc = CAR(x); switch (7 & (int)proc) { case 0: - if ECONSP(proc) - if ISYMP(CAR(proc)) *farlookup(proc) = arg2; + if (ECONSP(proc)) + if (ISYMP(CAR(proc))) *farlookup(proc) = arg2; else { x = scm_multi_set(proc, arg2); goto retx; @@ -2342,7 +2342,7 @@ static SCM ceval_1(x) x = macroexp1(x, STATIC_ENV, EOL, 3); goto loop; #else - if ATOMP(CAR(x)) { + if (ATOMP(CAR(x))) { proc = scm_lookupval(x, 0); if (KEYWORDP(proc)) { x = macroexp1(x, STATIC_ENV, EOL, 3); @@ -2356,7 +2356,7 @@ static SCM ceval_1(x) position and x has the form which is being evaluated. */ ASRTGO(NIMP(proc), badfun); scm_estk_ptr[0] = scm_env; /* For error reporting at wrongnumargs. */ - if NULLP(CDR(x)) { + if (NULLP(CDR(x))) { evap0: TOP_TRACE(xorig, STATIC_ENV); ENV_MAY_POP(envpp, CLOSUREP(proc)); @@ -2386,12 +2386,12 @@ static SCM ceval_1(x) DEFER_INTS_EGC; arg2 = scm_env_tmp; while NIMP(arg1) { - if NCONSP(arg1) goto clo_unchecked; - if IMP(arg2) goto umwrongnumargs; + if (NCONSP(arg1)) goto clo_unchecked; + if (IMP(arg2)) goto umwrongnumargs; arg1 = CDR(arg1); arg2 = CDR(arg2); } - if NNULLP(arg2) goto umwrongnumargs; + if (NNULLP(arg2)) goto umwrongnumargs; } #else /* def CAUTIOUS */ clo_checked: @@ -2447,7 +2447,7 @@ static SCM ceval_1(x) #endif arg1 = EVALCAR(x); x = CDR(x); - if NULLP(x) { + if (NULLP(x)) { TOP_TRACE(xorig, STATIC_ENV); evap1: ENV_MAY_POP(envpp, CLOSUREP(proc)); @@ -2460,14 +2460,14 @@ evap1: return SUBRF(proc)(arg1); case tc7_cxr: #ifdef FLOATS - if SUBRF(proc) { - if INUMP(arg1) + if (SUBRF(proc)) { + if (INUMP(arg1)) return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0); ASRTGO(NIMP(arg1), floerr); - if REALP(arg1) + if (REALP(arg1)) return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0); # ifdef BIGDIG - if BIGP(arg1) + if (BIGP(arg1)) return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0); # endif floerr: @@ -2561,7 +2561,7 @@ evap1: { /* have two or more arguments */ arg2 = EVALCAR(x); x = CDR(x); - if NULLP(x) { /* have two arguments */ + if (NULLP(x)) { /* have two arguments */ TOP_TRACE(xorig, STATIC_ENV); evap2: ENV_MAY_POP(envpp, CLOSUREP(proc)); @@ -2582,7 +2582,7 @@ evap1: case tc16_apply: proc = arg1; ASRTGO(NIMP(proc), badfun); - if NULLP(arg2) goto evap0; + if (NULLP(arg2)) goto evap0; if (IMP(arg2) || NCONSP(arg2)) { x = arg2; badlst: wta(x, (char *)ARGn, s_apply); @@ -2590,17 +2590,17 @@ evap1: arg1 = CAR(arg2); x = CDR(arg2); apply3: - if NULLP(x) goto evap1; + if (NULLP(x)) goto evap1; ASRTGO(NIMP(x) && CONSP(x), badlst); arg2 = CAR(x); x = CDR(x); apply4: - if NULLP(x) goto evap2; + if (NULLP(x)) goto evap2; ASRTGO(NIMP(x) && CONSP(x), badlst); arg3 = x; x = scm_cp_list(CDR(x), 0); #ifndef RECKLESS - if UNBNDP(x) {x = arg3; goto badlst;} + if (UNBNDP(x)) {x = arg3; goto badlst;} #endif arg3 = CAR(arg3); goto evap3; @@ -2665,7 +2665,7 @@ evap1: { /* have 3 or more arguments */ arg3 = EVALCAR(x); x = CDR(x); - if NIMP(x) { + if (NIMP(x)) { if (CLOSUREP(proc) && 3==ARGC(proc)) { ALLOW_INTS_EGC; ENV_MAY_PUSH(envpp); @@ -2716,12 +2716,12 @@ evap1: proc = arg1; ASRTGO(NIMP(proc), badfun); arg1 = arg2; - if IMP(x) { + if (IMP(x)) { x = arg3; goto apply3; } arg2 = arg3; - if IMP(CDR(x)) { + if (IMP(CDR(x))) { x = CAR(x); goto apply4; } @@ -2756,7 +2756,7 @@ evap1: SCM procedurep(obj) SCM obj; { - if NIMP(obj) switch TYP7(obj) { + if (NIMP(obj)) switch TYP7(obj) { case tcs_closures: case tc7_contin: case tcs_subrs: @@ -2838,8 +2838,8 @@ SCM apply(proc, arg1, args) SCM proc, arg1, args; { ASRTGO(NIMP(proc), badproc); - if NULLP(args) - if NULLP(arg1) arg1 = UNDEFINED; + if (NULLP(args)) + if (NULLP(arg1)) arg1 = UNDEFINED; else { args = CDR(arg1); arg1 = CAR(arg1); @@ -2855,7 +2855,7 @@ SCM apply(proc, arg1, args) wrongnumargs: wta(proc, (char *)WNA, s_apply); case tc7_subr_2o: - if NULLP(args) { + if (NULLP(args)) { args = UNDEFINED; return SUBRF(proc)(arg1, args); } @@ -2874,14 +2874,14 @@ SCM apply(proc, arg1, args) case tc7_cxr: ASRTGO(NULLP(args), wrongnumargs); #ifdef FLOATS - if SUBRF(proc) { - if INUMP(arg1) + if (SUBRF(proc)) { + if (INUMP(arg1)) return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0); ASRTGO(NIMP(arg1), floerr); - if REALP(arg1) + if (REALP(arg1)) return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0); # ifdef BIGDIG - if BIGP(arg1) + if (BIGP(arg1)) return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0); # endif floerr: @@ -2911,7 +2911,7 @@ SCM apply(proc, arg1, args) ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); return SUBRF(proc)(arg1, CAR(args), CDR(args)); case tc7_asubr: - if NULLP(args) return SUBRF(proc)(arg1, UNDEFINED); + if (NULLP(args)) return SUBRF(proc)(arg1, UNDEFINED); while NIMP(args) { ASRTER(CONSP(args), args, ARG2, s_apply); arg1 = SUBRF(proc)(arg1, CAR(args)); @@ -2919,10 +2919,10 @@ SCM apply(proc, arg1, args) } return arg1; case tc7_rpsubr: - if NULLP(args) return BOOL_T; + if (NULLP(args)) return BOOL_T; while NIMP(args) { ASRTER(CONSP(args), args, ARG2, s_apply); - if FALSEP(SUBRF(proc)(arg1, CAR(args))) return BOOL_F; + if (FALSEP(SUBRF(proc)(arg1, CAR(args)))) return BOOL_F; arg1 = CAR(args); args = CDR(args); } @@ -2978,14 +2978,14 @@ SCM scm_cvapply(proc, n, argv) return SUBRF(proc)(argv[0]); case tc7_cxr: #ifdef FLOATS - if SUBRF(proc) { - if INUMP(argv[0]) + if (SUBRF(proc)) { + if (INUMP(argv[0])) return makdbl(DSUBRF(proc)((double) INUM(argv[0])), 0.0); ASRTGO(NIMP(argv[0]), floerr); - if REALP(argv[0]) + if (REALP(argv[0])) return makdbl(DSUBRF(proc)(REALPART(argv[0])), 0.0); # ifdef BIGDIG - if BIGP(argv[0]) + if (BIGP(argv[0])) return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0); # endif floerr: @@ -3019,7 +3019,7 @@ SCM scm_cvapply(proc, n, argv) case tc7_rpsubr: if (1 >= n) return BOOL_T; for (i = 0; i < n-1; i++) - if FALSEP(SUBRF(proc)(argv[i], argv[i+1])) return BOOL_F; + if (FALSEP(SUBRF(proc)(argv[i], argv[i+1]))) return BOOL_F; return BOOL_T; case tcs_closures: { SCM p = proc; @@ -3070,7 +3070,7 @@ SCM map(proc, arg1, args) SCM *ve = auto_ve, *ave = auto_ave; long i, n = ilength(args) + 1; scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */ - if NULLP(arg1) return res; + if (NULLP(arg1)) return res; #ifndef RECKLESS scm_arity_check(proc, n, s_map); #endif @@ -3099,7 +3099,7 @@ SCM map(proc, arg1, args) while (1) { arg1 = EOL; for (i = n-1;i >= 0;i--) { - if IMP(ve[i]) { + if (IMP(ve[i])) { /* We could check for lists the same length here. */ return res; } @@ -3118,7 +3118,7 @@ SCM for_each(proc, arg1, args) SCM *ve = auto_ve, *ave = auto_ave; long i, n = ilength(args) + 1; scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */ - if NULLP(arg1) return UNSPECIFIED; + if (NULLP(arg1)) return UNSPECIFIED; #ifndef RECKLESS scm_arity_check(proc, n, s_for_each); #endif @@ -3147,7 +3147,7 @@ SCM for_each(proc, arg1, args) while (1) { arg1 = EOL; for (i = n-1;i >= 0;i--) { - if IMP(ve[i]) { + if (IMP(ve[i])) { return UNSPECIFIED; } ASRTER(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each); @@ -3205,7 +3205,7 @@ static int prinprom(exp, port, writing) static SCM makro(code, flags, what) SCM code; long flags; - char *what; + const char *what; { register SCM z; ASRTER(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L), @@ -3371,14 +3371,14 @@ SCM copytree(obj) SCM obj; { SCM ans, tl; - if IMP(obj) return obj; - if VECTORP(obj) { + if (IMP(obj)) return obj; + if (VECTORP(obj)) { sizet i = LENGTH(obj); ans = make_vector(MAKINUM(i), UNSPECIFIED); while(i--) VELTS(ans)[i] = copytree(VELTS(obj)[i]); return ans; } - if NCONSP(obj) return obj; + if (NCONSP(obj)) return obj; /* return cons(copytree(CAR(obj)), copytree(CDR(obj))); */ ans = tl = cons(copytree(CAR(obj)), UNSPECIFIED); while(NIMP(obj = CDR(obj)) && CONSP(obj)) @@ -3425,9 +3425,9 @@ SCM ident_eqp(id1, id2, env) { SCM s1 = id1, s2 = id2; # ifndef RECKLESS - if IMP(id1) + if (IMP(id1)) badarg1: wta(id1, (char *)ARG1, s_ident_eqp); - if IMP(id1) + if (IMP(id1)) badarg2: wta(id2, (char *)ARG2, s_ident_eqp); # endif if (id1==id2) return BOOL_T; diff --git a/grtest.scm b/grtest.scm new file mode 100644 index 0000000..7401308 --- /dev/null +++ b/grtest.scm @@ -0,0 +1,82 @@ + +; This is a quick hack to test the graphics primitives. +; The SLIB scheme library is needed for random. +; IMHO, the syntax of `do' in scheme is horrible! +; - sjm + +(define (grtest) + (require 'random) ; needs SLIB + (graphics-mode!) + + (display "testing draw-to") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 3))) + ((> x (max-x)) 0) + (set-color! (remainder (/ x 3) (max-color))) + (draw-to x 0) + (draw-to x (max-y)) + ) + + (do ((y 0 (+ y 3))) + ((> y (max-y)) 0) + (set-color! (remainder (/ y 3) (max-color))) + (goto-center!) + (draw-to! 0 y) + (goto-center!) + (draw-to! (max-x) y) + ) + + (goto-nw!) + (do ((x 0 (+ x 2))) + ((> x (max-x)) 0) + (set-color! (remainder (/ x 2) (max-color))) + (draw-to x (max-y)) + ) + (do ((y (+ (max-y) 1) (- y 2))) + ((< y 0) 0) + (set-color! (remainder (/ y 2) (max-color))) + (draw-to (max-x) y) + ) + + (display "testing set-dot!") (newline) + (clear-graphics!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-dot! (+ (random (max-x)) 1) (+ (random (max-y)) 1) + (+ (random (max-color)) 1)) + ) + + (display "testing draw with turn-to!") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-color! (+ (random (max-color)) 1)) + (turn-to! (random 360)) + (draw (random 50)) + ) + + (display "testing draw with turn-right") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-color! (+ (random (max-color)) 1)) + (turn-right (random 90)) + (draw (random 50)) + ) + + (display "testing draw with turn-left") (newline) + (clear-graphics!) + (goto-center!) + (do ((x 0 (+ x 1))) + ((= x 100) 0) + (set-color! (+ (random (max-color)) 1)) + (turn-left (random 90)) + (draw (random 50)) + ) + + (text-mode!) +) + diff --git a/gsubr.c b/gsubr.c index d3d7c82..6f9a790 100644 --- a/gsubr.c +++ b/gsubr.c @@ -96,21 +96,21 @@ SCM gsubr_apply(args) args = CDR(args); for (i = 0; i < GSUBR_REQ(typ); i++) { #ifndef RECKLESS - if IMP(args) + if (IMP(args)) wnargs: wta(UNDEFINED, (char *)WNA, SNAME(GSUBR_PROC(self))); #endif v[i] = CAR(args); args = CDR(args); } for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) { - if NIMP(args) { + if (NIMP(args)) { v[i] = CAR(args); args = CDR(args); } else v[i] = UNDEFINED; } - if GSUBR_REST(typ) + if (GSUBR_REST(typ)) v[i] = args; else ASRTGO(NULLP(args), wnargs); diff --git a/hobbit.info b/hobbit.info index d775565..9f124f3 100644 --- a/hobbit.info +++ b/hobbit.info @@ -138,7 +138,7 @@ File: hobbit.info, Node: Compiling And Linking, Next: Error Detection, Prev: (lambda (fp) (for-each (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"Init5e1.scm\"" + '("#define IMPLINIT \"Init5e2.scm\"" "#define BIGNUMS" "#define FLOATS" "#define ARRAYS" @@ -190,7 +190,7 @@ File: hobbit.info, Node: Compiling And Linking, Next: Error Detection, Prev: (lambda (fp) (for-each (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"Init5e1.scm\"" + '("#define IMPLINIT \"Init5e2.scm\"" "#define COMPILED_INITS init_example();" "#define CCLO" "#define FLOATS")))) diff --git a/hobbit.scm b/hobbit.scm index 65dfff1..006719b 100644 --- a/hobbit.scm +++ b/hobbit.scm @@ -242,7 +242,7 @@ setcar setcdr listp list length append reverse list-ref memq memv member assq assv assoc symbolp symbol2string string2symbol numberp exactp inexactp eqp lessp zerop positivep negativep oddp evenp lmax lmin sum - product difference lquotient absval remainder lremainder modulo lgcd llcm + product difference lquotient scm_abs remainder lremainder modulo lgcd llcm number2string ;;; string2number makdbl istr2flo mkbig long2big dbl2big @@ -2492,7 +2492,7 @@ (@copy-tree "copytree" 1) (exact? "exactp" 1) (inexact? "inexactp" 1) - (odd? "oddp" 1) (even? "evenp" 1) (max "lmax" 2) (min "lmin" 2) (abs "absval" 1) + (odd? "oddp" 1) (even? "evenp" 1) (max "lmax" 2) (min "lmin" 2) (abs "scm_abs" 1) (quotient "lquotient" 2) (remainder "lremainder" 2) (modulo "modulo" 2) (gcd "lgcd" 2) (lcm "llcm" 2) @@ -2511,7 +2511,7 @@ (inexact->exact "in2ex" 1) (make-rectangular "makrect" 2) (make-polar "makpolar" 2) (real-part "real_part" 1) (imag-part "imag_part" 1) - (magnitude "magnitude" 1) (angle "angle" 1) + (magnitude "scm_magnitude" 1) (angle "angle" 1) (number->string "number2string" 2) (string->number "string2number" 1) diff --git a/ioext.c b/ioext.c index 6a8e6e1..62efc2b 100644 --- a/ioext.c +++ b/ioext.c @@ -93,6 +93,9 @@ SCM stat2scm P((struct stat *stat_temp)); #ifdef __MACH__ # include #endif +#ifdef __CYGWIN__ +# include +#endif #ifndef STDC_HEADERS int chdir P((const char *path)); @@ -136,7 +139,7 @@ SCM read_line(port) sizet len = 30; SCM tok_buf = makstr((long) len); register char *p = CHARS(tok_buf); - if UNBNDP(port) port = cur_inp; + if (UNBNDP(port)) port = cur_inp; else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_line); if (EOF==(c = lgetc(port))) return EOF_VAL; while(1) { @@ -167,7 +170,7 @@ SCM read_line1(str, port) ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_read_line1); p = CHARS(str); len = LENGTH(str); - if UNBNDP(port) port = cur_inp; + if (UNBNDP(port)) port = cur_inp; else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG2, s_read_line1); c = lgetc(port); if (EOF==c) return EOF_VAL; @@ -202,7 +205,7 @@ SCM file_position(port) long ans; ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position); SYSCALL(ans = ftell(STREAM(port));); - if CRDYP(port) ans--; + if (CRDYP(port)) ans--; return MAKINUM(ans); } SCM file_set_position(port, pos) @@ -367,7 +370,7 @@ SCM l_closedir(port) int sts; ASRTER(DIRP(port), port, ARG1, s_closedir); DEFER_INTS; - if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;} + if (CLOSEDP(port)) {ALLOW_INTS;return BOOL_F;} SYSCALL(sts = closedir((DIR *)CDR(port));); if (sts) {ALLOW_INTS; return BOOL_F;} CAR(port) = tc16_dir; @@ -384,10 +387,10 @@ int dir_print(sexp, port, writing) sizet dir_free(p) CELLPTR p; { - if OPENP((SCM)p) closedir((DIR *)CDR((SCM)p)); + if (OPENP((SCM)p)) closedir((DIR *)CDR((SCM)p)); return 0; } -# define dir_mark mark0 +# define dir_mark mark0 # else /* _WIN32 */ struct WDIR { long handle; //-1 if at end of list. @@ -464,7 +467,7 @@ SCM l_closedir(port) ASRTER(DIRP(port), port, ARG1, s_closedir); wdir = (struct WDIR*)CHARS(port); DEFER_INTS; - if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;} + if (CLOSEDP(port)) {ALLOW_INTS;return BOOL_F;} if (-1 != wdir->handle) { SYSCALL(_findclose(wdir->handle);); wdir->handle = -1; @@ -624,7 +627,7 @@ SCM ren_fil(oldname, newname) SYSCALL(ans = link(CHARS(oldname), CHARS(newname)) ? BOOL_F : BOOL_T;); if (!FALSEP(ans)) { SYSCALL(ans = unlink(CHARS(oldname)) ? BOOL_F : BOOL_T;); - if FALSEP(ans) + if (FALSEP(ans)) SYSCALL(unlink(CHARS(newname));); /* unlink failed. remove new name */ } ALLOW_INTS; @@ -654,7 +657,7 @@ SCM l_access(pathname, mode) int val; int imodes; ASRTER(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_access); - if INUMP(mode) imodes = INUM(mode); + if (INUMP(mode)) imodes = INUM(mode); else { ASRTER(NIMP(mode) && STRINGP(mode), mode, ARG2, s_access); imodes = F_OK | (strchr(CHARS(mode), 'r') ? R_OK : 0) @@ -674,9 +677,9 @@ SCM l_stat(str) { int i; struct stat stat_temp; - if IMP(str) + if (IMP(str)) badarg1: wta(str, (char *)ARG1, s_stat); - if STRINGP(str) {SYSCALL(i = stat(CHARS(str), &stat_temp););} + if (STRINGP(str)) {SYSCALL(i = stat(CHARS(str), &stat_temp););} else { # ifndef MCH_AMIGA if (!OPFPORTP(str)) goto badarg1; diff --git a/patchlvl.h b/patchlvl.h index 779b7d8..1c2c038 100644 --- a/patchlvl.h +++ b/patchlvl.h @@ -4,11 +4,11 @@ # for alpha release, "b" for beta release, "c", and so on), and the # trailing number is the patchlevel. */ # /* This next line sets VERSION when included from the Makefile */ -VERSION=5e1 +VERSION=5e2 #endif #ifndef SCMVERSION -# define SCMVERSION "5e1" +# define SCMVERSION "5e2" #endif #ifdef nosve # define INIT_FILE_NAME "Init"SCMVERSION"_scm"; diff --git a/posix.c b/posix.c index 229384a..e6dab25 100644 --- a/posix.c +++ b/posix.c @@ -178,8 +178,8 @@ SCM l_pwinfo(user) struct passwd *entry; SCM *ve = VELTS(ans); DEFER_INTS; - if UNBNDP(user) SYSCALL(entry = getpwent();); - else if INUMP(user) SYSCALL(entry = getpwuid(INUM(user));); + if (UNBNDP(user)) SYSCALL(entry = getpwent();); + else if (INUMP(user)) SYSCALL(entry = getpwuid(INUM(user));); else { ASRTER(NIMP(user) && STRINGP(user), user, ARG1, s_pwinfo); SYSCALL(entry = getpwnam(CHARS(user));); @@ -204,8 +204,8 @@ SCM l_grinfo(name) struct group *entry; SCM *ve = VELTS(ans); DEFER_INTS; - if UNBNDP(name) SYSCALL(entry = getgrent();); - else if INUMP(name) SYSCALL(entry = getgrgid(INUM(name));); + if (UNBNDP(name)) SYSCALL(entry = getgrent();); + else if (INUMP(name)) SYSCALL(entry = getgrgid(INUM(name));); else { ASRTER(NIMP(name) && STRINGP(name), name, ARG1, s_grinfo); SYSCALL(entry = getgrnam(CHARS(name));); diff --git a/r4rstest.scm b/r4rstest.scm index 7768f03..d0842c5 100644 --- a/r4rstest.scm +++ b/r4rstest.scm @@ -482,7 +482,7 @@ (test #t exact? 3) (test #f inexact? 3) -;;(test 1 expt 0 0) +(test 1 expt 0 0) (test 0 expt 0 1) (test 0 expt 0 256) ;;(test 0 expt 0 -255) diff --git a/ramap.c b/ramap.c index 1ebafce..749e1c1 100644 --- a/ramap.c +++ b/ramap.c @@ -97,7 +97,7 @@ int ra_matchp(ra0, ras) sizet bas0 = 0; int i, ndim = 1; int exact = 2 /* 4 */; /* Don't care about values >2 (yet?) */ - if IMP(ra0) return 0; + if (IMP(ra0)) return 0; switch TYP7(ra0) { default: return 0; case tc7_vector: @@ -163,7 +163,7 @@ static char s_ra_mismatch[] = "array shape mismatch"; int ramapc(cproc, data, ra0, lra, what) int (*cproc)(); SCM data, ra0, lra; - char *what; + const char *what; { SCM z, vra0, ra1, vra1; SCM lvra, *plvra; @@ -174,7 +174,7 @@ int ramapc(cproc, data, ra0, lra, what) case 2: case 3: case 4: /* Try unrolling arrays */ if (kmax < 0) goto gencase; vra0 = (0==kmax ? ra0 : array_contents(ra0, UNDEFINED)); - if IMP(vra0) goto gencase; + if (IMP(vra0)) goto gencase; if (!ARRAYP(vra0)) { vra1 = make_ra(1); ARRAY_BASE(vra1) = 0; @@ -188,7 +188,7 @@ int ramapc(cproc, data, ra0, lra, what) plvra = &lvra; for (z = lra; NIMP(z); z = CDR(z)) { vra1 = ra1 = (0==kmax ? CAR(z) : array_contents(CAR(z), UNDEFINED)); - if FALSEP(ra1) goto gencase; + if (FALSEP(ra1)) goto gencase; if (!ARRAYP(ra1)) { vra1 = make_ra(1); ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd; @@ -212,7 +212,7 @@ int ramapc(cproc, data, ra0, lra, what) indv = (long *)VELTS(hp_indv); } vra0 = make_ra(1); - if ARRAYP(ra0) { + if (ARRAYP(ra0)) { if (kmax < 0) { ARRAY_DIMS(vra0)->lbnd = 0; ARRAY_DIMS(vra0)->ubnd = 0; @@ -241,7 +241,7 @@ int ramapc(cproc, data, ra0, lra, what) vra1 = make_ra(1); ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd; ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd; - if ARRAYP(ra1) { + if (ARRAYP(ra1)) { if (kmax >= 0) ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc; ARRAY_V(vra1) = ARRAY_V(ra1); @@ -514,7 +514,7 @@ SCM sc2array(s, ra, prot) { SCM res; ASRTER(NIMP(ra), ra, ARG2, s_sc2array); - if ARRAYP(ra) { + if (ARRAYP(ra)) { int k = ARRAY_NDIM(ra); res = make_ra(k); while (k--) { @@ -545,7 +545,7 @@ SCM sc2array(s, ra, prot) if (BOOL_T==s || BOOL_F==s) break; goto mismatch; case tc7_string: - if ICHRP(s) break; + if (ICHRP(s)) break; goto mismatch; case tc7_uvect: if (INUMP(s) && INUM(s)>=0) break; @@ -554,7 +554,7 @@ SCM sc2array(s, ra, prot) #endif goto mismatch; case tc7_ivect: - if INUMP(s) break; + if (INUMP(s)) break; #ifdef BIGDIG if (NIMP(s) && BIGP(s) && NUMDIGS(s)<=DIGSPERLONG) break; #endif @@ -565,7 +565,7 @@ SCM sc2array(s, ra, prot) if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break; goto mismatch; case tc7_cvect: - if NUMBERP(s) break; + if (NUMBERP(s)) break; goto mismatch; #endif mismatch: ARRAY_V(res) = make_vector(MAKINUM(1), s); @@ -592,33 +592,33 @@ int ra_eqp(ra0, ras) default: { SCM e1 = UNDEFINED, e2 = UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) - if FALSEP(eqp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) + if (BVE_REF(ra0, i0)) + if (FALSEP(eqp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)))) BVE_CLR(ra0, i0); break; } case tc7_uvect: case tc7_ivect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (VELTS(ra1)[i1] != VELTS(ra2)[i2]) BVE_CLR(ra0, i0); break; # ifdef FLOATS case tc7_fvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (((float *)VELTS(ra1))[i1] != ((float *)VELTS(ra2))[i2]) BVE_CLR(ra0, i0); break; case tc7_dvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (((double *)VELTS(ra1))[i1] != ((double *)VELTS(ra2))[i2]) BVE_CLR(ra0, i0); break; case tc7_cvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (((double *)VELTS(ra1))[2*i1] != ((double *)VELTS(ra2))[2*i2] || ((double *)VELTS(ra1))[2*i1+1] != ((double *)VELTS(ra2))[2*i2+1]) BVE_CLR(ra0, i0); @@ -644,7 +644,7 @@ static int ra_compare(ra0, ra1, ra2, opt) default: { SCM e1 = UNDEFINED, e2 = UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (opt ? NFALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) : FALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) ) @@ -653,7 +653,7 @@ static int ra_compare(ra0, ra1, ra2, opt) } case tc7_uvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) { - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (opt ? ((unsigned long*)VELTS(ra1))[i1] < ((unsigned long*)VELTS(ra2))[i2] : ((unsigned long*)VELTS(ra1))[i1] >= ((unsigned long*)VELTS(ra2))[i2]) @@ -662,7 +662,7 @@ static int ra_compare(ra0, ra1, ra2, opt) break; case tc7_ivect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) { - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (opt ? VELTS(ra1)[i1] < VELTS(ra2)[i2] : VELTS(ra1)[i1] >= VELTS(ra2)[i2]) @@ -672,7 +672,7 @@ static int ra_compare(ra0, ra1, ra2, opt) # ifdef FLOATS case tc7_fvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (opt ? ((float *)VELTS(ra1))[i1] < ((float *)VELTS(ra2))[i2] : ((float *)VELTS(ra1))[i1] >= ((float *)VELTS(ra2))[i2]) @@ -680,7 +680,7 @@ static int ra_compare(ra0, ra1, ra2, opt) break; case tc7_dvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) + if (BVE_REF(ra0, i0)) if (opt ? ((double *)VELTS(ra1))[i1] < ((double *)VELTS(ra2))[i2] : ((double *)VELTS(ra1))[i1] >= ((double *)VELTS(ra2))[i2]) @@ -718,7 +718,7 @@ int ra_sum(ra0, ras) sizet i0 = ARRAY_BASE(ra0); long inc0 = ARRAY_DIMS(ra0)->inc; ra0 = ARRAY_V(ra0); - if NNULLP(ras) { + if (NNULLP(ras)) { SCM ra1 = CAR(ras); sizet i1 = ARRAY_BASE(ra1); long inc1 = ARRAY_DIMS(ra1)->inc; @@ -794,7 +794,7 @@ int ra_difference(ra0, ras) sizet i0 = ARRAY_BASE(ra0); long inc0 = ARRAY_DIMS(ra0)->inc; ra0 = ARRAY_V(ra0); - if NULLP(ras) { + if (NULLP(ras)) { switch TYP7(ra0) { default: { SCM e0 = UNDEFINED; @@ -907,7 +907,7 @@ int ra_product(ra0, ras) sizet i0 = ARRAY_BASE(ra0); long inc0 = ARRAY_DIMS(ra0)->inc; ra0 = ARRAY_V(ra0); - if NNULLP(ras) { + if (NNULLP(ras)) { SCM ra1 = CAR(ras); sizet i1 = ARRAY_BASE(ra1); long inc1 = ARRAY_DIMS(ra1)->inc; @@ -984,7 +984,7 @@ int ra_divide(ra0, ras) sizet i0 = ARRAY_BASE(ra0); long inc0 = ARRAY_DIMS(ra0)->inc; ra0 = ARRAY_V(ra0); - if NULLP(ras) { + if (NULLP(ras)) { switch TYP7(ra0) { default: { SCM e0 = UNDEFINED; @@ -1168,8 +1168,8 @@ static int ramap_rp(ra0, proc, ras) ra1 = ARRAY_V(ra1); ra2 = ARRAY_V(ra2); for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF(ra0, i0) - if FALSEP(SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) + if (BVE_REF(ra0, i0)) + if (FALSEP(SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)))) BVE_CLR(ra0, i0); return 1; } @@ -1202,7 +1202,7 @@ static int ramap_2o(ra0, proc, ras) ra0 = ARRAY_V(ra0); ra1 = ARRAY_V(ra1); ras = CDR(ras); - if NULLP(ras) { + if (NULLP(ras)) { if (tc7_vector==TYP7(ra0)) for (; n-- > 0; i0 += inc0, i1 += inc1) VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED), UNDEFINED); @@ -1237,7 +1237,7 @@ static int ramap_a(ra0, proc, ras) sizet i0 = ARRAY_BASE(ra0); long inc0 = ARRAY_DIMS(ra0)->inc; ra0 = ARRAY_V(ra0); - if NULLP(ras) + if (NULLP(ras)) for (; n-- > 0; i0 += inc0) aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0)); else { @@ -1314,9 +1314,9 @@ SCM array_map(ra0, proc, lra) return UNSPECIFIED; } case tc7_asubr: - if NULLP(lra) { + if (NULLP(lra)) { SCM prot, fill = SUBRF(proc)(UNDEFINED, UNDEFINED); - if INUMP(fill) { + if (INUMP(fill)) { prot = array_prot(ra0); # ifdef FLOATS if (NIMP(prot) && INEXP(prot)) @@ -1353,7 +1353,7 @@ SCM array_map(ra0, proc, lra) } ramapc(ramap_2o, proc, ra0, lra, s_array_map); lra = CDR(lra); - if NIMP(lra) + if (NIMP(lra)) for (lra = CDR(lra); NIMP(lra); lra = CDR(lra)) ramapc(ramap_a, proc, ra0, lra, s_array_map); } @@ -1506,13 +1506,13 @@ static int raeql_1(ra0, as_equal, ra1) long inc0 = 1, inc1 = 1; sizet n = LENGTH(ra0); ra1 = CAR(ra1); - if ARRAYP(ra0) { + if (ARRAYP(ra0)) { n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; i0 = ARRAY_BASE(ra0); inc0 = ARRAY_DIMS(ra0)->inc; ra0 = ARRAY_V(ra0); } - if ARRAYP(ra1) { + if (ARRAYP(ra1)) { i1 = ARRAY_BASE(ra1); inc1 = ARRAY_DIMS(ra1)->inc; ra1 = ARRAY_V(ra1); @@ -1520,12 +1520,12 @@ static int raeql_1(ra0, as_equal, ra1) switch TYP7(ra0) { case tc7_vector: default: for (; n--; i0+=inc0, i1+=inc1) { - if FALSEP(as_equal) { - if FALSEP(array_equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))) + if (FALSEP(as_equal)) { + if (FALSEP(array_equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)))) return 0; } else - if FALSEP(equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))) + if (FALSEP(equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)))) return 0; } return 1; @@ -1582,7 +1582,7 @@ static int raeql(ra0, as_equal, ra1) array_dim *s0 = &dim0, *s1 = &dim1; sizet bas0 = 0, bas1 = 0; int k, unroll = 1, ndim = 1; - if ARRAYP(ra0) { + if (ARRAYP(ra0)) { ndim = ARRAY_NDIM(ra0); s0 = ARRAY_DIMS(ra0); bas0 = ARRAY_BASE(ra0); @@ -1591,7 +1591,7 @@ static int raeql(ra0, as_equal, ra1) else { s0->inc = 1; s0->lbnd = 0; s0->ubnd = LENGTH(v0) - 1; } - if ARRAYP(ra1) { + if (ARRAYP(ra1)) { if (ndim != ARRAY_NDIM(ra1)) return 0; s1 = ARRAY_DIMS(ra1); bas1 = ARRAY_BASE(ra1); diff --git a/record.c b/record.c index 5370daf..de72dce 100644 --- a/record.c +++ b/record.c @@ -125,7 +125,7 @@ SCM rec_constr(rtd, flds) RCLO_RTD(cclo) = rtd; i = ilength(RTD_FIELDS(rtd)); RCONSTR_SIZE(cclo) = MAKINUM(i); - if UNBNDP(flds) { + if (UNBNDP(flds)) { indices = MAKE_REC_INDS(i); while (i--) REC_IND_SET(indices, i, i+1); } @@ -199,7 +199,7 @@ SCM rec_constr1(args) A cclo with 2 env elts -- rtd and field-number. */ static SCM makrecclo(proc, rtd, field, what) SCM proc, rtd, field; - char *what; + const char *what; { SCM flst; SCM cclo = makcclo(proc, 3L); @@ -286,7 +286,7 @@ static SCM markrec(ptr) { sizet i; for (i = NUMDIGS(ptr); --i;) - if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]); + if (NIMP(VELTS(ptr)[i])) gc_mark(VELTS(ptr)[i]); return REC_RTD(ptr); } static sizet freerec(ptr) @@ -302,7 +302,7 @@ static int recprin1(exp, port, writing) SCM names, printer = RTD_PRINTER(REC_RTD(exp)); SCM argv[3]; sizet i; - if NIMP(printer) { + if (NIMP(printer)) { argv[0] = exp; argv[1] = port; argv[2] = writing ? BOOL_T : BOOL_F; @@ -369,7 +369,7 @@ SCM recequal(rec0, rec1) if (i != NUMDIGS(rec1)) return BOOL_F; if (REC_RTD(rec0) != REC_RTD(rec1)) return BOOL_F; while(--i) - if FALSEP(equal(VELTS(rec0)[i], VELTS(rec1)[i])) + if (FALSEP(equal(VELTS(rec0)[i], VELTS(rec1)[i]))) return BOOL_F; return BOOL_T; } diff --git a/repl.c b/repl.c index a3204dc..a8856ae 100644 --- a/repl.c +++ b/repl.c @@ -44,12 +44,12 @@ #include "scm.h" #include "setjump.h" -void igc P((char *what, STACKITEM *stackbase)); +void igc P((const char *what, STACKITEM *stackbase)); void unexec P((char *new_name, char *a_name, unsigned data_start, unsigned bss_start, unsigned entry_address)); void scm_fill_freelist P((void)); -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ # include #endif @@ -155,7 +155,7 @@ static char s_freshline[] = "freshline"; static char s_eofin[] = "end of file in "; static char s_unknown_sharp[] = "unknown # object"; -static SCM lread1 P((SCM port, int flgs, char *what)); +static SCM lread1 P((SCM port, int flgs, const char *what)); static SCM lreadr P((SCM tok_buf, SCM port, int flgs)); static SCM lreadpr P((SCM tok_buf, SCM port, int flgs)); static SCM lreadparen P((SCM tok_buf, SCM port, int flgs, char *name)); @@ -203,12 +203,12 @@ void iprlist(hdr, exp, tlr, port, writing) exp = GCCDR(exp); /* CDR(exp); */ for(;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) { if (!scm_cell_p(~1L & exp)) break; - if NECONSP(exp) break; + if (NECONSP(exp)) break; lputc(' ', port); /* CHECK_INTS; */ iprin1(CAR(exp), port, writing); } - if NNULLP(exp) { + if (NNULLP(exp)) { lputs(" . ", port); iprin1(exp, port, writing); } @@ -227,7 +227,7 @@ taloop: intprint(INUM(exp), 10, port); break; case 4: - if ICHRP(exp) { + if (ICHRP(exp)) { i = ICHR(exp); if (writing) lputs("#\\", port); if (!writing) lputc((int)i, port); @@ -247,7 +247,7 @@ taloop: } else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *)))) lputs(ISYMCHARS(exp), port); - else if ILOCP(exp) { + else if (ILOCP(exp)) { lputs("#@", port); intprint((long)IFRAME(exp), -10, port); lputc(ICDRP(exp)?'-':'+', port); @@ -470,7 +470,7 @@ static int input_waiting(f) SCM char_readyp(port) SCM port; { - if UNBNDP(port) port = cur_inp; + if (UNBNDP(port)) port = cur_inp; ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T; return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F; @@ -500,7 +500,7 @@ SCM wait_for_input(args) ASRTER(!NULLP(args), INUM0, WNA, s_wfi); how_long = CAR(args); args = CDR(args); - if NULLP(args) port1 = cur_inp; + if (NULLP(args)) port1 = cur_inp; else { port1 = CAR(args); args = CDR(args); @@ -595,7 +595,7 @@ static SCM *loc_broken_pipe = 0; /* returning non-zero means try again. */ int scm_io_error(port, what) SCM port; - char *what; + const char *what; { #ifdef HAVE_PIPE # ifdef EPIPE @@ -636,7 +636,7 @@ static char s_flush[] = "force-output"; SCM lflush(port) /* user accessible as force-output */ SCM port; { - if UNBNDP(port) port = cur_outp; + if (UNBNDP(port)) port = cur_outp; else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush); { sizet i = PTOBNUM(port); @@ -650,7 +650,7 @@ SCM lflush(port) /* user accessible as force-output */ SCM lwrite(obj, port) SCM obj, port; { - if UNBNDP(port) port = cur_outp; + if (UNBNDP(port)) port = cur_outp; else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write); iprin1(obj, port, 1); return UNSPECIFIED; @@ -658,7 +658,7 @@ SCM lwrite(obj, port) SCM display(obj, port) SCM obj, port; { - if UNBNDP(port) port = cur_outp; + if (UNBNDP(port)) port = cur_outp; else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display); iprin1(obj, port, 0); return UNSPECIFIED; @@ -666,7 +666,7 @@ SCM display(obj, port) SCM newline(port) SCM port; { - if UNBNDP(port) port = cur_outp; + if (UNBNDP(port)) port = cur_outp; else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline); lputc('\n', port); if (port==cur_outp) lfflush(port); @@ -675,7 +675,7 @@ SCM newline(port) SCM write_char(chr, port) SCM chr, port; { - if UNBNDP(port) port = cur_outp; + if (UNBNDP(port)) port = cur_outp; else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char); ASRTER(ICHRP(chr), chr, ARG1, s_write_char); lputc((int)ICHR(chr), port); @@ -684,7 +684,7 @@ SCM write_char(chr, port) SCM scm_freshline(port) SCM port; { - if UNBNDP(port) port = cur_outp; + if (UNBNDP(port)) port = cur_outp; else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline); if (INUM0==scm_port_col(port)) return UNSPECIFIED; lputc('\n', port); @@ -713,7 +713,7 @@ void lputc(c, port) } } void lputs(s, port) - char *s; + const char *s; SCM port; { sizet i = PTOBNUM(port); @@ -817,7 +817,7 @@ SCM scm_read_char(port) SCM port; { int c; - if UNBNDP(port) port = cur_inp; + if (UNBNDP(port)) port = cur_inp; ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); c = lgetc(port); if (EOF==c) return EOF_VAL; @@ -827,7 +827,7 @@ SCM peek_char(port) SCM port; { int c; - if UNBNDP(port) port = cur_inp; + if (UNBNDP(port)) port = cur_inp; else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char); c = lgetc(port); if (EOF==c) return EOF_VAL; @@ -888,11 +888,11 @@ SCM scm_read_numbered(port) static SCM lread1(port, flgs, what) SCM port; int flgs; - char *what; + const char *what; { int c; SCM tok_buf; - if UNBNDP(port) port = cur_inp; + if (UNBNDP(port)) port = cur_inp; ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, what); do { c = flush_ws(port); @@ -972,7 +972,7 @@ static SCM lreadpr(tok_buf, port, flgs) if (loc_charsharp && NIMP(*loc_charsharp)) { resizuve(tok_buf, MAKINUM(j)); p = apply(*loc_charsharp, tok_buf, listofnull); - if ICHRP(p) return p; + if (ICHRP(p)) return p; } wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf)); case '|': @@ -1040,7 +1040,7 @@ static SCM lreadpr(tok_buf, port, flgs) num: j = read_token(c, tok_buf, port); p = istring2number(CHARS(tok_buf), (long)j, 10L); - if NFALSEP(p) return p; + if (NFALSEP(p)) return p; if (c=='#') { if ((j==2) && (lgetc(port)=='(')) { lungetc('(', port); @@ -1297,7 +1297,7 @@ int handle_it(i) ALLOW_INTS; /* discarding was necessary here because intern() may do NEWCELL */ proc = CDR(intern(name, (sizet)strlen(name))); - if NIMP(proc) { /* Save environment stack, in case it moves + if (NIMP(proc)) { /* Save environment stack, in case it moves when applying proc. Do an ecache gc to protect contents of stack. */ SCM estk, *estk_ptr, env, env_tmp; @@ -1357,7 +1357,7 @@ SCM scm_top_level(initpath, toplvl_fun) char *name = errmsgs[i-WNA].s_response; if (name) { SCM proc = CDR(intern(name, (sizet)strlen(name))); - if NIMP(proc) apply(proc, EOL, EOL); + if (NIMP(proc)) apply(proc, EOL, EOL); }} i = errmsgs[i-WNA].parent_err; if (i) goto drloop; @@ -1388,7 +1388,7 @@ SCM scm_top_level(initpath, toplvl_fun) { SCM boot_tail = scm_evstr("boot-tail"); /* initialization tail-call */ - if NIMP(boot_tail) + if (NIMP(boot_tail)) apply(boot_tail, (dumped ? makfrom0str(initpath) : BOOL_F), listofnull); } case -2: /* abrt */ @@ -1420,7 +1420,7 @@ SCM scm_top_level(initpath, toplvl_fun) ints_disabled = 0; dowinds(EOL); ret = toplvl_fun(); /* typically repl() */ - if INUMP(ret) exitval = ret; + if (INUMP(ret)) exitval = ret; err_pos = (char *)EXIT; i = EXIT; goto drloop; /* encountered EOF on stdin */ @@ -1536,7 +1536,7 @@ void growth_mon(obj, size, units, grewp) } void gc_start(what) - char *what; + const char *what; { if (verbose > 4) { lputs(";GC(", sys_errp); @@ -1686,7 +1686,7 @@ SCM prolixity(arg) { int old = verbose; if (!UNBNDP(arg)) { - if FALSEP(arg) scm_verbose = 1; + if (FALSEP(arg)) scm_verbose = 1; else scm_verbose = INUM(arg); } return MAKINUM(old); @@ -1701,7 +1701,7 @@ SCM repl() if (OPINPORTP(cur_inp) && OPOUTPORTP(cur_outp)) { repl_report(); while(1) { - if OPOUTPORTP(cur_inp) { /* This case for curses window */ + if (OPOUTPORTP(cur_inp)) { /* This case for curses window */ lfflush(cur_outp); if (verbose) lputs(PROMPT, cur_inp); lfflush(cur_inp); @@ -1728,7 +1728,7 @@ SCM repl() #endif #ifdef __MSDOS__ if ('\n' != CGETUN(cur_inp)) - if OPOUTPORTP(cur_inp) /* This case for curses window */ + if (OPOUTPORTP(cur_inp)) /* This case for curses window */ {lfflush(cur_outp); newline(cur_inp);} else newline(cur_outp); #endif @@ -1761,7 +1761,7 @@ SCM quit(n) SCM n; { if (UNBNDP(n) || BOOL_T==n) n = MAKINUM(EXIT_SUCCESS); - if INUMP(n) exitval = n; + if (INUMP(n)) exitval = n; else exitval = MAKINUM(EXIT_FAILURE); if (errjmp_bad) exit(INUM(exitval)); longjump(CONT(rootcont)->jmpbuf, COOKIE(-1)); @@ -1852,7 +1852,7 @@ SCM tryload(filename, reader) SCM form, port; SCM env = EOL; port = open_file(filename, makfromstr("r?", (sizet)2*sizeof(char))); - if FALSEP(port) return port; + if (FALSEP(port)) return port; *loc_loadpath = filename; loadports = cons(port, loadports); #ifdef SCM_ENV_FILENAME @@ -1918,7 +1918,7 @@ void scm_line_msg(file, linum, port) lputs(": ", port); } void scm_err_line(what, file, linum, port) - char *what; + const char *what; SCM file, linum, port; { lputs(what, port); @@ -1983,7 +1983,7 @@ SCM lerrno(arg) { int old = errno; if (!UNBNDP(arg)) { - if FALSEP(arg) errno = 0; + if (FALSEP(arg)) errno = 0; else errno = INUM(arg); } return MAKINUM(old); @@ -2055,8 +2055,8 @@ static void def_err_response() if (codep) scm_princode(obj, EOL, sys_safep, writing); else iprin1(obj, sys_safep, writing); } - if UNBNDP(err_exp) goto getout; - if NIMP(err_exp) { + if (UNBNDP(err_exp)) goto getout; + if (NIMP(err_exp)) { if (reset_safeport(sys_safep, 55, cur_errp)) if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { lputs("\n; in expression: ", cur_errp); @@ -2093,7 +2093,7 @@ static void def_err_response() } void everr(exp, env, arg, pos, s_subr, codep) SCM exp, env, arg; - char *pos, *s_subr; + const char *pos, *s_subr; int codep; { err_exp = exp; @@ -2110,7 +2110,7 @@ void everr(exp, env, arg, pos, s_subr, codep) } void wta(arg, pos, s_subr) SCM arg; - char *pos, *s_subr; + const char *pos, *s_subr; { #ifndef RECKLESS everr(scm_trace, scm_trace_env, arg, pos, s_subr, 0); @@ -2120,7 +2120,7 @@ void wta(arg, pos, s_subr) } void scm_experr(arg, pos, s_subr) SCM arg; - char *pos, *s_subr; + const char *pos, *s_subr; { #ifndef RECKLESS everr(scm_trace, scm_trace_env, arg, pos, s_subr, !0); diff --git a/rope.c b/rope.c index b4ca0d4..c8a4d09 100644 --- a/rope.c +++ b/rope.c @@ -101,14 +101,14 @@ unsigned long num2ulong(num, pos, s_caller) char *pos, *s_caller; { unsigned long res; - if INUMP(num) { + if (INUMP(num)) { ASRTGO(0 < num, errout); res = INUM((unsigned long)num); return res; } ASRTGO(NIMP(num), errout); #ifdef FLOATS - if REALP(num) { + if (REALP(num)) { double u = REALPART(num); if ((0 <= u) && (u <= (unsigned long)~0L)) { res = u; @@ -132,13 +132,13 @@ long num2long(num, pos, s_caller) char *pos, *s_caller; { long res; - if INUMP(num) { + if (INUMP(num)) { res = INUM((long)num); return res; } ASRTGO(NIMP(num), errout); # ifdef FLOATS - if REALP(num) { + if (REALP(num)) { double u = REALPART(num); if (((MOST_NEGATIVE_FIXNUM * 4) <= u) && (u <= (MOST_POSITIVE_FIXNUM * 4 + 3))) { @@ -148,7 +148,7 @@ long num2long(num, pos, s_caller) } # endif # ifdef BIGDIG - if BIGP(num) { + if (BIGP(num)) { sizet l = NUMDIGS(num); ASRTGO(DIGSPERLONG >= l, errout); res = 0; @@ -173,11 +173,12 @@ double num2dbl(num, pos, s_caller) SCM num; char *pos, *s_caller; { - if INUMP(num) return (double)INUM(num); + if (INUMP(num)) return (double)INUM(num); ASRTGO(NIMP(num), errout); - if REALP(num) return REALPART(num); + if (REALP(num)) return REALPART(num); + if (scm_narn==num) return REALPART(num); #ifdef BIGDIG - if BIGP(num) return big2dbl(num); + if (BIGP(num)) return big2dbl(num); #endif errout: wta(num, pos, s_caller); } @@ -185,7 +186,7 @@ double num2dbl(num, pos, s_caller) /* Convert (arrays of) strings to SCM */ SCM makfromstr(src, len) - char *src; + const char *src; sizet len; { SCM s; @@ -196,7 +197,7 @@ SCM makfromstr(src, len) return s; } SCM makfrom0str(src) - char *src; + const char *src; { if (!src) return BOOL_F; return makfromstr(src, (sizet) strlen(src)); @@ -205,7 +206,7 @@ SCM makfrom0str(src) /* If argc < 0, a null terminated array is assumed. */ SCM makfromstrs(argc, argv) int argc; - char **argv; + const char * const *argv; { int i = argc; SCM lst = EOL; @@ -217,9 +218,9 @@ SCM makfromstrs(argc, argv) /* INTS must be DEFERed around this call and the use of the returned array. */ char **makargvfrmstrs(args, s_name) SCM args; - char *s_name; + const char *s_name; { - char **argv; + char ** argv; int argc = ilength(args); argv = (char **)must_malloc((1L+argc)*sizeof(char *), s_vector); for(argc = 0; NNULLP(args); args=CDR(args), ++argc) { @@ -236,7 +237,7 @@ char **makargvfrmstrs(args, s_name) return argv; } void must_free_argv(argv) - char **argv; + const char * const *argv; { sizet i; for(i = 0; argv[i]; i++) { @@ -282,7 +283,7 @@ int scm_ldprog(path) /* Get byte address of SCM array */ #ifdef ARRAYS -long aind P((SCM ra, SCM args, char *what)); +long aind P((SCM ra, SCM args, const char *what)); unsigned long scm_addr(args, s_name) SCM args; char *s_name; @@ -293,18 +294,18 @@ unsigned long scm_addr(args, s_name) ASRTGO(NIMP(args), wna); v = CAR(args); args = CDR(args); - if IMP(v) {goto badarg;} - else if ARRAYP(v) { + if (IMP(v)) {goto badarg;} + else if (ARRAYP(v)) { pos = aind(v, args, s_name); v = ARRAY_V(v); } else { - if NIMP(args) { + if (NIMP(args)) { ASRTER(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_name); pos = INUM(CAR(args)); ASRTGO(NULLP(CDR(args)), wna); } - else if NULLP(args) pos = 0; + else if (NULLP(args)) pos = 0; else { ASRTER(INUMP(args), args, ARG2, s_name); pos = INUM(args); @@ -346,8 +347,8 @@ unsigned long scm_base_addr(v, s_name) { long pos = 0; unsigned long ptr = 0; /* gratuitous assignment squelches cc warn. */ - if IMP(v) {goto badarg;} - else if ARRAYP(v) { + if (IMP(v)) {goto badarg;} + else if (ARRAYP(v)) { pos = ARRAY_BASE(v); v = ARRAY_V(v); } @@ -394,13 +395,13 @@ int scm_cell_p(x) { register int i, j; register CELLPTR ptr; - if NCELLP(x) return 0; + if (NCELLP(x)) return 0; ptr = (CELLPTR)SCM2PTR(x); i = 0; j = hplim_ind; do { - if PTR_GT(hplims[i++], ptr) break; - if PTR_LE(hplims[--j], ptr) break; + if (PTR_GT(hplims[i++], ptr)) break; + if (PTR_LE(hplims[--j], ptr)) break; if ((i != j) && PTR_LE(hplims[i++], ptr) && PTR_GT(hplims[--j], ptr)) continue; @@ -419,7 +420,7 @@ SCM scm_gc_protect(obj) { long len; ASRTER(NIMP(scm_uprotects), MAKINUM(20), NALLOC, "protects"); - if IMP(obj) return obj; + if (IMP(obj)) return obj; for (len = LENGTH(scm_uprotects);len--;) { if (obj==VELTS(scm_uprotects)[len]) return obj; } diff --git a/rwb-isam.scm b/rwb-isam.scm new file mode 100644 index 0000000..962a97b --- /dev/null +++ b/rwb-isam.scm @@ -0,0 +1,616 @@ +;;; "rwb-isam.scm" Relational WB database with sequential indexes. +; Copyright 1996, 2000, 2001, 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;; *catalog* is informed of 'rwb-isam binding by "scm/mkimpcat.scm". +(require 'wb) +(require 'byte) +(require 'byte-number) +(require 'relational-database) ;for make-relational-system + +;;; WB-SEG:LOCKS has one extra location at end for loop end test +(defvar wb-seg:locks (let ((locks (make-vector (+ 1 wb:num-segs) #f))) + (do ((i (+ -2 (vector-length locks)) (+ -1 i))) + ((negative? i) locks) + (vector-set! locks i (make-arbiter i))))) +(defvar wb-seg:files (make-vector (+ 1 wb:num-segs) #f)) +(defvar wb-seg:roots (make-vector (+ 1 wb:num-segs) #f)) +(defvar wb-seg:mut?s (make-vector (+ 1 wb:num-segs) #f)) +;@ +(define rwb-isam + ;; foiled indentation so etags will recognize definitions + (let ((make-handle list) + (handle->base-id car) + (handle->bt cadr) + (catalog-id 0) + (free-id "") + (root-name "rwb") + (key:s255 (bytes 255)) + (key:col1 (bytes 1)) + (key:col0 (bytes 0)) + (key:null (bytes 0)) + + (key:col-field bytes)) + +;;;The least-upper-bound of a composite key. +(define (key:incr key) + (string-append key key:s255)) + +;;;Return key sans prefix and column suffix if first column. +(define (key:match-prefix? prefix ckey) + (define sdx (+ -1 (string-length ckey))) + (define prelen (string-length prefix)) + (and (<= prelen sdx) + (string=? prefix (substring ckey 0 prelen)) + (substring ckey prelen sdx))) + +;;;Detects when all match-keys given are false. +(define (list-all-false? lst) + (cond ((null? lst) #t) + ((car lst) #f) + (else (list-all-false? (cdr lst))))) + +;;; These two NTHCDR procedures replicate those in "comlist.scm". +(define (nthcdr k list) + (do ((i k (+ -1 i)) + (lst list (cdr lst))) + ((<= i 0) lst))) + +(define (butnthcdr k lst) + (cond ((or (zero? k) (null? lst)) '()) + (else (let ((ans (list (car lst)))) + (do ((lst (cdr lst) (cdr lst)) + (tail ans (cdr tail)) + (k (+ -2 k) (+ -1 k))) + ((or (negative? k) (null? lst)) ans) + (set-cdr! tail (list (car lst)))))))) + +;;;; Segments + +(define (find-free-seg) + (do ((i 0 (+ 1 i)) + (arb (vector-ref wb-seg:locks 0) + (vector-ref wb-seg:locks (+ 1 i)))) + ((or (not arb) (try-arbiter arb)) + (and arb i)))) +(define (release-seg seg) + (and seg + (release-arbiter (vector-ref wb-seg:locks seg)) + #f)) + +;;;; Create, open, write, sync, or close database. + +(define (seg-open-base seg filename writable?) + (vector-set! wb-seg:files seg filename) + (vector-set! wb-seg:mut?s seg writable?) + (vector-set! wb-seg:roots seg (open-db seg root-name)) + (cond ((wb:err? (vector-ref wb-seg:roots seg)) + (close-base seg) + #f) + (else seg))) + +;;; Because B-trees grow in depth only very slowly, we might as well +;;; put everything into one B-tree named "rwb". + +(define (make-base filename dim types) + (define seg (find-free-seg)) + (cond ((not seg) #f) + ((wb:err? (make-seg seg filename 2048)) (release-seg seg) #f) + ((wb:err? (open-seg seg filename 2)) (release-seg seg) #f) + ((or (wb:err? (bt:put! (create-db seg #\T root-name) free-id "1")) + (wb:err? (bt:put! (open-bt seg 0 1) "base-table" "rwb-isam"))) + (release-seg seg) + (slib:error 'make-base "couldn't modify new base" filename) + #f) + (else (seg-open-base seg filename #t)))) + +(define (open-base filename writable?) + (define seg (find-free-seg)) + (cond ((wb:err? (open-seg seg filename (if writable? 2 0))) + (release-seg seg) #f) + (else (seg-open-base seg filename writable?)))) + +(define (write-base seg filename) + (cond ((and filename + (equal? filename (vector-ref wb-seg:files seg))) + (let ((status (close-seg seg #f))) + (cond ((wb:err? status) #f) + ((wb:err? (open-seg seg filename 2)) #f) + (else #t)))) + (else + ;;(slib:error 'write-base "WB can't change database filename" filename) + #f))) + +(define (sync-base seg) + (and seg (write-base seg (vector-ref wb-seg:files seg)))) + +(define (close-base seg) + (cond ((wb:err? (close-seg seg #f)) + (let ((status (close-seg seg #t))) + (release-seg seg) + (not (wb:err? status)))) + (else (release-seg seg) #t))) + +;;;; Make, open, and destroy tables. + +(define (make-table seg dim types) + (and (vector-ref wb-seg:mut?s seg) + (let* ((tns (bt:rem (vector-ref wb-seg:roots seg) free-id)) + (base-id (and (string? tns) (string->number tns)))) + (cond ((not tns) + (slib:error 'make-table 'free-id "in use?") + #f) + ((not base-id) + (bt:put (vector-ref wb-seg:roots seg) free-id tns) + (slib:error 'make-table "free-id corrupted" base-id) + #f) + ((not (bt:put (vector-ref wb-seg:roots seg) + free-id + (number->string (+ 1 base-id)))) + (slib:error 'make-table "free-id lock broken") + #f) + (else base-id))))) + +;;; OPEN-TABLE allocates a new handle (in call to open-db) so each +;;; table handle will have its own last-block-used + +(define (open-table seg base-id dim types) + (define (base-id->prefix base-id) + (define nstr (number->string base-id)) + (string-append (string #\T (integer->char (string-length nstr))) + nstr + (string (integer->char 1) #\D))) + (make-handle (base-id->prefix base-id) + (open-db seg root-name))) + +(define (kill-table seg base-id dim types) + (let* ((handle (open-table seg base-id dim types)) + (prefix (handle->base-id handle))) + (not (wb:err? (bt:rem* (handle->bt handle) + prefix + (key:incr prefix)))))) + +;;;; Conversions from Scheme objects into and from strings. + +(define (object->wb-string type) + (case type + ((string) identity) + ((symbol) symbol->string) + ((integer number ordinal) number->string) + ((boolean) (lambda (b) (if b "T" "F"))) + ((c64) (lambda (x) (string-append (ieee-double->bytes (real-part x)) + (ieee-double->bytes (imag-part x))))) + ((c32) (lambda (x) (string-append (ieee-float->bytes (real-part x)) + (ieee-float->bytes (imag-part x))))) + ((r64) (lambda (x) (ieee-double->bytes x))) + ((r32) (lambda (x) (ieee-float->bytes x))) + ((s64) (lambda (n) (integer->bytes n -8))) + ((s32) (lambda (n) (integer->bytes n -4))) + ((s16) (lambda (n) (integer->bytes n -2))) + (( s8) (lambda (n) (integer->bytes n -1))) + ((u64) (lambda (n) (integer->bytes n 8))) + ((u32) (lambda (n) (integer->bytes n 4))) + ((u16) (lambda (n) (integer->bytes n 2))) + (( u8) (lambda (n) (integer->bytes n 1))) + ((atom) (lambda (obj) (if (not obj) "#f" (symbol->string obj)))) + ((expression) (lambda (obj) (call-with-output-string + (lambda (port) (write obj port))))) + (else #f))) + +(define (wb-string->object type) + (case type + ((string) identity) + ((symbol) string->symbol) + ((integer number ordinal) string->number) + ((boolean) (lambda (str) (not (equal? str "F")))) + ((c64) (lambda (str) (make-rectangular + (bytes->ieee-double (substring str 0 8)) + (bytes->ieee-double (substring str 8 16))))) + ((c32) (lambda (str) (make-rectangular + (bytes->ieee-float (substring str 0 4)) + (bytes->ieee-float (substring str 4 8))))) + ((r64) (lambda (str) (bytes->ieee-double str))) + ((r32) (lambda (str) (bytes->ieee-float str))) + ((s64) (lambda (str) (bytes->integer str -8))) + ((s32) (lambda (str) (bytes->integer str -4))) + ((s16) (lambda (str) (bytes->integer str -2))) + (( s8) (lambda (str) (bytes->integer str -1))) + ((u64) (lambda (str) (bytes->integer str 8))) + ((u32) (lambda (str) (bytes->integer str 4))) + ((u16) (lambda (str) (bytes->integer str 2))) + (( u8) (lambda (str) (bytes->integer str 1))) + ((atom) (lambda (str) (if (string-ci=? "#f" str) #f (string->symbol str)))) + ((expression) (lambda (str) (call-with-input-string str read))) + (else #f))) + +(define (supported-type? type) + (case type + ((ordinal atom integer number boolean string symbol expression + c64 c32 r64 r32 s64 s32 s16 s8 u64 u32 u16 u8) #t) + (else #f))) + +(define (supported-key-type? type) + (case type + ((atom ordinal integer number symbol string boolean + r64 r32 s64 s32 s16 s8 u64 u32 u16 u8) #t) + (else #f))) + +;;;; Keys + +;;;Keys are composed of one to many fields. +;;; +;;;* The binary number formats r64, r32, s64, s32, s16, s8, u64, u32, +;;; u16, and u8 have fixed widths and are encoded so that the key +;;; sort order is the same as numerical order. +;;; +;;;* Booleans occupy one byte: 'T' or 'F'. +;;; +;;;* Strings, symbols, and atoms (symbol or #f) are variable width +;;; fields terminated by a null byte. They sort in lexicographic +;;; (dictionary) order. A #f atom is represented by the null string. +;;; +;;;* The integer, number, and ordinal formats are strings of decimal +;;; digits preceeded by a length byte. Nonnegative integers sort +;;; correctly. +;;; +;;;Use of null bytes in string, symbol, or atom key-fields will break +;;;this encoding. + +(define (string-number-keyifier n) + (define str (number->string n)) + (string-append (bytes (string-length str)) str)) + +(define (string-keyifier str) + (string-append str key:null)) + +(define (key:shorten-1 str) + (substring str 0 (+ -1 (string-length str)))) + +;;; unitary composite-key maker +(define (make-keyifier-1 type) + (case type + ((string) string-keyifier) + ((symbol) (lambda (s) (string-keyifier (symbol->string s)))) + ((atom) (lambda (obj) (string-keyifier (if obj (symbol->string obj) "")))) + ((boolean) (lambda (b) (if b "T" "F"))) + ((integer number ordinal) string-number-keyifier) + ;; binary number formats + ((r64) (lambda (x) (ieee-byte-collate! (ieee-double->bytes x)))) + ((r32) (lambda (x) (ieee-byte-collate! (ieee-float->bytes x)))) + ((s64) (lambda (n) (integer-byte-collate! (integer->bytes n -8)))) + ((s32) (lambda (n) (integer-byte-collate! (integer->bytes n -4)))) + ((s16) (lambda (n) (integer-byte-collate! (integer->bytes n -2)))) + (( s8) (lambda (n) (integer->bytes n -1))) + ((u64) (lambda (n) (integer-byte-collate! (integer->bytes n 8)))) + ((u32) (lambda (n) (integer-byte-collate! (integer->bytes n 4)))) + ((u16) (lambda (n) (integer-byte-collate! (integer->bytes n 2)))) + (( u8) (lambda (n) (integer->bytes n 1))) + (else (slib:error 'make-keyifier-1 'unsupported-type type)))) + +;;; composite-key maker +(define (key-polymerase prinum types) + (set! types (butnthcdr prinum types)) + ;; Special case when there is just one primary key. + (if (= 1 prinum) + (let ((proc (make-keyifier-1 (car types)))) + (lambda (lst) (proc (car lst)))) + (let ((procs (map make-keyifier-1 types))) + (lambda (lst) + (apply string-append (map (lambda (p v) (p v)) procs lst)))))) + +(define (key:width type) + (case type + ((r64 s64 u64) 8) + ((r32 s32 u32) 4) + ((s16 u16) 2) + ((s8 u8 boolean) 1) + ((integer number ordinal) + (lambda (key pos) (+ 1 (byte-ref key pos)))) + ((string symbol atom) ;null terminated + (lambda (key pos) + (do ((i pos (+ 1 i))) + ((zero? (byte-ref key i)) (- i pos -1))))) + (else #f))) + +(define (exokeyase type) + (case type + ((string) key:shorten-1) + ((symbol) (lambda (str) (string->symbol (key:shorten-1 str)))) + ((atom) (lambda (str) (if (string=? "" str) #f + (string->symbol (key:shorten-1 str))))) + ((boolean) (lambda (str) (not (string=? "F" str)))) + ((integer number ordinal) + (lambda (str) (string->number (substring str 1 (string-length str))))) + ;; binary number formats + ((r64) (lambda (str) (bytes->ieee-double (ieee-byte-decollate! str)))) + ((r32) (lambda (str) (bytes->ieee-float (ieee-byte-decollate! str)))) + ((s64) (lambda (str) (bytes->integer (integer-byte-collate! str) -8))) + ((s32) (lambda (str) (bytes->integer (integer-byte-collate! str) -4))) + ((s16) (lambda (str) (bytes->integer (integer-byte-collate! str) -2))) + (( s8) (lambda (str) (bytes->integer str -1))) + ((u64) (lambda (str) (bytes->integer (integer-byte-collate! str) 8))) + ((u32) (lambda (str) (bytes->integer (integer-byte-collate! str) 4))) + ((u16) (lambda (str) (bytes->integer (integer-byte-collate! str) 2))) + (( u8) (lambda (str) (bytes->integer str 1))) + (else #f))) + +;;; extracts one key-field from composite-key +(define (make-key-extractor primary-limit types index) + (define (wither type) + (or (key:width type) + (slib:error 'make-key-extractor 'unsupported-type type))) + (let ((proc (exokeyase (list-ref types (+ -1 index)))) + (skips (map wither (butnthcdr index types)))) + (lambda (key) + (let loop ((pos 0) (skips skips)) + (define flen (car skips)) + (if (procedure? flen) (set! flen (flen key pos))) + (if (null? (cdr skips)) + (proc (substring key pos (+ pos flen))) + (loop (+ pos flen) (cdr skips))))))) + +;;; composite-key to list +(define (make-key->list primary-limit types) + (define (wither type) + (or (key:width type) + (slib:error 'make-key->list 'unsupported-type type))) + (define typs (butnthcdr primary-limit types)) + (let ((procs (map exokeyase typs)) + (skips (map wither typs))) + (lambda (key) + (let loop ((pos 0) (skips skips) (procs procs)) + (define flen (car skips)) + (if (procedure? flen) (set! flen (flen key pos))) + ;;(print 'key->list pos flen typs key) + (cons ((car procs) (substring key pos (+ pos flen))) + (if (null? (cdr skips)) + '() + (loop (+ pos flen) (cdr skips) (cdr procs)))))))) + +;;;; for-each-key, ordered-for-each-key, and map-key + +(define (make-key-match? key-dimension column-types match-keys) + (if (list-all-false? match-keys) + (lambda (ckey) #t) + (let ((keyploder (make-key->list key-dimension column-types))) + (lambda (ckey) + (define (key-match? match-keys keys) + (cond ((null? match-keys) #t) + ((not (car match-keys)) + (key-match? (cdr match-keys) (cdr keys))) + ((equal? (car match-keys) (car keys)) + (key-match? (cdr match-keys) (cdr keys))) + ((not (procedure? (car match-keys))) + #f) + (((car match-keys) (car keys)) + (key-match? (cdr match-keys) (cdr keys))) + (else #f))) + (key-match? match-keys (keyploder ckey)))))) + +(define (map-key handle operation key-dimension column-types match-keys) + (define lst (list 'dummy)) + (let ((tail lst)) + (ordered-for-each-key handle + (lambda (k) + (set-cdr! tail (list (operation k))) + (set! tail (cdr tail))) + key-dimension column-types match-keys) + (cdr lst))) + +;;;; Indexed Sequential Access Methods + +(define (ordered-for-each-key handle operation key-dimension column-types match-keys) + (let ((bt (handle->bt handle)) + (prefix (handle->base-id handle)) + (key-match? (make-key-match? key-dimension column-types match-keys))) + (case (- (length column-types) key-dimension) + ((0) (let ((prefix+ (key:incr prefix)) + (maproc (lambda (ckey val) + (define fkey (key:match-prefix? prefix ckey)) + ;;(print 'ordered-for-each-key ckey fkey) + (and fkey (key-match? fkey) (operation fkey)) + #f))) + (do ((res (bt:scan bt 0 prefix prefix+ maproc 1) + (bt:scan bt 0 (caddr res) prefix+ maproc 1))) + ((not (= -1 (car res))))))) + (else (let ((prelen (string-length prefix))) + (do ((nkey (bt:next bt prefix) + (bt:next bt (key:incr (key:shorten-1 nkey))))) + ((or (not nkey) + (not (string=? prefix (substring nkey 0 prelen)))) + #f) + ;;(print 'ordered-for-each-key nkey (key:match-prefix? prefix nkey)) + (let ((fkey (key:match-prefix? prefix nkey))) + (and fkey (key-match? fkey) (operation fkey))))))))) + +(define (make-nexter handle key-dimension column-types index) + (define bt (handle->bt handle)) + (define prefix (handle->base-id handle)) + (define key->list (make-key->list key-dimension column-types)) + (define list->key (key-polymerase key-dimension column-types)) + (lambda keys + (define nkey + (bt:next bt (string-append prefix + (list->key (butnthcdr index keys)) + key:s255))) + (and nkey (let ((ckey (key:match-prefix? prefix nkey))) + (and ckey (key->list ckey)))))) + +(define (make-prever handle key-dimension column-types index) + (define bt (handle->bt handle)) + (define ldx (- (length column-types) key-dimension)) + (define prefix (handle->base-id handle)) + (define key->list (make-key->list key-dimension column-types)) + (define list->key (key-polymerase key-dimension column-types)) + (lambda keys + (define pkey + (bt:prev bt (string-append prefix + (list->key (butnthcdr index keys))))) + (and pkey (let ((ckey (key:match-prefix? prefix pkey))) + (and ckey (key->list ckey)))))) + +;;;; getters and putters + +;;;Records are stored as multiple copies of the key to which a +;;;one-byte code is appended, identifying the field. If all fields +;;;are primary keys, then KEY:COL0 (a 0 byte) is appended. + +(define (make-getter-1 prinum types index) + (define type (list-ref types (- index prinum))) + (let ((proc (or (wb-string->object type) + (slib:error 'make-getter-1 'unsupported-type type))) + (ci (key:col-field (- index prinum)))) + (lambda (handle key) + (define val + (db:get + (handle->bt handle) + (string-append (handle->base-id handle) key ci))) ; (print 'ckey ) + (and val (proc val))))) + +;;;If more than one non-primary value is stored, then use SCAN to +;;;extract the values. + +(define (make-getter prinum types) + (define (wbstr->obj type) + (or (wb-string->object type) + (slib:error 'make-getter 'unsupported-type type))) + (case (- (length types) prinum) + ((0) (lambda (handle key) + (and (db:get (handle->bt handle) + (string-append (handle->base-id handle) key key:col0)) + '()))) + ((1) (let ((proc (wbstr->obj (list-ref types prinum)))) + (lambda (handle key) + (define val + (db:get + (handle->bt handle) + (string-append (handle->base-id handle) key key:col1))) + (and val (list (proc val)))))) + (else (let ((procs (map wbstr->obj (nthcdr prinum types)))) + (lambda (handle key) + (define lst (list 'dummy)) + (define idx 1) + (let ((bt (handle->bt handle)) + (prefix (string-append (handle->base-id handle) key)) + (tail lst)) + (define (loop procs) + (define val (db:get bt (string-append prefix (bytes idx)))) + (cond (val (set-cdr! tail (list ((car procs) val))) + (set! tail (cdr tail)) + (set! idx (+ 1 idx)) + (if (null? (cdr procs)) + (cdr lst) + (loop (cdr procs)))) + (else #f))) + (loop procs))))))) + +(define (make-putter prinum types) + (define (obj->wbstr type) + (or (object->wb-string type) + (slib:error 'make-putter 'unsupported-type type))) + (case (- (length types) prinum) + ((0) (lambda (handle ckey restcols) + (bt:put! (handle->bt handle) + (string-append (handle->base-id handle) ckey key:col0) + ""))) + ((1) (let ((proc (obj->wbstr (list-ref types prinum)))) + (lambda (handle ckey restcols) + (db:put! (handle->bt handle) + (string-append (handle->base-id handle) ckey key:col1) + (proc (car restcols)))))) + (else (let ((procs (map obj->wbstr (nthcdr prinum types)))) + (lambda (handle ckey restcols) + (define i 0) + (for-each + (lambda (proc val) + (set! i (+ 1 i)) + (db:put! (handle->bt handle) + (string-append (handle->base-id handle) + ckey + (key:col-field i)) + (proc val))) + procs restcols)))))) + +;;;; other table methods. + +(define (present? handle key) + (let* ((kc (string-append (handle->base-id handle) key)) + (kcl (string-length kc)) + (n (bt:next (handle->bt handle) kc))) + (and n + (<= (+ 1 kcl) (string-length n) (+ 2 kcl)) + (string=? kc (substring n 0 kcl))))) + +(define (delete handle key) + (let ((prefix (string-append (handle->base-id handle) key))) + (not (wb:err? (bt:rem* (handle->bt handle) + prefix + (key:incr prefix)))))) + +(define (delete* handle key-dimension column-types match-keys) + (let ((prefix (string-append (handle->base-id handle) match-keys))) + (not (wb:err? (bt:rem* (handle->bt handle) + prefix + (key:incr prefix)))))) + + (lambda (operation-name) + ;;(require 'trace) + #+foo ; To trace methods use this wrapper: + ((lambda (proc) + (if (procedure? proc) + (lambda args + (let ((ans (apply proc args))) + (if (procedure? ans) + (tracef ans operation-name) + ans))) + proc)) + ) + (case operation-name + ((make-base) make-base) + ((open-base) open-base) + ((write-base) write-base) + ((sync-base) sync-base) + ((close-base) close-base) + ((make-table) make-table) + ((open-table) open-table) + ((kill-table) kill-table) + ((make-keyifier-1) make-keyifier-1) + ((make-list-keyifier) key-polymerase) + ((make-key->list) make-key->list) + ((make-key-extractor) make-key-extractor) + ((supported-type?) supported-type?) + ((supported-key-type?) supported-key-type?) + ((present?) present?) + ((make-putter) make-putter) + ((make-getter) make-getter) + ((make-getter-1) make-getter-1) + ((delete) delete) + ((delete*) delete*) + ((for-each-key) ordered-for-each-key) + ((map-key) map-key) + ((ordered-for-each-key) ordered-for-each-key) + ((make-nexter) make-nexter) + ((make-prever) make-prever) + ((catalog-id) catalog-id) + (else #f)) + ))) + +(set! *base-table-implementations* + (cons (list 'rwb-isam (make-relational-system rwb-isam)) + *base-table-implementations*)) +;;(trace bt:scan bt:get make-getter map-key ordered-for-each-key make-key-extractor make-key->list) (set! *qp-width* 333) ;;(trace-all "rwb-isam.scm") diff --git a/sc2.c b/sc2.c index 5749b63..1487dbd 100644 --- a/sc2.c +++ b/sc2.c @@ -135,7 +135,7 @@ SCM strnullp(str) SCM str; { ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_strnullp); - if LENGTH(str) return BOOL_F; + if (LENGTH(str)) return BOOL_F; else return BOOL_T; } @@ -145,11 +145,11 @@ SCM appendb(args) { SCM arg; tail: - if NULLP(args) return EOL; + if (NULLP(args)) return EOL; arg = CAR(args); args = CDR(args); - if NULLP(args) return arg; - if NULLP(arg) goto tail; + if (NULLP(args)) return arg; + if (NULLP(arg)) goto tail; ASRTER(NIMP(arg) && CONSP(arg), arg, ARG1, s_appendb); CDR(last_pair(arg)) = appendb(args); return arg; diff --git a/scl.c b/scl.c index 2858989..9fe779f 100644 --- a/scl.c +++ b/scl.c @@ -56,7 +56,7 @@ static int apx_log10 P((double x)); static double lpow10 P((double x, int n)); static sizet idbl2str P((double f, char *a)); static sizet iflo2str P((SCM flt, char *str)); -static void add1 P((double f, double *fsum)); +static void safe_add_1 P((double f, double *fsum)); static long scm_twos_power P((SCM n)); static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar", @@ -72,7 +72,7 @@ SCM sys_protects[NUM_PROTECTS]; sizet num_protects = NUM_PROTECTS; char s_inexactp[] = "inexact?"; -static char s_zerop[] = "zero?", +static char s_zerop[] = "zero?", s_abs[] = "abs", s_positivep[] = "positive?", s_negativep[] = "negative?"; static char s_lessp[] = "<", s_grp[] = ">"; static char s_leqp[] = "<=", s_greqp[] = ">="; @@ -88,7 +88,7 @@ static char s_str2list[] = "string->list"; static char s_st_copy[] = "string-copy", s_st_fill[] = "string-fill!"; static char s_vect2list[] = "vector->list", s_ve_fill[] = "vector-fill!"; static char s_intexpt[] = "integer-expt"; - +static char str_inf0[] = "inf.0"; /*** NUMBERS -> STRINGS ***/ #ifdef FLOATS @@ -114,11 +114,11 @@ static int apx_log10(x) double x; { int expt; - double frac = frexp(x, &expt); + frexp(x, &expt); expt -= 1; if (expt >= 0) return (int)(expt * llog2); - return -((int)( -expt * llog2)); + return -((int)(-expt * llog2)); } static double p10[] = {1.0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7}; @@ -146,8 +146,21 @@ int inf2str(f, a) { sizet ch = 0; if (f < 0.0) a[ch++] = '-'; - a[ch++] = (f != f) ? '0' : '1'; - a[ch++] = '/'; a[ch++] = '0'; + else if (f > 0.0) a[ch++] = '+'; + else { + a[ch++] = '0'; a[ch++] = '/'; a[ch++] = '0'; + return ch; + } + while (str_inf0[ch - 1]) { + a[ch] = str_inf0[ch - 1]; + ch++; + } +/* # ifdef COMPACT_INFINITY_NOTATION */ +/* else a[ch++] = '0'; */ +/* # else */ +/* a[ch++] = (f != f) ? '0' : '1'; */ +/* # endif */ +/* a[ch++] = '/'; a[ch++] = '0'; */ return ch; } @@ -260,12 +273,12 @@ static sizet iflo2str(flt, str) { sizet i; # ifdef SINGLES - if SINGP(flt) i = idbl2str(FLO(flt), str); + if (SINGP(flt)) i = idbl2str(FLO(flt), str); else # endif i = idbl2str(REAL(flt), str); if (scm_narn==flt) return i; - if CPLXP(flt) { + if (CPLXP(flt)) { if (!(0 > IMAG(flt))) str[i++] = '+'; i += idbl2str(IMAG(flt), &str[i]); str[i++] = 'i'; @@ -313,10 +326,10 @@ static SCM big2str(b, radix) sizet i = NUMDIGS(t); sizet j = radix==16 ? (BITSPERDIG*i)/4+2 : radix >= 10 ? (BITSPERDIG*i*241L)/800+2 - : (BITSPERDIG*i)+2; + : (BITSPERDIG*i)+2; sizet k = 0; sizet radct = 0; - sizet ch; /* jeh */ + sizet ch; /* jeh */ BIGDIG radpow = 1, radmod = 0; SCM ss = makstr((long)j); char *s = CHARS(ss), c; @@ -335,7 +348,7 @@ static SCM big2str(b, radix) c = radmod % radix; radmod /= radix; k--; s[--j] = c < 10 ? c + '0' : c + 'a' - 10; } - ch = s[0]=='-' ? 1 : 0; /* jeh */ + ch = s[0]=='-' ? 1 : 0; /* jeh */ if (ch < j) { /* jeh */ for(i = j;j < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */ resizuve(ss, (SCM)MAKINUM(ch+LENGTH(ss)-i)); /* jeh */ @@ -346,17 +359,17 @@ static SCM big2str(b, radix) SCM number2string(x, radix) SCM x, radix; { - if UNBNDP(radix) radix=MAKINUM(10L); + if (UNBNDP(radix)) radix=MAKINUM(10L); else ASRTER(INUMP(radix), radix, ARG2, s_number2string); #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { char num_buf[FLOBUFLEN]; # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) return big2str(x, (unsigned int)INUM(radix)); + if (BIGP(x)) return big2str(x, (unsigned int)INUM(radix)); # ifndef RECKLESS if (!(INEXP(x))) - badx: wta(x, (char *)ARG1, s_number2string); + badx: wta(x, (char *)ARG1, s_number2string); # endif # else ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_number2string); @@ -365,7 +378,7 @@ SCM number2string(x, radix) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_number2string); return big2str(x, (unsigned int)INUM(radix)); } @@ -453,7 +466,7 @@ SCM istr2int(str, len, radix) t2 = c; moretodo: while(k < blen) { -/* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/ +/* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/ t2 += ds[k]*radix; ds[k++] = BIGLO(t2); t2 = BIGDN(t2); @@ -466,7 +479,7 @@ SCM istr2int(str, len, radix) } } while (i < len); if (blen * BITSPERDIG/CHAR_BIT <= sizeof(SCM)) - if INUMP(res = big2inum(res, blen)) return res; + if (INUMP(res = big2inum(res, blen))) return res; if (j==blen) return res; return adjbig(res, blen); } @@ -532,7 +545,7 @@ static long scm_twos_power(n) long d, c = 0; int d4; # ifdef BIGDIG - if NINUMP(n) { + if (NINUMP(n)) { BIGDIG *ds; int i = 0; ds = BDIGITS(n); @@ -558,7 +571,7 @@ SCM istr2flo(str, len, radix) register long radix; { register int c, i = 0; - double lead_sgn; + double lead_sgn = 0.0; double res = 0.0, tmp = 0.0; int flg = 0; int point = 0; @@ -569,15 +582,27 @@ SCM istr2flo(str, len, radix) switch (*str) { /* leading sign */ case '-': lead_sgn = -1.0; i++; break; case '+': lead_sgn = 1.0; i++; break; - default : lead_sgn = 0.0; } if (i==len) return BOOL_F; /* bad if lone `+' or `-' */ +# ifdef FLOATS + if (6==len && ('+'==str[0] || '-'==str[0])) + if (0==strcmp(str_inf0, &str[1])) + return makdbl(1./0. * ('+'==str[0] ? 1 : -1), 0.0); +# endif + if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */ if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */ if (++i < len) return BOOL_F; /* `i' not last character */ return makdbl(0.0, lead_sgn); } + /* # ifdef COMPACT_INFINITY_NOTATION */ + if (0.0 != lead_sgn && str[i]=='/') { + res = 1; + flg = 1; + goto out1; + } + /* # endif */ do { /* check initial digits */ switch (c = str[i]) { case DIGITS: @@ -637,7 +662,7 @@ SCM istr2flo(str, len, radix) } } out2: -/* if (tmp==0.0) return BOOL_F; /\* `slash zero' not allowed *\/ */ + /* if (tmp==0.0) return BOOL_F; /\* `slash zero' not allowed *\/ */ if (i < len) while (str[i]=='#') { /* optional sharps */ tmp *= radix; @@ -686,9 +711,9 @@ SCM istr2flo(str, len, radix) switch (c = str[i]) { case DIGITS: expon = expon*10 + c-'0'; -/* if (expon > MAXEXP) */ -/* if (1==expsgn || expon > (MAXEXP + dblprec + 1)) */ -/* return BOOL_F; /\* exponent too large *\/ */ + /* if (expon > MAXEXP) */ + /* if (1==expsgn || expon > (MAXEXP + dblprec + 1)) */ + /* return BOOL_F; /\* exponent too large *\/ */ break; default: goto out4; @@ -706,7 +731,7 @@ SCM istr2flo(str, len, radix) # ifdef _UNICOS while (point++) res *= 0.1; # else - while (point++) res /= 10.0; + while (point++) res /= 10.0; # endif done: @@ -726,7 +751,7 @@ SCM istr2flo(str, len, radix) case '@': { /* polar input for complex number */ /* get a `real' for angle */ second = istr2flo(&str[i], (long)(len-i), radix); - if IMP(second) return BOOL_F; + if (IMP(second)) return BOOL_F; if (!(INEXP(second))) return BOOL_F; /* not `real' */ if (CPLXP(second)) return BOOL_F; /* not `real' */ tmp = REALPART(second); @@ -741,7 +766,7 @@ SCM istr2flo(str, len, radix) if (i==(len-1)) return makdbl(res, lead_sgn); /* get a `ureal' for complex part */ second = istr2flo(&str[i], (long)((len-i)-1), radix); - if IMP(second) return BOOL_F; + if (IMP(second)) return BOOL_F; if (!(INEXP(second))) return BOOL_F; /* not `ureal' */ if (CPLXP(second)) return BOOL_F; /* not `ureal' */ tmp = REALPART(second); @@ -780,7 +805,7 @@ SCM istring2number(str, len, radix) return istr2int(&str[i], len-i, radix); case 0: res = istr2int(&str[i], len-i, radix); - if NFALSEP(res) return res; + if (NFALSEP(res)) return res; #ifdef FLOATS case 2: return istr2flo(&str[i], len-i, radix); #endif @@ -792,7 +817,7 @@ SCM istring2number(str, len, radix) SCM string2number(str, radix) SCM str, radix; { - if UNBNDP(radix) radix=MAKINUM(10L); + if (UNBNDP(radix)) radix=MAKINUM(10L); else ASRTER(INUMP(radix), radix, ARG2, s_str2number); ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_str2number); return istring2number(CHARS(str), LENGTH(str), INUM(radix)); @@ -807,8 +832,8 @@ SCM makdbl (x, y) if ((y==0.0) && (x==0.0)) return flo0; # ifndef _MSC_VER # ifndef SINGLESONLY - if ((y != y) || (x != x) || (y==(2 * y) && y != 0.0)) return scm_narn; - if ((x==(2 * x)) && (x != 0.0) && (y != 0.0)) return scm_narn; + if ((y != y) || (x != x) || (y==(2 * y) && (y != 0.0))) return scm_narn; + if ((x==(2 * x)) && (x != 0.0)) y = 0.0; # endif # endif DEFER_INTS; @@ -844,13 +869,13 @@ SCM eqv(x, y) SCM x, y; { if (x==y) return BOOL_T; - if IMP(x) return BOOL_F; - if IMP(y) return BOOL_F; + if (IMP(x)) return BOOL_F; + if (IMP(y)) return BOOL_F; /* this ensures that types and length are the same. */ if (CAR(x) != CAR(y)) return BOOL_F; - if NUMP(x) { + if (NUMP(x)) { # ifdef BIGDIG - if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; + if (BIGP(x)) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; # endif # ifdef FLOATS return floequal(x, y); @@ -863,7 +888,7 @@ SCM x, lst; { for(;NIMP(lst);lst = CDR(lst)) { ASRTGO(CONSP(lst), badlst); - if NFALSEP(eqv(CAR(lst), x)) return lst; + if (NFALSEP(eqv(CAR(lst), x))) return lst; } # ifndef RECKLESS if (!(NULLP(lst))) @@ -879,7 +904,7 @@ SCM x, alist; ASRTGO(CONSP(alist), badlst); tmp = CAR(alist); ASRTGO(NIMP(tmp) && CONSP(tmp), badlst); - if NFALSEP(eqv(CAR(tmp), x)) return tmp; + if (NFALSEP(eqv(CAR(tmp), x))) return tmp; } # ifndef RECKLESS if (!(NULLP(alist))) @@ -957,7 +982,7 @@ static SCM vector_equal(x, y) { long i; for(i = LENGTH(x)-1;i >= 0;i--) - if FALSEP(equal(VELTS(x)[i], VELTS(y)[i])) return BOOL_F; + if (FALSEP(equal(VELTS(x)[i], VELTS(y)[i]))) return BOOL_F; return BOOL_T; } #ifdef BIGDIG @@ -983,41 +1008,41 @@ SCM equal(x, y) { CHECK_STACK; tailrecurse: POLL; - if (x==y) return BOOL_T; - if IMP(x) return BOOL_F; - if IMP(y) return BOOL_F; - if (CONSP(x) && CONSP(y)) { - if FALSEP(equal(CAR(x), CAR(y))) return BOOL_F; - x = CDR(x); - y = CDR(y); - goto tailrecurse; - } - /* this ensures that types and length are the same. */ - if (CAR(x) != CAR(y)) return BOOL_F; - switch (TYP7(x)) { - default: return BOOL_F; - case tc7_string: return st_equal(x, y); - case tc7_vector: return vector_equal(x, y); - case tc7_smob: { - int i = SMOBNUM(x); - if (!(i < numsmob)) return BOOL_F; - if (smobs[i].equalp) return (smobs[i].equalp)(x, y); - else return BOOL_F; - } - case tc7_bvect: - case tc7_uvect: case tc7_ivect: case tc7_svect: - case tc7_fvect: case tc7_cvect: case tc7_dvect: { - SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp; - if (pred) return (*pred)(x, y); - else return BOOL_F; - } - } + if (x==y) return BOOL_T; + if (IMP(x)) return BOOL_F; + if (IMP(y)) return BOOL_F; + if (CONSP(x) && CONSP(y)) { + if (FALSEP(equal(CAR(x), CAR(y)))) return BOOL_F; + x = CDR(x); + y = CDR(y); + goto tailrecurse; + } + /* this ensures that types and length are the same. */ + if (CAR(x) != CAR(y)) return BOOL_F; + switch (TYP7(x)) { + default: return BOOL_F; + case tc7_string: return st_equal(x, y); + case tc7_vector: return vector_equal(x, y); + case tc7_smob: { + int i = SMOBNUM(x); + if (!(i < numsmob)) return BOOL_F; + if (smobs[i].equalp) return (smobs[i].equalp)(x, y); + else return BOOL_F; + } + case tc7_bvect: + case tc7_uvect: case tc7_ivect: case tc7_svect: + case tc7_fvect: case tc7_cvect: case tc7_dvect: { + SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp; + if (pred) return (*pred)(x, y); + else return BOOL_F; + } + } } SCM numberp(obj) SCM obj; { - if INUMP(obj) return BOOL_T; + if (INUMP(obj)) return BOOL_T; #ifdef FLOATS if (NIMP(obj) && NUMP(obj)) return BOOL_T; #else @@ -1061,26 +1086,26 @@ int scm_bigdblcomp(b, d) SCM realp(x) SCM x; { - if INUMP(x) return BOOL_T; - if IMP(x) return BOOL_F; - if REALP(x) return BOOL_T; + if (INUMP(x)) return BOOL_T; + if (IMP(x)) return BOOL_F; + if (REALP(x)) return BOOL_T; # ifdef BIGDIG - if BIGP(x) return BOOL_T; + if (BIGP(x)) return BOOL_T; # endif return BOOL_F; } SCM scm_rationalp(x) SCM x; { - if INUMP(x) return BOOL_T; - if IMP(x) return BOOL_F; - if REALP(x) { + if (INUMP(x)) return BOOL_T; + if (IMP(x)) return BOOL_F; + if (REALP(x)) { float y = REALPART(x); if (y==2*y && y != 0.0) return BOOL_F; return BOOL_T; } # ifdef BIGDIG - if BIGP(x) return BOOL_T; + if (BIGP(x)) return BOOL_T; # endif return BOOL_F; } @@ -1088,13 +1113,13 @@ SCM intp(x) SCM x; { double r; - if INUMP(x) return BOOL_T; - if IMP(x) return BOOL_F; + if (INUMP(x)) return BOOL_T; + if (IMP(x)) return BOOL_F; # ifdef BIGDIG - if BIGP(x) return BOOL_T; + if (BIGP(x)) return BOOL_T; # endif if (!INEXP(x)) return BOOL_F; - if CPLXP(x) return BOOL_F; + if (CPLXP(x)) return BOOL_F; r = REALPART(x); if (r != floor(r)) return BOOL_F; if (r==2*r && r != 0.0) return BOOL_F; @@ -1116,16 +1141,16 @@ SCM eqp(x, y) { #ifdef FLOATS SCM t; - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_eqp); + badx: wta(x, (char *)ARG1, s_eqp); # endif - if BIGP(x) { - if INUMP(y) return BOOL_F; + if (BIGP(x)) { + if (INUMP(y)) return BOOL_F; ASRTGO(NIMP(y), bady); - if BIGP(y) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; + if (BIGP(y)) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; ASRTGO(INEXP(y), bady); bigreal: return (REALP(y) && (0==scm_bigdblcomp(x, REALPART(y)))) ? @@ -1135,10 +1160,10 @@ SCM eqp(x, y) # else ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_eqp); # endif - if INUMP(y) {t = x; x = y; y = t; goto realint;} + if (INUMP(y)) {t = x; x = y; y = t; goto realint;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) {t = x; x = y; y = t; goto bigreal;} + if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;} ASRTGO(INEXP(y), bady); # else ASRTGO(NIMP(y) && INEXP(y), bady); @@ -1146,18 +1171,18 @@ SCM eqp(x, y) if (x==y) return BOOL_T; return floequal(x, y); } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BOOL_F; + if (BIGP(y)) return BOOL_F; # ifndef RECKLESS if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_eqp); + bady: wta(y, (char *)ARG2, s_eqp); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_eqp); + bady: wta(y, (char *)ARG2, s_eqp); # endif # endif realint: @@ -1165,16 +1190,16 @@ SCM eqp(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_eqp); - if INUMP(y) return BOOL_F; + if (INUMP(y)) return BOOL_F; ASRTGO(NIMP(y) && BIGP(y), bady); return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_eqp); + bady: wta(y, (char *)ARG2, s_eqp); # endif return BOOL_F; } @@ -1189,16 +1214,16 @@ SCM lessp(x, y) SCM x, y; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_lessp); + badx: wta(x, (char *)ARG1, s_lessp); # endif - if BIGP(x) { - if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F; + if (BIGP(x)) { + if (INUMP(y)) return BIGSIGN(x) ? BOOL_T : BOOL_F; ASRTGO(NIMP(y), bady); - if BIGP(y) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; + if (BIGP(y)) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; ASRTGO(REALP(y), bady); return (1==scm_bigdblcomp(x, REALPART(y))) ? BOOL_T : BOOL_F; } @@ -1206,44 +1231,44 @@ SCM lessp(x, y) # else ASRTER(NIMP(x) && REALP(x), x, ARG1, s_lessp); # endif - if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F; + if (INUMP(y)) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return (-1==scm_bigdblcomp(y, REALPART(x))) ? BOOL_T : BOOL_F; + if (BIGP(y)) return (-1==scm_bigdblcomp(y, REALPART(x))) ? BOOL_T : BOOL_F; ASRTGO(REALP(y), bady); # else ASRTGO(NIMP(y) && REALP(y), bady); # endif return (REALPART(x) < REALPART(y)) ? BOOL_T : BOOL_F; } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BIGSIGN(y) ? BOOL_F : BOOL_T; + if (BIGP(y)) return BIGSIGN(y) ? BOOL_F : BOOL_T; # ifndef RECKLESS if (!(REALP(y))) - bady: wta(y, (char *)ARG2, s_lessp); + bady: wta(y, (char *)ARG2, s_lessp); # endif # else # ifndef RECKLESS if (!(NIMP(y) && REALP(y))) - bady: wta(y, (char *)ARG2, s_lessp); + bady: wta(y, (char *)ARG2, s_lessp); # endif # endif return (((double)INUM(x)) < REALPART(y)) ? BOOL_T : BOOL_F; } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_lessp); - if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F; + if (INUMP(y)) return BIGSIGN(x) ? BOOL_T : BOOL_F; ASRTGO(NIMP(y) && BIGP(y), bady); return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_lessp); + bady: wta(y, (char *)ARG2, s_lessp); # endif return BIGSIGN(y) ? BOOL_F : BOOL_T; } @@ -1273,10 +1298,10 @@ SCM zerop(z) SCM z; { #ifdef FLOATS - if NINUMP(z) { + if (NINUMP(z)) { # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return BOOL_F; + if (BIGP(z)) return BOOL_F; # ifndef RECKLESS if (!(INEXP(z))) badz: wta(z, (char *)ARG1, s_zerop); @@ -1288,7 +1313,7 @@ SCM zerop(z) } #else # ifdef BIGDIG - if NINUMP(z) { + if (NINUMP(z)) { ASRTER(NIMP(z) && BIGP(z), z, ARG1, s_zerop); return BOOL_F; } @@ -1302,10 +1327,10 @@ SCM positivep(x) SCM x; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; + if (BIGP(x)) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; # ifndef RECKLESS if (!(REALP(x))) badx: wta(x, (char *)ARG1, s_positivep); @@ -1317,7 +1342,7 @@ SCM positivep(x) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_positivep); return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; } @@ -1331,10 +1356,10 @@ SCM negativep(x) SCM x; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T; + if (BIGP(x)) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T; # ifndef RECKLESS if (!(REALP(x))) badx: wta(x, (char *)ARG1, s_negativep); @@ -1346,7 +1371,7 @@ SCM negativep(x) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_negativep); return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F; } @@ -1365,21 +1390,21 @@ SCM lmax(x, y) SCM t; double z; #endif - if UNBNDP(y) { + if (UNBNDP(y)) { #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_max); + badx: wta(x, (char *)ARG1, s_max); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) return BIGSIGN(x) ? y : x; + if (BIGP(x)) { + if (INUMP(y)) return BIGSIGN(x) ? y : x; ASRTGO(NIMP(y), bady); - if BIGP(y) return (1==bigcomp(x, y)) ? y : x; + if (BIGP(y)) return (1==bigcomp(x, y)) ? y : x; ASRTGO(REALP(y), bady); big_dbl: if (-1 != scm_bigdblcomp(x, REALPART(y))) return y; @@ -1391,10 +1416,10 @@ SCM lmax(x, y) # else ASRTER(NIMP(x) && REALP(x), x, ARG1, s_max); # endif - if INUMP(y) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x; + if (INUMP(y)) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { t = y; y = x; x = t; goto big_dbl; } ASRTGO(REALP(y), bady); @@ -1403,34 +1428,34 @@ SCM lmax(x, y) # endif return (REALPART(x) < REALPART(y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BIGSIGN(y) ? x : y; + if (BIGP(y)) return BIGSIGN(y) ? x : y; # ifndef RECKLESS if (!(REALP(y))) - bady: wta(y, (char *)ARG2, s_max); + bady: wta(y, (char *)ARG2, s_max); # endif # else # ifndef RECKLESS if (!(NIMP(y) && REALP(y))) - bady: wta(y, (char *)ARG2, s_max); + bady: wta(y, (char *)ARG2, s_max); # endif # endif return ((z = INUM(x)) < REALPART(y)) ? y : makdbl(z, 0.0); } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_max); - if INUMP(y) return BIGSIGN(x) ? y : x; + if (INUMP(y)) return BIGSIGN(x) ? y : x; ASRTGO(NIMP(y) && BIGP(y), bady); return (1==bigcomp(x, y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_max); + bady: wta(y, (char *)ARG2, s_max); # endif return BIGSIGN(y) ? x : y; } @@ -1449,21 +1474,21 @@ SCM lmin(x, y) SCM t; double z; #endif - if UNBNDP(y) { + if (UNBNDP(y)) { #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_min); + badx: wta(x, (char *)ARG1, s_min); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) return BIGSIGN(x) ? x : y; + if (BIGP(x)) { + if (INUMP(y)) return BIGSIGN(x) ? x : y; ASRTGO(NIMP(y), bady); - if BIGP(y) return (-1==bigcomp(x, y)) ? y : x; + if (BIGP(y)) return (-1==bigcomp(x, y)) ? y : x; ASRTGO(REALP(y), bady); big_dbl: if (1 != scm_bigdblcomp(x, REALPART(y))) return y; @@ -1475,10 +1500,10 @@ SCM lmin(x, y) # else ASRTER(NIMP(x) && REALP(x), x, ARG1, s_min); # endif - if INUMP(y) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x; + if (INUMP(y)) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { t = y; y = x; x = t; goto big_dbl; } ASRTGO(REALP(y), bady); @@ -1487,34 +1512,34 @@ SCM lmin(x, y) # endif return (REALPART(x) > REALPART(y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BIGSIGN(y) ? y : x; + if (BIGP(y)) return BIGSIGN(y) ? y : x; # ifndef RECKLESS if (!(REALP(y))) - bady: wta(y, (char *)ARG2, s_min); + bady: wta(y, (char *)ARG2, s_min); # endif # else # ifndef RECKLESS if (!(NIMP(y) && REALP(y))) - bady: wta(y, (char *)ARG2, s_min); + bady: wta(y, (char *)ARG2, s_min); # endif # endif return ((z = INUM(x)) > REALPART(y)) ? y : makdbl(z, 0.0); } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_min); - if INUMP(y) return BIGSIGN(x) ? x : y; + if (INUMP(y)) return BIGSIGN(x) ? x : y; ASRTGO(NIMP(y) && BIGP(y), bady); return (-1==bigcomp(x, y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_min); + bady: wta(y, (char *)ARG2, s_min); # endif return BIGSIGN(y) ? y : x; } @@ -1529,23 +1554,23 @@ SCM lmin(x, y) SCM sum(x, y) SCM x, y; { - if UNBNDP(y) { - if UNBNDP(x) return INUM0; + if (UNBNDP(y)) { + if (UNBNDP(x)) return INUM0; #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_sum); + badx: wta(x, (char *)ARG1, s_sum); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { SCM t; # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) {t = x; x = y; y = t; goto intbig;} + if (BIGP(x)) { + if (INUMP(y)) {t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); } @@ -1556,30 +1581,32 @@ SCM sum(x, y) # else ASRTGO(NIMP(x) && INEXP(x), badx); # endif - if INUMP(y) {t = x; x = y; y = t; goto intreal;} + if (INUMP(y)) {t = x; x = y; y = t; goto intreal;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) {t = x; x = y; y = t; goto bigreal;} + if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;} # ifndef RECKLESS else if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_sum); + bady: wta(y, (char *)ARG2, s_sum); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_sum); + bady: wta(y, (char *)ARG2, s_sum); # endif # endif - { double i = 0.0; - if CPLXP(x) i = IMAG(x); - if CPLXP(y) i += IMAG(y); - return makdbl(REALPART(x)+REALPART(y), i); } + { + double i = 0.0; + if (CPLXP(x)) i = IMAG(x); + if (CPLXP(y)) i += IMAG(y); + return makdbl(REALPART(x)+REALPART(y), i); + } } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) - intbig: { + if (BIGP(y)) + intbig: { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); @@ -1597,23 +1624,23 @@ SCM sum(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { SCM t; ASRTGO(NIMP(x) && BIGP(x), badx); - if INUMP(y) {t = x; x = y; y = t; goto intbig;} + if (INUMP(y)) {t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y) && BIGP(y), bady); if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_sum); + bady: wta(y, (char *)ARG2, s_sum); # endif - intbig: { + intbig: { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); - return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); # else BIGDIG zdigs[DIGSPERLONG]; longdigs(INUM(x), zdigs); @@ -1627,7 +1654,7 @@ SCM sum(x, y) # endif #endif x = INUM(x)+INUM(y); - if FIXABLE(x) return MAKINUM(x); + if (FIXABLE(x)) return MAKINUM(x); #ifdef BIGDIG return long2big(x); #else @@ -1643,14 +1670,14 @@ SCM difference(x, y) SCM x, y; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_difference); + badx: wta(x, (char *)ARG1, s_difference); # endif - if UNBNDP(y) { + if (UNBNDP(y)) { # ifdef BIGDIG - if BIGP(x) { + if (BIGP(x)) { x = copybig(x, !BIGSIGN(x)); return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? big2inum(x, NUMDIGS(x)) : x; @@ -1659,36 +1686,36 @@ SCM difference(x, y) ASRTGO(INEXP(x), badx); return makdbl(-REALPART(x), CPLXP(x)?-IMAG(x):0.0); } - if INUMP(y) return sum(x, MAKINUM(-INUM(y))); + if (INUMP(y)) return sum(x, MAKINUM(-INUM(y))); # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(x) { - if BIGP(y) return (NUMDIGS(x) < NUMDIGS(y)) ? - addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : - addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); + if (BIGP(x)) { + if (BIGP(y)) return (NUMDIGS(x) < NUMDIGS(y)) ? + addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : + addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); ASRTGO(INEXP(y), bady); return makdbl(big2dbl(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); } ASRTGO(INEXP(x), badx); - if BIGP(y) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0); + if (BIGP(y)) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0); ASRTGO(INEXP(y), bady); # else ASRTGO(INEXP(x), badx); ASRTGO(NIMP(y) && INEXP(y), bady); # endif - if CPLXP(x) { - if CPLXP(y) + if (CPLXP(x)) { + if (CPLXP(y)) return makdbl(REAL(x)-REAL(y), IMAG(x)-IMAG(y)); else return makdbl(REAL(x)-REALPART(y), IMAG(x)); } return makdbl(REALPART(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); } - if UNBNDP(y) {x = -INUM(x); goto checkx;} - if NINUMP(y) { + if (UNBNDP(y)) {x = -INUM(x); goto checkx;} + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); @@ -1700,29 +1727,29 @@ SCM difference(x, y) } # ifndef RECKLESS if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_difference); + bady: wta(y, (char *)ARG2, s_difference); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_difference); + bady: wta(y, (char *)ARG2, s_difference); # endif # endif return makdbl(INUM(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_difference); - if UNBNDP(y) { + if (UNBNDP(y)) { x = copybig(x, !BIGSIGN(x)); return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? - big2inum(x, NUMDIGS(x)) : x; + big2inum(x, NUMDIGS(x)) : x; } - if INUMP(y) { + if (INUMP(y)) { # ifndef DIGSTOOBIG long z = pseudolong(INUM(y)); - return addbig(&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); + return addbig((BIGDIG *)&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); # else BIGDIG zdigs[DIGSPERLONG]; longdigs(INUM(x), zdigs); @@ -1731,19 +1758,19 @@ SCM difference(x, y) } ASRTGO(NIMP(y) && BIGP(y), bady); return (NUMDIGS(x) < NUMDIGS(y)) ? - addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : - addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); + addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : + addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); } - if UNBNDP(y) {x = -INUM(x); goto checkx;} - if NINUMP(y) { + if (UNBNDP(y)) {x = -INUM(x); goto checkx;} + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_difference); + bady: wta(y, (char *)ARG2, s_difference); # endif { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); - return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); # else BIGDIG zdigs[DIGSPERLONG]; longdigs(INUM(x), zdigs); @@ -1753,13 +1780,13 @@ SCM difference(x, y) } # else ASRTER(INUMP(x), x, ARG1, s_difference); - if UNBNDP(y) {x = -INUM(x); goto checkx;} + if (UNBNDP(y)) {x = -INUM(x); goto checkx;} ASRTER(INUMP(y), y, ARG2, s_difference); # endif #endif x = INUM(x)-INUM(y); checkx: - if FIXABLE(x) return MAKINUM(x); + if (FIXABLE(x)) return MAKINUM(x); #ifdef BIGDIG return long2big(x); #else @@ -1774,24 +1801,24 @@ SCM difference(x, y) SCM product(x, y) SCM x, y; { - if UNBNDP(y) { - if UNBNDP(x) return MAKINUM(1L); + if (UNBNDP(y)) { + if (UNBNDP(x)) return MAKINUM(1L); #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_product); + badx: wta(x, (char *)ARG1, s_product); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { SCM t; # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) {t = x; x = y; y = t; goto intbig;} + if (BIGP(x)) { + if (INUMP(y)) {t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y), bady); - if BIGP(y) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), - BIGSIGN(x) ^ BIGSIGN(y)); + if (BIGP(y)) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y)); ASRTGO(INEXP(y), bady); bigreal: return bigdblop('*', x, REALPART(y), CPLXP(y) ? IMAG(y) : 0.0); @@ -1800,22 +1827,22 @@ SCM product(x, y) # else ASRTGO(NIMP(x) && INEXP(x), badx); # endif - if INUMP(y) {t = x; x = y; y = t; goto intreal;} + if (INUMP(y)) {t = x; x = y; y = t; goto intreal;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) {t = x; x = y; y = t; goto bigreal;} + if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;} # ifndef RECKLESS else if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_product); + bady: wta(y, (char *)ARG2, s_product); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_product); + bady: wta(y, (char *)ARG2, s_product); # endif # endif - if CPLXP(x) { - if CPLXP(y) + if (CPLXP(x)) { + if (CPLXP(y)) return makdbl(REAL(x)*REAL(y)-IMAG(x)*IMAG(y), REAL(x)*IMAG(y)+IMAG(x)*REAL(y)); else @@ -1824,23 +1851,23 @@ SCM product(x, y) return makdbl(REALPART(x)*REALPART(y), CPLXP(y)?REALPART(x)*IMAG(y):0.0); } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y; - { + { # ifndef DIGSTOOBIG - long z = pseudolong(INUM(x)); - return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + long z = pseudolong(INUM(x)); + return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # else - BIGDIG zdigs[DIGSPERLONG]; - longdigs(INUM(x), zdigs); - return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # endif - } + } } ASRTGO(INEXP(y), bady); # else @@ -1850,31 +1877,31 @@ SCM product(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTGO(NIMP(x) && BIGP(x), badx); - if INUMP(y) {SCM t = x; x = y; y = t; goto intbig;} + if (INUMP(y)) {SCM t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y) && BIGP(y), bady); return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), BIGSIGN(x) ^ BIGSIGN(y)); } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_product); + bady: wta(y, (char *)ARG2, s_product); # endif intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y; - { + { # ifndef DIGSTOOBIG - long z = pseudolong(INUM(x)); - return mulbig(&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + long z = pseudolong(INUM(x)); + return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # else - BIGDIG zdigs[DIGSPERLONG]; - longdigs(INUM(x), zdigs); - return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # endif - } + } } # else ASRTGO(INUMP(x), badx); @@ -1890,7 +1917,8 @@ SCM product(x, y) y = MAKINUM(k); if (k != INUM(y) || k/i != j) #ifdef BIGDIG - { int sgn = (i < 0) ^ (j < 0); + { + int sgn = (i < 0) ^ (j < 0); # ifndef DIGSTOOBIG i = pseudolong(i); j = pseudolong(j); @@ -1919,24 +1947,24 @@ SCM divide(x, y) { #ifdef FLOATS double d, r, i, a; - if NINUMP(x) { + if (NINUMP(x)) { # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_divide); + badx: wta(x, (char *)ARG1, s_divide); # endif - if UNBNDP(y) { + if (UNBNDP(y)) { # ifdef BIGDIG - if BIGP(x) return makdbl(1.0/big2dbl(x), 0.0); + if (BIGP(x)) return makdbl(1.0/big2dbl(x), 0.0); # endif ASRTGO(INEXP(x), badx); - if REALP(x) return makdbl(1.0/REALPART(x), 0.0); + if (REALP(x)) return makdbl(1.0/REALPART(x), 0.0); r = REAL(x); i = IMAG(x); d = r*r+i*i; return makdbl(r/d, -i/d); } # ifdef BIGDIG - if BIGP(x) { + if (BIGP(x)) { SCM z; - if INUMP(y) { + if (INUMP(y)) { z = INUM(y); ASRTER(z, y, OVFLOW, s_divide); if (1==z) return x; @@ -1951,15 +1979,17 @@ SCM divide(x, y) z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG, BIGSIGN(x) ? (y>0) : (y<0), 3); # else - { BIGDIG zdigs[DIGSPERLONG]; + { + BIGDIG zdigs[DIGSPERLONG]; longdigs(z, zdigs); z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, - BIGSIGN(x) ? (y>0) : (y<0), 3);} + BIGSIGN(x) ? (y>0) : (y<0), 3); + } # endif return z ? z : bigdblop('/', x, INUM(y), 0.0); } ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), BIGSIGN(x) ^ BIGSIGN(y), 3); return z ? z : inex_divbigbig(x, y); @@ -1969,42 +1999,42 @@ SCM divide(x, y) } # endif ASRTGO(INEXP(x), badx); - if INUMP(y) {d = INUM(y); goto basic_div;} + if (INUMP(y)) {d = INUM(y); goto basic_div;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return bigdblop('\\', y, REALPART(x), CPLXP(x) ? IMAG(x) : 0.0); + if (BIGP(y)) return bigdblop('\\', y, REALPART(x), CPLXP(x) ? IMAG(x) : 0.0); ASRTGO(INEXP(y), bady); # else ASRTGO(NIMP(y) && INEXP(y), bady); # endif - if REALP(y) { + if (REALP(y)) { d = REALPART(y); basic_div: return makdbl(REALPART(x)/d, CPLXP(x)?IMAG(x)/d:0.0); } a = REALPART(x); - if REALP(x) goto complex_div; + if (REALP(x)) goto complex_div; r = REAL(y); i = IMAG(y); d = r*r+i*i; return makdbl((a*r+IMAG(x)*i)/d, (IMAG(x)*r-a*i)/d); } - if UNBNDP(y) { + if (UNBNDP(y)) { if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; return makdbl(1.0/((double)INUM(x)), 0.0); } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return bigdblop('\\', y, INUM(x), 0.0); + if (BIGP(y)) return bigdblop('\\', y, INUM(x), 0.0); # ifndef RECKLESS if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_divide); + bady: wta(y, (char *)ARG2, s_divide); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_divide); + bady: wta(y, (char *)ARG2, s_divide); # endif # endif - if REALP(y) return makdbl(INUM(x)/REALPART(y), 0.0); + if (REALP(y)) return makdbl(INUM(x)/REALPART(y), 0.0); a = INUM(x); complex_div: r = REAL(y); i = IMAG(y); d = r*r+i*i; @@ -2012,11 +2042,11 @@ SCM divide(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { SCM z; ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_divide); - if UNBNDP(y) goto ov; - if INUMP(y) { + if (UNBNDP(y)) goto ov; + if (INUMP(y)) { z = INUM(y); if (!z) goto ov; if (1==z) return x; @@ -2028,13 +2058,15 @@ SCM divide(x, y) } # ifndef DIGSTOOBIG z = pseudolong(z); - z = divbigbig(BDIGITS(x), NUMDIGS(x), &z, DIGSPERLONG, + z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG, BIGSIGN(x) ? (y>0) : (y<0), 3); # else - { BIGDIG zdigs[DIGSPERLONG]; + { + BIGDIG zdigs[DIGSPERLONG]; longdigs(z, zdigs); z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, - BIGSIGN(x) ? (y>0) : (y<0), 3);} + BIGSIGN(x) ? (y>0) : (y<0), 3); + } # endif } else { ASRTGO(NIMP(y) && BIGP(y), bady); @@ -2044,20 +2076,20 @@ SCM divide(x, y) if (!z) goto ov; return z; } - if UNBNDP(y) { + if (UNBNDP(y)) { if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; goto ov; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_divide); + bady: wta(y, (char *)ARG2, s_divide); # endif goto ov; } # else ASRTER(INUMP(x), x, ARG1, s_divide); - if UNBNDP(y) { + if (UNBNDP(y)) { if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; goto ov; } @@ -2068,7 +2100,7 @@ SCM divide(x, y) long z = INUM(y); if ((0==z) || INUM(x)%z) goto ov; z = INUM(x)/z; - if FIXABLE(z) return MAKINUM(z); + if (FIXABLE(z)) return MAKINUM(z); #ifdef BIGDIG return long2big(z); #endif @@ -2088,17 +2120,16 @@ SCM scm_intexpt(z1, z2) #ifdef FLOATS double dacc, dz1; #endif -#ifdef BIGDIG - if (INUM0==z1 || acc==z1) return z1; - else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; -#endif + if (INUM0==z2) return sum(acc, product(z1, INUM0)); ASRTER(INUMP(z2), z2, ARG2, s_intexpt); + if (acc==z1) return z1; + if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; z2 = INUM(z2); if (z2 < 0) { z2 = -z2; recip = 1; /* z1 = divide(z1, UNDEFINED); */ } - if INUMP(z1) { + if (INUMP(z1)) { long tmp, iacc = 1, iz1 = INUM(z1); #ifdef FLOATS if (recip) { dz1 = iz1; goto flocase; } @@ -2142,7 +2173,7 @@ SCM scm_intexpt(z1, z2) } ASRTER(NIMP(z1), z1, ARG1, s_intexpt); #ifdef FLOATS - if REALP(z1) { + if (REALP(z1)) { dz1 = REALPART(z1); flocase: dacc = 1.0; @@ -2168,25 +2199,27 @@ SCM scm_intexpt(z1, z2) } #ifdef FLOATS -double lasinh(x) +# ifndef HAVE_ATANH +double asinh(x) double x; { return log(x+sqrt(x*x+1)); } -double lacosh(x) +double acosh(x) double x; { return log(x+sqrt(x*x-1)); } -double latanh(x) +double atanh(x) double x; { return 0.5*log((1+x)/(1-x)); } +# endif -double ltrunc(x) +double scm_truncate(x) double x; { if (x < 0.0) return -floor(-x); @@ -2210,36 +2243,38 @@ void two_doubles(z1, z2, sstring, xy) char *sstring; struct dpair *xy; { - if INUMP(z1) xy->x = INUM(z1); + if (INUMP(z1)) xy->x = INUM(z1); else { # ifdef BIGDIG ASRTGO(NIMP(z1), badz1); - if BIGP(z1) xy->x = big2dbl(z1); + if (BIGP(z1)) xy->x = big2dbl(z1); else { # ifndef RECKLESS if (!(REALP(z1))) - badz1: wta(z1, (char *)ARG1, sstring); + badz1: wta(z1, (char *)ARG1, sstring); # endif xy->x = REALPART(z1);} # else {ASRTER(NIMP(z1) && REALP(z1), z1, ARG1, sstring); - xy->x = REALPART(z1);} + xy->x = REALPART(z1);} # endif } - if INUMP(z2) xy->y = INUM(z2); + if (INUMP(z2)) xy->y = INUM(z2); else { # ifdef BIGDIG ASRTGO(NIMP(z2), badz2); - if BIGP(z2) xy->y = big2dbl(z2); + if (BIGP(z2)) xy->y = big2dbl(z2); else { # ifndef RECKLESS if (!(REALP(z2))) - badz2: wta(z2, (char *)ARG2, sstring); + badz2: wta(z2, (char *)ARG2, sstring); # endif xy->y = REALPART(z2);} # else - {ASRTER(NIMP(z2) && REALP(z2), z2, ARG2, sstring); - xy->y = REALPART(z2);} + { + ASRTER(NIMP(z2) && REALP(z2), z2, ARG2, sstring); + xy->y = REALPART(z2); + } # endif } } @@ -2276,53 +2311,63 @@ SCM makpolar(z1, z2) SCM real_part(z) SCM z; { - if NINUMP(z) { + if (NINUMP(z)) { # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return z; + if (BIGP(z)) return z; # ifndef RECKLESS if (!(INEXP(z))) - badz: wta(z, (char *)ARG1, s_real_part); + badz: wta(z, (char *)ARG1, s_real_part); # endif # else ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_real_part); # endif - if CPLXP(z) return makdbl(REAL(z), 0.0); + if (CPLXP(z)) return makdbl(REAL(z), 0.0); } return z; } SCM imag_part(z) SCM z; { - if INUMP(z) return INUM0; + if (INUMP(z)) return INUM0; # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return INUM0; + if (BIGP(z)) return INUM0; # ifndef RECKLESS if (!(INEXP(z))) - badz: wta(z, (char *)ARG1, s_imag_part); + badz: wta(z, (char *)ARG1, s_imag_part); # endif # else ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_imag_part); # endif - if CPLXP(z) return makdbl(IMAG(z), 0.0); + if (CPLXP(z)) return makdbl(IMAG(z), 0.0); return flo0; } -SCM magnitude(z) + +SCM scm_abs(z) SCM z; { - if INUMP(z) return absval(z); + if (INUMP(z)) return scm_iabs(z); + ASRTGO(NIMP(z), badz); # ifdef BIGDIG + if (BIGP(z)) return scm_iabs(z); +# endif + if (!REALP(z)) + badz: wta(z, (char *)ARG1, s_abs); + return makdbl(fabs(REALPART(z)), 0.0); +} + +SCM scm_magnitude(z) + SCM z; +{ + if (INUMP(z)) return scm_iabs(z); ASRTGO(NIMP(z), badz); - if BIGP(z) return absval(z); -# ifndef RECKLESS - if (!(INEXP(z))) - badz: wta(z, (char *)ARG1, s_magnitude); -# endif -# else - ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_magnitude); +# ifdef BIGDIG + if (BIGP(z)) return scm_iabs(z); # endif - if CPLXP(z) + if (!INEXP(z)) + badz: wta(z, (char *)ARG1, s_magnitude); + if (CPLXP(z)) { double i = IMAG(z), r = REAL(z); return makdbl(sqrt(i*i+r*r), 0.0); @@ -2334,10 +2379,10 @@ SCM angle(z) SCM z; { double x, y = 0.0; - if INUMP(z) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;} + if (INUMP(z)) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;} # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;} + if (BIGP(z)) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;} # ifndef RECKLESS if (!(INEXP(z))) { badz: wta(z, (char *)ARG1, s_angle);} @@ -2345,7 +2390,7 @@ SCM angle(z) # else ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_angle); # endif - if REALP(z) {x = REALPART(z); goto do_angle;} + if (REALP(z)) {x = REALPART(z); goto do_angle;} x = REAL(z); y = IMAG(z); do_angle: return makdbl(atan2(y, x), 0.0); @@ -2355,21 +2400,21 @@ do_angle: SCM ex2in(z) SCM z; { - if INUMP(z) return makdbl((double)INUM(z), 0.0); + if (INUMP(z)) return makdbl((double)INUM(z), 0.0); ASRTGO(NIMP(z), badz); - if INEXP(z) return z; + if (INEXP(z)) return z; # ifdef BIGDIG - if BIGP(z) return makdbl(big2dbl(z), 0.0); + if (BIGP(z)) return makdbl(big2dbl(z), 0.0); # endif badz: wta(z, (char *)ARG1, s_ex2in); } SCM in2ex(z) SCM z; { - if INUMP(z) return z; + if (INUMP(z)) return z; # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return z; + if (BIGP(z)) return z; # ifndef RECKLESS if (!(REALP(z))) badz: wta(z, (char *)ARG1, s_in2ex); @@ -2400,11 +2445,38 @@ static char s_trunc[] = "truncate"; SCM numident(x) SCM x; { +# ifdef BIGDIG + ASRTER(INUMP(x) || (NIMP(x) && BIGP(x)), x, ARG1, s_trunc); +# else ASRTER(INUMP(x), x, ARG1, s_trunc); +# endif return x; } #endif /* FLOATS */ +SCM scm_iabs(x) + SCM x; +{ +#ifdef BIGDIG + if (NINUMP(x)) { + ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_abs); + if (TYP16(x)==tc16_bigpos) return x; + return copybig(x, 0); + } +#else + ASRTER(INUMP(x), x, ARG1, s_abs); +#endif + if (INUM(x) >= 0) return x; + x = -INUM(x); + if (!POSFIXABLE(x)) +#ifdef BIGDIG + return long2big(x); +#else + wta(MAKINUM(-x), (char *)OVFLOW, s_abs); +#endif + return MAKINUM(x); +} + #ifdef BIGDIG # ifdef FLOATS SCM dbl2big(d) @@ -2584,7 +2656,7 @@ unsigned long hasher(obj, n, d) case 2: case 6: /* INUMP(obj) */ return INUM(obj) % n; case 4: - if ICHRP(obj) + if (ICHRP(obj)) return (unsigned)(downcase[ICHR(obj)]) % n; switch ((int) obj) { #ifndef SICP @@ -2607,11 +2679,11 @@ unsigned long hasher(obj, n, d) default: return 263 % n; #ifdef FLOATS case tc16_flo: - if REALP(obj) { + if (REALP(obj)) { double r = REALPART(obj); if (floor(r)==r) { obj = in2ex(obj); - if IMP(obj) return INUM(obj) % n; + if (IMP(obj)) return INUM(obj) % n; goto bighash; } } @@ -2664,7 +2736,7 @@ SCM hashv(obj, n) SCM n; { ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hashv); - if ICHRP(obj) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n)); + if (ICHRP(obj)) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n)); if (NIMP(obj) && NUMP(obj)) return MAKINUM(hasher(obj, INUM(n), 10)); else return MAKINUM(obj % INUM(n)); } @@ -2687,10 +2759,11 @@ static iproc subr1s[] = { {"integer?", intp}, {s_real_part, real_part}, {s_imag_part, imag_part}, - {s_magnitude, magnitude}, + {s_magnitude, scm_magnitude}, {s_angle, angle}, {s_in2ex, in2ex}, {s_ex2in, ex2in}, + {s_abs, scm_abs}, # ifdef BIGDIG {s_dfloat_parts, scm_dfloat_parts}, # endif @@ -2703,6 +2776,7 @@ static iproc subr1s[] = { {"ceiling", numident}, {s_trunc, numident}, {"round", numident}, + {s_abs, scm_iabs}, #endif {s_zerop, zerop}, {s_positivep, positivep}, @@ -2772,7 +2846,7 @@ static iproc rpsubrs[] = { static dblproc cxrs[] = { {"floor", floor}, {"ceiling", ceil}, - {"truncate", ltrunc}, + {"truncate", scm_truncate}, {"round", scm_round}, {"$sqrt", sqrt}, {"$abs", fabs}, @@ -2788,14 +2862,14 @@ static dblproc cxrs[] = { {"$sinh", sinh}, {"$cosh", cosh}, {"$tanh", tanh}, - {"$asinh", lasinh}, - {"$acosh", lacosh}, - {"$atanh", latanh}, + {"$asinh", asinh}, + {"$acosh", acosh}, + {"$atanh", atanh}, {0, 0}}; #endif #ifdef FLOATS -static void add1(f, fsum) +static void safe_add_1(f, fsum) double f, *fsum; { *fsum = f + 1.0; @@ -2836,11 +2910,11 @@ void init_scl() # else { /* determine floating point precision */ double f = 0.1; - double fsum = 1.0+f; + volatile double fsum = 1.0+f; while (fsum != 1.0) { f /= 10.0; if (++dblprec > 20) break; - add1(f, &fsum); + safe_add_1(f, &fsum); } dblprec = dblprec-1; } @@ -2849,11 +2923,12 @@ void init_scl() dbl_mant_dig = DBL_MANT_DIG; # else { /* means we #defined it. */ - double fsum = 0.0, eps = 1.0; + volatile double fsum = 0.0; + double eps = 1.0; int i = 0; while (fsum != 1.0) { eps = 0.5 * eps; - add1(eps, &fsum); + safe_add_1(eps, &fsum); i++; } dbl_mant_dig = i; diff --git a/scm.1 b/scm.1 index 8d5ce5b..2091712 100644 --- a/scm.1 +++ b/scm.1 @@ -92,7 +92,7 @@ and .I sh respectively. On Amiga systems the entire option and argument need to be enclosed in -qoutes. For instance "-e(newline)". +quotes. For instance "-e(newline)". .TP .BI -r feature requires @@ -103,7 +103,7 @@ is not already supported. If .I feature is 2, 3, 4, or 5 .I scm -will require the features neccessary to support R2RS, R3RS, R4RS, or +will require the features necessary to support R2RS, R3RS, R4RS, or R5RS, respectively. .TP .BI -h feature @@ -117,7 +117,7 @@ loads .I filename. .I Scm will load the first (unoptioned) file named on the command line if no --c, -e, -f, -l, or -s option preceeds it. +-c, -e, -f, -l, or -s option precedes it. .TP .BI -d filename opens (read-only) the extended relational database @@ -144,7 +144,7 @@ sets the prolixity (verboseness) to .I level. This is the same as the .I scm -command (verobse +command (verbose .I level ). .TP @@ -207,7 +207,7 @@ errors. .B -s specifies, by analogy with .I sh, -that further options are to be treated as program aguments. +that further options are to be treated as program arguments. .TP .BI - .BI -- @@ -302,7 +302,7 @@ Arrays and bit-vectors. String ports and software emulation ports. I/O extensions providing most of ANSI C and POSIX.1 facilities. .PP User definable responses to interrupts and errors, -Process-syncronization primitives, String regular expression matching, +Process-synchronization primitives, String regular expression matching, and the CURSES screen management package. .PP Available add-on packages including an interactive debugger, database, diff --git a/scm.c b/scm.c index d4506e8..bdb7967 100644 --- a/scm.c +++ b/scm.c @@ -236,11 +236,11 @@ SIGRETTYPE win32_sigint(int sig) CONTEXT ctx; DWORD *Stack; - if(-1 == SuspendThread(scm_hMainThread)) + if (-1 == SuspendThread(scm_hMainThread)) return; ctx.ContextFlags = CONTEXT_FULL; - if(0 == GetThreadContext(scm_hMainThread, &ctx)) + if (0 == GetThreadContext(scm_hMainThread, &ctx)) { ResumeThread(scm_hMainThread); return; @@ -289,7 +289,7 @@ static SIGRETTYPE scmable_signal(sig) if (sig == sigdesc[i].signo) break; ASRTER(i >= 0, MAKINUM(sig), s_unksig, ""); #ifdef WINSIGNALS - if(SIGINT == sig) + if (SIGINT == sig) signal(sig, win32_sigint); else #endif @@ -385,13 +385,11 @@ SCM scm_setitimer(which, value, interval) } # endif # ifndef AMIGA -# ifndef __CYGWIN32__ SCM l_pause() { pause(); return UNSPECIFIED; } -# endif # endif #endif /* SIGALRM */ @@ -680,14 +678,14 @@ void restore_signals() void scm_init_from_argv(argc, argv, script_arg, iverbose, buf0stdin) int argc; - char **argv; + const char * const *argv; char *script_arg; int iverbose; int buf0stdin; { long i = 0L; if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) { - char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2]; + const char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2]; do { switch (*str) { case DIGITS: @@ -731,7 +729,7 @@ void final_scm(freeall) # define SYSTNAME "unix" # define DIRSEP "/" #endif -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ # define SYSTNAME "unix" # define DIRSEP "/" #endif @@ -885,8 +883,8 @@ SCM scm_execpath(newpath) } char *scm_find_execpath(argc, argv, script_arg) int argc; - char **argv; - char *script_arg; + const char * const *argv; + const char *script_arg; { char *exepath = 0; #ifndef macintosh @@ -985,9 +983,7 @@ static iproc subr0s[] = { #endif #ifdef SIGALRM # ifndef AMIGA -# ifndef __CYGWIN32__ {"pause", l_pause}, -# endif # endif #endif {0, 0}}; diff --git a/scm.doc b/scm.doc index 2367bc0..954e965 100644 --- a/scm.doc +++ b/scm.doc @@ -1,9 +1,7 @@ +SCM(Jan 4 2000) SCM(Jan 4 2000) -SCM(Jan 4 2000) SCM(Jan 4 2000) - - NAME scm - a Scheme Language Interpreter @@ -17,63 +15,44 @@ SYNOPSIS DESCRIPTION Scm is a Scheme interpreter. - Upon startup scm loads the file specified by by the envi- - ronment variable SCM_INIT_PATH or by the parameter - IMPLINIT in the makefile (or scmfig.h) if SCM_INIT_PATH is - not defined. The makefiles attempt to set IMPLINIT to - "Init.scm" in the source directory. + Upon startup scm loads the file specified by by the environment vari- + able SCM_INIT_PATH or by the parameter IMPLINIT in the makefile (or + scmfig.h) if SCM_INIT_PATH is not defined. The makefiles attempt to + set IMPLINIT to "Init.scm" in the source directory. - Unless the option -no-init-file or --no-init-file occurs - in the command line, "Init.scm" checks to see if there is - file "ScmInit.scm" in the path specified by the environ- - ment variable HOME (or in the current directory if HOME is - undefined). If it finds such a file it is loaded. + Unless the option -no-init-file or --no-init-file occurs in the command + line, "Init.scm" checks to see if there is file "ScmInit.scm" in the + path specified by the environment variable HOME (or in the current + directory if HOME is undefined). If it finds such a file it is loaded. - "Init.scm" then looks for command input from one of three - sources: From an option on the command line, from a file - named on the command line, or from standard input. + "Init.scm" then looks for command input from one of three sources: From + an option on the command line, from a file named on the command line, + or from standard input. OPTIONS - The options are processed in the order specified on the - command line. + The options are processed in the order specified on the command line. -akbytes - specifies that scm should allocate an initial heap- - size of kbytes. This option, if present, must be the - first on the command line. + specifies that scm should allocate an initial heapsize of kbytes. + This option, if present, must be the first on the command line. -no-init-file - Inhibits the loading of "ScmInit.scm" as described - above. + Inhibits the loading of "ScmInit.scm" as described above. -eexpression -cexpression - specifies that the scheme expression expression is to - be evaluated. These options are inspired by perl and - sh respectively. On Amiga systems the entire option - and argument need to be enclosed in qoutes. For - instance "-e(newline)". + specifies that the scheme expression expression is to be evalu- + ated. These options are inspired by perl and sh respectively. On + Amiga systems the entire option and argument need to be enclosed + in quotes. For instance "-e(newline)". -rfeature - requires feature. This will load a file from SLIB if - - - - 1 - - - - - -SCM(Jan 4 2000) SCM(Jan 4 2000) - - - that feature is not already supported. If feature is - 2, 3, 4, or 5 scm will require the features necces- - sary to support R2RS, R3RS, R4RS, or R5RS, respec- - tively. + requires feature. This will load a file from SLIB if that feature + is not already supported. If feature is 2, 3, 4, or 5 scm will + require the features necessary to support R2RS, R3RS, R4RS, or + R5RS, respectively. -hfeature provides feature. @@ -81,211 +60,153 @@ SCM(Jan 4 2000) SCM(Jan 4 2000) -lfilename -ffilename - loads filename. Scm will load the first (unoptioned) - file named on the command line if no -c, -e, -f, -l, - or -s option preceeds it. + loads filename. Scm will load the first (unoptioned) file named + on the command line if no -c, -e, -f, -l, or -s option precedes + it. -dfilename - opens (read-only) the extended relational database - filename. If filename contains initialization code, - it will be run when the database is opened. + opens (read-only) the extended relational database filename. If + filename contains initialization code, it will be run when the + database is opened. -odumpname - saves the current SCM session as the executable pro- - gram dumpname. This option works only in SCM builds - supporting dump. + saves the current SCM session as the executable program dumpname. + This option works only in SCM builds supporting dump. - If options appear on the command line after -o dump- - name, then the saved session will continue with pro- - cessing those options when it is invoked. Otherwise - the (new) command line is processed as usual when the - saved image is invoked. + If options appear on the command line after -o dumpname, then the + saved session will continue with processing those options when it + is invoked. Otherwise the (new) command line is processed as + usual when the saved image is invoked. -plevel - sets the prolixity (verboseness) to level. This is - the same as the scm command (verobse level ). - - -v (verbose mode) specifies that scm will print prompts, - evaluation times, notice of loading files, and - garbage collection statistics. This is the same as - -p3. - - -q (quiet mode) specifies that scm will print no extra - information. This is the same as -p0. + sets the prolixity (verboseness) to level. This is the same as + the scm command (verbose level ). - -m specifies that subsequent loads, evaluations, and - user interactions will be with R4RS macro capability. - To use a specific R4RS macro implementation from SLIB - (instead of SLIB's default) put -r macropackage - before -m on the command line. + -v (verbose mode) specifies that scm will print prompts, evaluation + times, notice of loading files, and garbage collection statistics. + This is the same as -p3. - -u specifies that subsequent loads, evaluations, and - user interactions will be without R4RS macro capabil- - ity. R4RS macro capability can be restored by a sub- - sequent -m on the command line or from Scheme code. + -q (quiet mode) specifies that scm will print no extra information. + This is the same as -p0. + -m specifies that subsequent loads, evaluations, and user interac- + tions will be with R4RS macro capability. To use a specific R4RS + macro implementation from SLIB (instead of SLIB’s default) put -r + macropackage before -m on the command line. + -u specifies that subsequent loads, evaluations, and user interac- + tions will be without R4RS macro capability. R4RS macro capabil- + ity can be restored by a subsequent -m on the command line or from + Scheme code. + -i specifies that scm should run interactively. That means that scm + will not terminate until the (quit) or (exit) command is given, + even if there are errors. It also sets the prolixity level to 2 + if it is less than 2. This will print prompts, evaluation times, + and notice of loading files. The prolixity level can be set by + subsequent options. If scm is started from a tty, it will assume + that it should be interactive unless given a subsequent -b option. - 2 + -b specifies that scm should run non-interactively. That means that + scm will terminate after processing the command line or if there + are errors. + -s specifies, by analogy with sh, that further options are to be + treated as program arguments. - - - -SCM(Jan 4 2000) SCM(Jan 4 2000) - - - -i specifies that scm should run interactively. That - means that scm will not terminate until the (quit) or - (exit) command is given, even if there are errors. - It also sets the prolixity level to 2 if it is less - than 2. This will print prompts, evaluation times, - and notice of loading files. The prolixity level can - be set by subsequent options. If scm is started from - a tty, it will assume that it should be interactive - unless given a subsequent -b option. - - -b specifies that scm should run non-interactively. - That means that scm will terminate after processing - the command line or if there are errors. - - -s specifies, by analogy with sh, that further options - are to be treated as program aguments. - - - -- specifies that there are no more options on the - command line. + - -- specifies that there are no more options on the command line. ENVIRONMENT VARIABLES SCM_INIT_PATH - is the pathname where scm will look for its initial- - ization code. The default is the file "Init.scm" in - the source directory. + is the pathname where scm will look for its initialization code. + The default is the file "Init.scm" in the source directory. SCHEME_LIBRARY_PATH is the SLIB Scheme library directory. - HOME is the directory where "Init.scm" will look for the - user initialization file "ScmInit.scm". + HOME is the directory where "Init.scm" will look for the user initial- + ization file "ScmInit.scm". SCHEME VARIABLES *argv* - contains the list of arguments to the program. - *argv* can change during argument processing. This - list is suitable for use as an argument to SLIB - getopt. + contains the list of arguments to the program. *argv* can change + during argument processing. This list is suitable for use as an + argument to SLIB getopt. *R4RS-macro* - controls whether loading and interaction support R4RS - macros. Define this in "ScmInit.scm" or files speci- - fied on the command line. This can be overridden by - subsequent -m and -u options. + controls whether loading and interaction support R4RS macros. + Define this in "ScmInit.scm" or files specified on the command + line. This can be overridden by subsequent -m and -u options. *interactive* - controls interactivity as explained for the -i and -b - options. Define this in "ScmInit.scm" or files spec- - ified on the command line. This can be overridden by - subsequent -i and -b options. + controls interactivity as explained for the -i and -b options. + Define this in "ScmInit.scm" or files specified on the command + line. This can be overridden by subsequent -i and -b options. EXAMPLES - - - - - - 3 - - - - - -SCM(Jan 4 2000) SCM(Jan 4 2000) - - % scm foo.scm arg1 arg2 arg3 - Load and execute the contents of foo.scm. Parameters - arg1 arg2 and arg3 are stored in the global list - *argv*. + Load and execute the contents of foo.scm. Parameters arg1 arg2 + and arg3 are stored in the global list *argv*. % scm -f foo.scm arg1 arg2 arg3 The same. % scm -s foo.scm arg1 arg2 - Set *argv* to ("foo.scm" "arg1" "arg2") and enter - interactive session. + Set *argv* to ("foo.scm" "arg1" "arg2") and enter interactive ses- + sion. - % scm -e '(display (list-ref *argv* *optind*))' bar - Print ``bar'' + % scm -e ’(display (list-ref *argv* *optind*))’ bar + Print ‘‘bar’’ % scm -rpretty-print -r format -i - Load pretty-print and format and enter interactive - mode. + Load pretty-print and format and enter interactive mode. % scm -r5 - Load dynamic-wind, values, and R4RS macros and enter - interactive (with macros) mode. + Load dynamic-wind, values, and R4RS macros and enter interactive + (with macros) mode. % scm -r5 -r4 - Like above but rev4-optional-procedures are also - loaded. + Like above but rev4-optional-procedures are also loaded. FEATURES - Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, - Unicos, VMS, Unix and similar systems. Support for ASCII - and EBCDIC character sets. + Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, + Unix and similar systems. Support for ASCII and EBCDIC character sets. - Conforms to Revised^5 Report on the Algorithmic Language - Scheme and the IEEE P1178 specification. + Conforms to Revised^5 Report on the Algorithmic Language Scheme and the + IEEE P1178 specification. Support for SICP, R2RS, R3RS, and R4RS scheme code. - Many Common Lisp functions: logand, logor, logxor, lognot, - ash, logcount, integer-length, bit-extract, defmacro, - macroexpand, macroexpand1, gentemp, defvar, force-output, - software-type, get-decoded-time, get-internal-run-time, - get-internal-real-time, delete-file, rename-file, copy- - tree, acons, and eval. - - Char-code-limit, most-positive-fixnum, most-negative- - fixnum, and internal-time-units-per-second constants. - *Features* and *load-pathname* variables. - - Arrays and bit-vectors. String ports and software emula- - tion ports. I/O extensions providing most of ANSI C and - POSIX.1 facilities. - - User definable responses to interrupts and errors, Pro- - cess-syncronization primitives, String regular expression - - - - 4 + Many Common Lisp functions: logand, logor, logxor, lognot, ash, log- + count, integer-length, bit-extract, defmacro, macroexpand, macroex- + pand1, gentemp, defvar, force-output, software-type, get-decoded-time, + get-internal-run-time, get-internal-real-time, delete-file, rename- + file, copy-tree, acons, and eval. + Char-code-limit, most-positive-fixnum, most-negative-fixnum, and inter- + nal-time-units-per-second constants. *Features* and *load-pathname* + variables. + Arrays and bit-vectors. String ports and software emulation ports. + I/O extensions providing most of ANSI C and POSIX.1 facilities. + User definable responses to interrupts and errors, Process-synchroniza- + tion primitives, String regular expression matching, and the CURSES + screen management package. + Available add-on packages including an interactive debugger, database, + X-window graphics, BGI graphics, Motif, and Open-Windows packages. -SCM(Jan 4 2000) SCM(Jan 4 2000) + A compiler (HOBBIT, available separately) and dynamic linking of + compiled modules. - - matching, and the CURSES screen management package. - - Available add-on packages including an interactive debug- - ger, database, X-window graphics, BGI graphics, Motif, and - Open-Windows packages. - - A compiler (HOBBIT, available separately) and dynamic - linking of compiled modules. - - Setable levels of monitoring and timing information - printed interactively (the `verbose' function). Restart, - quit, and exec. + Setable levels of monitoring and timing information printed interac- + tively (the ‘verbose’ function). Restart, quit, and exec. FILES scm.texi - Texinfo documentation of scm enhancements, internal - representations, and how to extend or include scm - in other programs. + Texinfo documentation of scm enhancements, internal representa- + tions, and how to extend or include scm in other programs. AUTHORS Aubrey Jaffer (jaffer @ alum.mit.edu) @@ -296,9 +217,8 @@ SEE ALSO The SCM home-page: http://swissnet.ai.mit.edu/~jaffer/SCM.html - The Scheme specifications for details on specific proce- - dures (http://swissnet.ai.mit.edu/ftpdir/scheme-reports/) - or + The Scheme specifications for details on specific procedures + (http://swissnet.ai.mit.edu/ftpdir/scheme-reports/) or IEEE Std 1178-1990, IEEE Standard for the Scheme Programming Language, @@ -318,13 +238,4 @@ SEE ALSO - - - - - - - - 5 - - +4th Berkeley Distribution SCM(Jan 4 2000) diff --git a/scm.h b/scm.h index 4fb3afe..ab737a2 100644 --- a/scm.h +++ b/scm.h @@ -98,7 +98,7 @@ typedef struct { sizet len; sizet alloclen; sizet maxlen; - char *what; + const char *what; char *elts;} scm_gra; #ifdef USE_ANSI_PROTOTYPES @@ -167,10 +167,12 @@ typedef struct {SCM type;float num;} flo; typedef struct {SCM type;double *real;} dbl; #endif -#define IMP(x) (6 & (int)(x)) + /* Conditionals should always expect immediates */ + /* GCC __builtin_expect() is stubbed in scmfig.h */ +#define IMP(x) SCM_EXPECT_TRUE(6 & (int)(x)) #define NIMP(x) (!IMP(x)) -#define INUMP(x) (2 & (int)(x)) +#define INUMP(x) SCM_EXPECT_TRUE(2 & (int)(x)) #define NINUMP(x) (!INUMP(x)) #define INUM0 ((SCM) 2) #define ICHRP(x) ((0xff & (int)(x))==0xf4) @@ -405,7 +407,7 @@ SCM_EXPORT long tc16_env, tc16_ident; /* ((&REAL(x))[1]) */ # ifdef SINGLES # define REALP(x) ((~REAL_PART & CAR(x))==tc_flo) -# define SINGP(x) (CAR(x)==tc_flo) +# define SINGP(x) SCM_EXPECT_TRUE(CAR(x)==tc_flo) # define FLO(x) (((flo *)(SCM2PTR(x)))->num) # define REALPART(x) (SINGP(x)?0.0+FLO(x):REAL(x)) # else /* SINGLES */ @@ -702,10 +704,10 @@ SCM_EXPORT void (*init_user_scm) P((void)); SCM_EXPORT void (* deferred_proc) P((void)); SCM_EXPORT void process_signals P((void)); SCM_EXPORT int handle_it P((int i)); -SCM_EXPORT SCM must_malloc_cell P((long len, SCM c, char *what)); -SCM_EXPORT void must_realloc_cell P((SCM z, long olen, long len, char *what)); -SCM_EXPORT char *must_malloc P((long len, char *what)); -SCM_EXPORT char *must_realloc P((char *where, long olen, long len, char *what)); +SCM_EXPORT SCM must_malloc_cell P((long len, SCM c, const char *what)); +SCM_EXPORT void must_realloc_cell P((SCM z, long olen, long len, const char *what)); +SCM_EXPORT char *must_malloc P((long len, const char *what)); +SCM_EXPORT char *must_realloc P((char *where, long olen, long len, const char *what)); SCM_EXPORT void must_free P((char *obj, sizet len)); SCM_EXPORT void scm_protect_temp P((SCM *ptr)); SCM_EXPORT long ilength P((SCM sx)); @@ -719,7 +721,7 @@ SCM_EXPORT unsigned long hasher P((SCM obj, unsigned long n, sizet d)); SCM_EXPORT SCM lroom P((SCM args)); SCM_EXPORT SCM lflush P((SCM port)); SCM_EXPORT void scm_init_gra P((scm_gra *gra, sizet eltsize, sizet len, - sizet maxlen, char *what)); + sizet maxlen, const char *what)); SCM_EXPORT int scm_grow_gra P((scm_gra *gra, char *elt)); SCM_EXPORT void scm_trim_gra P((scm_gra *gra)); SCM_EXPORT void scm_free_gra P((scm_gra *gra)); @@ -731,7 +733,7 @@ SCM_EXPORT void prinport P((SCM exp, SCM port, char *type)); SCM_EXPORT SCM repl P((void)); SCM_EXPORT void repl_report P((void)); SCM_EXPORT void growth_mon P((char *obj, long size, char *units, int grewp)); -SCM_EXPORT void gc_start P((char *what)); +SCM_EXPORT void gc_start P((const char *what)); SCM_EXPORT void gc_end P((void)); SCM_EXPORT void gc_mark P((SCM p)); SCM_EXPORT void scm_gc_hook P((void)); @@ -753,7 +755,7 @@ SCM_EXPORT void iprin1 P((SCM exp, SCM port, int writing)); SCM_EXPORT void intprint P((long n, int radix, SCM port)); SCM_EXPORT void iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing)); SCM_EXPORT SCM scm_env_lookup P((SCM var, SCM stenv)); -SCM_EXPORT SCM scm_env_rlookup P((SCM addr, SCM stenv, char *what)); +SCM_EXPORT SCM scm_env_rlookup P((SCM addr, SCM stenv, const char *what)); SCM_EXPORT SCM scm_env_getprop P((SCM prop, SCM env)); SCM_EXPORT SCM scm_env_addprop P((SCM prop, SCM val, SCM env)); SCM_EXPORT long num_frames P((SCM estk, int i)); @@ -763,7 +765,7 @@ SCM_EXPORT SCM stacktrace1 P((SCM estk, int i)); SCM_EXPORT void scm_princode P((SCM code, SCM env, SCM port, int writing)); SCM_EXPORT void scm_princlosure P((SCM proc, SCM port, int writing)); SCM_EXPORT void lputc P((int c, SCM port)); -SCM_EXPORT void lputs P((char *s, SCM port)); +SCM_EXPORT void lputs P((const char *s, SCM port)); SCM_EXPORT sizet lfwrite P((char *ptr, sizet size, sizet nitems, SCM port)); SCM_EXPORT int lgetc P((SCM port)); SCM_EXPORT void lungetc P((int c, SCM port)); @@ -777,14 +779,14 @@ SCM_EXPORT void init_iprocs P((iproc *subra, int type)); SCM_EXPORT void final_scm P((int)); SCM_EXPORT void init_sbrk P((void)); SCM_EXPORT int init_buf0 P((FILE *inport)); -SCM_EXPORT void scm_init_from_argv P((int argc, char **argv, char *script_arg, +SCM_EXPORT void scm_init_from_argv P((int argc, const char * const *argv, char *script_arg, int iverbose, int buf0stdin)); SCM_EXPORT void init_signals P((void)); SCM_EXPORT SCM scm_top_level P((char *initpath, SCM (*toplvl_fun)())); SCM_EXPORT void restore_signals P((void)); SCM_EXPORT void free_storage P((void)); SCM_EXPORT char *dld_find_executable P((const char* command)); -SCM_EXPORT char *scm_find_execpath P((int argc, char **argv, char *script_arg)); +SCM_EXPORT char *scm_find_execpath P((int argc, const char * const *argv, const char *script_arg)); SCM_EXPORT void init_scm P((int iverbose, int buf0stdin, long init_heap_size)); SCM_EXPORT void scm_init_INITS P((void)); SCM_EXPORT SCM scm_init_extensions P((void)); @@ -798,9 +800,9 @@ SCM_EXPORT SCM markcdr P((SCM ptr)); SCM_EXPORT SCM equal0 P((SCM ptr1, SCM ptr2)); SCM_EXPORT sizet free0 P((CELLPTR ptr)); SCM_EXPORT void scm_warn P((char *str1, char *str2, SCM obj)); -SCM_EXPORT void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr, int codep)); -SCM_EXPORT void wta P((SCM arg, char *pos, char *s_subr)); -SCM_EXPORT void scm_experr P((SCM arg, char *pos, char *s_subr)); +SCM_EXPORT void everr P((SCM exp, SCM env, SCM arg, const char *pos, const char *s_subr, int codep)); +SCM_EXPORT void wta P((SCM arg, const char *pos, const char *s_subr)); +SCM_EXPORT void scm_experr P((SCM arg, const char *pos, const char *s_subr)); SCM_EXPORT SCM intern P((char *name, sizet len)); SCM_EXPORT SCM sysintern P((const char *name, SCM val)); SCM_EXPORT SCM sym2vcell P((SCM sym)); @@ -870,7 +872,8 @@ SCM_EXPORT SCM difference P((SCM x, SCM y)); SCM_EXPORT SCM product P((SCM x, SCM y)); SCM_EXPORT SCM divide P((SCM x, SCM y)); SCM_EXPORT SCM lquotient P((SCM x, SCM y)); -SCM_EXPORT SCM absval P((SCM x)); +SCM_EXPORT SCM scm_iabs P((SCM x)); +SCM_EXPORT SCM scm_abs P((SCM x)); SCM_EXPORT SCM lremainder P((SCM x, SCM y)); SCM_EXPORT SCM modulo P((SCM x, SCM y)); SCM_EXPORT SCM lgcd P((SCM x, SCM y)); @@ -942,12 +945,12 @@ SCM_EXPORT SCM for_each P((SCM proc, SCM arg1, SCM args)); SCM_EXPORT SCM procedurep P((SCM obj)); SCM_EXPORT SCM apply P((SCM proc, SCM arg1, SCM args)); SCM_EXPORT SCM scm_cvapply P((SCM proc, long n, SCM *argv)); -SCM_EXPORT int scm_arity_check P((SCM proc, long argc, char *what)); +SCM_EXPORT int scm_arity_check P((SCM proc, long argc, const char *what)); SCM_EXPORT SCM map P((SCM proc, SCM arg1, SCM args)); SCM_EXPORT SCM scm_make_cont P((void)); SCM_EXPORT SCM copytree P((SCM obj)); SCM_EXPORT SCM eval P((SCM obj)); -SCM_EXPORT SCM scm_values P((SCM arg1, SCM arg2, SCM rest, char *what)); +SCM_EXPORT SCM scm_values P((SCM arg1, SCM arg2, SCM rest, const char *what)); SCM_EXPORT SCM scm_eval_values P((SCM x, SCM static_env, SCM env)); SCM_EXPORT SCM identp P((SCM obj)); SCM_EXPORT SCM ident2sym P((SCM id)); @@ -970,7 +973,7 @@ SCM_EXPORT SCM scm_read P((SCM port)); SCM_EXPORT SCM scm_read_char P((SCM port)); SCM_EXPORT SCM peek_char P((SCM port)); SCM_EXPORT SCM eof_objectp P((SCM x)); -SCM_EXPORT int scm_io_error P((SCM port, char *what)); +SCM_EXPORT int scm_io_error P((SCM port, const char *what)); SCM_EXPORT SCM lwrite P((SCM obj, SCM port)); SCM_EXPORT SCM display P((SCM obj, SCM port)); SCM_EXPORT SCM newline P((SCM port)); @@ -978,7 +981,7 @@ SCM_EXPORT SCM write_char P((SCM chr, SCM port)); SCM_EXPORT SCM scm_port_line P((SCM port)); SCM_EXPORT SCM scm_port_col P((SCM port)); SCM_EXPORT void scm_line_msg P((SCM file, SCM linum, SCM port)); -SCM_EXPORT void scm_err_line P((char *what, SCM file, SCM linum, SCM port)); +SCM_EXPORT void scm_err_line P((const char *what, SCM file, SCM linum, SCM port)); SCM_EXPORT SCM lgetenv P((SCM nam)); SCM_EXPORT SCM prog_args P((void)); SCM_EXPORT SCM makacro P((SCM code)); @@ -1005,7 +1008,7 @@ SCM_EXPORT void add_final P((void (*final)(void))); SCM_EXPORT SCM makcclo P((SCM proc, long len)); SCM_EXPORT SCM make_uve P((long k, SCM prot)); SCM_EXPORT long scm_prot2type P((SCM prot)); -SCM_EXPORT long aind P((SCM ra, SCM args, char *what)); +SCM_EXPORT long aind P((SCM ra, SCM args, const char *what)); SCM_EXPORT SCM scm_eval_string P((SCM str)); SCM_EXPORT SCM scm_load_string P((SCM str)); SCM_EXPORT SCM scm_unexec P((const SCM pathname)); @@ -1033,11 +1036,11 @@ SCM_EXPORT unsigned long num2ulong P((SCM num, char *pos, char *s_caller)); SCM_EXPORT long num2long P((SCM num, char *pos, char *s_caller)); SCM_EXPORT short num2short P((SCM num, char *pos, char *s_caller)); SCM_EXPORT double num2dbl P((SCM num, char *pos, char *s_caller)); -SCM_EXPORT SCM makfromstr P((char *src, sizet len)); -SCM_EXPORT SCM makfromstrs P((int argc, char **argv)); -SCM_EXPORT SCM makfrom0str P((char *scr)); -SCM_EXPORT char **makargvfrmstrs P((SCM args, char *s_v)); -SCM_EXPORT void must_free_argv P((char **argv)); +SCM_EXPORT SCM makfromstr P((const char *src, sizet len)); +SCM_EXPORT SCM makfromstrs P((int argc, const char * const *argv)); +SCM_EXPORT SCM makfrom0str P((const char *scr)); +SCM_EXPORT char **makargvfrmstrs P((SCM args, const char *s_v)); +SCM_EXPORT void must_free_argv P((const char * const *argv)); SCM_EXPORT SCM scm_evstr P((char *str)); SCM_EXPORT void scm_ldstr P((char *str)); SCM_EXPORT int scm_ldfile P((char *path)); @@ -1050,10 +1053,7 @@ SCM_EXPORT int scm_cell_p P((SCM x)); SCM_EXPORT SCM makdbl P((double x, double y)); SCM_EXPORT SCM dbl2big P((double d)); SCM_EXPORT double big2dbl P((SCM b)); -SCM_EXPORT double lasinh P((double x)); -SCM_EXPORT double lacosh P((double x)); -SCM_EXPORT double latanh P((double x)); -SCM_EXPORT double ltrunc P((double x)); +SCM_EXPORT double scm_truncate P((double x)); SCM_EXPORT double scm_round P((double x)); SCM_EXPORT double floident P((double x)); #endif @@ -1079,9 +1079,9 @@ SCM_EXPORT int scm_bigdblcomp P((SCM b, double d)); SCM_EXPORT char * scm_cat_path P((char *str1, const char *str2, long n)); SCM_EXPORT char * scm_try_path P((char *path)); SCM_EXPORT char * script_find_executable P((const char *command)); -SCM_EXPORT char ** script_process_argv P((int argc, char **argv)); -SCM_EXPORT int script_count_argv P((char **argv)); -SCM_EXPORT char * find_impl_file P((char *exec_path, const char *generic_name, +SCM_EXPORT char ** script_process_argv P((int argc, const char **argv)); +SCM_EXPORT int script_count_argv P((const char **argv)); +SCM_EXPORT char * find_impl_file P((const char *exec_path, const char *generic_name, const char *initname, const char *sep)); /* environment cache functions */ @@ -1111,8 +1111,8 @@ SCM_EXPORT SCM scm_trace, scm_trace_env; # define ASRTER(_cond, _arg, _pos, _subr) ; # define ASRTGO(_cond, _label) ; #else -# define ASRTER(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)(_pos), _subr); -# define ASRTGO(_cond, _label) if(!(_cond)) goto _label; +# define ASRTER(_cond, _arg, _pos, _subr) if (SCM_EXPECT_FALSE(!(_cond))) wta(_arg, (char *)(_pos), _subr); +# define ASRTGO(_cond, _label) if (SCM_EXPECT_FALSE(!(_cond))) goto _label; #endif #define ARGn 1 @@ -1138,12 +1138,12 @@ SCM_EXPORT SCM scm_trace, scm_trace_env; #define PROF_SIGNAL 20 #define EVAL(x, env, venv) (IMP(x)?(x):ceval((x), (SCM)(env), (SCM)(venv))) -#define SIDEVAL(x, env, venv) if NIMP(x) ceval((x), (SCM)(env), (SCM)(venv)) +#define SIDEVAL(x, env, venv) if (NIMP(x)) ceval((x), (SCM)(env), (SCM)(venv)) -#define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\ +#define NEWCELL(_into) {if (IMP(freelist)) _into = gc_for_newcell();\ else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}} /* -#define NEWCELL(_into) {DEFER_INTS;if IMP(freelist) _into = gc_for_newcell();\ +#define NEWCELL(_into) {DEFER_INTS;if (IMP(freelist)) _into = gc_for_newcell();\ else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}\ ALLOW_INTS;} */ diff --git a/scm.info b/scm.info index f554663..59f4f8a 100644 --- a/scm.info +++ b/scm.info @@ -1,4 +1,4 @@ -This is scm.info, produced by makeinfo version 4.7 from scm.texi. | +This is scm.info, produced by makeinfo version 4.7 from scm.texi. INFO-DIR-SECTION The Algorithmic Language Scheme START-INFO-DIR-ENTRY @@ -9,10 +9,10 @@ END-INFO-DIR-ENTRY File: scm.info, Node: Top, Next: Overview, Prev: (dir), Up: (dir) This manual documents the SCM Scheme implementation. SCM version -5e1 was released June 2005. The most recent information about SCM can | -be found on SCM's "WWW" home page: | +5e2 was released February 2006. The most recent information about SCM | +can be found on SCM's "WWW" home page: | - `http://swiss.csail.mit.edu/~jaffer/SCM' | + `http://swiss.csail.mit.edu/~jaffer/SCM' Copyright (C) 1990-1999 Free Software Foundation @@ -43,8 +43,8 @@ approved by the author.  File: scm.info, Node: Overview, Next: Installing SCM, Prev: Top, Up: Top -1 Overview | -********** | +1 Overview +********** Scm is a portable Scheme implementation written in C. Scm provides a machine independent platform for [JACAL], a symbolic algebra system. @@ -59,8 +59,8 @@ machine independent platform for [JACAL], a symbolic algebra system.  File: scm.info, Node: SCM Features, Next: SCM Authors, Prev: Overview, Up: Overview -1.1 Features | -============ | +1.1 Features +============ * Conforms to Revised^5 Report on the Algorithmic Language Scheme [R5RS] and the [IEEE] P1178 specification. @@ -109,8 +109,8 @@ File: scm.info, Node: SCM Features, Next: SCM Authors, Prev: Overview, Up: O  File: scm.info, Node: SCM Authors, Next: Copying, Prev: SCM Features, Up: Overview -1.2 Authors | -=========== | +1.2 Authors +=========== Aubrey Jaffer (agj @ alum.mit.edu) Most of SCM. @@ -138,70 +138,70 @@ file `ChangeLog', a log of changes that have been made to scm.  File: scm.info, Node: Copying, Next: Bibliography, Prev: SCM Authors, Up: Overview -1.3 Copyright | -============= | +1.3 Copyright +============= Authors have assigned their SCM copyrights to: Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111, USA -* Menu: | - | -* The SCM License:: | -* SIOD copyright:: | - | +* Menu: + +* The SCM License:: +* SIOD copyright:: +  File: scm.info, Node: The SCM License, Next: SIOD copyright, Prev: Copying, Up: Copying - | -1.3.1 The SCM License | ---------------------- | - | -The license of SCM consists of the GNU GPL plus a special statement | -giving blanket permission to link with non-free software. This is the | -license statement as found in any individual file that it applies to: | - | - 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, Inc., 59 Temple Place, Suite 330, | - Boston, MA 02111-1307 USA | - | - As a special exception, the Free Software Foundation gives | - permission for additional uses of the text contained in its | - release of SCM. | - | - The exception is that, if you link the SCM 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 SCM 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 SCM. If you copy code from | - other Free Software Foundation releases into a copy of SCM, 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 SCM, it is your choice | - whether to permit this exception to apply to your modifications. | - If you do not wish that, delete this exception notice. | - | + +1.3.1 The SCM License +--------------------- + +The license of SCM consists of the GNU GPL plus a special statement +giving blanket permission to link with non-free software. This is the +license statement as found in any individual file that it applies to: + + 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, Inc., 59 Temple Place, Suite 330, + Boston, MA 02111-1307 USA + + As a special exception, the Free Software Foundation gives + permission for additional uses of the text contained in its + release of SCM. + + The exception is that, if you link the SCM 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 SCM 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 SCM. If you copy code from + other Free Software Foundation releases into a copy of SCM, 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 SCM, it is your choice + whether to permit this exception to apply to your modifications. + If you do not wish that, delete this exception notice. + Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided that the above copyright notice appear in all copies and that @@ -232,9 +232,9 @@ OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.  File: scm.info, Node: SIOD copyright, Prev: The SCM License, Up: Copying - | -1.3.2 SIOD copyright | --------------------- | + +1.3.2 SIOD copyright +-------------------- COPYRIGHT (c) 1989 BY @@ -267,8 +267,8 @@ Cambridge, MA 02138  File: scm.info, Node: Bibliography, Prev: Copying, Up: Overview -1.4 Bibliography | -================ | +1.4 Bibliography +================ [IEEE] `IEEE Standard 1178-1990. IEEE Standard for the Scheme @@ -331,8 +331,8 @@ File: scm.info, Node: Bibliography, Prev: Copying, Up: Overview  File: scm.info, Node: Installing SCM, Next: Operational Features, Prev: Overview, Up: Top -2 Installing SCM | -**************** | +2 Installing SCM +**************** * Menu: @@ -352,8 +352,8 @@ File: scm.info, Node: Installing SCM, Next: Operational Features, Prev: Overv  File: scm.info, Node: Making SCM, Next: SLIB, Prev: Installing SCM, Up: Installing SCM -2.1 Making SCM | -============== | +2.1 Making SCM +============== The SCM distribution has "Makefile" which contains rules for making "scmlit", a "bare-bones" version of SCM sufficient for running `build'. @@ -364,7 +364,7 @@ Makefiles are not portable to the majority of platforms. If `Makefile' works for you, good; If not, I don't want to hear about it. If you need to compile SCM without build, there are several ways to proceed: - * Use the build (http://swiss.csail.mit.edu/~jaffer/buildscm.html) | + * Use the build (http://swiss.csail.mit.edu/~jaffer/buildscm.html) web page to create custom batch scripts for compiling SCM. * Use SCM on a different platform to run `build' to create a script @@ -378,8 +378,8 @@ need to compile SCM without build, there are several ways to proceed:  File: scm.info, Node: SLIB, Next: Building SCM, Prev: Making SCM, Up: Installing SCM -2.2 SLIB | -======== | +2.2 SLIB +======== [SLIB] is a portable Scheme library meant to provide compatibility and utility functions for all standard Scheme implementations. Although @@ -387,18 +387,18 @@ SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and install it. Bug reports about running SCM without SLIB have very low priority. SLIB is available from the same sites as SCM: - * swiss.csail.mit.edu:/pub/scm/slib3a2.tar.gz | + * swiss.csail.mit.edu:/pub/scm/slib3a3.tar.gz | - * ftp.gnu.org:/pub/gnu/jacal/slib3a2.tar.gz | + * ftp.gnu.org:/pub/gnu/jacal/slib3a3.tar.gz | - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a2.tar.gz | + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a3.tar.gz | -Unpack SLIB (`tar xzf slib3a2.tar.gz' or `unzip -ao slib3a2.zip') in an | +Unpack SLIB (`tar xzf slib3a3.tar.gz' or `unzip -ao slib3a3.zip') in an | appropriate directory for your system; both `tar' and `unzip' will create the directory `slib'. Then create a file `require.scm' in the SCM "implementation-vicinity" -(this is the same directory as where the file `Init5e1.scm' is | +(this is the same directory as where the file `Init5e2.scm' is | installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -422,8 +422,8 @@ overrides `require.scm'. Again, absolute pathnames are recommended.  File: scm.info, Node: Building SCM, Next: Installing Dynamic Linking, Prev: SLIB, Up: Installing SCM -2.3 Building SCM | -================ | +2.3 Building SCM +================ The file "build" loads the file "build.scm", which constructs a relational database of how to compile and link SCM executables. @@ -441,8 +441,8 @@ ai.mit.edu.  File: scm.info, Node: Invoking Build, Next: Build Options, Prev: Building SCM, Up: Building SCM -2.3.1 Invoking Build | --------------------- | +2.3.1 Invoking Build +-------------------- The _all_ method will also work for MS-DOS and unix. Use the _all_ method if you encounter problems with `build'. @@ -470,7 +470,7 @@ script with the `arrays', `inexact', and `bignums' options as defaults. # unix (linux) script created by SLIB/batch # ================ Write file with C defines rm -f scmflags.h - echo '#define IMPLINIT "Init5e1.scm"'>>scmflags.h | + echo '#define IMPLINIT "Init5e2.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -489,7 +489,7 @@ in the `-p' or `--platform=' option. # unix (darwin) script created by SLIB/batch # ================ Write file with C defines rm -f scmflags.h - echo '#define IMPLINIT "Init5e1.scm"'>>scmflags.h | + echo '#define IMPLINIT "Init5e2.scm"'>>scmflags.h | # ================ Compile C source files cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c # ================ Link C object files @@ -499,149 +499,149 @@ in the `-p' or `--platform=' option.  File: scm.info, Node: Build Options, Next: Compiling and Linking Custom Files, Prev: Invoking Build, Up: Building SCM -2.3.2 Build Options | -------------------- | +2.3.2 Build Options +------------------- The options to "build" specify what, where, and how to build a SCM program or dynamically linked module. These options are unrelated to the SCM command line options. - -- Build Option: -p PLATFORM-NAME | - -- Build Option: --platform=PLATFORM-NAME | + -- Build Option: -p PLATFORM-NAME + -- Build Option: --platform=PLATFORM-NAME specifies that the compilation should be for a computer/operating-system combination called PLATFORM-NAME. - _Note_ The case of PLATFORM-NAME is distinguised. The current | + _Note_ The case of PLATFORM-NAME is distinguised. The current PLATFORM-NAMEs are all lower-case. The platforms defined by table "platform" in `build.scm' are: - Table: platform | - name processor operating-system compiler | - #f processor-family operating-system #f | - symbol processor-family operating-system symbol | - symbol symbol symbol symbol | - ================= ================= ================= ================= | - *unknown* *unknown* unix cc | - acorn-unixlib acorn *unknown* cc | - aix powerpc aix cc | - alpha-elf alpha unix cc | - alpha-linux alpha linux gcc | - amiga-aztec m68000 amiga cc | - amiga-dice-c m68000 amiga dcc | - amiga-gcc m68000 amiga gcc | - amiga-sas m68000 amiga lc | - atari-st-gcc m68000 atari.st gcc | - atari-st-turbo-c m68000 atari.st tcc | - borland-c i8086 ms-dos bcc | - darwin powerpc unix cc | - djgpp i386 ms-dos gcc | - freebsd i386 unix cc | - gcc *unknown* unix gcc | - gnu-win32 i386 unix gcc | - highc i386 ms-dos hc386 | - hp-ux hp-risc hp-ux cc | - irix mips irix gcc | - linux i386 linux gcc | - linux-aout i386 linux gcc | - microsoft-c i8086 ms-dos cl | - microsoft-c-nt i386 ms-dos cl | - microsoft-quick-c i8086 ms-dos qcl | - ms-dos i8086 ms-dos cc | - netbsd *unknown* unix gcc | - openbsd *unknown* unix gcc | - os/2-cset i386 os/2 icc | - os/2-emx i386 os/2 gcc | - osf1 alpha unix cc | - plan9-8 i386 plan9 8c | - sunos sparc sunos cc | - svr4 *unknown* unix cc | - svr4-gcc-sun-ld sparc sunos gcc | - turbo-c i8086 ms-dos tcc | - unicos cray unicos cc | - unix *unknown* unix cc | - vms vax vms cc | - vms-gcc vax vms gcc | - watcom-9.0 i386 ms-dos wcc386p | - - -- Build Option: -f PATHNAME | + Table: platform + name processor operating-system compiler + #f processor-family operating-system #f + symbol processor-family operating-system symbol + symbol symbol symbol symbol + ================= ================= ================= ================= + *unknown* *unknown* unix cc + acorn-unixlib acorn *unknown* cc + aix powerpc aix cc + alpha-elf alpha unix cc + alpha-linux alpha linux gcc + amiga-aztec m68000 amiga cc + amiga-dice-c m68000 amiga dcc + amiga-gcc m68000 amiga gcc + amiga-sas m68000 amiga lc + atari-st-gcc m68000 atari.st gcc + atari-st-turbo-c m68000 atari.st tcc + borland-c i8086 ms-dos bcc + darwin powerpc unix cc + djgpp i386 ms-dos gcc + freebsd i386 unix cc + gcc *unknown* unix gcc + gnu-win32 i386 unix gcc + highc i386 ms-dos hc386 + hp-ux hp-risc hp-ux cc + irix mips irix gcc + linux i386 linux gcc + linux-aout i386 linux gcc + microsoft-c i8086 ms-dos cl + microsoft-c-nt i386 ms-dos cl + microsoft-quick-c i8086 ms-dos qcl + ms-dos i8086 ms-dos cc + netbsd *unknown* unix gcc + openbsd *unknown* unix gcc + os/2-cset i386 os/2 icc + os/2-emx i386 os/2 gcc + osf1 alpha unix cc + plan9-8 i386 plan9 8c + sunos sparc sunos cc + svr4 *unknown* unix cc + svr4-gcc-sun-ld sparc sunos gcc + turbo-c i8086 ms-dos tcc + unicos cray unicos cc + unix *unknown* unix cc + vms vax vms cc + vms-gcc vax vms gcc + watcom-9.0 i386 ms-dos wcc386p + + -- Build Option: -f PATHNAME specifies that the build options contained in PATHNAME be spliced - into the argument list at this point. The use of option files can | - separate functional features from platform-specific ones. | - - The `Makefile' calls out builds with the options in `.opt' files: | - | - `dlls.opt' | - Options for Makefile targets mydlls, myturtle, and x.so. | - | - `gdb.opt' | - Options for udgdbscm and gdbscm. | - | - `libscm.opt' | - Options for libscm.a. | - | - `pg.opt' | - Options for pgscm, which instruments C functions. | - | - `udscm4.opt' | - Options for targets udscm4 and dscm4 (scm). | - | - `udscm5.opt' | - Options for targets udscm5 and dscm5 (scm). | - | - The Makefile creates options files it depends on only if they do | - not already exist. | - | - -- Build Option: -o FILENAME | - -- Build Option: --outname=FILENAME | + into the argument list at this point. The use of option files can + separate functional features from platform-specific ones. + + The `Makefile' calls out builds with the options in `.opt' files: + + `dlls.opt' + Options for Makefile targets mydlls, myturtle, and x.so. + + `gdb.opt' + Options for udgdbscm and gdbscm. + + `libscm.opt' + Options for libscm.a. + + `pg.opt' + Options for pgscm, which instruments C functions. + + `udscm4.opt' + Options for targets udscm4 and dscm4 (scm). + + `udscm5.opt' + Options for targets udscm5 and dscm5 (scm). + + The Makefile creates options files it depends on only if they do + not already exist. + + -- Build Option: -o FILENAME + -- Build Option: --outname=FILENAME specifies that the compilation should produce an executable or object name of FILENAME. The default is `scm'. Executable suffixes will be added if neccessary, e.g. `scm' => `scm.exe'. - -- Build Option: -l LIBNAME ... | - -- Build Option: --libraries=LIBNAME | + -- Build Option: -l LIBNAME ... + -- Build Option: --libraries=LIBNAME specifies that the LIBNAME should be linked with the executable produced. If compile flags or include directories (`-I') are needed, they are automatically supplied for compilations. The `c' library is always included. SCM "features" specify any libraries they need; so you shouldn't need this option often. - -- Build Option: -D DEFINITION ... | - -- Build Option: --defines=DEFINITION | + -- Build Option: -D DEFINITION ... + -- Build Option: --defines=DEFINITION specifies that the DEFINITION should be made in any C source compilations. If compile flags or include directories (`-I') are needed, they are automatically supplied for compilations. SCM "features" specify any flags they need; so you shouldn't need this option often. - -- Build Option: --compiler-options=FLAG | + -- Build Option: --compiler-options=FLAG specifies that that FLAG will be put on compiler command-lines. - -- Build Option: --linker-options=FLAG | + -- Build Option: --linker-options=FLAG specifies that that FLAG will be put on linker command-lines. - -- Build Option: -s PATHNAME | - -- Build Option: --scheme-initial=PATHNAME | + -- Build Option: -s PATHNAME + -- Build Option: --scheme-initial=PATHNAME specifies that PATHNAME should be the default location of the SCM - initialization file `Init5e1.scm'. SCM tries several likely | + initialization file `Init5e2.scm'. SCM tries several likely | locations before resorting to PATHNAME (*note File-System Habitat::). If not specified, the current directory (where build is building) is used. - -- Build Option: -c PATHNAME ... | - -- Build Option: --c-source-files=PATHNAME | + -- Build Option: -c PATHNAME ... + -- Build Option: --c-source-files=PATHNAME specifies that the C source files PATHNAME ... are to be compiled. - -- Build Option: -j PATHNAME ... | - -- Build Option: --object-files=PATHNAME | + -- Build Option: -j PATHNAME ... + -- Build Option: --object-files=PATHNAME specifies that the object files PATHNAME ... are to be linked. - -- Build Option: -i CALL ... | - -- Build Option: --initialization=CALL | + -- Build Option: -i CALL ... + -- Build Option: --initialization=CALL specifies that the C functions CALL ... are to be invoked during initialization. - -- Build Option: -t BUILD-WHAT | - -- Build Option: --type=BUILD-WHAT | + -- Build Option: -t BUILD-WHAT + -- Build Option: --type=BUILD-WHAT specifies in general terms what sort of thing to build. The choices are: `exe' @@ -658,8 +658,8 @@ the SCM command line options. The default is to build an executable. - -- Build Option: -h BATCH-SYNTAX | - -- Build Option: -batch-dialect=BATCH-SYNTAX | + -- Build Option: -h BATCH-SYNTAX + -- Build Option: -batch-dialect=BATCH-SYNTAX specifies how to build. The default is to create a batch file for the host system. The SLIB file `batch.scm' knows how to create batch files for: @@ -680,13 +680,13 @@ the SCM command line options. This option outputs Scheme code. - -- Build Option: -w BATCH-FILENAME | - -- Build Option: -script-name=BATCH-FILENAME | + -- Build Option: -w BATCH-FILENAME + -- Build Option: -script-name=BATCH-FILENAME specifies where to write the build script. The default is to display it on `(current-output-port)'. - -- Build Option: -F FEATURE ... | - -- Build Option: --features=FEATURE | + -- Build Option: -F FEATURE ... + -- Build Option: --features=FEATURE specifies to build the given features into the executable. The defined features are: @@ -702,9 +702,9 @@ the SCM command line options. "bignums" Large precision integers. - "byte" | - Treating strings as byte-vectors. | - | + "byte" + Treating strings as byte-vectors. + "careful-interrupt-masking" Define this for extra checking of interrupt masking and some simple checks for proper use of malloc and free. This is for @@ -740,9 +740,9 @@ the SCM command line options. `careful-interrupt-masking', and `stack-limit'; uses `-g' flags for debugging SCM source code. - "differ" | - Sequence comparison | - | + "differ" + Sequence comparison + "dump" Convert a running scheme program into an executable file. @@ -827,8 +827,8 @@ the SCM command line options. numbers. "socket" - BSD "socket" interface. Socket addr functions require | - inexacts or bignums for 32-bit precision. | + BSD "socket" interface. Socket addr functions require + inexacts or bignums for 32-bit precision. "stack-limit" Use to enable checking for stack overflow. Define value of @@ -848,9 +848,9 @@ the SCM command line options. Those unix features which have not made it into the Posix specs: nice, acct, lstat, readlink, symlink, mknod and sync. - "wb" | - WB database with relational wrapper. | - | + "wb" + WB database with relational wrapper. + "windows" Microsoft Windows executable. @@ -864,8 +864,8 @@ the SCM command line options.  File: scm.info, Node: Compiling and Linking Custom Files, Prev: Build Options, Up: Building SCM -2.3.3 Compiling and Linking Custom Files | ----------------------------------------- | +2.3.3 Compiling and Linking Custom Files +---------------------------------------- A correspondent asks: @@ -875,14 +875,14 @@ A correspondent asks: build.scm or the Makefile or both? (*note Changing Scm:: has instructions describing the C code format). Suppose -a C file "foo.c" has functions you wish to add to SCM. To compile and | -link your file at compile time, use the `-c' and `-i' options to build: | +a C file "foo.c" has functions you wish to add to SCM. To compile and +link your file at compile time, use the `-c' and `-i' options to build: bash$ ./build -c foo.c -i init_foo -| #! /bin/sh rm -f scmflags.h - echo '#define IMPLINIT "/home/jaffer/scm/Init5e1.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5e2.scm"'>>scmflags.h | echo '#define COMPILED_INITS init_foo();'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h @@ -898,7 +898,7 @@ To make a dynamically loadable object file use the `-t dll' option: -| #! /bin/sh rm -f scmflags.h - echo '#define IMPLINIT "/home/jaffer/scm/Init5e1.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5e2.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -914,8 +914,8 @@ add a compiled dll file to SLIB's catalog.  File: scm.info, Node: Installing Dynamic Linking, Next: Configure Module Catalog, Prev: Building SCM, Up: Installing SCM -2.4 Installing Dynamic Linking | -============================== | +2.4 Installing Dynamic Linking +============================== Dynamic linking has not been ported to all platforms. Operating systems in the BSD family (a.out binary format) can usually be ported to "DLD". @@ -954,15 +954,15 @@ These notes about using libdl on SunOS are from `gcc.info':  File: scm.info, Node: Configure Module Catalog, Next: Saving Images, Prev: Installing Dynamic Linking, Up: Installing SCM -2.5 Configure Module Catalog | -============================ | +2.5 Configure Module Catalog +============================ The SLIB module "catalog" can be extended to define other `require'-able packages by adding calls to the Scheme source file `mkimpcat.scm'. Within `mkimpcat.scm', the following procedures are defined. - -- Function: add-link feature object-file lib1 ... | + -- Function: add-link feature object-file lib1 ... FEATURE should be a symbol. OBJECT-FILE should be a string naming a file containing compiled "object-code". Each LIBn argument should be either a string naming a library file or `#f'. @@ -983,7 +983,7 @@ defined. link:able-suffix)) - -- Function: add-alias alias feature | + -- Function: add-alias alias feature ALIAS and FEATURE are symbols. The procedure `add-alias' registers ALIAS as an alias for FEATURE. An unspecified value is returned. @@ -991,7 +991,7 @@ defined. `add-alias' causes `(require 'ALIAS)' to behave like `(require 'FEATURE)'. - -- Function: add-source feature filename | + -- Function: add-source feature filename FEATURE is a symbol. FILENAME is a string naming a file containing Scheme source code. The procedure `add-source' registers FEATURE so that the first time `require' is called with @@ -1004,8 +1004,8 @@ Remember to delete the file `slibcat' after modifying the file  File: scm.info, Node: Saving Images, Next: Automatic C Preprocessor Definitions, Prev: Configure Module Catalog, Up: Installing SCM -2.6 Saving Images | -================= | +2.6 Saving Images +================= In SCM, the ability to save running program images is called "dump" (*note Dump::). In order to make `dump' available to SCM, build with @@ -1021,8 +1021,8 @@ file from emacs.  File: scm.info, Node: Automatic C Preprocessor Definitions, Next: Problems Compiling, Prev: Saving Images, Up: Installing SCM -2.7 Automatic C Preprocessor Definitions | -======================================== | +2.7 Automatic C Preprocessor Definitions +======================================== These `#defines' are automatically provided by preprocessors of various C compilers. SCM uses the presence or absence of these definitions to @@ -1037,6 +1037,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of ARM_ULIB Huw Rogers free unix library for acorn archimedes AZTEC_C Aztec_C 5.2a __CYGWIN__ Cygwin + __CYGWIN32__ Cygwin | _DCC Dice C on AMIGA __GNUC__ Gnu CC (and DJGPP) __EMX__ Gnu C port (gcc/emx 0.8e) to OS/2 2.0 @@ -1066,13 +1067,14 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of macintosh Macintosh (THINK_C and __MWERKS__ define) MCH_AMIGA Aztec_c 5.2a on AMIGA __MACH__ Apple Darwin + __MINGW32__ MinGW - Minimalist GNU for Windows | MSDOS Microsoft C 5.10 and 6.00A _MSDOS Microsoft CLARM and CLTHUMB compilers. __MSDOS__ Turbo C, Borland C, and DJGPP __NetBSD__ NetBSD nosve Control Data NOS/VE SVR2 System V Revision 2. - sun SunOS | + sun SunOS __SVR4 SunOS THINK_C developement environment for the Macintosh ultrix VAX with ULTRIX operating system. @@ -1091,9 +1093,9 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of __alpha DEC Alpha processor __alpha__ DEC Alpha processor hp9000s800 HP RISC processor - __ia64 GCC on IA64 | - __ia64__ GCC on IA64 | - _LONGLONG GCC on IA64 | + __ia64 GCC on IA64 + __ia64__ GCC on IA64 + _LONGLONG GCC on IA64 __i386__ DJGPP i386 DJGPP _M_ARM Microsoft CLARM compiler defines as 4 for ARM. @@ -1107,12 +1109,13 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of sequent Sequent computer tahoe CCI Tahoe processor vax VAX processor + __x86_64 AMD Opteron |  File: scm.info, Node: Problems Compiling, Next: Problems Linking, Prev: Automatic C Preprocessor Definitions, Up: Installing SCM -2.8 Problems Compiling | -====================== | +2.8 Problems Compiling +====================== FILE PROBLEM / MESSAGE HOW TO FIX *.c include file not found. Correct the status of @@ -1144,8 +1147,8 @@ scl.c syntax error. #define SYSTNAME to your system  File: scm.info, Node: Problems Linking, Next: Problems Running, Prev: Problems Compiling, Up: Installing SCM -2.9 Problems Linking | -==================== | +2.9 Problems Linking +==================== PROBLEM HOW TO FIX _sin etc. missing. Uncomment LIBS in makefile. @@ -1153,8 +1156,8 @@ _sin etc. missing. Uncomment LIBS in makefile.  File: scm.info, Node: Problems Running, Next: Testing, Prev: Problems Linking, Up: Installing SCM -2.10 Problems Running | -===================== | +2.10 Problems Running +===================== PROBLEM HOW TO FIX Opening message and then machine Change memory model option to C @@ -1173,17 +1176,17 @@ remove in scmfig.h and Do so and recompile files. recompile scm. add in scmfig.h and recompile scm. -ERROR: Init5e1.scm not found. Assign correct IMPLINIT in makefile | +ERROR: Init5e2.scm not found. Assign correct IMPLINIT in makefile | or scmfig.h. Define environment variable SCM_INIT_PATH to be the full - pathname of Init5e1.scm. | + pathname of Init5e2.scm. | WARNING: require.scm not found. Define environment variable SCHEME_LIBRARY_PATH to be the full pathname of the scheme library [SLIB]. Change library-vicinity in - Init5e1.scm to point to library or | + Init5e2.scm to point to library or | remove. Make sure the value of (library-vicinity) has a trailing @@ -1192,8 +1195,8 @@ WARNING: require.scm not found. Define environment variable  File: scm.info, Node: Testing, Next: Reporting Problems, Prev: Problems Running, Up: Installing SCM -2.11 Testing | -============ | +2.11 Testing +============ Loading `r4rstest.scm' in the distribution will run an [R4RS] conformance test on `scm'. @@ -1243,7 +1246,7 @@ Some symbol names print incorrectly. Change memory model option to C than HEAP_SEG_SIZE). ERROR: Rogue pointer in Heap. See above under machine crashes. Newlines don't appear correctly in Check file mode (define OPEN_... in -output files. `Init5e1.scm'). | +output files. `Init5e2.scm'). | Spaces or control characters appear Check character defines in in symbol names. `scmfig.h'. Negative numbers turn positive. Check SRS in `scmfig.h'. @@ -1258,14 +1261,14 @@ Sparc(SUN-4) heap is growing out of control This causes lots of stuff which should be collected to not be. This will be a problem with any _conservative_ GC until we find what instruction will clear the register windows. This problem is - exacerbated by using lots of call-with-current-continuations. A | - possible fix for dynthrow() is commented out in `continue.c'. | + exacerbated by using lots of call-with-current-continuations. A + possible fix for dynthrow() is commented out in `continue.c'.  File: scm.info, Node: Reporting Problems, Prev: Testing, Up: Installing SCM -2.12 Reporting Problems | -======================= | +2.12 Reporting Problems +======================= Reported problems and solutions are grouped under Compiling, Linking, Running, and Testing. If you don't find your problem listed there, you @@ -1290,8 +1293,8 @@ include:  File: scm.info, Node: Operational Features, Next: The Language, Prev: Installing SCM, Up: Top -3 Operational Features | -********************** | +3 Operational Features +********************** * Menu: @@ -1302,7 +1305,7 @@ File: scm.info, Node: Operational Features, Next: The Language, Prev: Install * SCM Session:: * Editing Scheme Code:: * Debugging Scheme Code:: -* Debugging Continuations:: | +* Debugging Continuations:: * Errors:: * Memoized Expressions:: * Internal State:: @@ -1311,8 +1314,8 @@ File: scm.info, Node: Operational Features, Next: The Language, Prev: Install  File: scm.info, Node: Invoking SCM, Next: SCM Options, Prev: Operational Features, Up: Operational Features -3.1 Invoking SCM | -================ | +3.1 Invoking SCM +================ scm [-a kbytes] [-muvbiq] [-version] [-help] [[-]-no-init-file] [-p int] [-r feature] [-h feature] @@ -1326,7 +1329,7 @@ variable SCM_INIT_PATH. If SCM_INIT_PATH is not defined or if the file it names is not present, `scm' tries to find the directory containing the executable file. If it is able to locate the executable, `scm' looks for the initialization -file (usually `Init5e1.scm') in platform-dependent directories relative | +file (usually `Init5e2.scm') in platform-dependent directories relative | to this directory. See *Note File-System Habitat:: for a blow-by-blow description. @@ -1335,12 +1338,12 @@ compile parameter IMPLINIT (defined in the makefile or `scmfig.h') is tried. Unless the option `-no-init-file' or `--no-init-file' occurs in the -command line, `Init5e1.scm' checks to see if there is file | +command line, `Init5e2.scm' checks to see if there is file | `ScmInit.scm' in the path specified by the environment variable HOME (or in the current directory if HOME is undefined). If it finds such a file it is loaded. -`Init5e1.scm' then looks for command input from one of three sources: | +`Init5e2.scm' then looks for command input from one of three sources: | From an option on the command line, from a file named on the command line, or from standard input. @@ -1352,55 +1355,55 @@ Lexical Conventions.  File: scm.info, Node: SCM Options, Next: Invocation Examples, Prev: Invoking SCM, Up: Operational Features -3.2 Options | -=========== | +3.2 Options +=========== The options are processed in the order specified on the command line. - -- Command Option: -a k | + -- Command Option: -a k specifies that `scm' should allocate an initial heapsize of K kilobytes. This option, if present, must be the first on the command line. If not specified, the default is `INIT_HEAP_SIZE' in source file `setjump.h' which the distribution sets at `25000*sizeof(cell)'. - -- Command Option: -no-init-file | - -- Command Option: --no-init-file | + -- Command Option: -no-init-file + -- Command Option: --no-init-file Inhibits the loading of `ScmInit.scm' as described above. - -- Command Option: --help | + -- Command Option: --help prints usage information and URI; then exit. - -- Command Option: --version | + -- Command Option: --version prints version information and exit. - -- Command Option: -r feature | + -- Command Option: -r feature requires FEATURE. This will load a file from [SLIB] if that - FEATURE is not already provided. If FEATURE is 2, 2rs, or r2rs; | - 3, 3rs, or r3rs; 4, 4rs, or r4rs; 5, 5rs, or r5rs; `scm' will | - require the features neccessary to support [R2RS]; [R3RS]; [R4RS]; | - or [R5RS], respectively. | + FEATURE is not already provided. If FEATURE is 2, 2rs, or r2rs; + 3, 3rs, or r3rs; 4, 4rs, or r4rs; 5, 5rs, or r5rs; `scm' will + require the features neccessary to support [R2RS]; [R3RS]; [R4RS]; + or [R5RS], respectively. - -- Command Option: -h feature | + -- Command Option: -h feature provides FEATURE. - -- Command Option: -l filename | - -- Command Option: -f filename | + -- Command Option: -l filename + -- Command Option: -f filename loads FILENAME. `Scm' will load the first (unoptioned) file named on the command line if no `-c', `-e', `-f', `-l', or `-s' option preceeds it. - -- Command Option: -d filename | + -- Command Option: -d filename Loads SLIB `databases' feature and opens FILENAME as a database. - -- Command Option: -e expression | - -- Command Option: -c expression | + -- Command Option: -e expression + -- Command Option: -c expression specifies that the scheme expression EXPRESSION is to be evaluated. These options are inspired by `perl' and `sh' respectively. On Amiga systems the entire option and argument need to be enclosed in quotes. For instance `"-e(newline)"'. - -- Command Option: -o dumpname | + -- Command Option: -o dumpname saves the current SCM session as the executable program `dumpname'. This option works only in SCM builds supporting `dump' (*note Dump::). @@ -1410,33 +1413,33 @@ The options are processed in the order specified on the command line. it is invoked. Otherwise the (new) command line is processed as usual when the saved image is invoked. - -- Command Option: -p level | + -- Command Option: -p level sets the prolixity (verboseness) to LEVEL. This is the same as the `scm' command (verobse LEVEL). - -- Command Option: -v | + -- Command Option: -v (verbose mode) specifies that `scm' will print prompts, evaluation times, notice of loading files, and garbage collection statistics. This is the same as `-p3'. - -- Command Option: -q | + -- Command Option: -q (quiet mode) specifies that `scm' will print no extra information. This is the same as `-p0'. - -- Command Option: -m | + -- Command Option: -m specifies that subsequent loads, evaluations, and user interactions will be with syntax-rules macro capability. To use a specific syntax-rules macro implementation from [SLIB] (instead of [SLIB]'s default) put `-r' MACROPACKAGE before `-m' on the command line. - -- Command Option: -u | + -- Command Option: -u specifies that subsequent loads, evaluations, and user interactions will be without syntax-rules macro capability. Syntax-rules macro capability can be restored by a subsequent `-m' on the command line or from Scheme code. - -- Command Option: -i | + -- Command Option: -i specifies that `scm' should run interactively. That means that `scm' will not terminate until the `(quit)' or `(exit)' command is given, even if there are errors. It also sets the prolixity level @@ -1446,26 +1449,26 @@ The options are processed in the order specified on the command line. will assume that it should be interactive unless given a subsequent `-b' option. - -- Command Option: -b | + -- Command Option: -b specifies that `scm' should run non-interactively. That means that `scm' will terminate after processing the command line or if there are errors. - -- Command Option: -s | + -- Command Option: -s specifies, by analogy with `sh', that `scm' should run interactively and that further options are to be treated as program aguments. - -- Command Option: - | - -- Command Option: -- | + -- Command Option: - + -- Command Option: -- specifies that further options are to be treated as program aguments.  File: scm.info, Node: Invocation Examples, Next: SCM Variables, Prev: SCM Options, Up: Operational Features -3.3 Invocation Examples | -======================= | +3.3 Invocation Examples +======================= `% scm foo.scm' Loads and executes the contents of `foo.scm' and then enters @@ -1496,39 +1499,39 @@ File: scm.info, Node: Invocation Examples, Next: SCM Variables, Prev: SCM Opt  File: scm.info, Node: SCM Variables, Next: SCM Session, Prev: Invocation Examples, Up: Operational Features -3.4 Environment Variables | -========================= | +3.4 Environment Variables +========================= - -- Environment Variable: SCM_INIT_PATH | + -- Environment Variable: SCM_INIT_PATH is the pathname where `scm' will look for its initialization code. - The default is the file `Init5e1.scm' in the source directory. | + The default is the file `Init5e2.scm' in the source directory. | - -- Environment Variable: SCHEME_LIBRARY_PATH | + -- Environment Variable: SCHEME_LIBRARY_PATH is the [SLIB] Scheme library directory. - -- Environment Variable: HOME | - is the directory where `Init5e1.scm' will look for the user | + -- Environment Variable: HOME + is the directory where `Init5e2.scm' will look for the user | initialization file `ScmInit.scm'. - -- Environment Variable: EDITOR | + -- Environment Variable: EDITOR is the name of the program which `ed' will call. If EDITOR is not defined, the default is `ed'. -3.5 Scheme Variables | -==================== | +3.5 Scheme Variables +==================== - -- Variable: *argv* | + -- Variable: *argv* contains the list of arguments to the program. `*argv*' can change during argument processing. This list is suitable for use as an argument to [SLIB] `getopt'. - -- Variable: *syntax-rules* | + -- Variable: *syntax-rules* controls whether loading and interaction support syntax-rules macros. Define this in `ScmInit.scm' or files specified on the command line. This can be overridden by subsequent `-m' and `-u' options. - -- Variable: *interactive* | + -- Variable: *interactive* controls interactivity as explained for the `-i' and `-b' options. Define this in `ScmInit.scm' or files specified on the command line. This can be overridden by subsequent `-i' and `-b' options. @@ -1536,8 +1539,8 @@ File: scm.info, Node: SCM Variables, Next: SCM Session, Prev: Invocation Exam  File: scm.info, Node: SCM Session, Next: Editing Scheme Code, Prev: SCM Variables, Up: Operational Features -3.6 SCM Session | -=============== | +3.6 SCM Session +=============== * Options, file loading and features can be specified from the command line. *Note System interface: (scm)System interface. @@ -1549,23 +1552,23 @@ File: scm.info, Node: SCM Session, Next: Editing Scheme Code, Prev: SCM Varia * Typing the interrupt character aborts evaluation of the current form and resumes the top level read-eval-print loop. - -- Function: quit | - -- Function: quit n | - -- Function: exit | - -- Function: exit n | + -- Function: quit + -- Function: quit n + -- Function: exit + -- Function: exit n Aliases for `exit' (*note exit: (slib)System.). On many systems, SCM can also tail-call another program. *Note execp: I/O-Extensions. - -- Callback procedure: boot-tail dumped? | + -- Callback procedure: boot-tail dumped? `boot-tail' is called by `scm_top_level' just before entering interactive top-level. If `boot-tail' calls `quit', then interactive top-level is not entered. - -- Function: program-arguments | + -- Function: program-arguments Returns a list of strings of the arguments scm was called with. - -- Function: getlogin | + -- Function: getlogin Returns the (login) name of the user logged in on the controlling terminal of the process, or #f if this information cannot be determined. @@ -1573,31 +1576,31 @@ File: scm.info, Node: SCM Session, Next: Editing Scheme Code, Prev: SCM Varia For documentation of the procedures `getenv' and `system' *Note System Interface: (slib)System Interface. - -- Function: vms-debug | + -- Function: vms-debug If SCM is compiled under VMS this `vms-debug' will invoke the VMS debugger.  File: scm.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: SCM Session, Up: Operational Features -3.7 Editing Scheme Code | -======================= | +3.7 Editing Scheme Code +======================= - -- Function: ed arg1 ... | + -- Function: ed arg1 ... The value of the environment variable `EDITOR' (or just `ed' if it isn't defined) is invoked as a command with arguments ARG1 .... - -- Function: ed filename | + -- Function: ed filename If SCM is compiled under VMS `ed' will invoke the editor with a single the single argument FILENAME. Gnu Emacs: Editing of Scheme code is supported by emacs. Buffers holding - files ending in .scm are automatically put into scheme-mode. | + files ending in .scm are automatically put into scheme-mode. - If your Emacs can run a process in a buffer you can use the Emacs | - command `M-x run-scheme' with SCM. Otherwise, use the emacs | - command `M-x suspend-emacs'; or see "other systems" below. | + If your Emacs can run a process in a buffer you can use the Emacs + command `M-x run-scheme' with SCM. Otherwise, use the emacs + command `M-x suspend-emacs'; or see "other systems" below. Epsilon (MS-DOS): There is lisp (and scheme) mode available by use of the package @@ -1627,9 +1630,9 @@ other systems:  File: scm.info, Node: Debugging Scheme Code, Next: Debugging Continuations, Prev: Editing Scheme Code, Up: Operational Features - | -3.8 Debugging Scheme Code | -========================= | + +3.8 Debugging Scheme Code +========================= The `cautious' and `stack-limit' options of `build' (*note Build Options::) support debugging in Scheme. @@ -1665,53 +1668,53 @@ Options::) support debugging in Scheme. There are several SLIB macros which so useful that SCM automatically loads the appropriate module from SLIB if they are invoked. - -- Macro: trace proc1 ... | + -- Macro: trace proc1 ... Traces the top-level named procedures given as arguments. - -- Macro: trace | + -- Macro: trace With no arguments, makes sure that all the currently traced identifiers are traced (even if those identifiers have been redefined) and returns a list of the traced identifiers. - -- Macro: untrace proc1 ... | + -- Macro: untrace proc1 ... Turns tracing off for its arguments. - -- Macro: untrace | + -- Macro: untrace With no arguments, untraces all currently traced identifiers and returns a list of these formerly traced identifiers. The routines I use most frequently for debugging are: - -- Function: print arg1 ... | + -- Function: print arg1 ... `Print' writes all its arguments, separated by spaces. `Print' outputs a `newline' at the end and returns the value of the last argument. - One can just insert `(print '