From 302e3218b7d487539ec305bf23881a6ee7d5be99 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:29 -0800 Subject: Import Upstream version 5e1 --- ANNOUNCE | 283 +++-- ChangeLog | 329 ++++- Idiffer.scm | 112 ++ Init5d9.scm | 1394 --------------------- Init5e1.scm | 1555 +++++++++++++++++++++++ Link.scm | 31 +- Makefile | 152 ++- README | 65 +- Transcen.scm | 136 +- Xlibscm.info | 681 +++++----- Xlibscm.texi | 4 +- build | 4 +- build.bat | 2 +- build.scm | 385 +++--- byte.c | 4 +- compile.scm | 4 +- differ.c | 594 +++++++++ eval.c | 47 +- features.txi | 11 +- hobbit.info | 306 ++--- hobbit.scm | 2 +- hobbit.texi | 9 +- inc2scm | 4 +- mkimpcat.scm | 20 + patchlvl.h | 4 +- r4rstest.scm | 48 +- ramap.c | 27 +- repl.c | 76 +- scl.c | 86 +- scm.h | 970 +++++++------- scm.info | 3967 +++++++++++++++++++++++++++++++--------------------------- scm.spec | 80 +- scm.texi | 434 +++++-- scmfig.h | 6 - scmhob.scm | 5 + script.c | 22 +- subr.c | 12 +- sys.c | 14 +- unif.c | 57 +- version.txi | 4 +- x11.scm | 106 +- xgen.scm | 4 +- 42 files changed, 7078 insertions(+), 4978 deletions(-) create mode 100644 Idiffer.scm delete mode 100644 Init5d9.scm create mode 100644 Init5e1.scm create mode 100644 differ.c diff --git a/ANNOUNCE b/ANNOUNCE index fc0f9f9..1effd27 100644 --- a/ANNOUNCE +++ b/ANNOUNCE @@ -1,94 +1,157 @@ -This message announces the availability of Scheme release scm5d9. - -New in scm5d9: - - * ramap.c (array-map): Added. - * byte.c: Added. Improves RANDOM speed by 32%. - * subr.c (scm_logbitp, scm_ash): Prevent wraparound (1>>32==1). - * ioext.c, posix.c (system->line): Defined. - * scl.c (floequal): Fixed so 0/0==0/0. - (eqv, eqp): Use floequal. - * eval.c (init_eval): add_feature("primitive-hygiene"). - * scl.c (eqp): Fixed so (let ((nan 0/0)) (= nan nan)) ==> #t. - (in2ex): Infinite loop on (inexact->exact 0/0) change to err. - * scl.c (iflo2str): Use negated conditional to handle 0/0. - (NaN2str): Removed "#i" prefix. - - * scm.texi (Embedding SCM): Updated libtest example for - init_user_scm indirection (which Radey added 2003-01-24). - * scm.texi (MS-DOS Compatible Scripts): Added sharpbang URL. - * scm.texi (Build Options): Described *.opt option files. - * scm.texi (Automatic C Preprocessor Definitions): Added IA64. - * scm.texi (Line Numbers): Added read-for-load. - (Load Syntax): Distinguished from Read syntax; documented #?line, - #?column, and #?file. - (Data Type Representations): Updated port formats. - - * Makefile (dfiles): Added version.txi platform.txi features.txi. - * Makefile (CFLAGS): Removed "-g". - * Makefile (pg.opt, gdb.opt, dlls.opt): Added. Cleanup options. - * Makefile (continue.o): Was missing scmfig.h and scm.h - dependencies. - * Makefile (uninstallinfo): Created. - (uninstall): Remove libscmdir files. - * Makefile (release): Make pdf(s). - - * Init5d8.scm (slib:eval-load): Use *load-reader*. - * repl.c (scm_read_for_load): Added. - (p_read_numbered, p_read_for_load, p_read): Added locatives. - (lreadr): Pass appropriate read routine to load:sharp; read:sharp. - (flgs): Renamed from nump to reduce interference with INUMP, etc. - * Init5d8.scm (load:sharp, read:sharp): Split read:sharp. - (load:sharp, read:sharp, char:sharp, read:array): Added READ arg. - (char:sharp): Renamed from read:sharp-char. - (read:sharp): Integrated #; into. - * repl.c (scm_read): Renamed from lread(). - (loc_charsharp): Renamed from loc_readsharpc. - (loc_loadsharp): Added to separate LOAD-macros from READ-macros. - (f_read_numbered): Removed unused variable. - (repl, tryload, scm_load_string): Use scm_read_numbered(). - (lreadpr): Dispatch to loc_readsharp or loc_loadsharp depending on - nump. - * Init5d8.scm (make-array): Alias of create-array. - (read:sharp): Feature evaluation now slib:provided? - - * mkimpcat.scm: Added rwb-isam feature. - * mkimpcat.scm (primitive-hygiene): Use feature to conditionalize - macro association. - - * scmfig.h (CDR_DOUBLES, SHORT_INT): Added __ia64 #defines. - - * build.scm (build): processor-family now symbol; i8086 <- 8086. - * build.scm (manifest): Added "byte.c". - * build.scm (compile-c-files): Removed "-O" and "-Wall" options; - use --compiler-options= instead. - * build.scm: Use open-table! and open-table. - * build (print-manifest, make-features-txi): Use open-table. - * build, build.scm: Moved requires to top. - * compile.scm, hobbit.scm: Added REQUIRE-IFs. - * hobbit.texi (SLIB Logical Procedures): Removed "logical:" - aliases. - - * bench.scm (benchmark-prng): Limit to 1000 samples if no bignums. - - * r4rstest.scm (inexact->exact): Added tests. - (exact->inexact): check for both exact and inexact argument. - * r4rstest.scm (6 5 5): Added some kawa chokers: #i, #e. - Added more kawa STRING->NUMBER bait. - * r4rstest.scm (test-string->number): Implementations which don't - allow division by 0 can have fragile string->number. - - From Sam Hocevar - * r4rstest.scm (test-inexact): SECTION 6.2 checks that - (not (eqv? 1 1.0)). - - From Andy Gaynor - * Makefile (Xlibscm.info, hobbit.info): Fixed / separators. - * unif.c (make_sh_array): Bracket with ifndef RECKLESS. - - From Radey Shouman - * eval.c (m_case): Check on clauses for CASE was - confused by line-number annotations. +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. + + * eval.c (macroexp1): Catch more syntax errors: ('f . f) + * eval.c (m_case) (definedp): Avoid segfault in cases of syntax + error. + +From Wim Lewis: + + * Makefile (scmflags): Use "cmp -s" instead of "diff". + (x.h): Use -x $CPROTO to test for cproto's existence. -=-=- @@ -104,24 +167,24 @@ include SCM in other programs. Documentation is online at: http://swissnet.ai.mit.edu/~jaffer/SCM.html SCM source is available from: - http://swissnet.ai.mit.edu/ftpdir/scm/scm5d9.zip - swissnet.ai.mit.edu:/pub/scm/scm5d9.zip - http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d9-1.src.rpm - swissnet.ai.mit.edu:/pub/scm/scm-5d9-1.src.rpm + 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 Also available as i386 binary RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d9-1.i386.rpm - swissnet.ai.mit.edu:/pub/scm/scm-5d9-1.i386.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/scm-5e1-1.i386.rpm + swissnet.ai.mit.edu:/pub/scm/scm-5e1-1.i386.rpm SLIB is a portable Scheme library which SCM uses: - http://swissnet.ai.mit.edu/ftpdir/scm/slib3a1.zip - swissnet.ai.mit.edu:/pub/scm/slib3a1.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib3a2.zip + swissnet.ai.mit.edu:/pub/scm/slib3a2.zip Also available as RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a1-1.noarch.rpm - swissnet.ai.mit.edu:/pub/scm/slib-3a1-1.noarch.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a2-1.noarch.rpm + swissnet.ai.mit.edu:/pub/scm/slib-3a2-1.noarch.rpm JACAL is a symbolic math system written in Scheme: - http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b4.zip - swissnet.ai.mit.edu:/pub/scm/jacal1b4.zip + http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b5.zip + swissnet.ai.mit.edu:/pub/scm/jacal1b5.zip SLIB-PSD is a portable debugger for Scheme (requires emacs editor): http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz @@ -149,13 +212,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/wb1b1.zip - swissnet.ai.mit.edu:/pub/scm/wb1b1.zip - http://swissnet.ai.mit.edu/ftpdir/scm/wb-1b1-1.src.rpm - swissnet.ai.mit.edu:/pub/scm/wb-1b1-1.src.rpm + 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 Also available as i386 binary RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/wb-1b1-1.i386.rpm - swissnet.ai.mit.edu:/pub/scm/wb-1b1-1.i386.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/wb-1c1-1.i386.rpm + swissnet.ai.mit.edu:/pub/scm/wb-1c1-1.i386.rpm SIMSYNCH is a digital logic simulation system written in SCM. http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip @@ -168,7 +231,7 @@ 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 slib3a1 and scm5d9 above. +Note: SCM.EXE still requires slib3a2 and scm5e1 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 0e564f2..df2ebd4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,328 @@ +2005-06-25 Aubrey Jaffer + + * scm.spec (slibpath, dumparch): Added. + +2005-06-24 Aubrey Jaffer + + * Makefile (DOSCM): Abstracted DOS zip creation. + + * 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. + +2005-06-21 Aubrey Jaffer + + * patchlvl.h (SCMVERSION): Bumped from 5d9 to 5e1. + +2005-06-13 Aubrey Jaffer + + * Transcen.scm (limit): Check and report input errors. + +2005-06-12 Aubrey Jaffer + + * Transcen.scm (limit): Added srfi-70 procedure. + +2005-05-20 Aubrey Jaffer + + * r4rstest.scm: Removed tests for 0^0 in anticipation of SRFI-70. + + * scl.c (scm_complex_p): 0/0 is not complex. + +2005-05-18 Aubrey Jaffer + + * Makfile (scm5): Added target for undumpable architectures (FC3). + * Transcen.scm (expt, quotient, remainder, modulo): SRFI-70 + extensions. + +2005-05-10 Aubrey Jaffer + + * scl.c (inf2str): Renamed from NaN2str(). + (makdbl): Returns `infi' for unreal infinities. + (scm_rationalp): Added (infinities not). + + * scm.h (infi): Nonreal infinity added to sys_protects. + + * scmfig.h (IS_INF): Removed. + + * Init5d9.scm (numerator, denominator): Check rational. + +2005-04-15 Aubrey Jaffer + + * Init5d9.scm (numerator, denominator): Added. + +2005-04-14 Aubrey Jaffer + + * Init5d9.scm (with-load-pathname): Moved from slib/require.scm. + +2005-03-18 Aubrey Jaffer + + * Makefile (install): Added db.so. + (uninstall): Beefed up. + +2005-01-30 Radey Shouman + + * Init5d9.scm (read:array): Make default rank one, not zero. + (as before). + +2005-01-27 Aubrey Jaffer + + * Init5d9.scm (any-bits-set?, first-set-bit, bitwise-merge): Added + remaining SRFI-33 aliases. + +2005-01-26 Aubrey Jaffer + + * Init5d9.scm (read-array-type): Handle A:char. + +2005-01-19 Radey Shouman + + * script.c (find_impl_file): Find executable path accurately + on MS windows. + + * 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. + +2005-01-18 Aubrey Jaffer + + * scm.texi (MS-DOS Compatible Scripts): Replaced %0 ... %9 with + %~f0 %* + + * xgen.scm, build.bat, inc2scm: Replaced %0 ... %9 with %~f0 %* + +2005-01-16 Aubrey Jaffer + + * Init5d9.scm (list->array, vector->array, array->vector): Added. + +2005-01-09 Aubrey Jaffer + + * Init5d9.scm: Updated per SRFI-60. + + * subr.c (scm_copybitfield): Changed argument order (SRFI-60). + +2005-01-08 Aubrey Jaffer + + * Init5d9.scm (arithmetic-shift): Aliases ASH. + + * scmhob.scm: Moved LOGICAL: aliases from logical.scm. + +2005-01-06 Aubrey Jaffer + + * Init5d9.scm (read:array, read:sharp): Accept whole boatload of + SRFI-58 sytnaxes. + +2005-01-01 Aubrey Jaffer + + * unif.c (scm_prot2type): Was not defaulting correctly. + +2004-12-26 Aubrey Jaffer + + * unif.c (raprin1): Don't elide 1 from #1A. + +2004-11-29 Aubrey Jaffer + + * Makefile (SETARCH): Workaround for unexec on Fedora Linux i386. + +2004-11-14 Aubrey Jaffer + + * r4rstest.scm (test-numeric-predicates): Raised exponent so + intransitive 128-bit-float implementations are caught. + +2004-10-13 Aubrey Jaffer + + * byte.c (scm_write_byte): Was hosed for even number of bytes. + + * scl.c (scm_intexpt): EXPT of zero behaves like Common-Lisp. + + * 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. + + * Transcen.scm (expt): Changed so (expt 0 -5) signals error. + EXPT of zero returns zero or one matching input exactness. + +2004-10-10 Aubrey Jaffer + + * r4rstest.scm (SECTION 6 5 5): Added exact tests for EXPT. + Inexact EXPT corner cases should return inexacts. + + * scl.c (scm_intexpt): Bombed given (integer-expt 0 25). + +2004-09-23 Aubrey Jaffer + + * Init5d9.scm (inexact->exact, exact->inexact): Identity when + exacts-only. + +2004-09-15 Aubrey Jaffer + + * ramap.c (array:copy!): Renamed from array-copy!. + (array_copy): Arguments reversed. + +2004-09-12 Aubrey Jaffer + + * scm.texi (SCMDB): Added section with link. + (Hobbit): Moved notinfo stuff after Xlib so it appears same place + in all products. + +2004-09-09 Wim Lewis + + * Makefile (scmflags): Use "cmp -s" instead of "diff". + (x.h): Use -x $CPROTO to test for cproto's existence. + +2004-09-04 Aubrey Jaffer + + * build.scm (dlll gnu-win32): Changed flag to "-DSCM_WIN_DLL". + (dlll microsoft-c-nt): Changed flag to "-DSCM_WIN_DLL". + + * scm.h (SCM_WIN_DLL): renamed from SCM_DLL and DLLSCM. + Unatabified. + + * ramap.c (init_ramap): Its tc7_subr_2 not tc7_subr2! + +2004-08-11 Aubrey Jaffer + + * byte.c (scm_substring_read): Fixed off-by-one reading backwards. + +2004-07-29 Aubrey Jaffer + + * Makefile (db.so, rwb-isam.scm, wbtab.scm): Added. + +2004-07-28 Aubrey Jaffer + + * 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. + + * mkimpcat.scm: Support WB compiled in implementation-vicinity. + +2002-07-07 Radey Shouman + + * scm.texi (Debugging Continuations): Added documenting + frame-trace, frame->environment, scope-trace, frame-eval. + +2004-06-14 Aubrey Jaffer + + * Init5d9.scm (slib:eval-load): Define moved to "slib/require.scm" + +2004-06-13 Aubrey Jaffer + + * repl.c (err_head): Fixed "loaded from" messages and formatting. + + * Init5d9.scm (slib:eval-load): Converted to use (SLIB) + with-load-pathname. + + * Link.scm (link:link): Converted to use with-load-pathname. + +2004-05-28 Aubrey Jaffer + + * Makefile: (SHOBJS): Abstracted *.sl and *.so. + +2004-05-27 Aubrey Jaffer + + * repl.c (iprin1): Slashify uppercase chars in symbols. + +2004-04-17 Aubrey Jaffer + + * differ.c, Idiffer.scm: Linear-space O(PN) sequence comparison. + + * scm.spec (differ.so, Idiffer.scm): Added to %files. + + * Makefile (differ.so): Added target. + + * scm.texi (Sequence Comparison): Added. + +2004-03-27 Aubrey Jaffer + + * ramap.c (rafe): Removed unused variables inc and base. + +2004-03-26 Radey Shouman + + * 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. + +2004-03-08 Aubrey Jaffer + + * Makefile (mydlls): Call BUILD separately for each dll. + +2004-03-07 Aubrey Jaffer + + * mkimpcat.scm: Added 'DIFF. + + * build.scm (compile-dll-c-files): For those platforms supporting + shared object files, generate just one combining all FILES. + +2004-02-24 Radey Shouman + + * subr.c (scm_logbitp): Fixed bug in range check for fixnum + case. Eg (logbit? 10 #xffff) now correctly returns #t. + +2004-02-19 Aubrey Jaffer + + * Init5d9.scm (read:array): Ignore third argument; line-numbers + were hosing array reading. + +2004-02-08 Aubrey Jaffer + + * repl.c (handle_it): Added comments. Call scm_fill_freelist() if + interrupt lacks handler. + +2004-02-02 Aubrey Jaffer + + * repl.c (scm_top_level): Default value of toplvl_fun just once. + +2004-01-30 Aubrey Jaffer + + * 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. + +2004-01-20 Aubrey Jaffer + + * repl.c (read_token, iprin1, lreadr): Handle slashified symbols. + +2004-01-19 Radey Shouman + + * eval.c (macroexp1): Catch more syntax errors: ('f . f) + +2004-01-17 Aubrey Jaffer + + * scm.texi (SIOD copyright): Put in subsection. + (The SCM License): Parallel Guile License text. + +2004-01-16 Aubrey Jaffer + + * scm.texi (Automatic C Preprocessor Definitions): Added "sun". + + * unif.c, sys.c: Sun cc doesn't like fwrite declaration. + +2004-01-14 Aubrey Jaffer + + * Makefile (srcdir.mk): Include after target. + Separated shell assignments and exports. + +2004-01-07 Aubrey Jaffer + + * r4rstest.scm: Added URLs. + +2004-01-07 Radey Shouman + + * eval.c (m_case) (definedp): Avoid segfault in cases of syntax + error. + +2003-12-03 Aubrey Jaffer + + * eval.c (definedp): Added third (dummy) argument. + 2003-11-30 Aubrey Jaffer * patchlvl.h (SCMVERSION): Bumped from 5d8 to 5d9. @@ -3431,8 +3756,8 @@ Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer 1998-08-10 Aubrey Jaffer - * sys.c (scm_fill_freelist): added. Assures that at least - MIN_GC_YIELD cells are in freelis. This is used before returning + * sys.c (scm_fill_freelist): Added; assures that at least + MIN_GC_YIELD cells are in freelist. This is used before returning from interrupts. * repl.c (handle_it): Discard 2 cells (because of CDR in NEWCELL). diff --git a/Idiffer.scm b/Idiffer.scm new file mode 100644 index 0000000..ee36485 --- /dev/null +++ b/Idiffer.scm @@ -0,0 +1,112 @@ +;; Copyright (C) 2003, 2004 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. + +;;;; Linear-space O(PN) sequence comparison. +;;; "Idiffer.scm" Top-level sequence-comparison functions. +;;; Author: Aubrey Jaffer + +(define (diff:invert-edits! edits) + (define cost (car (array-dimensions edits))) + (do ((idx (+ -1 cost) (+ -1 idx))) + ((negative? idx)) + (array-set! edits (- (array-ref edits idx)) idx))) + +(define (edits2lcs! lcs edits A) + (define cost (car (array-dimensions edits))) + (define len-a (car (array-dimensions A))) + (let loop ((edx 0) + (sdx 0) + (adx 0)) + (let ((edit (if (< edx cost) (array-ref edits edx) 0))) + (cond ((>= adx len-a)) + ((positive? edit) + (loop (+ 1 edx) sdx adx)) + ((zero? edit) + (array-set! lcs (array-ref A adx) sdx) + (loop edx (+ 1 sdx) (+ 1 adx))) + ((>= adx (- -1 edit)) + (loop (+ 1 edx) sdx (+ 1 adx))) + (else + (array-set! lcs (array-ref A adx) sdx) + (loop edx (+ 1 sdx) (+ 1 adx))))))) + +(define (diff:longest-common-subsequence A B . p-lim) + (define M (car (array-dimensions A))) + (define N (car (array-dimensions B))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (let ((edits (if (< N M) + (diff:edits B A p-lim) + (diff:edits A B p-lim)))) + (and edits + (let* ((cost (car (array-dimensions edits))) + (lcs (make-array A (/ (- (+ N M) cost) 2)))) + (edits2lcs! lcs edits (if (< N M) B A)) + lcs)))) + +(define (diff:edits A B . p-lim) + (define M (car (array-dimensions A))) + (define N (car (array-dimensions B))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (let ((fp (make-array (A:fixZ32b) (if (negative? p-lim) + (+ 3 M N) + (+ 3 (abs (- N M)) p-lim p-lim))))) + (define est (if (< N M) + (diff2editlen fp B A p-lim) + (diff2editlen fp A B p-lim))) + (and est + (let ((edits (make-array (A:fixZ32b) est)) + (CCRR (make-array (A:fixZ32b) (* 2 (+ (max M N) 1))))) + (cond ((< N M) + (diff2edits! edits fp CCRR B A) + (diff:invert-edits! edits)) + (else + (diff2edits! edits fp CCRR A B))) + edits)))) + +(define (diff:edit-length A B . p-lim) + (define M (car (array-dimensions A))) + (define N (car (array-dimensions B))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (let ((fp (make-array (A:fixZ32b) (if (negative? p-lim) + (+ 3 M N) + (+ 3 (abs (- N M)) p-lim p-lim))))) + (if (< N M) + (diff2editlen fp B A p-lim) + (diff2editlen fp A B p-lim)))) diff --git a/Init5d9.scm b/Init5d9.scm deleted file mode 100644 index a95fada..0000000 --- a/Init5d9.scm +++ /dev/null @@ -1,1394 +0,0 @@ -;; Copyright (C) 1991-2002 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) "5d9") -(define (scheme-implementation-home-page) - "http://swissnet.ai.mit.edu/~jaffer/SCM") - -(define in-vicinity string-append) - -(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) - *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"))) - -(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 rank port read) - (define (bomb pc wid) - (error (string-append "array syntax? #" - (number->string rank) - "A" (string pc) - (if wid (number->string wid) "")))) - (list->uniform-array - rank - (case (char-downcase (peek-char port)) - ((#\\) (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))) - ((#\s #\f #\d #\l) (read-char port) 32) - ((#\() 32) ;legacy - (else (bomb pc wid))))) - ((#\e) ;legacy - (read-char port) - (case (char-downcase (peek-char port)) - ((#\s) (read-char port) -16) - ((#\f #\d #\l) (read-char port) -32) - (else -32))) - ((#\i) ;legacy - (read-char port) - (case (char-downcase (peek-char port)) - ((#\c) - (read-char port) - (case (char-downcase (peek-char port)) - ((#\s #\f #\d #\l) (read-char port))) - +64i) - ((#\s #\f) (read-char port) 32.0) - ((#\d #\l) (read-char port) 64.0) - (else (bomb (read-char port) #f)))) - (else #f)) - (read port))) - -;;; read-macros valid only in LOAD. -(define (load:sharp c port read) - (case c - ((#\') (read port)) - ((#\.) (eval (read 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)))) - -;;; read-macros valid for LOAD and READ. -(define (read:sharp c port read) - (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 1 port read)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (let* ((num (read:try-number port c)) - (c (peek-char port))) - (cond ((memv c '(#\a #\A)) (read-char port) (read:array num port read)) - (else (error "syntax? #" num c))))) - (else (error "unknown # object" c)))) - -;;; 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 ((string? obj) (s2cis obj)) - ((number? obj) (s2cis (number->string obj))) - ((symbol? obj) (symbol->string obj)) - ((not obj) "") - (else (slib: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) - (if (zero? deg) 0 (+ (* 2 (+ -1 (integer-expt 2 (- deg 1)))) 1))) - -(define (rotate k count len) - (set! count (modulo count len)) - (logior (logand (ash k count) (logical:ones len)) - (ash k (- count len)))) -(define logical:rotate rotate) - -(define (bit-reverse k n) - (do ((m (if (negative? n) (lognot n) n) (ash m -1)) - (k (+ -1 k) (+ -1 k)) - (rvs 0 (logior (ash rvs 1) (logand 1 m)))) - ((negative? k) (if (negative? n) (lognot rvs) rvs)))) - -(define (integer->list k . len) - (if (null? len) - (do ((k k (ash k -1)) - (lst '() (cons (odd? k) lst))) - ((<= k 0) lst)) - (do ((idx (+ -1 (car len)) (+ -1 idx)) - (k k (ash 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)) - -(define (bitwise:laminate . ks) - (define nks (length ks)) - (define nbs (apply max (map integer-length ks))) - (do ((kdx (+ -1 nbs) (+ -1 kdx)) - (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks)) - (ash ibs nks)))) - ((negative? kdx) ibs))) - -(define (bitwise:delaminate count k) - (define nbs (* count (+ 1 (quotient (integer-length k) count)))) - (do ((kdx (- nbs count) (- kdx count)) - (lst (vector->list (make-vector count 0)) - (map (lambda (k bool) (+ (if bool 1 0) (ash k 1))) - lst - (integer->list (ash k (- kdx)) count)))) - ((negative? kdx) lst))) - -;;;; Gray-code - -(define (integer->gray-code k) - (logxor k (ash k -1))) - -(define (gray-code->integer k) - (if (negative? k) - (error 'gray-code->integer 'negative? k) - (let ((kln (integer-length k))) - (do ((d 1 (* d 2)) - (ans (logxor k (ash k -1)) ; == (integer->gray-code k) - (logxor ans (ash ans (* d -2))))) - ((>= (* 2 d) kln) ans))))) - -(define (grayter k1 k2) - (define kl1 (integer-length k1)) - (define kl2 (integer-length k2)) - (if (eqv? kl1 kl2) - (> (gray-code->integer k1) (gray-code->integer k2)) - (> kl1 kl2))) - -(define (gray-code? k1 k2) - (and (not (eqv? k1 k2)) (grayter k1 k2))) -(define (gray-code>=? k1 k2) - (or (eqv? k1 k2) (grayter k1 k2))) - -(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) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (*load-reader* port) (*load-reader* port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -;;;; 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 (slib: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 print-args - (procedure->syntax - (lambda (sexp env) - (set! env (environment->tree env)) - (let ((frame (and (not (null? env)) (car env)))) - (cond ((not (null? (cdr sexp))) - (display "In") - (for-each (lambda (exp) (display #\ ) (display exp)) (cdr sexp)) - (display ": "))) - (do ((vars (car frame) (cdr vars)) - (vals (cdr frame) (cdr vals))) - ((not (pair? vars)) - (cond ((not (null? vars)) - (write vars) - (display " := ") - (write vals))) - (newline)) - (write (car vars)) - (display " = ") - (write (car vals)) - (display "; ")))))) - -(cond - ((defined? stack-trace) - -;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR -(define error - (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))) - -(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 (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)) - -(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?) -)) - -(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/Init5e1.scm b/Init5e1.scm new file mode 100644 index 0000000..ae2f591 --- /dev/null +++ b/Init5e1.scm @@ -0,0 +1,1555 @@ +;; 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/Link.scm b/Link.scm index 8e01de9..e0ea89b 100644 --- a/Link.scm +++ b/Link.scm @@ -57,7 +57,6 @@ (map char-downcase (string->list name)))))) (define link:link (lambda (file . libs) - (define oloadpath *load-pathname*) (let* ((sl (string-length file)) (lasl (string-length link:able-suffix)) (fname (let loop ((i (- sl 1))) @@ -72,26 +71,23 @@ (substring fname 0 (- nsl lasl))) (else fname))) (linkobj #f)) - (set! *load-pathname* file) (if (and (provided? 'sun-dl) (< 3 sl) (not (eqv? (string-ref file 0) '#\/))) (set! file (string-append "./" file))) - (set! linkobj (or (provided? 'sun-dl) (dyn:link file))) - (and linkobj - (for-each (lambda (lib) - (or (dyn:link lib) (slib:error "couldn't link: " lib))) - libs)) - (if (provided? 'sun-dl) (set! linkobj (dyn:link file))) - (cond ((not linkobj) - (set! *load-pathname* oloadpath) #f) - ((dyn:call (file->init_name name) linkobj) - (set! *load-pathname* oloadpath) #t) - (else - (dyn:unlink linkobj) - (set! *load-pathname* oloadpath) #f))))))) + (with-load-pathname file + (lambda () + (set! linkobj (or (provided? 'sun-dl) (dyn:link file))) + (and linkobj + (for-each (lambda (lib) + (or (dyn:link lib) + (slib:error "couldn't link: " lib))) + libs)) + (if (provided? 'sun-dl) (set! linkobj (dyn:link file))) + (cond ((not linkobj) #f) + ((dyn:call (file->init_name name) linkobj) #t) + (else (dyn:unlink linkobj) #f)))))))) -(cond ((defined? vms:dynamic-link-call) (define link:able-suffix #f) (define (link:link file) @@ -103,7 +99,8 @@ (set! dir (substring file 0 (+ i 1))) (set! fil (substring file (+ i 1) (string-length file)))) (else (loop (- i 1))))) - (vms:dynamic-link-call dir fil (file->init_name fil))))) + (with-load-pathname file + (lambda () (vms:dynamic-link-call dir fil (file->init_name fil))))))) (cond ((provided? 'sun-dl) diff --git a/Makefile b/Makefile index 4f2a011..a59ddbc 100644 --- a/Makefile +++ b/Makefile @@ -49,10 +49,15 @@ SHELL = /bin/sh LD = $(CC) SCMLIT = ./scmlit SCMEXE = ./scm +#SHOBJS = *.sl +SHOBJS = *.so #BUILD = ./build -hsystem -p svr4-gcc-sun-ld BUILD = ./build -hsystem +# Workaround for unexec on Fedora Linux i386 +#SETARCH = setarch i386 + #for RPMs RELEASE = 1 @@ -60,16 +65,16 @@ intro: @echo @echo "This is the scm$(VERSION) distribution. Read \"scm.info\"" @echo "to learn how to build and install SCM. Or browse" - @echo " http://swissnet.ai.mit.edu/~jaffer/SCM" + @echo " http://swiss.csail.mit.edu/~jaffer/SCM" @echo $(MAKE) scm -#srcdir=$(HOME)/scm/ -#srcdir=/usr/local/src/scm/ -include srcdir.mk srcdir.mk: Makefile echo "CPROTO=`type cproto | sed 's%.* %%'`" > srcdir.mk echo "srcdir=`pwd`/" >> srcdir.mk +#srcdir=$(HOME)/scm/ +#srcdir=/usr/local/src/scm/ +include srcdir.mk # directory where COPYING and InitXXX.scm reside. #IMPLPATH = /usr/local/src/scm/ @@ -85,21 +90,22 @@ IMPLINIT = $(IMPLPATH)Init$(VERSION).scm 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 Iedline.scm continue.c \ - findexec.c script.c debug.c byte.c + unix.c rope.c ramap.c gsubr.c edline.c continue.c \ + findexec.c script.c debug.c byte.c differ.c ofiles = scm.o time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \ continue.o findexec.o script.o debug.o # ramap.o ifiles = Init$(VERSION).scm Transcen.scm Link.scm Macro.scm Macexp.scm \ - Tscript.scm compile.scm + Tscript.scm compile.scm Iedline.scm Idiffer.scm hobfiles = hobbit.scm scmhob.scm scmhob.h xafiles = xatoms.scm x11.scm xevent.scm keysymdef.scm xfiles = x.c x.h xgen.scm xevent.h inc2scm $(xafiles) all: require.scm $(MAKE) mydlls - $(MAKE) myscm5 + $(MAKE) dscm5 $(MAKE) x.so + $(MAKE) db.so require.scm: cp -p requires.scm require.scm @@ -113,7 +119,7 @@ scmflags: echo "#define IMPLINIT \"$(IMPLINIT)\"" >> newflags.h echo "#endif" >> newflags.h echo "#define CAUTIOUS" >> newflags.h - -if (diff newflags.h scmflags.h) then rm newflags.h; \ + -if (cmp -s newflags.h scmflags.h) then rm newflags.h; \ else mv newflags.h scmflags.h; fi .c.o: $(CC) -c $(CFLAGS) $< -o $@ @@ -132,23 +138,34 @@ rope.o: rope.c scm.h scmfig.h scmflags.h continue.o: continue.c continue.h setjump.h scm.h scmfig.h scmflags.h # Simple build with bignums for running JACAL -scm: +scm: scmlit $(BUILD) -s $(IMPLPATH) -F cautious bignums arrays # i/o-extensions $(MAKE) check -# R4RS interpreter +# R5RS interpreter (not dumpable) +scm5.opt: + echo "-F cautious bignums arrays inexact" >> scm5.opt + echo "-F engineering-notation dynamic-linking" >> scm5.opt + echo "-F macro" >> scm5.opt +scm5: $(cfiles) $(hfiles) build.scm build scm5.opt + $(BUILD) -f scm5.opt -o scm -s $(IMPLPATH) + rm $(ofiles) scmmain.o + -$(MAKE) check + -$(MAKE) checkmacro + +# dumpable R4RS interpreter udscm4.opt: echo "-F cautious bignums arrays inexact" >> udscm4.opt echo "-F engineering-notation dump dynamic-linking" >> udscm4.opt udscm4: $(cfiles) $(hfiles) build.scm build udscm4.opt $(BUILD) -f udscm4.opt -o udscm4 -s $(IMPLPATH) rm $(ofiles) scmmain.o -myscm4: udscm4 $(ifiles) require.scm +dscm4: udscm4 $(ifiles) require.scm -rm slibcat implcat -mv scm scm~ - echo "(quit)" | ./udscm4 -no-init-file -o scm + echo "(quit)" | $(SETARCH) ./udscm4 -no-init-file -o scm -# R5RS interpreter +# dumpable R5RS interpreter udscm5.opt: udscm4.opt cat udscm4.opt >> udscm5.opt echo "-F macro" >> udscm5.opt @@ -156,10 +173,10 @@ udscm5.opt: udscm4.opt udscm5: $(cfiles) $(hfiles) build.scm build Makefile udscm5.opt $(BUILD) -f udscm5.opt -o udscm5 -s $(IMPLPATH) rm $(ofiles) scmmain.o -myscm5: udscm5 $(ifiles) require.scm +dscm5: udscm5 $(ifiles) require.scm -rm slibcat implcat -mv scm scm~ - echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm + echo "(quit)" | $(SETARCH) ./udscm5 -no-init-file -r5 -o scm $(MAKE) check $(MAKE) checkmacro @@ -174,7 +191,7 @@ gdb.opt: udscm5.opt udgdbscm: gdb.opt $(BUILD) -f gdb.opt -o udgdbscm -s $(IMPLPATH) gdbscm: udgdbscm - echo "(quit)" | ./udgdbscm -no-init-file -r5 -o gdbscm + echo "(quit)" | $(SETARCH) ./udgdbscm -no-init-file -r5 -o gdbscm # R4RS interpreter for profiling pg.opt: udscm4.opt @@ -185,7 +202,7 @@ pg.opt: udscm4.opt udpgscm: pg.opt $(BUILD) -f pg.opt -o udpgscm -s $(IMPLPATH) pgscm: udpgscm - echo "(quit)" | ./udpgscm -no-init-file -o pgscm + echo "(quit)" | $(SETARCH) ./udpgscm -no-init-file -o pgscm # R4RS SCM library libscm.opt: @@ -207,9 +224,25 @@ mydlls: dlls.opt if [ -f /usr/lib/libreadline.so ]; \ then $(BUILD) -t dll -f dlls.opt -F edit-line; fi $(BUILD) -t dll -f dlls.opt -F curses - $(BUILD) -t dll -f dlls.opt -c sc2.c rgx.c record.c gsubr.c \ - ioext.c posix.c unix.c socket.c ramap.c byte.c - + $(BUILD) -t dll -f dlls.opt -c sc2.c + $(BUILD) -t dll -f dlls.opt -c rgx.c + $(BUILD) -t dll -f dlls.opt -c record.c + $(BUILD) -t dll -f dlls.opt -c gsubr.c + $(BUILD) -t dll -f dlls.opt -c ioext.c + $(BUILD) -t dll -f dlls.opt -c posix.c + $(BUILD) -t dll -f dlls.opt -c unix.c + $(BUILD) -t dll -f dlls.opt -c socket.c + $(BUILD) -t dll -f dlls.opt -c ramap.c + $(BUILD) -t dll -f dlls.opt -c byte.c + +rwb-isam.scm wbtab.scm: ../wb/rwb-isam.scm ../wb/wbtab.scm + cp ../wb/rwb-isam.scm ../wb/wbtab.scm ./ +db.so: dlls.opt rwb-isam.scm wbtab.scm + if [ -f ../wb/blink.c ]; then \ + $(BUILD) -t dll -f dlls.opt -F wb; fi + +differ.so: differ.c + $(BUILD) -t dll -f dlls.opt -F differ myturtle: dlls.opt $(BUILD) -t dll -f dlls.opt -F turtlegr @@ -228,7 +261,7 @@ keysymdef.scm: inc2scm xevent.h xevent.scm xatoms.scm: xgen.scm Makefile $(SCMLIT) -l xgen.scm $(incdir)X11/Xlib.h x.h: x.c xevent.h - if [ ! -z "$(CPROTO)" ]; then $(CPROTO) x.c > x.h; fi + if [ -x "$(CPROTO)" ]; then $(CPROTO) x.c > x.h; fi # Check SCM; SCMLIT function. checklit: @@ -278,7 +311,7 @@ report: $(SCMLIT) -e"(slib:report #t)" $(SCMEXE) -e"(slib:report #t)" -implcat: *.so mkimpcat.scm +implcat: $(SHOBJS) mkimpcat.scm $(SCMLIT) -lmkimpcat.scm htmldir=../public_html/ @@ -286,23 +319,23 @@ dvidir=../dvi/ dvi: $(dvidir)scm.dvi $(dvidir)Xlibscm.dvi $(dvidir)hobbit.dvi $(dvidir)scm.dvi: version.txi scm.texi platform.txi features.txi\ $(dvidir)scm.fn Makefile -# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)scm.texi - -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex scm.??) - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi +# cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;texi2dvi $(srcdir)scm.texi + -(cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;texindex scm.??) + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;tex $(srcdir)scm.texi $(dvidir)scm.fn: - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;tex $(srcdir)scm.texi $(dvidir)Xlibscm.dvi: version.txi Xlibscm.texi $(dvidir)Xlibscm.fn Makefile -# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)Xlibscm.texi - -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex Xlibscm.??) - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)Xlibscm.texi +# cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;texi2dvi $(srcdir)Xlibscm.texi + -(cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;texindex Xlibscm.??) + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;tex $(srcdir)Xlibscm.texi $(dvidir)Xlibscm.fn: - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)Xlibscm.texi + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;tex $(srcdir)Xlibscm.texi $(dvidir)hobbit.dvi: version.txi hobbit.texi $(dvidir)hobbit.fn Makefile -# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)hobbit.texi - -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex hobbit.??) - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)hobbit.texi +# cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;texi2dvi $(srcdir)hobbit.texi + -(cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;texindex hobbit.??) + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;tex $(srcdir)hobbit.texi $(dvidir)hobbit.fn: - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)hobbit.texi + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;tex $(srcdir)hobbit.texi xdvi: $(dvidir)scm.dvi xdvi -s 3 $(dvidir)scm.dvi Xdvi: $(dvidir)Xlibscm.dvi @@ -313,13 +346,13 @@ hobdvi: $(dvidir)hobbit.dvi pdf: $(htmldir)scm.pdf $(htmldir)Xlibscm.pdf $(htmldir)hobbit.pdf $(htmldir)scm.pdf: version.txi scm.texi platform.txi features.txi\ $(dvidir)scm.fn Makefile - cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)scm.texi + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;pdftex $(srcdir)scm.texi mv $(dvidir)scm.pdf $(htmldir) $(htmldir)Xlibscm.pdf: version.txi Xlibscm.texi $(dvidir)Xlibscm.fn Makefile - cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)Xlibscm.texi + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;pdftex $(srcdir)Xlibscm.texi mv $(dvidir)Xlibscm.pdf $(htmldir) $(htmldir)hobbit.pdf: version.txi hobbit.texi $(dvidir)hobbit.fn Makefile - cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)hobbit.texi + cd $(dvidir);TEXINPUTS=$(srcdir):;export TEXINPUTS;pdftex $(srcdir)hobbit.texi mv $(dvidir)hobbit.pdf $(htmldir) xpdf: $(htmldir)scm.pdf xpdf -z 3 $(htmldir)scm.pdf @@ -420,7 +453,7 @@ $(infodir)Xlibscm.info.gz: $(infodir)Xlibscm.info $(infodir)hobbit.info.gz: $(infodir)hobbit.info gzip -f $(infodir)hobbit.info -install: scm.1 +install: scm.1 db.so wbtab.scm rwb-isam.scm test -d $(bindir) || mkdir $(bindir) test -d $(mandir) || mkdir $(mandir) test -d $(man1dir) || mkdir $(man1dir) @@ -432,8 +465,9 @@ install: scm.1 -cp $(ifiles) $(hobfiles) COPYING r4rstest.scm $(libscmdir) test -f $(libscmdir)require.scm || \ cp requires.scm $(libscmdir)require.scm - -cp build build.scm mkimpcat.scm Iedline.scm *.sl *.so patchlvl.h\ + -cp build build.scm mkimpcat.scm Iedline.scm $(SHOBJS) patchlvl.h\ $(xafiles) $(libscmdir) + -cp db.so wbtab.scm rwb-isam.scm $(libscmdir) installlib: test -d $(includedir) || mkdir $(includedir) @@ -446,18 +480,10 @@ uninstall: -rm $(man1dir)scm.1 -rm $(includedir)scm.h $(includedir)scmfig.h $(includedir)scmflags.h -rm $(libdir)libscm.a - -rm $(libscmdir)Transcen.scm\ - $(libscmdir)Link.scm\ - $(libscmdir)Macro.scm\ - $(libscmdir)Macexp.scm\ - $(libscmdir)Tscript.scm\ - $(libscmdir)compile.scm\ - $(libscmdir)hobbit.scm\ - $(libscmdir)scmhob.scm\ - $(libscmdir)scmhob.h\ - $(libscmdir)COPYING\ - $(libscmdir)r4rstest.scm - -rm $(libscmdir)Init$(VERSION).scm + -(cd $(libscmdir); rm $(ifiles) $(hobfiles) COPYING r4rstest.scm) + -(cd $(libscmdir); rm build build.scm mkimpcat.scm \ + $(SHOBJS) patchlvl.h $(xafiles)) + -(cd $(libscmdir); rm db.so wbtab.scm rwb-isam.scm require.scm) uninstallinfo: -rm $(infodir)scm.info.gz $(infodir)Xlibscm.info.gz\ @@ -499,9 +525,11 @@ afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \ makedev = make -f $(HOME)/makefile.dev CHPAT=$(HOME)/bin/chpat -RSYNC=rsync -avessh +RSYNC=rsync --rsync-path=bin/rsync -bav UPLOADEE=swissnet_upload dest = $(HOME)/dist/ +DOSCM = /misc/usb1/scm/ + temp/scm: $(afiles) -$(RM_R) temp mkdir temp @@ -532,6 +560,8 @@ postnews: upzip: $(HOME)/pub/scm.zip $(RSYNC) $(HOME)/pub/scm.zip $(UPLOADEE):pub/ + $(RSYNC) r4rstest.scm $(HOME)/dist/ + $(RSYNC) r4rstest.scm $(UPLOADEE):dist/ dist: $(dest)scm$(VERSION).zip $(dest)scm$(VERSION).zip: temp/scm @@ -540,7 +570,7 @@ $(dest)scm$(VERSION).zip: temp/scm rpm: pubzip # $(dest)scm-$(VERSION)-$(RELEASE).i386.rpm: $(dest)scm$(VERSION).zip cp -f $(HOME)/pub/scm.zip $(rpm_prefix)SOURCES/scm$(VERSION).zip - rpm -ba scm.spec # --clean + rpmbuild -ba scm.spec # --clean rm $(rpm_prefix)SOURCES/scm$(VERSION).zip mv $(rpm_prefix)RPMS/i386/scm-$(VERSION)-$(RELEASE).i386.rpm \ $(rpm_prefix)SRPMS/scm-$(VERSION)-$(RELEASE).src.rpm $(dest) @@ -555,12 +585,12 @@ scm.com: temp/scm zip: scm.zip scm.zip: temp/scm $(makedev) PROD=scm zip -doszip: /c/scm/dist/scm$(VERSION).zip -/c/scm/dist/scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm - $(makedev) DEST=/c/scm/dist/ PROD=scm ver=$(VERSION) zip - cd ..; zip -9ur /c/scm/dist/scm$(VERSION).zip \ +doszip: $(DOSCM)dist/scm$(VERSION).zip +$(DOSCM)dist/scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm + $(makedev) DEST=$(DOSCM)dist/ PROD=scm ver=$(VERSION) zip + cd ..; zip -9ur $(DOSCM)dist/scm$(VERSION).zip \ scm/turtle scm/turtlegr.c scm/grtest.scm - zip -d /c/scm/dist/scm$(VERSION).zip scm/scm.info scm/Xlibscm.info scm/hobbit.info + zip -d $(DOSCM)dist/scm$(VERSION).zip scm/scm.info scm/Xlibscm.info scm/hobbit.info pubzip: $(HOME)/pub/scm.zip $(HOME)/pub/scm.zip: temp/scm $(makedev) DEST=$(HOME)/pub/ PROD=scm zip @@ -577,8 +607,8 @@ CITERS = ANNOUNCE ../jacal/ANNOUNCE \ $(htmldir)SLIB.html $(htmldir)JACAL.html \ $(htmldir)SCM.html $(htmldir)SIMSYNCH.html \ ../jacal/jacal.texi ../wb/wb.texi \ - /c/scm/dist/install.bat /c/scm/dist/makefile \ - /c/scm/dist/mkdisk.bat hobbit.texi hobbit.scm + $(DOSCM)dist/install.bat $(DOSCM)dist/makefile \ + $(DOSCM)dist/mkdisk.bat hobbit.texi hobbit.scm updates: Init$(ver).scm $(CHPAT) scm$(VERSION) scm$(ver) $(CITERS) diff --git a/README b/README index e672a56..6a1ba84 100644 --- a/README +++ b/README @@ -1,17 +1,18 @@ -This directory contains the distribution of scm5d9. Scm conforms to +This directory contains the distribution of scm5e1. 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. - + `http://swiss.csail.mit.edu/~jaffer/SCM' -Manifest -======== +0.1 Manifest +============ `.gdbinit' provides commands for debugging SCM with GDB `COPYING' details the LACK OF WARRANTY for SCM and the conditions for distributing SCM. `ChangeLog' changes to SCM. +`Idiffer.scm' Linear-space O(PN) sequence comparison. `Iedline.scm' Gnu readline input editing. `Init.scm' Scheme initialization. `Link.scm' Dynamic link/loading. @@ -30,6 +31,7 @@ Manifest `continue.h' continuations. `crs.c' interactive terminal control. `debug.c' debugging, printing code. +`differ.c' Linear-space O(PN) sequence comparison. `dynl.c' dynamically load object files. `ecrt0.c' discover the start of initialized data space dynamically at runtime. @@ -93,8 +95,8 @@ Manifest File: scm.info, Node: SLIB, Next: Building SCM, Prev: Making SCM, Up: Installing SCM -SLIB -==== +2.2 SLIB +======== [SLIB] is a portable Scheme library meant to provide compatibility and utility functions for all standard Scheme implementations. Although @@ -102,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: - * swissnet.ai.mit.edu:/pub/scm/slib3a1.tar.gz + * swiss.csail.mit.edu:/pub/scm/slib3a2.tar.gz - * ftp.gnu.org:/pub/gnu/jacal/slib3a1.tar.gz + * ftp.gnu.org:/pub/gnu/jacal/slib3a2.tar.gz - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a1.tar.gz + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a2.tar.gz -Unpack SLIB (`tar xzf slib3a1.tar.gz' or `unzip -ao slib3a1.zip') in an +Unpack SLIB (`tar xzf slib3a2.tar.gz' or `unzip -ao slib3a2.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 `Init5d9.scm' is +(this is the same directory as where the file `Init5e1.scm' is installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -138,8 +140,8 @@ overrides `require.scm'. Again, absolute pathnames are recommended. File: scm.info, Node: Making SCM, Next: SLIB, Prev: Installing SCM, Up: Installing SCM -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'. @@ -150,7 +152,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://swissnet.ai.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 @@ -165,14 +167,14 @@ need to compile SCM without build, there are several ways to proceed: File: scm.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: SCM Session, Up: Operational Features -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. @@ -214,8 +216,8 @@ other systems: File: scm.info, Node: Problems Compiling, Next: Problems Linking, Prev: Automatic C Preprocessor Definitions, Up: Installing SCM -Problems Compiling -================== +2.8 Problems Compiling +====================== FILE PROBLEM / MESSAGE HOW TO FIX *.c include file not found. Correct the status of @@ -248,8 +250,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 -Problems Linking -================ +2.9 Problems Linking +==================== PROBLEM HOW TO FIX _sin etc. missing. Uncomment LIBS in makefile. @@ -258,8 +260,8 @@ _sin etc. missing. Uncomment LIBS in makefile. File: scm.info, Node: Problems Running, Next: Testing, Prev: Problems Linking, Up: Installing SCM -Problems Running -================ +2.10 Problems Running +===================== PROBLEM HOW TO FIX Opening message and then machine Change memory model option to C @@ -278,17 +280,17 @@ remove in scmfig.h and Do so and recompile files. recompile scm. add in scmfig.h and recompile scm. -ERROR: Init5d9.scm not found. Assign correct IMPLINIT in makefile +ERROR: Init5e1.scm not found. Assign correct IMPLINIT in makefile or scmfig.h. Define environment variable SCM_INIT_PATH to be the full - pathname of Init5d9.scm. + pathname of Init5e1.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 - Init5d9.scm to point to library or + Init5e1.scm to point to library or remove. Make sure the value of (library-vicinity) has a trailing @@ -298,8 +300,8 @@ WARNING: require.scm not found. Define environment variable File: scm.info, Node: Testing, Next: Reporting Problems, Prev: Problems Running, Up: Installing SCM -Testing -======= +2.11 Testing +============ Loading `r4rstest.scm' in the distribution will run an [R4RS] conformance test on `scm'. @@ -349,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. `Init5d9.scm'). +output files. `Init5e1.scm'). Spaces or control characters appear Check character defines in in symbol names. `scmfig.h'. Negative numbers turn positive. Check SRS in `scmfig.h'. @@ -364,5 +366,6 @@ 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. + exacerbated by using lots of call-with-current-continuations. A + possible fix for dynthrow() is commented out in `continue.c'. diff --git a/Transcen.scm b/Transcen.scm index b0d1a2b..dd869a7 100644 --- a/Transcen.scm +++ b/Transcen.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1992, 1993, 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1995, 1997, 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 @@ -40,6 +40,8 @@ ;;;; "Transcen.scm", Complex trancendental functions for SCM. ;;; Author: Jerry D. Hedden. +;;;; 2005-05 SRFI-70 extensions. +;;; Author: Aubrey Jaffer (define compile-allnumbers #t) ;for HOBBIT compiler @@ -63,17 +65,6 @@ ($sqrt z)) (make-polar ($sqrt (magnitude z)) (/ (angle z) 2)))) -(define expt - (let ((integer-expt integer-expt)) - (lambda (z1 z2) - (cond ((zero? z1) (if (zero? z2) 1 0)) - ((exact? z2) - (integer-expt z1 z2)) - ((and (real? z2) (real? z1) (>= z1 0)) - ($expt z1 z2)) - (else - (exp (* z2 (log z1)))))))) - (define (sinh z) (if (real? z) ($sinh z) (let ((x (real-part z)) (y (imag-part z))) @@ -137,3 +128,124 @@ (if (real? z) ($atan z) (/ (log (/ (- +i z) (+ +i z))) +2i)) ($atan2 z (car y)))) + +;;;; SRFI-70 +(define expt + (let ((integer-expt integer-expt)) + (lambda (z1 z2) + (cond ((and (exact? z2) (not (and (zero? z1) (not (positive? z2))))) + (integer-expt 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 (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/Xlibscm.info b/Xlibscm.info index a9d7325..7223702 100644 --- a/Xlibscm.info +++ b/Xlibscm.info @@ -1,4 +1,4 @@ -This is Xlibscm.info, produced by makeinfo version 4.0 from +This is Xlibscm.info, produced by makeinfo version 4.7 from Xlibscm.texi. INFO-DIR-SECTION The Algorithmic Language Scheme @@ -12,7 +12,7 @@ File: Xlibscm.info, Node: Top, Next: Xlibscm, Prev: (dir), Up: (dir) This manual documents the X - SCM Language X Interface. The most recent information about SCM can be found on SCM's "WWW" home page: - + `http://swiss.csail.mit.edu/~jaffer/SCM' Copyright (C) 1990-1999 Free Software Foundation @@ -46,21 +46,19 @@ approved by the author.  File: Xlibscm.info, Node: Xlibscm, Next: Display and Screens, Prev: Top, Up: Top -Xlibscm -******* +1 Xlibscm +********* "Xlibscm" is a SCM interface to "X". The X Window System is a network-transparent window system that was designed at MIT. SCM is a portable Scheme implementation written in C. The interface can be compiled into SCM or, on those platforms supporting dynamic linking, -compiled separately and loaded with `(require 'Xlib)'. +compiled separately and loaded with `(require 'Xlib)'. Much of this X documentation is dervied from: Xlib - C Language X Interface - X Consortium Standard - X Version 11, Release 6.3 The X Window System is a trademark of X Consortium, Inc. @@ -112,10 +110,10 @@ the suitability of this documentation for any purpose. It is provided  File: Xlibscm.info, Node: Display and Screens, Next: Drawables, Prev: Xlibscm, Up: Top -Display and Screens -******************* +2 Display and Screens +********************* - - Function: x:open-display display-name + -- Function: x:open-display display-name DISPLAY-NAME Specifies the hardware display name, which determines the display and communications domain to be used. On a POSIX-conformant system, if the display-name is #f, it defaults to @@ -126,7 +124,7 @@ Display and Screens DISPLAY-NAME or DISPLAY environment variable can be a string in the format: - - Special Form: hostname:number.screen-number + -- Special Form: hostname:number.screen-number HOSTNAME specifies the name of the host machine on which the display is physically attached. Follow the HOSTNAME with either a single colon (:) or a double colon (::). @@ -141,7 +139,7 @@ Display and Screens SCREEN-NUMBER sets an internal variable that can be accessed by using the x:default-screen procedure. - - Function: x:close display + -- Function: x:close display DISPLAY specifies the connection to the X server. The `x:close' function closes the connection to the X server for @@ -154,32 +152,32 @@ Display and Screens generated. Before exiting, you should call X:CLOSE-DISPLAY or X:FLUSH explicitly so that any pending errors are reported. - - Function: x:protocol-version display + -- Function: x:protocol-version display Returns cons of the major version number (11) of the X protocol associated with the connected DISPLAY and the minor protocol revision number of the X server. - - Function: x:server-vendor display + -- Function: x:server-vendor display Returns a string that provides some identification of the owner of the X server implementation. The contents of the string are implementation-dependent. - - Function: x:vendor-release display + -- Function: x:vendor-release display Returns a number related to a vendor's release of the X server. A display consists of one or more "Screen"s. Each screen has a "root-window", "default-graphics-context", and "colormap". - - Function: x:screen-count display + -- Function: x:screen-count display Returns the number of available screens. - - Function: x:default-screen display + -- Function: x:default-screen display Returns the default screen number specified by the `x:open-display' function. Use this screen number in applications which will use only a single screen. - - Function: x:root-window display screen-number - - Function: x:root-window display + -- Function: x:root-window display screen-number + -- Function: x:root-window display SCREEN-NUMBER, if givien, specifies the appropriate screen number on the host server. Otherwise the default-screen for DISPLAY is used. @@ -188,40 +186,40 @@ A display consists of one or more "Screen"s. Each screen has a `x:root-window' for functions that need a drawable of a particular screen or for creating top-level windows. - - Function: x:root-window window + -- Function: x:root-window window Returns the root window for the specified WINDOW's screen. - - Function: x:default-colormap display screen-number - - Function: x:default-colormap display - - Function: x:default-colormap window + -- Function: x:default-colormap display screen-number + -- Function: x:default-colormap display + -- Function: x:default-colormap window Returns the default colormap of the specified screen. - - Function: x:default-ccc display screen-number - - Function: x:default-ccc display - - Function: x:default-ccc window + -- Function: x:default-ccc display screen-number + -- Function: x:default-ccc display + -- Function: x:default-ccc window Returns the default Color-Conversion-Context (ccc) of the specified screen. - - Function: x:default-gc display screen-number - - Function: x:default-gc display - - Function: x:default-gc window + -- Function: x:default-gc display screen-number + -- Function: x:default-gc display + -- Function: x:default-gc window Returns the default graphics-context of the specified screen. - - Function: x:screen-depths display screen-number - - Function: x:screen-depths display - - Function: x:screen-depths window + -- Function: x:screen-depths display screen-number + -- Function: x:screen-depths display + -- Function: x:screen-depths window Returns an array of depths supported by the specified screen. The "Visual" type describes possible colormap depths and arrangements. - - Function: x:default-visual display screen-number - - Function: x:default-visual display - - Function: x:default-visual window + -- Function: x:default-visual display screen-number + -- Function: x:default-visual display + -- Function: x:default-visual window Returns the default Visual type for the specified screen. - - Function: x:make-visual display depth class - - Function: x:make-visual window depth class + -- Function: x:make-visual display depth class + -- Function: x:make-visual window depth class The integer DEPTH specifies the number of bits per pixel. The CLASS argument specifies one of the possible visual classes for a screen: @@ -240,14 +238,14 @@ The "Visual" type describes possible colormap depths and arrangements. `X:make-visual' returns a visual type for the screen specified by DISPLAY or WINDOW if successful; #f if not. - - Function: x:visual-class visual - - Function: x:visual-class screen - - Function: x:visual-class display + -- Function: x:visual-class visual + -- Function: x:visual-class screen + -- Function: x:visual-class display Returns the (integer) visual class of its argument. - - Function: x:visual-geometry visual - - Function: x:visual-geometry screen - - Function: x:visual-geometry display + -- Function: x:visual-geometry visual + -- Function: x:visual-geometry screen + -- Function: x:visual-geometry display Returns a list of the: * red_mask @@ -257,49 +255,49 @@ The "Visual" type describes possible colormap depths and arrangements. * colormap_size - - Function: x:screen-cells display screen-number - - Function: x:screen-cells display - - Function: x:screen-cells window + -- Function: x:screen-cells display screen-number + -- Function: x:screen-cells display + -- Function: x:screen-cells window Returns the number of entries in the default colormap. - - Function: x:screen-depth display screen-number + -- Function: x:screen-depth display screen-number Returns the depth of the root window of the specified screen. - - Function: x:screen-depth display - - Function: x:screen-depth window - - Function: x:screen-depth visual + -- Function: x:screen-depth display + -- Function: x:screen-depth window + -- Function: x:screen-depth visual Returns the depth of argument. The "depth" of a window or pixmap is the number of bits per pixel it has. The "depth" of a graphics context is the depth of the drawables it can be used in conjunction with graphics output. - - Function: x:screen-size display screen-number - - Function: x:screen-size display - - Function: x:screen-size window + -- Function: x:screen-size display screen-number + -- Function: x:screen-size display + -- Function: x:screen-size window Returns a list of integer height and width of the screen in pixels. - - Function: x:screen-dimensions display screen-number - - Function: x:screen-dimensions display - - Function: x:screen-dimensions window + -- Function: x:screen-dimensions display screen-number + -- Function: x:screen-dimensions display + -- Function: x:screen-dimensions window Returns a list of integer height and width of the screen in millimeters. - - Function: x:screen-white display screen-number - - Function: x:screen-white display - - Function: x:screen-white window + -- Function: x:screen-white display screen-number + -- Function: x:screen-white display + -- Function: x:screen-white window Returns the white pixel value of the specified screen. - - Function: x:screen-black display screen-number - - Function: x:screen-black display - - Function: x:screen-black window + -- Function: x:screen-black display screen-number + -- Function: x:screen-black display + -- Function: x:screen-black window Returns the black pixel value of the specified screen.  File: Xlibscm.info, Node: Drawables, Next: Graphics Context, Prev: Display and Screens, Up: Top -Drawables -********* +3 Drawables +*********** A "Drawable" is either a window or pixmap. @@ -312,10 +310,10 @@ A "Drawable" is either a window or pixmap.  File: Xlibscm.info, Node: Windows and Pixmaps, Next: Window Attributes, Prev: Drawables, Up: Drawables -Windows and Pixmaps -=================== +3.1 Windows and Pixmaps +======================= - - Function: x:create-window window position size border-width depth + -- Function: x:create-window window position size border-width depth class visual field-name value ... Creates and returns an unmapped Input-Output subwindow for a specified parent WINDOW and causes the X server to generate a @@ -341,14 +339,14 @@ Windows and Pixmaps The returned window will have the attributes specified by FIELD-NAMEs and VALUE. - - Function: x:create-window window position size border-width border + -- Function: x:create-window window position size border-width border background The returned window inherits its depth, class, and visual from its parent. All other window attributes, except BACKGROUND and BORDER, have their default values. - - Function: x:create-pixmap drawable size depth - - Function: x:create-pixmap display size depth + -- Function: x:create-pixmap drawable size depth + -- Function: x:create-pixmap display size depth SIZE is a list, vector, or pair of nonzero integers specifying the width and height desired in the new pixmap. @@ -357,7 +355,7 @@ Windows and Pixmaps drawable argument. The DEPTH argument must be one of the depths supported by the screen of the specified DRAWABLE. - - Function: x:close window + -- Function: x:close window Destroys the specified WINDOW as well as all of its subwindows and causes the X server to generate a DestroyNotify event for each window. The window should not be used again. If the window @@ -371,11 +369,11 @@ Windows and Pixmaps mapped WINDOW will generate x:Expose events on other windows that were obscured by the window being destroyed. - - Function: x:close pixmap + -- Function: x:close pixmap Deletes the association between the PIXMAP and its storage. The X server frees the pixmap storage when there are no references to it. - - Function: x:window-geometry drawable + -- Function: x:window-geometry drawable Returns a list of: coordinates @@ -396,7 +394,7 @@ Windows and Pixmaps depth The depth of the DRAWABLE (bits per pixel for the object). - - Function: x:window-geometry-set! window field-name value ... + -- Function: x:window-geometry-set! window field-name value ... Changes the "Configuration" components specified by FIELD-NAMEs for the specified WINDOW. @@ -405,10 +403,10 @@ these attributes are encoded by small integers - just like those of the next section. Be warned therefore that confusion of attribute names will likely not signal errors, just cause mysterious behavior. - - Attribute: x:CWX - - Attribute: x:CWY - - Attribute: x:CW-Width - - Attribute: x:CW-Height + -- Attribute: x:CWX + -- Attribute: x:CWY + -- Attribute: x:CW-Width + -- Attribute: x:CW-Height The x:CWX and x:CYY members are used to set the window's x and y coordinates, which are relative to the parent's origin and indicate the position of the upper-left outer corner of the @@ -420,18 +418,18 @@ will likely not signal errors, just cause mysterious behavior. according to their window gravity. Depending on the window's bit gravity, the contents of the window also may be moved - - Attribute: x:CW-Border-Width + -- Attribute: x:CW-Border-Width The integer x:CW-Border-Width is used to set the width of the border in pixels. Note that setting just the border width leaves the outer-left corner of the window in a fixed position but moves the absolute position of the window's origin. It is an error to set the border-width attribute of an InputOnly window nonzero. - - Attribute: x:CW-Sibling + -- Attribute: x:CW-Sibling The sibling member is used to set the sibling window for stacking operations. - - Attribute: x:CW-Stack-Mode + -- Attribute: x:CW-Stack-Mode The x:CW-Stack-Mode member is used to set how the window is to be restacked and can be set to x:Above, x:Below, x:Top-If, x:Bottom-If, or x:Opposite. @@ -483,10 +481,10 @@ restacked as follows:  File: Xlibscm.info, Node: Window Attributes, Next: Window Properties and Visibility, Prev: Windows and Pixmaps, Up: Drawables -Window Attributes -================= +3.2 Window Attributes +===================== - - Function: x:window-set! window field-name value ... + -- Function: x:window-set! window field-name value ... Changes the components specified by FIELD-NAMEs for the specified WINDOW. The restrictions are the same as for `x:create-window'. The order in which components are verified and altered is server @@ -498,7 +496,7 @@ argument (respectively) followed by pairs of arguments, where the first is one of the property-name symbols (or its top-level value) listed below; and the second is the value to associate with that property. - - Attribute: x:CW-Back-Pixmap + -- Attribute: x:CW-Back-Pixmap Sets the background pixmap of the WINDOW to the specified pixmap. The background pixmap can immediately be freed if no further explicit references to it are to be made. If x:Parent-Relative is @@ -508,25 +506,25 @@ below; and the second is the value to associate with that property. the background is set to #f or None, the window has no defined background. - - Attribute: x:CW-Back-Pixel + -- Attribute: x:CW-Back-Pixel Sets the background of the WINDOW to the specified pixel value. Changing the background does not cause the WINDOW contents to be changed. It is an error to perform this operation on an x:Input-Only window. - - Attribute: x:CW-Border-Pixmap + -- Attribute: x:CW-Border-Pixmap Sets the border pixmap of the WINDOW to the pixmap you specify. The border pixmap can be freed if no further explicit references to it are to be made. If you specify x:Copy-From-Parent, a copy of the parent window's border pixmap is used. It is an error to perform this operation on an x:Input-Only WINDOW. - - Attribute: x:CW-Border-Pixel + -- Attribute: x:CW-Border-Pixel Sets the border of the WINDOW to the pixel VALUE. It is an error to perform this operation on an x:Input-Only window. - - Attribute: x:CW-Bit-Gravity - - Attribute: x:CW-Win-Gravity + -- Attribute: x:CW-Bit-Gravity + -- Attribute: x:CW-Win-Gravity The bit gravity of a window defines which region of the window should be retained when an x:Input-Output window is resized. The default value for the bit-gravity attribute is x:Forget-Gravity. @@ -587,7 +585,7 @@ below; and the second is the value to associate with that property. window is not moved), except the child is also unmapped when the parent is resized, and an x:Unmap-Notify event is generated. - - Attribute: x:CW-Backing-Store + -- Attribute: x:CW-Backing-Store Some implementations of the X server may choose to maintain the contents of x:Input-Output windows. If the X server maintains the contents of a window, the off-screen saved pixels are known as @@ -616,8 +614,8 @@ below; and the second is the value to associate with that property. window is the source). However, regions obscured by inferior windows are not included. - - Attribute: x:CW-Backing-Planes - - Attribute: x:CW-Backing-Pixel + -- Attribute: x:CW-Backing-Planes + -- Attribute: x:CW-Backing-Pixel You can set backing planes to indicate (with bits set to 1) which bit planes of an x:Input-Output window hold dynamic data that must be preserved in backing store and during save unders. The default @@ -633,7 +631,7 @@ below; and the second is the value to associate with that property. you should use these members to minimize the amount of off-screen memory required to store your window. - - Attribute: x:CW-Override-Redirect + -- Attribute: x:CW-Override-Redirect To control window placement or to add decoration, a window manager often needs to intercept (redirect) any map or configure request. Pop-up windows, however, often need to be mapped without a window @@ -647,7 +645,7 @@ below; and the second is the value to associate with that property. override-redirect flag to #t or #f (default). Window managers use this information to avoid tampering with pop-up windows. - - Attribute: x:CW-Save-Under + -- Attribute: x:CW-Save-Under Some server implementations may preserve contents of x:Input-Output windows under other x:Input-Output windows. This is not the same as preserving the contents of a window for you. @@ -661,7 +659,7 @@ below; and the second is the value to associate with that property. is mapped, saving the contents of windows it obscures would be beneficial. - - Attribute: x:CW-Event-Mask + -- Attribute: x:CW-Event-Mask The event mask defines which events the client is interested in for this x:Input-Output or x:Input-Only window (or, for some event types, inferiors of this window). The event mask is the bitwise @@ -719,7 +717,7 @@ below; and the second is the value to associate with that property. owner_events set to True - - Attribute: x:CW-Dont-Propagate + -- Attribute: x:CW-Dont-Propagate The do-not-propagate-mask attribute defines which events should not be propagated to ancestor windows when no client has the event type selected in this x:Input-Output or x:Input-Only window. The @@ -730,7 +728,7 @@ below; and the second is the value to associate with that property. x:Button5Motion, and x:Button-Motion. You can specify that all events are propagated by setting x:No-Event-Mask (default). - - Attribute: x:CW-Colormap + -- Attribute: x:CW-Colormap The colormap attribute specifies which colormap best reflects the true colors of the x:Input-Output window. The colormap must have the same visual type as the window. X servers capable of @@ -748,7 +746,7 @@ below; and the second is the value to associate with that property. changes to the parent window's colormap attribute do not affect the child window. - - Attribute: x:CW-Cursor + -- Attribute: x:CW-Cursor The cursor attribute specifies which cursor is to be used when the pointer is in the x:Input-Output or x:Input-Only window. You can set the cursor to a cursor or x:None (default). @@ -759,7 +757,7 @@ below; and the second is the value to associate with that property. in the displayed cursor. On the root window, the default cursor is restored. - - Function: x:window-ref window field-name ... + -- Function: x:window-ref window field-name ... Returns a list of the components specified by FIELD-NAMEs for the specified WINDOW. Allowable FIELD-NAMEs are a subset of those for `x:window-set!': @@ -789,18 +787,18 @@ below; and the second is the value to associate with that property.  File: Xlibscm.info, Node: Window Properties and Visibility, Prev: Window Attributes, Up: Drawables -Window Properties and Visibility -================================ +3.3 Window Properties and Visibility +==================================== - - Function: x:get-window-property window property + -- Function: x:get-window-property window property Returns the (string or list of numbers) value of PROPERTY of WINDOW. - - Function: x:get-window-property window property #t + -- Function: x:get-window-property window property #t Removes and returns the (string or list of numbers) value of PROPERTY of WINDOW. - - Function: x:list-properties window + -- Function: x:list-properties window Returns a list of the properties (strings) defined for WINDOW. In X parlance, a window which is hidden even when not obscured by other @@ -808,7 +806,7 @@ windows is "unmapped"; one which shows is "mapped". It is an unfortunate name-collision with Scheme, and is ingrained in the attribute names. - - Function: x:map-window window + -- Function: x:map-window window Maps the WINDOW and all of its subwindows that have had map requests. Mapping a window that has an unmapped ancestor does not display the window but marks it as eligible for display when the @@ -845,7 +843,7 @@ attribute names. be to repaint the window. This method usually leads to simpler programs and to proper interaction with window managers. - - Function: x:map-subwindows window + -- Function: x:map-subwindows window Maps all subwindows of a specified WINDOW in top-to-bottom stacking order. The X server generates x:Expose events on each newly displayed window. This may be much more efficient than @@ -853,7 +851,7 @@ attribute names. perform much of the work only once, for all of the windows, rather than for each window. - - Function: x:unmap-window window + -- Function: x:unmap-window window Unmaps the specified WINDOW and causes the X server to generate an UnmapNotify event. If the specified WINDOW is already unmapped, `x:unmap-window' has no effect. Normal exposure processing on @@ -864,7 +862,7 @@ attribute names. generate x:Expose events on windows that were formerly obscured by it. - - Function: x:unmap-subwindows window + -- Function: x:unmap-subwindows window Unmaps all subwindows for the specified WINDOW in bottom-to-top stacking order. It causes the X server to generate an UnmapNotify event on each subwindow and x:Expose events on formerly obscured @@ -876,8 +874,8 @@ attribute names.  File: Xlibscm.info, Node: Graphics Context, Next: Cursor, Prev: Drawables, Up: Top -Graphics Context -**************** +4 Graphics Context +****************** Most attributes of graphics operations are stored in "GC"s. These include line width, line style, plane mask, foreground, background, @@ -885,24 +883,24 @@ tile, stipple, clipping region, end style, join style, and so on. Graphics operations (for example, drawing lines) use these values to determine the actual drawing operation. - - Function: x:create-gc drawable field-name value ... + -- Function: x:create-gc drawable field-name value ... Creates and returns graphics context. The graphics context can be used with any destination drawable having the same root and depth as the specified DRAWABLE. - - Function: x:gc-set! graphics-context field-name value ... + -- Function: x:gc-set! graphics-context field-name value ... Changes the components specified by FIELD-NAMEs for the specified GRAPHICS-CONTEXT. The restrictions are the same as for `x:create-gc'. The order in which components are verified and altered is server dependent. If an error occurs, a subset of the components may have been altered. - - Function: x:copy-gc-fields! gcontext-src gcontext-dst field-name ... + -- Function: x:copy-gc-fields! gcontext-src gcontext-dst field-name ... Copies the components specified by FIELD-NAMEs from GCONTEXT-SRC to GCONTEXT-DST. GCONTEXT-SRC and GCONTEXT-DST must have the same root and depth. - - Function: x:gc-ref graphics-context field-name ... + -- Function: x:gc-ref graphics-context field-name ... Returns a list of the components specified by FIELD-NAMEs ... from the specified GRAPHICS-CONTEXT. @@ -914,7 +912,7 @@ pairs of arguments, where the first is one of the property-name symbols (or its top-level value) listed below; and the second is the value to associate with that property. - - Attribute: x:GC-Function + -- Attribute: x:GC-Function The function attributes of a GC are used when you update a section of a drawable (the destination) with bits from somewhere else (the source). The function in a GC defines how the new destination @@ -942,7 +940,7 @@ associate with that property. x:G-Xnand (OR (NOT src) (NOT dst)) x:G-Xset 1 - - Attribute: x:GC-Plane-Mask + -- Attribute: x:GC-Plane-Mask Many graphics operations depend on either pixel values or planes in a GC. The planes attribute is an integer which specifies which planes of the destination are to be modified, one bit per plane. @@ -963,8 +961,8 @@ associate with that property. Range checking is not performed on a plane-mask value. It is simply truncated to the appropriate number of bits. - - Attribute: x:GC-Foreground - - Attribute: x:GC-Background + -- Attribute: x:GC-Foreground + -- Attribute: x:GC-Background Range checking is not performed on the values for foreground or background. They are simply truncated to the appropriate number of bits. @@ -972,7 +970,7 @@ associate with that property. Note that foreground and background are not initialized to any values likely to be useful in a window. - - Attribute: x:GC-Line-Width + -- Attribute: x:GC-Line-Width The line-width is measured in pixels and either can be greater than or equal to one (wide line) or can be the special value zero (thin line). @@ -1009,7 +1007,7 @@ associate with that property. across all displays, a client should always use a line-width of one rather than a linewidth of zero. - - Attribute: x:GC-Line-Style + -- Attribute: x:GC-Line-Style The line-style defines which sections of a line are drawn: x:Line-Solid @@ -1025,7 +1023,7 @@ associate with that property. internal ends of the individual dashes, except x:Cap-Not-Last is treated as x:Cap-Butt. - - Attribute: x:GC-Cap-Style + -- Attribute: x:GC-Cap-Style The cap-style defines how the endpoints of a path are drawn: x:Cap-Not-Last @@ -1046,7 +1044,7 @@ associate with that property. the endpoint for a distance equal to half the line-width. (This is equivalent to x:Cap-Butt for line-width of zero). - - Attribute: x:GC-Join-Style + -- Attribute: x:GC-Join-Style The join-style defines how corners are drawn for wide lines: x:Join-Miter @@ -1062,7 +1060,7 @@ associate with that property. The corner has x:Cap-Butt endpoint styles with the triangular notch filled. - - Attribute: x:GC-Fill-Style + -- Attribute: x:GC-Fill-Style The fill-style defines the contents of the source for line, text, and fill requests. For all text and fill requests (for example, X:Draw-Text, X:Fill-Rectangle, X:Fill-Polygon, and X:Fill-Arc); @@ -1100,7 +1098,7 @@ associate with that property. x:Fill-Stippled Background masked by stipple - - Attribute: x:GC-Fill-Rule + -- Attribute: x:GC-Fill-Rule The fill-rule defines what pixels are inside (drawn) for paths given in X:Fill-Polygon requests and can be set to x:Even-Odd-Rule or x:Winding-Rule. @@ -1130,8 +1128,8 @@ associate with that property. horizontal edge are a special case and are inside if and only if the polygon interior is immediately below (y increasing direction). - - Attribute: x:GC-Tile - - Attribute: x:GC-Stipple + -- Attribute: x:GC-Tile + -- Attribute: x:GC-Stipple The tile/stipple represents an infinite two-dimensional plane, with the tile/stipple replicated in all dimensions. @@ -1144,8 +1142,8 @@ associate with that property. clip-mask. Although some sizes may be faster to use than others, any size pixmap can be used for tiling or stippling. - - Attribute: x:GC-Tile-Stip-X-Origin - - Attribute: x:GC-Tile-Stip-Y-Origin + -- Attribute: x:GC-Tile-Stip-X-Origin + -- Attribute: x:GC-Tile-Stip-Y-Origin When the tile/stipple plane is superimposed on a drawable for use in a graphics operation, the upper-left corner of some instance of the tile/stipple is at the coordinates within the drawable @@ -1153,10 +1151,10 @@ associate with that property. interpreted relative to the origin of whatever destination drawable is specified in a graphics request. - - Attribute: x:GC-Font + -- Attribute: x:GC-Font The font to be used for drawing text. - - Attribute: x:GC-Subwindow-Mode + -- Attribute: x:GC-Subwindow-Mode You can set the subwindow-mode to x:Clip-By-Children or x:Include-Inferiors. x:Clip-By-Children @@ -1171,30 +1169,30 @@ associate with that property. one depth with mapped inferiors of differing depth is not illegal, but the semantics are undefined by the core protocol. - - Attribute: x:GC-Graphics-Exposures + -- Attribute: x:GC-Graphics-Exposures The graphics-exposure flag controls x:Graphics-Expose event generation for X:Copy-Area and X:Copy-Plane requests (and any similar requests defined by extensions). - - Attribute: x:GC-Clip-X-Origin - - Attribute: x:GC-Clip-Y-Origin + -- Attribute: x:GC-Clip-X-Origin + -- Attribute: x:GC-Clip-Y-Origin The clip-mask origin is interpreted relative to the origin of whatever destination drawable is specified in a graphics request. - - Attribute: x:GC-Clip-Mask + -- Attribute: x:GC-Clip-Mask The clip-mask restricts writes to the destination drawable. If the clip-mask is set to a pixmap, it must have depth one and have the - same root as the GC, or an error results. If clip-mask is set to - "x:None", the pixels are always drawn regardless of the clip - origin. The clip-mask also can be set by calling `X:Set-Region'. - Only pixels where the clip-mask has a bit set to 1 are drawn. - Pixels are not drawn outside the area covered by the clip-mask or - where the clip-mask has a bit set to 0. The clip-mask affects all - graphics requests. The clip-mask does not clip sources. The - clip-mask origin is interpreted relative to the origin of whatever + same root as the GC, or an error results. If clip-mask is set to "x:None", + the pixels are always drawn regardless of the clip origin. The + clip-mask also can be set by calling `X:Set-Region'. Only pixels + where the clip-mask has a bit set to 1 are drawn. Pixels are not + drawn outside the area covered by the clip-mask or where the + clip-mask has a bit set to 0. The clip-mask affects all graphics + requests. The clip-mask does not clip sources. The clip-mask + origin is interpreted relative to the origin of whatever destination drawable is specified in a graphics request. - - Attribute: x:GC-Dash-Offset + -- Attribute: x:GC-Dash-Offset Defines the phase of the pattern, specifying how many pixels into the dash-list the pattern should actually begin in any single graphics request. Dashing is continuous through path elements @@ -1211,7 +1209,7 @@ associate with that property. between 135 and 225 degrees from the x axis. For all other lines, the major axis is the y axis. - - Attribute: x:GC-Dash-List + -- Attribute: x:GC-Dash-List There must be at least one element in the specified DASH-LIST. The initial and alternating elements (second, fourth, and so on) of the DASH-LIST are the even dashes, and the others are the odd @@ -1220,7 +1218,7 @@ associate with that property. equivalent to specifying the same list concatenated with itself to produce an even-length list. - - Attribute: x:GC-Arc-Mode + -- Attribute: x:GC-Arc-Mode The arc-mode controls filling in the X:Fill-Arcs function and can be set to x:Arc-Pie-Slice or x:Arc-Chord. x:Arc-Pie-Slice @@ -1232,13 +1230,13 @@ associate with that property.  File: Xlibscm.info, Node: Cursor, Next: Colormap, Prev: Graphics Context, Up: Top -Cursor -****** +5 Cursor +******** - - Function: x:create-cursor display shape - X provides a set of standard cursor shapes in a special font named - "cursor". Applications are encouraged to use this interface for - their cursors because the font can be customized for the individual + -- Function: x:create-cursor display shape + X provides a set of standard cursor shapes in a special font named "cursor". + Applications are encouraged to use this interface for their + cursors because the font can be customized for the individual display type. The SHAPE argument specifies which glyph of the standard fonts to use. @@ -1247,7 +1245,7 @@ Cursor background (see X:Recolor-Cursor). The names of all cursor shapes are defined with the prefix XC: in `x11.scm'. - - Function: x:create-cursor source-font source-char mask-font + -- Function: x:create-cursor source-font source-char mask-font mask-char fgc bgc Creates a cursor from the source and mask bitmaps obtained from the specified font glyphs. The integer SOURCE-CHAR must be a defined @@ -1258,11 +1256,11 @@ Cursor metrics, and there is no restriction on the placement of the hotspot relative to the bounding boxes. - - Function: x:create-cursor source-font source-char #f #f fgc bgc + -- Function: x:create-cursor source-font source-char #f #f fgc bgc If MASK-FONT and MASK-CHAR are #f, all pixels of the source are displayed. - - Function: x:create-cursor source-pixmap mask-pixmap fgc bgc origin + -- Function: x:create-cursor source-pixmap mask-pixmap fgc bgc origin MASK-PIXMAP must be the same size as the pixmap defined by the SOURCE-PIXMAP argument. The foreground and background RGB values must be specified using FOREGROUND-COLOR and BACKGROUND-COLOR, @@ -1277,18 +1275,18 @@ Cursor in MASK-PIXMAP define which source pixels are displayed, and the pixels set to 0 define which pixels are ignored. - - Function: x:create-cursor source-pixmap #f fgc bgc origin + -- Function: x:create-cursor source-pixmap #f fgc bgc origin If MASK-PIXMAP is #f, all pixels of the source are displayed.  File: Xlibscm.info, Node: Colormap, Next: Rendering, Prev: Cursor, Up: Top -Colormap -******** +6 Colormap +********** A "colormap" maps pixel values to "RGB" color space values. - - Function: x:create-colormap window visual alloc-policy + -- Function: x:create-colormap window visual alloc-policy WINDOW specifies the window on whose screen you want to create a colormap. VISUAL specifies a visual type supported on the screen. ALLOC-POLICY Specifies the colormap entries to be allocated. You @@ -1314,6 +1312,7 @@ A "colormap" maps pixel values to "RGB" color space values. specific to VISUAL and are not defined by X. The ALLOC-POLICY must be `X:Alloc-None'. + For the other visual classes, if ALLOC-POLICY is `X:Alloc-None', the colormap initially has no allocated entries, and clients can allocate them. @@ -1339,7 +1338,7 @@ A "colormap" maps pixel values to "RGB" color space values. To create a new colormap when the allocation out of a previously shared colormap has failed because of resource exhaustion, use: - - Function: x:copy-colormap-and-free colormap + -- Function: x:copy-colormap-and-free colormap Creates and returns a colormap of the same visual type and for the same screen as the specified COLORMAP. It also moves all of the client's existing allocation from the specified COLORMAP to the @@ -1361,8 +1360,9 @@ A "colormap" maps pixel values to elements of the "RGB" datatype. An RGB is a list or vector of 3 integers, describing the red, green, and blue intensities respectively. The integers are in the range 0 - 65535. - - Function: x:alloc-colormap-cells colormap ncolors nplanes - - Function: x:alloc-colormap-cells colormap ncolors nplanes contiguous? + -- Function: x:alloc-colormap-cells colormap ncolors nplanes + -- Function: x:alloc-colormap-cells colormap ncolors nplanes + contiguous? The `X:Alloc-Color-Cells' function allocates read/write color cells. The number of colors, NCOLORS must be positive and the number of planes, NPLANES nonnegative. If NCOLORS and nplanes are @@ -1391,8 +1391,8 @@ blue intensities respectively. The integers are in the range 0 - 65535. succeeded or #f if it failed. The first array has the pixels allocated and the second has the plane-masks. - - Function: x:alloc-colormap-cells colormap ncolors rgb - - Function: x:alloc-colormap-cells colormap ncolors rgb contiguous? + -- Function: x:alloc-colormap-cells colormap ncolors rgb + -- Function: x:alloc-colormap-cells colormap ncolors rgb contiguous? The specified NCOLORS must be positive; and RGB a list or vector of 3 nonnegative integers. If NCOLORS colors, NREDS reds, NGREENS greens, and NBLUES blues are requested, NCOLORS pixels are @@ -1415,8 +1415,8 @@ blue intensities respectively. The integers are in the range 0 - 65535. allocated. The second, third, and fourth elements are the red, green, and blue plane-masks. - - Function: x:free-colormap-cells colormap pixels planes - - Function: x:free-colormap-cells colormap pixels + -- Function: x:free-colormap-cells colormap pixels planes + -- Function: x:free-colormap-cells colormap pixels Frees the cells represented by pixels whose values are in the PIXELS unsigned-integer uniform-vector. The PLANES argument should not have any bits set to 1 in common with any of the @@ -1439,12 +1439,12 @@ blue intensities respectively. The integers are in the range 0 - 65535. passing `x:Alloc-All' to `X:Create-Colormap'). If more than one pixel is in error, the one that gets reported is arbitrary. - - Function: x:colormap-find-color colormap rgb + -- Function: x:colormap-find-color colormap rgb RGB is a list or vector of 3 integers, describing the red, green, and blue intensities respectively; or an integer `#xrrggbb', packing red, green and blue intensities in the range 0 - 255. - - Function: x:colormap-find-color colormap color-name + -- Function: x:colormap-find-color colormap color-name The case-insensitive string COLOR_NAME specifies the name of a color (for example, `red') @@ -1461,19 +1461,19 @@ blue intensities respectively. The integers are in the range 0 - 65535. deallocated. - - Function: x:color-ref colormap pixel + -- Function: x:color-ref colormap pixel Returns a list of 3 integers, describing the red, green, and blue intensities respectively of the COLORMAP entry of the cell indexed by PIXEL. The integer PIXEL must be a valid index into COLORMAP. - - Function: X:Color-Set! colormap pixel rgb + -- Function: X:Color-Set! colormap pixel rgb RGB is a list or vector of 3 integers, describing the red, green, and blue intensities respectively; or an integer `#xrrggbb', packing red, green and blue intensities in the range 0 - 255. - - Function: X:Color-Set! colormap pixel color-name + -- Function: X:Color-Set! colormap pixel color-name The case-insensitive string COLOR_NAME specifies the name of a color (for example, `red') @@ -1484,7 +1484,7 @@ blue intensities respectively. The integers are in the range 0 - 65535. screen, the changes are visible immediately. - - Function: x:install-colormap colormap + -- Function: x:install-colormap colormap Installs the specified COLORMAP for its associated screen. All windows associated with COLORMAP immediately display with true colors. A colormap is associated with a window when the window is @@ -1495,24 +1495,24 @@ blue intensities respectively. The integers are in the range 0 - 65535. has that colormap. - - Function: x:ccc colormap + -- Function: x:ccc colormap Returns the Color-Conversion-Context of COLORMAP.  File: Xlibscm.info, Node: Rendering, Next: Images, Prev: Colormap, Up: Top -Rendering -********* +7 Rendering +*********** - - Function: x:flush display - - Function: x:flush window + -- Function: x:flush display + -- Function: x:flush window Flushes the output buffer. Some client applications need not use this function because the output buffer is automatically flushed as needed by calls to X:Pending, X:Next-Event, and X:Window-Event. Events generated by the server may be enqueued into the library's event queue. - - Function: x:flush gc + -- Function: x:flush gc Forces sending of GC component changes. Xlib usually defers sending changes to the components of a GC to @@ -1524,7 +1524,7 @@ Rendering the GC indirectly, in such a way that the extension interface cannot know what GC will be used. - - Function: x:clear-area window (x-pos y-pos) (width height) expose? + -- Function: x:clear-area window (x-pos y-pos) (width height) expose? Paints a rectangular area in the specified WINDOW according to the specified dimensions with the WINDOW's background pixel or pixmap. The subwindow-mode effectively is `x:Clip-By-Children'. If width @@ -1538,19 +1538,19 @@ Rendering are either visible or are being retained in a backing store. If you specify a WINDOW whose class is x:Input-Only, an error results. - - Function: x:fill-rectangle window gcontext position size + -- Function: x:fill-rectangle window gcontext position size Draw Strings ============ - - Function: x:draw-string drawable gc position string + -- Function: x:draw-string drawable gc position string POSITION specifies coordinates relative to the origin of DRAWABLE of the origin of the first character to be drawn. `x:draw-string' draws the characters of STRING, starting at POSITION. - - Function: x:image-string drawable gc position string + -- Function: x:image-string drawable gc position string POSITION specifies coordinates relative to the origin of DRAWABLE of the origin of the first character to be drawn. @@ -1560,13 +1560,13 @@ Draw Strings Draw Shapes =========== - - Function: x:draw-points drawable gc position ... + -- Function: x:draw-points drawable gc position ... POSITION ... specifies coordinates of the point to be drawn. - - Function: x:draw-points drawable gc x y ... + -- Function: x:draw-points drawable gc x y ... (X, Y) ... specifies coordinates of the point to be drawn. - - Function: x:draw-points drawable gc point-array + -- Function: x:draw-points drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1578,14 +1578,14 @@ Draw Shapes foreground, subwindow-mode, clip-x-origin, clip-y-origin, and clip-mask. - - Function: x:draw-segments drawable gc pos1 pos2 ... + -- Function: x:draw-segments drawable gc pos1 pos2 ... POS1, POS2, ... specify coordinates to be connected by segments. - - Function: x:draw-segments drawable gc x1 y1 x2 y2 ... + -- Function: x:draw-segments drawable gc x1 y1 x2 y2 ... (X1, Y1), (X2, Y2) ... specify coordinates to be connected by segments. - - Function: x:draw-segments drawable gc point-array + -- Function: x:draw-segments drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1608,14 +1608,14 @@ Draw Shapes tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, dash-offset, and dash-list. - - Function: x:draw-lines drawable gc pos1 pos2 ... + -- Function: x:draw-lines drawable gc pos1 pos2 ... POS1, POS2, ... specify coordinates to be connected by lines. - - Function: x:draw-lines drawable gc x1 y1 x2 y2 ... + -- Function: x:draw-lines drawable gc x1 y1 x2 y2 ... (X1, Y1), (X2, Y2) ... specify coordinates to be connected by lines. - - Function: x:draw-lines drawable gc point-array + -- Function: x:draw-lines drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1639,13 +1639,13 @@ Draw Shapes tile, stipple, tilestipple-x-origin, tile-stipple-y-origin, dash-offset, and dash-list. - - Function: x:fill-polygon drawable gc pos1 pos2 ... + -- Function: x:fill-polygon drawable gc pos1 pos2 ... POS1, POS2, ... specify coordinates of the border path. - - Function: x:fill-polygon drawable gc x1 y1 x2 y2 ... + -- Function: x:fill-polygon drawable gc x1 y1 x2 y2 ... (X1, Y1), (X2, Y2) ... specify coordinates of the border path. - - Function: x:fill-polygon drawable gc point-array + -- Function: x:fill-polygon drawable gc point-array POINT-ARRAY is a uniform short array of rank 2, whose rightmost index spans a range of 2. @@ -1667,30 +1667,30 @@ Draw Shapes  File: Xlibscm.info, Node: Images, Next: Event, Prev: Rendering, Up: Top -Images -****** +8 Images +******** - - Function: x:read-bitmap-file drawable file + -- Function: x:read-bitmap-file drawable file  File: Xlibscm.info, Node: Event, Next: Index, Prev: Images, Up: Top -Event -***** +9 Event +******* These three status routines always return immediately if there are events already in the queue. - - Function: x:q-length display + -- Function: x:q-length display Returns the length of the event queue for the connected DISPLAY. Note that there may be more events that have not been read into the queue yet (see X:Events-Queued). - - Function: x:pending display + -- Function: x:pending display Returns the number of events that have been received from the X server but have not been removed from the event queue. - - Function: x:events-queued display + -- Function: x:events-queued display Returns the number of events already in the queue if the number is nonzero. If there are no events in the queue, `X:Events-Queued' attempts to read more events out of the application's connection @@ -1698,12 +1698,12 @@ events already in the queue. Both of these routines return an object of type "event". - - Function: x:next-event display + -- Function: x:next-event display Removes and returns the first event from the event queue. If the event queue is empty, `X:Next-Event' flushes the output buffer and blocks until an event is received. - - Function: x:peek-event display + -- Function: x:peek-event display Returns the first event from the event queue, but it does not remove the event from the queue. If the queue is empty, `X:Peek-Event' flushes the output buffer and blocks until an event @@ -1711,7 +1711,7 @@ Both of these routines return an object of type "event". Each event object has fields dependent on its sub-type. - - Function: x:event-ref event field-name + -- Function: x:event-ref event field-name window The window on which EVENT was generated and is referred to as the event window. root is the event window's root window. @@ -1921,168 +1921,181 @@ Procedure and Macro Index This is an alphabetical list of all the procedures and macros in Xlibscm. +[index] * Menu: -* hostname:number.screen-number: Display and Screens. -* x:alloc-colormap-cells: Colormap. -* x:ccc: Colormap. -* x:clear-area: Rendering. -* x:close <1>: Windows and Pixmaps. -* x:close: Display and Screens. -* x:color-ref: Colormap. -* X:Color-Set!: Colormap. -* x:colormap-find-color: Colormap. -* x:copy-colormap-and-free: Colormap. -* x:copy-gc-fields!: Graphics Context. -* x:create-colormap: Colormap. -* x:create-cursor: Cursor. -* x:create-gc: Graphics Context. -* x:create-pixmap: Windows and Pixmaps. -* x:create-window: Windows and Pixmaps. -* x:default-ccc: Display and Screens. -* x:default-colormap: Display and Screens. -* x:default-gc: Display and Screens. -* x:default-screen: Display and Screens. -* x:default-visual: Display and Screens. -* x:draw-lines: Rendering. -* x:draw-points: Rendering. -* x:draw-segments: Rendering. -* x:draw-string: Rendering. -* x:event-ref: Event. -* x:events-queued: Event. -* x:fill-polygon: Rendering. -* x:fill-rectangle: Rendering. -* x:flush: Rendering. -* x:free-colormap-cells: Colormap. -* x:gc-ref: Graphics Context. -* x:gc-set!: Graphics Context. +* hostname:number.screen-number: Display and Screens. (line 18) +* x:alloc-colormap-cells: Colormap. (line 83) +* x:ccc: Colormap. (line 218) +* x:clear-area: Rendering. (line 27) +* x:close <1>: Windows and Pixmaps. (line 49) +* x:close: Display and Screens. (line 33) +* x:color-ref: Colormap. (line 184) +* X:Color-Set!: Colormap. (line 191) +* x:colormap-find-color: Colormap. (line 162) +* x:copy-colormap-and-free: Colormap. (line 61) +* x:copy-gc-fields!: Graphics Context. (line 25) +* x:create-colormap: Colormap. (line 9) +* x:create-cursor: Cursor. (line 7) +* x:create-gc: Graphics Context. (line 13) +* x:create-pixmap: Windows and Pixmaps. (line 39) +* x:create-window: Windows and Pixmaps. (line 8) +* x:default-ccc: Display and Screens. (line 88) +* x:default-colormap: Display and Screens. (line 83) +* x:default-gc: Display and Screens. (line 94) +* x:default-screen: Display and Screens. (line 65) +* x:default-visual: Display and Screens. (line 106) +* x:draw-lines: Rendering. (line 111) +* x:draw-points: Rendering. (line 63) +* x:draw-segments: Rendering. (line 81) +* x:draw-string: Rendering. (line 46) +* x:event-ref: Event. (line 40) +* x:events-queued: Event. (line 19) +* x:fill-polygon: Rendering. (line 142) +* x:fill-rectangle: Rendering. (line 41) +* x:flush: Rendering. (line 7) +* x:free-colormap-cells: Colormap. (line 138) +* x:gc-ref: Graphics Context. (line 30) +* x:gc-set!: Graphics Context. (line 18) * x:get-window-property: Window Properties and Visibility. -* x:image-string: Rendering. -* x:install-colormap: Colormap. + (line 7) +* x:image-string: Rendering. (line 53) +* x:install-colormap: Colormap. (line 207) * x:list-properties: Window Properties and Visibility. -* x:make-visual: Display and Screens. + (line 15) +* x:make-visual: Display and Screens. (line 112) * x:map-subwindows: Window Properties and Visibility. + (line 60) * x:map-window: Window Properties and Visibility. -* x:next-event: Event. -* x:open-display: Display and Screens. -* x:peek-event: Event. -* x:pending: Event. -* x:protocol-version: Display and Screens. -* x:q-length: Event. -* x:read-bitmap-file: Images. -* x:root-window: Display and Screens. -* x:screen-black: Display and Screens. -* x:screen-cells: Display and Screens. -* x:screen-count: Display and Screens. -* x:screen-depth: Display and Screens. -* x:screen-depths: Display and Screens. -* x:screen-dimensions: Display and Screens. -* x:screen-size: Display and Screens. -* x:screen-white: Display and Screens. -* x:server-vendor: Display and Screens. + (line 23) +* x:next-event: Event. (line 27) +* x:open-display: Display and Screens. (line 7) +* x:peek-event: Event. (line 32) +* x:pending: Event. (line 15) +* x:protocol-version: Display and Screens. (line 46) +* x:q-length: Event. (line 10) +* x:read-bitmap-file: Images. (line 7) +* x:root-window: Display and Screens. (line 70) +* x:screen-black: Display and Screens. (line 182) +* x:screen-cells: Display and Screens. (line 149) +* x:screen-count: Display and Screens. (line 62) +* x:screen-depth: Display and Screens. (line 154) +* x:screen-depths: Display and Screens. (line 99) +* x:screen-dimensions: Display and Screens. (line 171) +* x:screen-size: Display and Screens. (line 166) +* x:screen-white: Display and Screens. (line 177) +* x:server-vendor: Display and Screens. (line 51) * x:unmap-subwindows: Window Properties and Visibility. + (line 79) * x:unmap-window: Window Properties and Visibility. -* x:vendor-release: Display and Screens. -* x:visual-class: Display and Screens. -* x:visual-geometry: Display and Screens. -* x:window-geometry: Windows and Pixmaps. -* x:window-geometry-set!: Windows and Pixmaps. -* x:window-ref: Window Attributes. -* x:window-set!: Window Attributes. + (line 68) +* x:vendor-release: Display and Screens. (line 56) +* x:visual-class: Display and Screens. (line 132) +* x:visual-geometry: Display and Screens. (line 137) +* x:window-geometry: Windows and Pixmaps. (line 67) +* x:window-geometry-set!: Windows and Pixmaps. (line 88) +* x:window-ref: Window Attributes. (line 280) +* x:window-set!: Window Attributes. (line 7) Variable Index ************** This is an alphabetical list of all the global variables in Xlibscm. +[index] * Menu: -* x:CW-Back-Pixel: Window Attributes. -* x:CW-Back-Pixmap: Window Attributes. -* x:CW-Backing-Pixel: Window Attributes. -* x:CW-Backing-Planes: Window Attributes. -* x:CW-Backing-Store: Window Attributes. -* x:CW-Bit-Gravity: Window Attributes. -* x:CW-Border-Pixel: Window Attributes. -* x:CW-Border-Pixmap: Window Attributes. -* x:CW-Border-Width: Windows and Pixmaps. -* x:CW-Colormap: Window Attributes. -* x:CW-Cursor: Window Attributes. -* x:CW-Dont-Propagate: Window Attributes. -* x:CW-Event-Mask: Window Attributes. -* x:CW-Height: Windows and Pixmaps. -* x:CW-Override-Redirect: Window Attributes. -* x:CW-Save-Under: Window Attributes. -* x:CW-Sibling: Windows and Pixmaps. -* x:CW-Stack-Mode: Windows and Pixmaps. -* x:CW-Width: Windows and Pixmaps. -* x:CW-Win-Gravity: Window Attributes. -* x:CWX: Windows and Pixmaps. -* x:CWY: Windows and Pixmaps. -* x:GC-Arc-Mode: Graphics Context. -* x:GC-Background: Graphics Context. -* x:GC-Cap-Style: Graphics Context. -* x:GC-Clip-Mask: Graphics Context. -* x:GC-Clip-X-Origin: Graphics Context. -* x:GC-Clip-Y-Origin: Graphics Context. -* x:GC-Dash-List: Graphics Context. -* x:GC-Dash-Offset: Graphics Context. -* x:GC-Fill-Rule: Graphics Context. -* x:GC-Fill-Style: Graphics Context. -* x:GC-Font: Graphics Context. -* x:GC-Foreground: Graphics Context. -* x:GC-Function: Graphics Context. -* x:GC-Graphics-Exposures: Graphics Context. -* x:GC-Join-Style: Graphics Context. -* x:GC-Line-Style: Graphics Context. -* x:GC-Line-Width: Graphics Context. -* x:GC-Plane-Mask: Graphics Context. -* x:GC-Stipple: Graphics Context. -* x:GC-Subwindow-Mode: Graphics Context. -* x:GC-Tile: Graphics Context. -* x:GC-Tile-Stip-X-Origin: Graphics Context. -* x:GC-Tile-Stip-Y-Origin: Graphics Context. +* x:CW-Back-Pixel: Window Attributes. (line 29) +* x:CW-Back-Pixmap: Window Attributes. (line 19) +* x:CW-Backing-Pixel: Window Attributes. (line 138) +* x:CW-Backing-Planes: Window Attributes. (line 137) +* x:CW-Backing-Store: Window Attributes. (line 108) +* x:CW-Bit-Gravity: Window Attributes. (line 46) +* x:CW-Border-Pixel: Window Attributes. (line 42) +* x:CW-Border-Pixmap: Window Attributes. (line 35) +* x:CW-Border-Width: Windows and Pixmaps. (line 112) +* x:CW-Colormap: Window Attributes. (line 251) +* x:CW-Cursor: Window Attributes. (line 269) +* x:CW-Dont-Propagate: Window Attributes. (line 240) +* x:CW-Event-Mask: Window Attributes. (line 182) +* x:CW-Height: Windows and Pixmaps. (line 100) +* x:CW-Override-Redirect: Window Attributes. (line 154) +* x:CW-Save-Under: Window Attributes. (line 168) +* x:CW-Sibling: Windows and Pixmaps. (line 119) +* x:CW-Stack-Mode: Windows and Pixmaps. (line 123) +* x:CW-Width: Windows and Pixmaps. (line 99) +* x:CW-Win-Gravity: Window Attributes. (line 47) +* x:CWX: Windows and Pixmaps. (line 97) +* x:CWY: Windows and Pixmaps. (line 98) +* x:GC-Arc-Mode: Graphics Context. (line 348) +* x:GC-Background: Graphics Context. (line 92) +* x:GC-Cap-Style: Graphics Context. (line 153) +* x:GC-Clip-Mask: Graphics Context. (line 309) +* x:GC-Clip-X-Origin: Graphics Context. (line 304) +* x:GC-Clip-Y-Origin: Graphics Context. (line 305) +* x:GC-Dash-List: Graphics Context. (line 339) +* x:GC-Dash-Offset: Graphics Context. (line 322) +* x:GC-Fill-Rule: Graphics Context. (line 228) +* x:GC-Fill-Style: Graphics Context. (line 190) +* x:GC-Font: Graphics Context. (line 281) +* x:GC-Foreground: Graphics Context. (line 91) +* x:GC-Function: Graphics Context. (line 42) +* x:GC-Graphics-Exposures: Graphics Context. (line 299) +* x:GC-Join-Style: Graphics Context. (line 174) +* x:GC-Line-Style: Graphics Context. (line 137) +* x:GC-Line-Width: Graphics Context. (line 100) +* x:GC-Plane-Mask: Graphics Context. (line 70) +* x:GC-Stipple: Graphics Context. (line 259) +* x:GC-Subwindow-Mode: Graphics Context. (line 284) +* x:GC-Tile: Graphics Context. (line 258) +* x:GC-Tile-Stip-X-Origin: Graphics Context. (line 272) +* x:GC-Tile-Stip-Y-Origin: Graphics Context. (line 273) This is an alphabetical list of concepts introduced in this manual. Concept Index ************* +[index] * Menu: -* colormap: Colormap. -* cursor: Cursor. -* depth: Display and Screens. -* drawable: Drawables. -* Drawable: Drawables. +* colormap: Colormap. (line 6) +* cursor: Cursor. (line 7) +* depth: Display and Screens. (line 161) +* drawable: Drawables. (line 6) +* Drawable: Drawables. (line 6) * map: Window Properties and Visibility. + (line 18) * mapped: Window Properties and Visibility. -* none: Graphics Context. -* RGB: Colormap. + (line 18) +* none: Graphics Context. (line 311) +* RGB: Colormap. (line 6) * unmap: Window Properties and Visibility. + (line 18) * unmapped: Window Properties and Visibility. -* Visual: Display and Screens. -* visual: Display and Screens. -* X: Xlibscm. -* x:None: Graphics Context. -* Xlib: Xlibscm. + (line 18) +* Visual: Display and Screens. (line 110) +* visual: Display and Screens. (line 110) +* X: Xlibscm. (line 6) +* x:None: Graphics Context. (line 311) +* Xlib: Xlibscm. (line 10)  Tag Table: Node: Top215 Node: Xlibscm1330 -Node: Display and Screens4120 -Node: Drawables11105 -Node: Windows and Pixmaps11366 -Node: Window Attributes18445 -Node: Window Properties and Visibility34425 -Node: Graphics Context38882 -Node: Cursor54589 -Node: Colormap57092 -Node: Rendering66958 -Node: Images74515 -Node: Event74656 -Node: Index89131 +Node: Display and Screens4124 +Node: Drawables11166 +Node: Windows and Pixmaps11431 +Node: Window Attributes18533 +Node: Window Properties and Visibility34538 +Node: Graphics Context39010 +Node: Cursor54750 +Node: Colormap57261 +Node: Rendering67157 +Node: Images74737 +Node: Event74883 +Node: Index89368  End Tag Table diff --git a/Xlibscm.texi b/Xlibscm.texi index 9ecaee1..356877c 100644 --- a/Xlibscm.texi +++ b/Xlibscm.texi @@ -54,7 +54,7 @@ by the author. This manual documents the X - SCM Language X Interface. The most recent information about SCM can be found on SCM's @dfn{WWW} home page: -@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM} +@center @url{http://swiss.csail.mit.edu/~jaffer/SCM} Copyright (C) 1990-1999 Free Software Foundation @@ -126,7 +126,7 @@ dynamic linking, compiled separately and loaded with @code{(require @noindent The most recent information about SCM can be found on SCM's @dfn{WWW} home page: -@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM} +@center @url{http://swiss.csail.mit.edu/~jaffer/SCM} @end iftex Much of this X documentation is dervied from: diff --git a/build b/build index dd43759..450726d 100755 --- a/build +++ b/build @@ -1,5 +1,5 @@ #! /bin/sh -:;exec ./scmlit -no-init-file -f $0 -e"(bi)" build $* +:;exec ./scmlit -no-init-file -f $0 -e"(bi)" build "$@" (require 'getopt) (require 'getopt-parameters) @@ -54,7 +54,7 @@ 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. -@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM} +@center @url{http://swiss.csail.mit.edu/~jaffer/SCM} @section Manifest " diff --git a/build.bat b/build.bat index d914f05..3478188 100755 --- a/build.bat +++ b/build.bat @@ -1,4 +1,4 @@ -scmlit -fbuild -e(bi) build %1 %2 %3 %4 %5 %6 %7 %8 %9 +scmlit -fbuild -e(bi) build %* @IF NOT ERRORLEVEL 1 GOTO ok @ECHO **** build.bat FAILED! **** :ok diff --git a/build.scm b/build.scm index 0c66ccc..a467a52 100644 --- a/build.scm +++ b/build.scm @@ -1,5 +1,5 @@ ;; "build.scm" Build database and program -*-scheme-*- -;; Copyright (C) 1994-2003 Aubrey Jaffer. +;; Copyright (C) 1994-2004 Aubrey Jaffer. ;; ;; 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 @@ -58,9 +58,9 @@ ((documentation string)) ((documentation "documentation") (platform-specific "required for certain platforms") - (required "required for building executable SCM") + (core "core for building executable SCM") (optional "required for some feature") - (linkable "required and can be dynamically linked") + (linkable "can be statically or dynamically linked for some feature") (test "test SCM") (none "no files"))) @@ -81,38 +81,38 @@ ("pi.scm" Scheme test "computes digits of pi [type (pi 100 5)]. Test performance against pi.c.") ("pi.c" c-source test "computes digits of pi [cc -o pi pi.c;time pi 100 5].") ("bench.scm" Scheme test "computes and records performance statistics of pi.scm.") - ("Makefile" Makefile required "builds SCMLIT using the `make' program.") - ("build.scm" Scheme required "database for compiling and linking new SCM programs.") + ("Makefile" Makefile core "builds SCMLIT using the `make' program.") + ("build.scm" Scheme core "database for compiling and linking new SCM programs.") ("build.bat" MS-DOS-batch platform-specific "invokes build.scm for MS-DOS") - ("mkimpcat.scm" Scheme required "build SCM-specific catalog for SLIB.") + ("mkimpcat.scm" Scheme core "build SCM-specific catalog for SLIB.") (".gdbinit" gdb-init optional "provides commands for debugging SCM with GDB") ("setjump.mar" Vax-asm platform-specific "provides setjump and longjump which do not use $unwind utility on VMS.") ("ugsetjump.s" gnu-as platform-specific "provides setjump and longjump which work on Ultrix VAX.") ("setjump.s" Cray-asm platform-specific "provides setjump and longjump for the Cray YMP.") - ("Init.scm" Scheme required "Scheme initialization.") - ("Transcen.scm" Scheme required "inexact builtin procedures.") - ("Link.scm" Scheme required "Dynamic link/loading.") - ("compile.scm" Scheme required "Hobbit compilation to C.") - ("Macro.scm" Scheme required "Supports Syntax-Rules Macros.") - ("scmfig.h" c-header required "contains system dependent definitions.") - ("patchlvl.h" c-header required "patchlevel of this release.") - ("setjump.h" c-header required "continuations, stacks, and memory allocation.") - ("continue.h" c-header required "continuations.") - ("continue.c" c-source required "continuations.") - ("scm.h" c-header required "data type and external definitions of SCM.") - ("scm.c" c-source required "initialization, interrupts, and non-IEEE utility functions.") - ("scmmain.c" c-source required "initialization, interrupts, and non-IEEE utility functions.") - ("findexec.c" c-source required "find the executable file function.") - ("script.c" c-source required "utilities for running as `#!' script.") - ("time.c" c-source required "functions dealing with time.") - ("repl.c" c-source required "error, read-eval-print loop, read, write and load.") - ("scl.c" c-source required "inexact arithmetic") - ("eval.c" c-source required "evaluator, apply, map, and foreach.") - ("sys.c" c-source required "call-with-current-continuation, opening and closing files, storage allocation and garbage collection.") - ("subr.c" c-source required "the rest of IEEE functions.") - ("debug.c" c-source required "debugging, printing code.") - ("unif.c" c-source required "uniform vectors.") - ("rope.c" c-source required "C interface functions.") + ("Init.scm" Scheme core "Scheme initialization.") + ("Transcen.scm" Scheme core "inexact builtin procedures.") + ("Link.scm" Scheme core "Dynamic link/loading.") + ("compile.scm" Scheme core "Hobbit compilation to C.") + ("Macro.scm" Scheme core "Supports Syntax-Rules Macros.") + ("scmfig.h" c-header core "contains system dependent definitions.") + ("patchlvl.h" c-header core "patchlevel of this release.") + ("setjump.h" c-header core "continuations, stacks, and memory allocation.") + ("continue.h" c-header core "continuations.") + ("continue.c" c-source core "continuations.") + ("scm.h" c-header core "data type and external definitions of SCM.") + ("scm.c" c-source core "initialization, interrupts, and non-IEEE utility functions.") + ("scmmain.c" c-source core "initialization, interrupts, and non-IEEE utility functions.") + ("findexec.c" c-source core "find the executable file function.") + ("script.c" c-source core "utilities for running as `#!' script.") + ("time.c" c-source core "functions dealing with time.") + ("repl.c" c-source core "error, read-eval-print loop, read, write and load.") + ("scl.c" c-source core "inexact arithmetic") + ("eval.c" c-source core "evaluator, apply, map, and foreach.") + ("sys.c" c-source core "call-with-current-continuation, opening and closing files, storage allocation and garbage collection.") + ("subr.c" c-source core "the rest of IEEE functions.") + ("debug.c" c-source core "debugging, printing code.") + ("unif.c" c-source core "uniform vectors.") + ("rope.c" c-source core "C interface functions.") ("ramap.c" c-source optional "array mapping") ("dynl.c" c-source optional "dynamically load object files.") ("sc2.c" c-source linkable "procedures from R2RS and R3RS not in R4RS.") @@ -122,6 +122,8 @@ ("split.scm" Scheme test "example use of crs.c. Input, output, and diagnostic output directed to separate windows.") ("edline.c" c-source linkable "Gnu readline input editing (get ftp.sys.toronto.edu:/pub/rc/editline.shar).") ("Iedline.scm" Scheme optional "Gnu readline input editing.") + ("differ.c" c-source linkable "Linear-space O(PN) sequence comparison.") + ("Idiffer.scm" Scheme optional "Linear-space O(PN) sequence comparison.") ("record.c" c-source linkable "proposed `Record' user definable datatypes.") ("gsubr.c" c-source linkable "make_gsubr for arbitrary (< 11) arguments to C functions.") ("ioext.c" c-source linkable "system calls in common between PC compilers and unix.") @@ -146,9 +148,9 @@ (o-proc symbol) (spec expression) (documentation string)) - ((exe required compile-c-files link-c-program #f + ((exe core compile-c-files link-c-program #f "executable program") - (lib required compile-c-files make-archive ((c-lib lib)) + (lib core compile-c-files make-archive ((c-lib lib)) "library module") (dlls linkable compile-dll-c-files make-dll-archive ((define "DLL")) "archived dynamically linked library object files") @@ -356,7 +358,8 @@ 'regex '((c-file "rgx.c") (c-lib regex) (compiled-init "init_rgx"))) -#;BSD @dfn{socket} interface. +#;BSD @dfn{socket} interface. Socket addr functions require +#;inexacts or bignums for 32-bit precision. (define-build-feature 'socket '((c-lib socket) (c-file "socket.c") (compiled-init "init_socket"))) @@ -374,6 +377,11 @@ 'unix '((c-file "unix.c") (compiled-init "init_unix"))) +#;Sequence comparison +(define-build-feature + 'differ + '((c-file "differ.c") (compiled-init "init_differ"))) + #;Microsoft Windows executable. (define-build-feature 'windows @@ -414,6 +422,14 @@ 'cheap-continuations '((define "CHEAP_CONTINUATIONS"))) +#;WB database with relational wrapper. +(define-build-feature + 'wb + '((c-file "../wb/blink.c" "../wb/blkio.c" "../wb/del.c" "../wb/ent.c" + "../wb/handle.c" "../wb/prev.c" "../wb/scan.c" "../wb/stats.c" + "../wb/wbsys.c" "../wb/db.c") + (scm-srcdir "../scm/") + (compiled-init "init_db"))) ;;;; The rest is about building on specific platforms. @@ -519,7 +535,8 @@ (m gnu-win32 "" "" "" () ()) (c gnu-win32 "" "" "" () ()) - (dlll gnu-win32 "-DSCM_DLL" "" #f () ("posix.c" "unix.c" "socket.c")) + (dlll gnu-win32 "-DSCM_WIN_DLL" "" #f () ("posix.c" "unix.c" "socket.c")) + (m linux-aout "" "-lm" "/usr/lib/libm.sa" () ()) (c linux-aout "" "-lc" "/usr/lib/libc.sa" () ()) (dlll linux-aout "-DDLD -DDLD_DYNCM" "-ldld" #f () ("findexec.c")) @@ -599,7 +616,7 @@ (m microsoft-c "" "" #f () ()) (c microsoft-c-nt "" "" #f () ("findexec.c")) (m microsoft-c-nt "" "" #f () ()) - (dlll microsoft-c-nt "-DSCM_DLL -MD" "" #f () ("posix.c" "unix.c" "socket.c")) + (dlll microsoft-c-nt "-DSCM_WIN_DLL -MD" "" #f () ("posix.c" "unix.c" "socket.c")) (debug microsoft-c-nt "-Zi" "/debug" #f () ()) (c microsoft-quick-c "" "" #f () ("findexec.c")) (m microsoft-quick-c "" "" #f () ()) @@ -625,7 +642,7 @@ (c freebsd "" "-export-dynamic" #f () ()) (m freebsd "" "-lm" #f () ()) (curses freebsd "" "-lncurses" "/usr/lib/libncurses.a" () ()) - (regex freebsd "" "-lgnuregex" "" () ()) + (regex freebsd "-I/usr/include/gnu" "-lgnuregex" "" () ()) (editline freebsd "" "-lreadline" "" () ()) (dlll freebsd "-DSUN_DL" "-export-dynamic" "" () ()) (nostart freebsd "" "-e start -dc -dp -Bstatic -lgnumalloc" #f ("pre-crt0.c") ()) @@ -635,7 +652,9 @@ (graphics netbsd "-I/usr/X11R6/include -DX11" "-lX11" "-Wl,-rpath -Wl,/usr/X11R6/lib -L/usr/X11R6/lib" () ()) (m netbsd "" "-lm" #f () ()) (m openbsd "" "-lm" #f () ()) + (dlll openbsd "-DSUN_DL" "" "" () ()) (curses openbsd "" "-lcurses" "/usr/lib/libcurses.a" () ()) + (regex openbsd "" "" #f () ()) )) '(compile-commands @@ -754,20 +773,16 @@ (c-includes parms) (c-flags parms) c-files) - (let ((results - (map - (lambda (fname) - (and (batch:try-command - parms "link" "/dll" "/nologo" - (string-append "/out:" fname ".dll") - (string-append "/implib:" fname ".lib") - fname - (map (lambda (l) (build:lib-ld-flag l platform)) - (parameter-list-ref parms 'c-lib)) - "scm.lib") - (string-append fname ".dll"))) - (map c-> c-files)))) - (and (apply and? results) results)))))) + (let ((fnames (map c-> c-files))) + (and (batch:try-command + parms "link" "/dll" "/nologo" + (string-append "/out:" (car fnames) ".dll") + (string-append "/implib:" (car fnames) ".lib") + fnames + (map (lambda (l) (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib)) + "scm.lib") + (list (string-append (car fnames) ".dll")))))))) (defcommand make-dll-archive microsoft-c-nt (lambda (oname objects libs parms) objects)) (defcommand make-archive microsoft-c-nt @@ -955,23 +970,18 @@ (lambda (files parms) (and (batch:try-chopped-command parms "cc" "+O1" "-Wl,-E" "+z" "-c" + (include-spec "-I" parms) (c-includes parms) (c-flags parms) files) - (let ((results - (map - (lambda (fname) - (batch:rename-file - parms - (string-append fname ".sl") - (string-append fname ".sl~")) - (and (batch:try-command - parms "ld" "-b" "-o" - (string-append fname ".sl") - (string-append fname ".o")) - (string-append fname ".sl"))) - (truncate-up-to (map c-> files) #\/)))) - (and (apply and? results) results))))) + (let ((fnames (truncate-up-to (map c-> files) #\/))) + (define fname.sl (string-append (car fnames) ".sl")) + (batch:rename-file parms fname.sl (string-append fname.sl "~")) + (and (batch:try-command + parms "ld" "-b" "-o" + fname.sl + (map (lambda (fname) (string-append fname ".o")) fnames)) + (list fname.sl)))))) ; (make-dll-archive HP-UX ; (lambda (oname objects libs parms) ; (and (batch:try-command @@ -994,6 +1004,7 @@ (and (batch:try-chopped-command parms "gcc" "-c" + (include-spec "-I" parms) (c-includes parms) (c-flags parms) files) @@ -1018,28 +1029,24 @@ (lambda (files parms) (and (batch:try-chopped-command - parms - "gcc" "-fpic" "-c" (c-includes parms) - (c-flags parms) - files) + parms "gcc" "-fpic" "-c" + (include-spec "-I" parms) (c-includes parms) (c-flags parms) files) (let* ((platform (car (parameter-list-ref parms 'platform))) - (ld-opts - (map (lambda (l) (build:lib-ld-flag l platform)) - (parameter-list-ref parms 'c-lib))) - (results - (map - (lambda (fname) - (and (batch:try-command - parms - "gcc" "-shared" "-o" - (string-append fname ".so") - (string-append fname ".o") - ld-opts) - (batch:delete-file - parms (string-append fname ".o")) - (string-append fname ".so"))) - (truncate-up-to (map c-> files) #\/)))) - (and (apply and? results) results))))) + (fnames (truncate-up-to (map c-> files) #\/)) + (fname.so (string-append (car fnames) ".so")) + (result + (and (batch:try-command + parms + "gcc" "-shared" "-o" fname.so + (map (lambda (fname) (string-append fname ".o")) fnames) + (map (lambda (l) (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib))) + (list fname.so)))) + (for-each (lambda (fname) + (batch:delete-file + parms (string-append fname ".o"))) + fnames) + result)))) (defcommand make-dll-archive linux (lambda (oname objects libs parms) (let ((platform (car (parameter-list-ref @@ -1135,6 +1142,7 @@ (lambda (files parms) (and (batch:try-chopped-command parms "gcc" "-c" + (include-spec "-I" parms) (c-includes parms) (c-flags parms) files) @@ -1160,27 +1168,20 @@ (define c-files (remove-if (lambda (file) (member file suppressors)) files)) (and (batch:try-chopped-command - parms - "gcc" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - c-files) - (let ((results - (map - (lambda (fname) - (and (batch:try-command - parms "dllwrap" - "--output-lib" (string-append fname ".lib") - "-dllname" (string-append fname ".dll") - "--output-def" (string-append fname ".def") - (string-append fname ".o") - (map (lambda (l) (build:lib-ld-flag l platform)) - (parameter-list-ref parms 'c-lib)) - "scm.lib") - (string-append fname ".dll"))) - (map c-> c-files)))) - (and (apply and? results) results)))))) + parms "gcc" "-c" (include-spec "-I" parms) + (c-includes parms) (c-flags parms) c-files) + (let ((fnames (map c-> c-files))) + (and (batch:try-command + parms "dllwrap" + "--output-lib" (string-append (car fnames) ".lib") + "-dllname" (string-append (car fnames) ".dll") + "--output-def" (string-append (car fnames) ".def") + (map (lambda (fname) (string-append fname ".o")) + fnames) + (map (lambda (l) (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib)) + "scm.lib") + (list (string-append (car fnames) ".dll")))))))) (defcommand make-dll-archive gnu-win32 (lambda (oname objects libs parms) objects)) (defcommand make-archive gnu-win32 @@ -1231,25 +1232,19 @@ (lambda (files parms) (and (batch:try-chopped-command - parms "cc" "-std1" "-c" (c-includes parms) (c-flags parms) files) + parms "cc" "-std1" "-c" (c-includes parms) + (include-spec "-I" parms) (c-flags parms) files) (let* ((platform (car (parameter-list-ref parms 'platform))) - (ld-opts + (fnames (truncate-up-to (map c-> files) #\/))) + (and (batch:try-command + parms "cc" "-shared" "-o" (string-append (car fnames) ".so") + (map (lambda (fname) (string-append fname ".o")) fnames) (map (lambda (l) (build:lib-ld-flag l platform)) (parameter-list-ref parms 'c-lib))) - (results - (map - (lambda (fname) - (and (batch:try-command - parms - "cc" "-shared" "-o" - (string-append fname ".so") - (string-append fname ".o") - ld-opts) - (batch:delete-file - parms (string-append fname ".o")) - (string-append fname ".so"))) - (truncate-up-to (map c-> files) #\/)))) - (and (apply and? results) results))))) + (for-each (lambda (fname) + (batch:delete-file parms (string-append fname ".o"))) + fnames) + (list (string-append (car fnames) ".so"))))))) (defcommand make-dll-archive osf1 (lambda (oname objects libs parms) (let ((platform (car (parameter-list-ref @@ -1292,30 +1287,20 @@ (defcommand compile-dll-c-files svr4-gcc-sun-ld (lambda (files parms) (and - (batch:try-chopped-command - parms - "gcc" - "-fpic" "-c" (c-includes parms) - (c-flags parms) - files) + (batch:try-chopped-command parms "gcc" "-fpic" "-c" + (include-spec "-I" parms) + (c-includes parms) (c-flags parms) files) (let* ((platform (car (parameter-list-ref parms 'platform))) - (ld-opts + (fnames (truncate-up-to (map c-> files) #\/))) + (and (batch:try-command + parms "ld" "-G" "-o" (string-append (car fnames) ".so") + (map (lambda (fname) (string-append fname ".o")) fnames) (map (lambda (l) (build:lib-ld-flag l platform)) (parameter-list-ref parms 'c-lib))) - (results - (map - (lambda (fname) - (and (batch:try-command - parms - "ld" "-G" "-o" - (string-append fname ".so") - (string-append fname ".o") - ld-opts) - (batch:delete-file - parms (string-append fname ".o")) - (string-append fname ".so"))) - (truncate-up-to (map c-> files) #\/)))) - (and (apply and? results) results))))) + (for-each (lambda (fname) + (batch:delete-file parms (string-append fname ".o"))) + fnames) + (list (string-append (car fnames) ".so"))))))) (defcommand compile-c-files svr4 (lambda (files parms) @@ -1569,6 +1554,7 @@ (lambda (files parms) (and (batch:try-chopped-command parms "cc" "-c" + (include-spec "-I" parms) (c-includes parms) (c-flags parms) files) @@ -1588,6 +1574,8 @@ (lambda (files parms) (and (batch:try-chopped-command parms +;;; gcc 3.4.2 for FreeBSD does not allow options other than default i.e. -O0 if NO -DGCC_SPARC_BUG - dai 2004-10-30 + ;;"cc" "-O3 -pipe -DGCC_SPARC_BUG " "-c" "cc" "-O3 -pipe " "-c" (c-includes parms) (c-flags parms) @@ -1608,29 +1596,22 @@ (defcommand compile-dll-c-files freebsd (lambda (files parms) (and (batch:try-chopped-command - parms - "cc" "-O3 -pipe " - "-fPIC" "-c" (c-includes parms) - (c-flags parms) - files) - (let ((results - (map - (lambda (fname) - (and (batch:try-command - parms - "cc" "-shared" - (cond - ((equal? fname "edline") "-lreadline") - ((equal? fname "x") "-L/usr/X11R6/lib -lSM -lICE -lXext -lX11 -lxpg4") - (else "")) - "-o" - (string-append fname ".so") - (string-append fname ".o")) - (batch:delete-file - parms (string-append fname ".o")) - (string-append fname ".so"))) - (truncate-up-to (map c-> files) #\/)))) - (and (apply and? results) results))))) + parms "cc" "-O3 -pipe " "-fPIC" "-c" + (c-includes parms) (c-flags parms) files) + (let ((fnames (truncate-up-to (map c-> files) #\/))) + (and (batch:try-command + parms "cc" "-shared" + (cond + ((equal? (car fnames) "edline") "-lreadline") + ((equal? (car fnames) "x") "-L/usr/X11R6/lib -lSM -lICE -lXext -lX11 -lxpg4") + (else "")) + "-o" (string-append (car fnames) ".so") + (map (lambda (fname) (string-append fname ".o")) fnames)) + (for-each (lambda (fname) + (batch:delete-file + parms (string-append fname ".o"))) + fnames) + (list (string-append (car fnames) ".so"))))))) (defcommand make-dll-archive freebsd (lambda (oname objects libs parms) (and (batch:try-command @@ -1667,7 +1648,7 @@ (lambda (files parms) (and (batch:try-chopped-command parms - "cc" "-c" + "cc" "-c" (include-spec "-I" parms) (c-includes parms) (c-flags parms) files) @@ -1687,23 +1668,12 @@ (defcommand compile-dll-c-files netbsd (lambda (files parms) (and (batch:try-chopped-command - parms - "cc" "-fPIC" "-c" - (string-append - "-I" (parameter-list-ref parms 'scm-srcdir)) - (c-includes parms) - (c-flags parms) - files) + parms "cc" "-fPIC" "-c" (include-spec "-I" parms) + (c-includes parms) (c-flags parms) files) (let ((objs (map c->o files))) - (every - (lambda (f) - (and (batch:try-command - parms "gcc" "-shared" "-fPIC" f) - (batch:try-command - parms "mv" "a.out" f))) - objs) - objs)))) - + (and (batch:try-command parms "gcc" "-shared" "-fPIC" objs) + (batch:try-command parms "mv" "a.out" (car objs)) + (list (car objs))))))) (defcommand make-dll-archive netbsd (lambda (oname objects libs parms) (and (batch:try-command @@ -1722,7 +1692,7 @@ (lambda (files parms) (and (batch:try-chopped-command parms - "cc" "-c" + "cc" "-c" (include-spec "-I" parms) (c-includes parms) (c-flags parms) files) @@ -1737,27 +1707,17 @@ '("-nostartfiles" "pre-crt0.o" "crt0.o" "/usr/lib/crt0.o") - (append libs objects))) + (append objects libs))) oname))) (defcommand compile-dll-c-files openbsd (lambda (files parms) (and (batch:try-chopped-command - parms - "cc" "-fPIC" "-c" - (string-append - "-I" (parameter-list-ref parms 'scm-srcdir)) - (c-includes parms) - (c-flags parms) - files) + parms "cc" "-fPIC" "-c" (include-spec "-I" parms) + (c-includes parms) (c-flags parms) files) (let ((objs (map c->o files))) - (every - (lambda (f) - (and (batch:try-command - parms "gcc" "-shared" "-fPIC" f) - (batch:try-command - parms "mv" "a.out" f))) - objs) - objs)))) + (and (batch:try-command parms "gcc" "-shared" "-fPIC" objs) + (batch:try-command parms "mv" "a.out" (car objs)) + (list (car objs))))))) (defcommand make-dll-archive openbsd (lambda (oname objects libs parms) @@ -1959,9 +1919,7 @@ parms (cons 'batch-dialect (list (os->batch-dialect os))))))) (adjoin-parameters! - parms - (cons 'c-defines c-defines) - (cons 'c-includes c-includes)) + parms (cons 'c-defines c-defines) (cons 'c-includes c-includes)) (set! parms (cons (cons 'operating-system @@ -1975,9 +1933,7 @@ name (lambda (batch-port) (define o-files #f) - (adjoin-parameters! - parms - (list 'batch-port batch-port)) + (adjoin-parameters! parms (list 'batch-port batch-port)) (let ((options-file (parameter-list-ref parms 'options-file))) (and (not (null? options-file)) @@ -1996,17 +1952,14 @@ (let ((suppressors (apply append (map (lambda (l) (build:c-suppress l platform)) - (parameter-list-ref parms 'c-lib)))) - (ssdir (car (parameter-list-ref parms 'scm-srcdir)))) + (parameter-list-ref parms 'c-lib))))) (c-proc - (map (lambda (file) (in-vicinity ssdir file)) - (apply - append - (remove-if (lambda (file) (member file suppressors)) - (parameter-list-ref parms 'c-file)) - (map - (lambda (l) (build:c-lib-support l platform)) - (parameter-list-ref parms 'c-lib)))) + (apply + append + (remove-if (lambda (file) (member file suppressors)) + (parameter-list-ref parms 'c-file)) + (map (lambda (l) (build:c-lib-support l platform)) + (parameter-list-ref parms 'c-lib))) parms))) (cond ((not o-files) diff --git a/byte.c b/byte.c index 1ef014f..457d878 100644 --- a/byte.c +++ b/byte.c @@ -119,7 +119,7 @@ SCM scm_bytes_reverse(str) ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bt_reverse); len = LENGTH(str); dst = CHARS(str); - for(k = len/2;k >= 0;k--) { + for(k = (len - 1)/2;k >= 0;k--) { int tmp = dst[k]; dst[k] = dst[len - k - 1]; dst[len - k - 1] = tmp; @@ -187,7 +187,7 @@ SCM scm_substring_read(sstr, start, args) } else { long idx = start; - while (end <= idx) { + while (end < idx) { int chr = lgetc(port); if (EOF==chr) return MAKINUM(start - idx); CHARS(sstr)[--idx] = chr; diff --git a/compile.scm b/compile.scm index 1242231..2cd9170 100755 --- a/compile.scm +++ b/compile.scm @@ -1,5 +1,5 @@ #! /bin/sh -:;exec scm -e"(set! *script* \"$0\")" -f$0 $* +:;exec scm -e"(set! *script* \"$0\")" -f$0 "$@" ;; Copyright (C) 1992-2002 Free Software Foundation, Inc. ;; @@ -64,7 +64,7 @@ Usage: compile.scm FILE1.scm FILE2.scm ... for your computer (for instance, `.o'). FILE1.scm must be in the current directory; FILE2.scm ... can be in other directories. -http://swissnet.ai.mit.edu/~jaffer/SCM +http://swiss.csail.mit.edu/~jaffer/SCM " (current-error-port)) #f) diff --git a/differ.c b/differ.c new file mode 100644 index 0000000..43b2c3f --- /dev/null +++ b/differ.c @@ -0,0 +1,594 @@ +/* Copyright (C) 2003, 2004 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. + */ + +/* "differ.c" Linear-space O(NP) sequence comparison. */ +/* Author: Aubrey Jaffer */ + +#include +/* #include */ + +#include "scm.h" + +SCM_EXPORT SCM array_dims P((SCM ra)); + +typedef int (*int_function) (); + +typedef struct { + void* (*subarray) (); + int_function array_refsEql_P; + int_function array_refs_revEql_P; +} fp_procs; + +int fp_compare(int *fp,int fpoff,int *cc,void *a,int m,void *b,int n,int_function array_refsEql_P,int p_lim); + +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); + +void fp_init(int *fp,int fpoff,int fill,int mindx,int maxdx); + +int diff_divide_and_conquer(int *fp,int fpoff,int *ccrr,void *a,int start_a,int end_a,void *b,int start_b,int end_b,int *edits,int edx,int epo,fp_procs *procs,int p_lim); + +int diff2et(int *fp,int fpoff,int *ccrr,void *a,int start_a,int end_a,void *b,int start_b,int end_b,int *edits,int edx,int epo,fp_procs *procs,int p_lim); + +int diff2ez(int *fp,int fpoff,int *ccrr,void *a,int start_a,int end_a,void *b,int start_b,int end_b,int *edits,int edx,int epo,fp_procs *procs,int p_lim); + +void check_cost(unsigned char *name,int est,int cost); + +SCM_EXPORT SCM diff2edits P((SCM Edits, SCM Fp, SCM Args)); + +SCM_EXPORT SCM diff2editlen P((SCM Fp, SCM A, SCM Args)); + +# define MAX(a,b) (ab ? b : a) + +long *long_subarray(ra, start, end) + long *ra; int start, end; +{ + return &(ra[start]); +} +short *short_subarray(ra, start, end) + short *ra; int start, end; +{ + return &(ra[start]); +} +char *char_subarray(ra, start, end) + char *ra; int start, end; +{ + return &(ra[start]); +} + +long long_array_refsEql_P(a, x, m, b, y, n) + long *a; int x, m; long *b; int y, n; +{ + return (a[x])==(b[y]); +} +long long_array_refs_revEql_P(a, x, m, b, y, n) + long *a; int x, m; long *b; int y, n; +{ +/* if (x > m) printf("long x(%d) > m(%d)\n", x, m); */ +/* if (y > n) printf("long y(%d) > n(%d)\n", y, n); */ + return a[(m)-(x)-1]==b[(n)-(y)-1]; +} +short short_array_refsEql_P(a, x, m, b, y, n) + short *a; int x, m; short *b; int y, n; +{ + return (a[x])==(b[y]); +} +short short_array_refs_revEql_P(a, x, m, b, y, n) + short *a; int x, m; short *b; int y, n; +{ +/* if (x > m) printf("short x(%d) > m(%d)\n", x, m); */ +/* if (y > n) printf("short y(%d) > n(%d)\n", y, n); */ + return a[(m)-(x)-1]==b[(n)-(y)-1]; +} +char char_array_refsEql_P(a, x, m, b, y, n) + char *a; int x, m; char *b; int y, n; +{ + return (a[x])==(b[y]); +} +char char_array_refs_revEql_P(a, x, m, b, y, n) + char *a; int x, m; char *b; int y, n; +{ +/* if (x > m) printf("char x(%d) > m(%d)\n", x, m); */ +/* if (y > n) printf("char y(%d) > n(%d)\n", y, n); */ + return a[(m)-(x)-1]==b[(n)-(y)-1]; +} + +fp_procs long_procs = + {long_subarray, long_array_refsEql_P, long_array_refs_revEql_P}; +fp_procs short_procs = + {short_subarray, short_array_refsEql_P, short_array_refs_revEql_P}; +fp_procs char_procs = + {char_subarray, char_array_refsEql_P, char_array_refs_revEql_P}; + +int fp_compare(fp, fpoff, cc, a, m, b, n, array_refsEql_P, p_lim) + int *fp; + int fpoff; + int *cc; + void *a; + int m; + void *b; + int n; + int_function array_refsEql_P; + int p_lim; +{ + int delta = (n)-(m); + { + int p = 0; +L_loop: + { + int k = -(p); + while (!((k)>=(delta))) { + fp_run(fp, fpoff, k, a, m, b, n, array_refsEql_P, cc, p); + { + k = 1+(k); + } + } + } + { + int k = (delta)+(p); + while (!((k)<=(delta))) { + fp_run(fp, fpoff, k, a, m, b, n, array_refsEql_P, cc, p); + { + k = -1+(k); + } + } + } + { + int fpval = fp_run(fp, fpoff, delta, a, m, b, n, array_refsEql_P, cc, p); + if ((!(cc)) + && ((n)<=(fpval))) + return (delta)+(2*(p)); + else if ((!(0 > (p_lim))) + && ((p)>=(p_lim))) + return -1; + else { + p = 1+(p); + goto L_loop; + } + } + } +} + +/* Traces runs of matches until they end; then set fp[k]=y. */ +/* If CC is supplied, set each CC[y] = MIN(CC[y], cost) for run. */ +/* Returns furthest y reached. */ + +int fp_run(fp, fpoff, k, a, m, b, n, array_refsEql_P, cc, p) + int *fp; + int fpoff; + int k; + void *a; + int m; + void *b; + int n; + int_function array_refsEql_P; + int *cc; + int p; +{ + int cost = (k)+(p)+(p); + { + int y = MAX((fp[ -1+(k)+(fpoff)])+1, fp[1+(k)+(fpoff)]); +L_snloop: + { + int x = (y)-(k); + if ((cc) + && ((y)<=(n))) + { + int xcst = (m)-(x); + if (0 > (xcst)) + ; + else cc[y] = MIN((xcst)+(cost), cc[y]); + } + if (((x)<(m)) + && ((y)<(n)) + && (array_refsEql_P(a, x, m, b, y, n))) + { + y = 1+(y); + goto L_snloop; + } + else { + fp[(fpoff)+(k)] = y; + return y; + } + } + } +} + +int diff_mid_split(m, n, rr, cc, cost) + int m; + int n; + int *rr; + int *cc; + int cost; +{ + { + int cdx = 1+((n)/2); + int rdx = (n)/2; +L_loop: + if ((cost)==((cc[rdx])+(rr[(n)-(rdx)]))) + return rdx; + else if ((cost)==((cc[cdx])+(rr[(n)-(cdx)]))) + return cdx; + else { + cdx = 1+(cdx); + rdx = -1+(rdx); + goto L_loop; + } + } +} + + +void fp_init(fp, fpoff, fill, mindx, maxdx) + int *fp; + int fpoff; + int fill; + int mindx; + int maxdx; +{ + int mlim = (fpoff)+(mindx); + { + int idx = (fpoff)+(maxdx); + while (!((idx)<(mlim))) { + fp[idx] = fill; + { + idx = -1+(idx); + } + } + } +} + +/* Split A[start-a..end-a] (shorter array) into smaller and smaller chunks. */ +/* EDX is index into EDITS. */ +/* EPO is insert/delete polarity (+1 or -1) */ + +int diff_divide_and_conquer(fp, fpoff, ccrr, a, start_a, end_a, b, start_b, end_b, edits, edx, epo, procs, p_lim) + int *fp; + int fpoff; + int *ccrr; + void *a; + int start_a; + int end_a; + void *b; + int start_b; + int end_b; + int *edits; + int edx; + int epo; + fp_procs *procs; + int p_lim; +{ + int mid_a = ((start_a)+(end_a))/2; + int len_b = (end_b)-(start_b); + int len_a = (end_a)-(start_a); + { + int tcst = (p_lim)+(p_lim)+((len_b)-(len_a)); + int *cc = &(ccrr[0]); + int *rr = &(ccrr[(len_b)+1]); + int m2 = (end_a)-(mid_a); + int m1 = (mid_a)-(start_a); + fp_init(cc, 0, (len_a)+(len_b), 0, len_b); + fp_init(fp, fpoff, -1, -(1+(p_lim)), 1+(p_lim)+((len_b)-(m1))); + fp_compare(fp, fpoff, cc, procs->subarray(a, start_a, mid_a), m1, procs->subarray(b, start_b, end_b), len_b, procs->array_refsEql_P, MIN(p_lim, len_a)); + fp_init(rr, 0, (len_a)+(len_b), 0, len_b); + 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 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)); + check_cost("rr", est_r, diff2et(fp, fpoff, ccrr, a, mid_a, end_a, b, (start_b)+(b_splt), end_b, edits, (est_c)+(edx), epo, procs, ((est_r)-(((len_b)-(b_splt))-((end_a)-(mid_a))))/2)); + return (est_c)+(est_r); + } + } +} + +/* Trim; then diff sub-arrays; either one longer. Returns edit-length */ + +int diff2et(fp, fpoff, ccrr, a, start_a, end_a, b, start_b, end_b, edits, edx, epo, procs, p_lim) + int *fp; + int fpoff; + int *ccrr; + void *a; + int start_a; + int end_a; + void *b; + int start_b; + int end_b; + int *edits; + int edx; + int epo; + fp_procs *procs; + int p_lim; +{ + { + int bdx = -1+(end_b); + int adx = -1+(end_a); + while (((start_b)<=(bdx)) + && ((start_a)<=(adx)) + && (procs->array_refsEql_P(a, adx, 0, b, bdx, 0))) { + { + bdx = -1+(bdx); + adx = -1+(adx); + } + } + { + int bsx = start_b; + int asx = start_a; + while (((bsx)<(bdx)) + && ((asx)<(adx)) + && (procs->array_refsEql_P(a, asx, 0, b, bsx, 0))) { + { + bsx = 1+(bsx); + asx = 1+(asx); + } + } + { + int delta = ((bdx)-(bsx))-((adx)-(asx)); + if (0 > (delta)) + return diff2ez(fp, fpoff, ccrr, b, bsx, 1+(bdx), a, asx, 1+(adx), edits, edx, -(epo), procs, (delta)+(p_lim)); + else return diff2ez(fp, fpoff, ccrr, a, asx, 1+(adx), b, bsx, 1+(bdx), edits, edx, epo, procs, p_lim); + } + } + } +} + +/* Diff sub-arrays, A not longer than B. Returns edit-length */ + +int diff2ez(fp, fpoff, ccrr, a, start_a, end_a, b, start_b, end_b, edits, edx, epo, procs, p_lim) + int *fp; + int fpoff; + int *ccrr; + void *a; + int start_a; + int end_a; + void *b; + int start_b; + int end_b; + int *edits; + int edx; + int epo; + fp_procs *procs; + int p_lim; +{ + int len_a = (end_a)-(start_a); + int len_b = (end_b)-(start_b); + if (!(p_lim)) + if ((len_b)==(len_a)) + return 0; + else { + int T_edx = edx; + int adx = start_a; + int bdx = start_b; + int edx = T_edx; +L_loop: + if ((bdx)>=(end_b)) + return (len_b)-(len_a); + else if ((adx)>=(end_a)) + { + int T_edx = edx; + int idx = bdx; + int edx = T_edx; + while (!((idx)>=(end_b))) { + edits[edx] = (epo)*(1+(idx)); + { + idx = 1+(idx); + edx = 1+(edx); + } + } + return (len_b)-(len_a); + } + else if (procs->array_refsEql_P(a, adx, 0, b, bdx, 0)) + { + adx = 1+(adx); + bdx = 1+(bdx); + goto L_loop; + } + else { + edits[edx] = (epo)*(1+(bdx)); + { + bdx = 1+(bdx); + edx = 1+(edx); + goto L_loop; + } + } + } + else if ((len_a)<=(p_lim)) + { + int idx = start_a; + int jdx = start_b; + while (!(((idx)>=(end_a)) + && ((jdx)>=(end_b)))) { + if ((jdx)<(end_b)) + { + edits[edx] = (epo)*(1+(jdx)); + edx = 1+(edx); + } + if ((idx)<(end_a)) + { + edits[edx] = (epo)*( -1-(idx)); + edx = 1+(edx); + } + { + idx = 1+(idx); + jdx = 1+(jdx); + } + } + return (len_a)+(len_b); + } + else return diff_divide_and_conquer(fp, fpoff, ccrr, a, start_a, end_a, b, start_b, end_b, edits, edx, epo, procs, p_lim); +} + +void check_cost(name, est, cost) + unsigned char *name; + int est; + int cost; +{ + if ((est)!=(cost)) { +/* fprintf(stderr, "%s: cost check failed %d != %d\\n", name, est, cost); */ + wta(MAKINUM(cost), "cost check failed", name); + } +} + +/* Routines interfacing API layer to algorithms. */ + +/* Return the fp_procs appropriate for SCM array prototype */ +fp_procs *raprot2procs(prot, s_name) + SCM prot; + char *s_name; +{ + fp_procs *procs; + if (ICHRP(prot)) procs = &char_procs; + else if (MAKINUM(16L)==prot) procs = &short_procs; + else if (MAKINUM(-16L)==prot) procs = &short_procs; + else if (MAKINUM(32L)==prot) procs = &long_procs; + else if (MAKINUM(-32L)==prot) procs = &long_procs; + else if (EOL==prot) procs = &long_procs; + else wta(prot, (char *)ARG3, s_name); + return procs; +} + +static SCM list_of_0; + +void* array2addr(RA, prot, pos, s_name) + SCM RA, prot; + char *pos; + char s_name[]; +{ + ASRTER(BOOL_T==arrayp(RA, UNDEFINED) && array_prot(RA)==prot, RA, + pos, s_name); + return (void*)scm_addr(cons(RA, list_of_0), s_name); +} + +/* A not longer than B (M <= N) */ +static char s_d2es[] = "diff2edits!"; +static char s_incomp[] = "incompatible array types"; +SCM diff2edits(Edits, Fp, Args) + SCM Edits, Fp, Args; /* Ccrr, A, B; */ +{ + SCM aprot, bprot; + int *edits; + int est; + int *fp; + int *ccrr; + void *a, *b; + int m, n; + fp_procs *procs; + ASRTER(3==ilength(Args), Args, WNA, s_d2es); + edits = array2addr(Edits, MAKINUM(-32), ARG1, s_d2es); + fp = array2addr(Fp, MAKINUM(-32), ARG2, s_d2es); + ccrr = array2addr(CAR(Args), MAKINUM(-32), ARG3, s_d2es); + Args = CDR(Args); + aprot = array_prot(CAR(Args)); + a = array2addr(CAR(Args), aprot, ARG4, s_d2es); + ASRTER(NFALSEP(aprot), aprot, ARG4, s_d2es); + m = INUM(CAR(array_dims(CAR(Args)))); + Args = CDR(Args); + bprot = array_prot(CAR(Args)); + b = array2addr(CAR(Args), bprot, ARG5, s_d2es); + ASRTER(NFALSEP(bprot), bprot, ARG5, s_d2es); + n = INUM(CAR(array_dims(CAR(Args)))); + ASRTER(aprot==bprot, bprot, s_incomp, s_d2es); + procs = raprot2procs(aprot, s_d2es); + est = INUM(CAR(array_dims(Edits))); + { + int p_lim = ((est)-((n)-(m)))/2; + check_cost(s_d2es, est, + diff2et(fp, 1+(p_lim), + ccrr, a, 0, m, b, 0, n, edits, 0, 1, procs, p_lim)); + return UNSPECIFIED; + } +} + +/* A not longer than B (M <= N) */ + +static char s_d2el[] = "diff2editlen"; +SCM diff2editlen(Fp, A, Args) + SCM Fp, A, Args; /* B, P_lim */ +{ + SCM aprot, bprot; + fp_procs *procs; + int p_lim; + int m, n; + int *fp; + void *a, *b; + ASRTER(2==ilength(Args), Args, WNA, s_d2el); + fp = array2addr(Fp, MAKINUM(-32), ARG1, s_d2el); + aprot = array_prot(A); + a = array2addr(A, aprot, ARG2, s_d2el); + ASRTER(NFALSEP(aprot), aprot, ARG2, s_d2el); + m = INUM(CAR(array_dims(A))); + bprot = array_prot(CAR(Args)); + b = array2addr(CAR(Args), bprot, ARG3, s_d2el); + ASRTER(NFALSEP(bprot), bprot, ARG3, s_d2el); + n = INUM(CAR(array_dims(CAR(Args)))); + Args = CDR(Args); + ASRTER(INUMP(CAR(Args)), CAR(Args), ARG4, s_d2el); + p_lim = INUM(CAR(Args)); + ASRTER(aprot==bprot, bprot, s_incomp, s_d2el); + procs = raprot2procs(aprot, s_d2el); + { + int maxdx = 0 > (p_lim) + ?1+(n) + :1+(p_lim)+((n)-(m)); + int mindx = 0 > (p_lim) + ?-(1+(m)) + :-(1+(p_lim)); + int res; + fp_init(fp, -(mindx), -1, mindx, maxdx); + res = fp_compare(fp, -(mindx), 0, a, m, b, n, + procs->array_refsEql_P, p_lim); + return (-1==res) ? BOOL_F : MAKINUM(res); + } +} + +static char s_Idiffer[] = "Idiffer.scm"; +void init_differ() +{ + list_of_0 = cons(INUM0, EOL); + scm_gc_protect(list_of_0); + make_subr(s_d2es, tc7_lsubr_2, diff2edits); + make_subr(s_d2el, tc7_lsubr_2, diff2editlen); + if (scm_ldprog(s_Idiffer)) + wta(*loc_errobj, "couldn't init", s_Idiffer); +} diff --git a/eval.c b/eval.c index d5bba5f..3e39bee 100644 --- a/eval.c +++ b/eval.c @@ -144,7 +144,7 @@ SCM m_define_syntax P((SCM xorig, SCM env, SCM ctxt)); SCM m_let_syntax P((SCM xorig, SCM env, SCM ctxt)); SCM m_letrec_syntax P((SCM xorig, SCM env, SCM ctxt)); SCM m_the_macro P((SCM xorig, SCM env, SCM ctxt)); -void scm_dynthrow P((SCM cont, SCM val)); +void scm_dynthrow P((SCM cont, SCM arg1, SCM arg2, SCM rest)); void scm_egc P((void)); void scm_estk_grow P((void)); void scm_estk_shrink P((void)); @@ -757,6 +757,7 @@ static SCM toplevel_define(xorig, env) SCM name = CAR(x); ASRTER(scm_nullenv_p(env), xorig, s_placement, s_define); ENV_PUSH; + scm_env_tmp = EOL; /* Make sure multiple values -> error */ x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL); x = evalcar(x); ENV_POP; @@ -1056,10 +1057,12 @@ static int in_atcase_aux = 0; SCM m_case(xorig, env, ctxt) SCM xorig, env, ctxt; { - SCM clause, x = CDR(xorig), key_expr = CAR(x); + SCM clause, key_expr, x = CDR(xorig); SCM s, keys = EOL, action, actions = EOL, else_action = list_unspecified; int opt = !scm_nullenv_p(env); + ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case); + key_expr = CAR(x); while(NIMP(x = CDR(x))) { clause = CAR(x); s = scm_check_linum(clause, 0L); @@ -1773,6 +1776,12 @@ static SCM macroexp1(xorig, env, ctxt, mode) goto retx; } } +#ifndef RECKLESS + if (ilength(x) < 0) { + what = s_expr; + goto errout; + } +#endif x = cons2(IM_FUNCALL, proc, CDR(x)); goto retx; } @@ -1930,8 +1939,10 @@ int scm_arity_check(proc, argc, what) if (what) wta(proc, (char *)WNA, what); return 0; case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0; - case tc7_cxr: case tc7_contin: + if (IM_VALUES_TOKEN == CONT(proc)->other.stkframe[1]) return !0; + /* else fall through */ + case tc7_cxr: case tc7_subr_1: ASRTGO(1==argc, wrongnumargs) return !0; case tc7_subr_1o: ASRTGO(0==argc || 1==argc, wrongnumargs) return !0; case tc7_subr_2: ASRTGO(2==argc, wrongnumargs) return !0; @@ -2193,6 +2204,8 @@ static SCM ceval_1(x) goto cdrxbegin; } */ + scm_env_tmp = EOL; /* needed so multiple values cause an error + to be signaled when this is a top-level form. */ do { scm_env_tmp = EVALCAR(proc); proc = CDR(proc); @@ -2403,6 +2416,7 @@ static SCM ceval_1(x) return scm_values(UNDEFINED, UNDEFINED, EOL, s_values); } case tc7_contin: + scm_dynthrow(proc, UNDEFINED, UNDEFINED, EOL); case tc7_subr_1: case tc7_subr_2: case tc7_subr_2o: @@ -2493,7 +2507,7 @@ evap1: goto clo_checked; } case tc7_contin: - scm_dynthrow(proc, arg1); + scm_dynthrow(proc, arg1, UNDEFINED, EOL); case tc7_specfun: switch TYP16(proc) { case tc16_call_cc: @@ -2625,6 +2639,7 @@ evap1: case tc7_subr_1: case tc7_subr_3: case tc7_contin: + scm_dynthrow(proc, arg1, arg2, EOL); goto wrongnumargs; default: goto badfun; @@ -2721,13 +2736,14 @@ evap1: case tc16_values: return scm_values(arg1, arg2, cons(arg3, x), s_values); } + case tc7_contin: + scm_dynthrow(proc, arg1, arg2, cons(arg3, x)); case tc7_subr_2: case tc7_subr_1o: case tc7_subr_2o: case tc7_subr_0: case tc7_cxr: case tc7_subr_1: - case tc7_contin: goto wrongnumargs; default: goto badfun; @@ -2922,8 +2938,8 @@ SCM apply(proc, arg1, args) return arg1; } case tc7_contin: - ASRTGO(NULLP(args), wrongnumargs); - scm_dynthrow(proc, arg1); + if (NULLP(args)) scm_dynthrow(proc, arg1, UNDEFINED, EOL); + /* else fall through */ case tc7_specfun: args = UNBNDP(arg1) ? EOL : cons(arg1, args); arg1 = proc; @@ -3023,7 +3039,8 @@ SCM scm_cvapply(proc, n, argv) return res; } case tc7_contin: - scm_dynthrow(proc, argv[0]); + if (1 == n) scm_dynthrow(proc, argv[0], UNDEFINED, EOL); + goto call_apply; case tc7_specfun: if (tc16_apply==TYP16(proc)) { proc = argv[0]; @@ -3034,6 +3051,7 @@ SCM scm_cvapply(proc, n, argv) #endif goto tail; } + call_apply: res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv, EOL)); #ifdef CCLO proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure); @@ -3375,10 +3393,15 @@ SCM eval(obj) return EVAL(obj, EOL, EOL); } -SCM definedp(x, env) - SCM x, env; +static char s_definedp[] = "defined?"; +SCM definedp(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM proc = CAR(x = CDR(x)); + SCM x = CDR(xorig); + SCM proc; + + ASSYNT(1 == ilength(x), xorig, s_body, s_definedp); + proc = CAR(x); #ifdef MACRO proc = id2sym(proc); #endif @@ -3661,7 +3684,7 @@ void init_eval() loc_atcase_aux = &CDR(sysintern("@case-aux", UNDEFINED)); /* acros */ - make_synt("defined?", MAC_ACRO, definedp); + make_synt(s_definedp, MAC_ACRO, definedp); /* end of acros */ make_synt(s_and, MAC_MMACRO, m_and); diff --git a/features.txi b/features.txi index 96987b8..c7e94fb 100644 --- a/features.txi +++ b/features.txi @@ -57,6 +57,10 @@ Turns on the features @samp{cautious}, @samp{careful-interrupt-masking}, and @samp{stack-limit}; uses @code{-g} flags for debugging SCM source code. +@item differ +@cindex differ +Sequence comparison + @item dump @cindex dump Convert a running scheme program into an executable file. @@ -162,7 +166,8 @@ This does not affect complex numbers. @item socket @cindex socket -BSD @dfn{socket} interface. +BSD @dfn{socket} interface. Socket addr functions require +inexacts or bignums for 32-bit precision. @item stack-limit @cindex stack-limit @@ -186,6 +191,10 @@ sjm@@ee.tut.fi. Those unix features which have not made it into the Posix specs: nice, acct, lstat, readlink, symlink, mknod and sync. +@item wb +@cindex wb +WB database with relational wrapper. + @item windows @cindex windows Microsoft Windows executable. diff --git a/hobbit.info b/hobbit.info index a9d8b9f..d775565 100644 --- a/hobbit.info +++ b/hobbit.info @@ -1,4 +1,4 @@ -This is hobbit.info, produced by makeinfo version 4.0 from hobbit.texi. +This is hobbit.info, produced by makeinfo version 4.7 from hobbit.texi. INFO-DIR-SECTION The Algorithmic Language Scheme START-INFO-DIR-ENTRY @@ -40,8 +40,8 @@ approved by the author.  File: hobbit.info, Node: Introduction, Next: Compiling with Hobbit, Prev: Top, Up: Top -Introduction -************ +1 Introduction +************** Hobbit is a small optimizing scheme-to-C compiler written in Report 4 scheme and intended for use together with the SCM scheme interpreter of @@ -67,17 +67,17 @@ Hobbit (derived from hobbit5x) is now part of the SCM Scheme implementation. The most recent information about SCM can be found on SCM's "WWW" home page: - + `http://swiss.csail.mit.edu/~jaffer/SCM' Hobbit4d has also been ported to the Guile Scheme implementation: - + `http://www.gnu.org/software/guile/anon-cvs.html'  File: hobbit.info, Node: Compiling with Hobbit, Next: The Language Compiled, Prev: Introduction, Up: Top -Compiling with Hobbit -********************* +2 Compiling with Hobbit +*********************** * Menu: @@ -89,16 +89,16 @@ Compiling with Hobbit  File: hobbit.info, Node: Compiling And Linking, Next: Error Detection, Prev: Compiling with Hobbit, Up: Compiling with Hobbit -Compiling And Linking -===================== +2.1 Compiling And Linking +========================= `(require 'compile)' - - Function: hobbit name1.scm name2.scm ... + -- Function: hobbit name1.scm name2.scm ... Invokes the HOBBIT compiler to translate Scheme files `NAME1.scm', `NAME2.scm', ... to C files `NAME1.c' and `NAME1.h'. - - Function: compile-file name1.scm name2.scm ... + -- Function: compile-file name1.scm name2.scm ... Compiles the HOBBIT translation of NAME1.scm, NAME2.scm, ... to a dynamically linkable object file NAME1, where is the object file suffix for your computer (for @@ -110,26 +110,26 @@ Compiling And Linking cd ~/scm/ scm -rcompile -e'(compile-file "example.scm")' - + Starting to read example.scm - + Generic (slow) arithmetic assumed: 1.0e-3 found. - + ** Pass 1 completed ** ** Pass 2 completed ** ** Pass 3 completed ** ** Pass 4 completed ** ** Pass 5 completed ** ** Pass 6 completed ** - + C source file example.c is built. C header file example.h is built. - + These top level higher order procedures are not clonable (slow): (nonkeyword_make-promise map-streams generate-vector runge-kutta-4) These top level procedures create non-liftable closures (slow): (nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system) - + ; Scheme (linux) script created by SLIB/batch Sun Apr 7 22:49:49 2002 ; ================ Write file with C defines (delete-file "scmflags.h") @@ -138,7 +138,7 @@ Compiling And Linking (lambda (fp) (for-each (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"Init5d9.scm\"" + '("#define IMPLINIT \"Init5e1.scm\"" "#define BIGNUMS" "#define FLOATS" "#define ARRAYS" @@ -149,10 +149,10 @@ Compiling And Linking (delete-file "example.o") ; ================ Link C object files (delete-file "slibcat") - + Compilation finished at Sun Apr 7 22:49:50 - - Function: compile->executable exename name1.scm name2.scm ... + -- Function: compile->executable exename name1.scm name2.scm ... Compiles and links the HOBBIT translation of NAME1.scm, NAME2.scm, ... to a SCM executable named EXENAME. NAME1.scm must be in the current directory; NAME2.scm, ... may be in other directories. @@ -162,26 +162,26 @@ Compiling And Linking cd ~/scm/ scm -rcompile -e'(compile->executable "exscm" "example.scm")' - + Starting to read example.scm - + Generic (slow) arithmetic assumed: 1.0e-3 found. - + ** Pass 1 completed ** ** Pass 2 completed ** ** Pass 3 completed ** ** Pass 4 completed ** ** Pass 5 completed ** ** Pass 6 completed ** - + C source file example.c is built. C header file example.h is built. - + These top level higher order procedures are not clonable (slow): (nonkeyword_make-promise map-streams generate-vector runge-kutta-4) These top level procedures create non-liftable closures (slow): (nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system) - + ; Scheme (linux) script created by SLIB/batch Sun Apr 7 22:46:31 2002 ; ================ Write file with C defines (delete-file "scmflags.h") @@ -190,7 +190,7 @@ Compiling And Linking (lambda (fp) (for-each (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"Init5d9.scm\"" + '("#define IMPLINIT \"Init5e1.scm\"" "#define COMPILED_INITS init_example();" "#define CCLO" "#define FLOATS")))) @@ -198,7 +198,7 @@ Compiling And Linking (system "gcc -O2 -c continue.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 example.c scm.c") ; ================ Link C object files (system "gcc -rdynamic -o exscm continue.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o example.o scm.o -L/usr/local/lib/scm/ -lm -lc") - + Compilation finished at Sun Apr 7 22:46:44 _Note Bene:_ `#define CCLO' must be present in `scmfig.h'. @@ -212,8 +212,8 @@ before calling these functions.  File: hobbit.info, Node: Error Detection, Next: Hobbit Options, Prev: Compiling And Linking, Up: Compiling with Hobbit -Error Detection -=============== +2.2 Error Detection +=================== Error detection during compilation is minimal. In case your scheme code is syntactically incorrect, hobbit may crash with no sensible error @@ -252,8 +252,8 @@ and hobbit will immediately halt compilation.  File: hobbit.info, Node: Hobbit Options, Next: CC Optimizations, Prev: Error Detection, Up: Compiling with Hobbit -Hobbit Options -============== +2.3 Hobbit Options +================== 1. Selecting the type of arithmetics. @@ -440,8 +440,8 @@ Hobbit Options  File: hobbit.info, Node: CC Optimizations, Prev: Hobbit Options, Up: Compiling with Hobbit -CC Optimizations -================ +2.4 CC Optimizations +==================== When using the C compiler to compile the C code output by hobbit, always use strong optimizations (eg. `cc -xO3' for cc on Sun, `gcc -O2' or @@ -461,8 +461,8 @@ checking into the code it produces.  File: hobbit.info, Node: The Language Compiled, Next: Performance of Compiled Code, Prev: Compiling with Hobbit, Up: Top -The Language Compiled -********************* +3 The Language Compiled +*********************** Calls to `load' or `require' occurring at the top level of a file being compiled are ignored. Calls to `load' or `require' within a procedure @@ -483,8 +483,8 @@ hobbit as Scheme primitives.  File: hobbit.info, Node: Macros, Next: SCM Primitive Procedures, Prev: The Language Compiled, Up: The Language Compiled -Macros -====== +3.1 Macros +========== The Common-lisp style defmacro implemented in SCM is recognized and procedures defined by defmacro are expanded during compilation. @@ -500,8 +500,8 @@ file.  File: hobbit.info, Node: SCM Primitive Procedures, Next: SLIB Logical Procedures, Prev: Macros, Up: The Language Compiled -SCM Primitive Procedures -======================== +3.2 SCM Primitive Procedures +============================ Real-only versions of transcedental procedures (warning: these procedures are not compiled directly into the corresponding C library @@ -522,8 +522,8 @@ delete-file, rename-file.  File: hobbit.info, Node: SLIB Logical Procedures, Next: Fast Integer Calculations, Prev: SCM Primitive Procedures, Up: The Language Compiled -SLIB Logical Procedures -======================= +3.3 SLIB Logical Procedures +=========================== The following bitwise procedures in the scheme library file `logical.scm' are compiled directly to fast C operations on immediate @@ -534,8 +534,8 @@ C ops below): & | ^ ~ << >> The following alternative names logical:logand, logical:logior, -logical:logxor, logical:lognot, ash, logical:ash are compiled for the -generic case, not immediate-integers-only and are thus much slower. +logical:logxor, logical:lognot, and ash are compiled for the generic +case, not immediate-integers-only and are thus much slower. Notice that the procedures logsleft, logsright are NOT in the the library file `logical.scm:' the universal procedure ash is instead. @@ -549,8 +549,8 @@ logsleft and logsright are defined for non-compiled use in the file  File: hobbit.info, Node: Fast Integer Calculations, Next: Force and Delay, Prev: SLIB Logical Procedures, Up: The Language Compiled -Fast Integer Calculations -========================= +3.4 Fast Integer Calculations +============================= The following primitives are for immediate (30-bit) integer-only arithmetics. The are compiled directly into the corresponding C @@ -573,8 +573,8 @@ in the SCM distribution.  File: hobbit.info, Node: Force and Delay, Next: Suggestions for writing fast code, Prev: Fast Integer Calculations, Up: The Language Compiled -Force and Delay -=============== +3.5 Force and Delay +=================== The nonessential procedure `force' and syntax `delay' are implemented exactly as suggested in the report 4. This implementation deviates @@ -586,8 +586,8 @@ for the promises created by the interpreter.  File: hobbit.info, Node: Suggestions for writing fast code, Prev: Force and Delay, Up: The Language Compiled -Suggestions for writing fast code -================================= +3.6 Suggestions for writing fast code +===================================== The following suggestions may help you to write well-optimizable and fast code for the hobbit-scm combination. Roughly speaking, the main @@ -844,8 +844,8 @@ Here come the details.  File: hobbit.info, Node: Performance of Compiled Code, Next: Principles of Compilation, Prev: The Language Compiled, Up: Top -Performance of Compiled Code -**************************** +4 Performance of Compiled Code +****************************** * Menu: @@ -856,8 +856,8 @@ Performance of Compiled Code  File: hobbit.info, Node: Gain in Speed, Next: Benchmarks, Prev: Performance of Compiled Code, Up: Performance of Compiled Code -Gain in Speed -============= +4.1 Gain in Speed +================= The author has so far compiled and tested a number of large programs (theorem provers for various logics and hobbit itself). @@ -895,8 +895,8 @@ benchmark CPSTAK in the following table.  File: hobbit.info, Node: Benchmarks, Next: Benchmark Sources, Prev: Gain in Speed, Up: Performance of Compiled Code -Benchmarks -========== +4.2 Benchmarks +============== We will present a table with the performance of three scheme systems on a number of benchmarks: interpreted SCM, byte-compiled VSCM and @@ -956,8 +956,8 @@ before each test.  File: hobbit.info, Node: Benchmark Sources, Prev: Benchmarks, Up: Performance of Compiled Code -Benchmark Sources -================= +4.3 Benchmark Sources +===================== A selection of (smaller) benchmark sources ------------------------------------------ @@ -977,8 +977,8 @@ A selection of (smaller) benchmark sources  File: hobbit.info, Node: Destruct, Next: Recfib, Prev: Benchmark Sources, Up: Benchmark Sources -Destruct --------- +4.3.1 Destruct +-------------- ;;;; Destructive operation benchmark (define (destructive n m) @@ -1014,8 +1014,8 @@ Destruct  File: hobbit.info, Node: Recfib, Next: div-iter and div-rec, Prev: Destruct, Up: Benchmark Sources -Recfib ------- +4.3.2 Recfib +------------ (define (recfib x) (if (< x 2) @@ -1026,8 +1026,8 @@ Recfib  File: hobbit.info, Node: div-iter and div-rec, Next: Hanoi, Prev: Recfib, Up: Benchmark Sources -div-iter and div-rec --------------------- +4.3.3 div-iter and div-rec +-------------------------- ;;;; Recursive and iterative benchmark divides by 2 using lists of ()'s. (define (create-n n) @@ -1060,8 +1060,8 @@ div-iter and div-rec  File: hobbit.info, Node: Hanoi, Next: Tak, Prev: div-iter and div-rec, Up: Benchmark Sources -Hanoi ------ +4.3.4 Hanoi +----------- ;;; C optimiser should be able to remove the first recursive call to ;;; move-them. But Solaris 2.4 cc, gcc 2.5.8, and hobbit don't. @@ -1077,8 +1077,8 @@ Hanoi  File: hobbit.info, Node: Tak, Next: Ctak, Prev: Hanoi, Up: Benchmark Sources -Tak ---- +4.3.5 Tak +--------- ;;;; A vanilla version of the TAKeuchi function (define (tak x y z) @@ -1092,15 +1092,15 @@ Tak  File: hobbit.info, Node: Ctak, Next: Takl, Prev: Tak, Up: Benchmark Sources -Ctak ----- +4.3.6 Ctak +---------- ;;;; A version of the TAK function that uses continuations (define (ctak x y z) (call-with-current-continuation (lambda (k) (ctak-aux k x y z)))) - + (define (ctak-aux k x y z) (cond ((not (< y x)) (k z)) (else (call-with-current-continuation @@ -1112,9 +1112,9 @@ Ctak (lambda (k) (ctak-aux k (- y 1) z x))) (call-with-current-continuation (lambda (k) (ctak-aux k (- z 1) x y)))))))) - + (define (id x) x) - + (define (mb-test r x y z) (if (zero? r) (ctak x y z) @@ -1124,26 +1124,26 @@ Ctak  File: hobbit.info, Node: Takl, Next: Cpstak, Prev: Ctak, Up: Benchmark Sources -Takl ----- +4.3.7 Takl +---------- ;;;; The TAKeuchi function using lists as counters. (define (listn n) (if (not (= 0 n)) (cons n (listn (- n 1))) '())) - + (define l18 (listn 18)) (define l12 (listn 12)) (define l6 (listn 6)) - + (define (mas x y z) (if (not (shorterp y x)) z (mas (mas (cdr x) y z) (mas (cdr y) z x) (mas (cdr z) x y)))) - + (define (shorterp x y) (and (pair? y) (or (null? x) (shorterp (cdr x) (cdr y))))) ;; call: (mas l18 l12 l6) @@ -1151,8 +1151,8 @@ Takl  File: hobbit.info, Node: Cpstak, Next: Pi, Prev: Takl, Up: Benchmark Sources -Cpstak ------- +4.3.8 Cpstak +------------ ;;;; A continuation-passing version of the TAK benchmark. (define (cpstak x y z) @@ -1178,8 +1178,8 @@ Cpstak  File: hobbit.info, Node: Pi, Prev: Cpstak, Up: Benchmark Sources -Pi --- +4.3.9 Pi +-------- (define (pi n . args) (let* ((d (car args)) @@ -1210,8 +1210,8 @@ Pi  File: hobbit.info, Node: Principles of Compilation, Next: About Hobbit, Prev: Performance of Compiled Code, Up: Top -Principles of Compilation -************************* +5 Principles of Compilation +*************************** * Menu: @@ -1225,8 +1225,8 @@ Principles of Compilation  File: hobbit.info, Node: Macro-Expansion and Analysis, Next: Building Closures, Prev: Principles of Compilation, Up: Principles of Compilation -Expansion and Analysis -====================== +5.1 Expansion and Analysis +========================== 1. Macros defined by defmacro and all the quasiquotes are expanded and compiled into equivalent form without macros and quasiquotes. @@ -1320,8 +1320,8 @@ Expansion and Analysis  File: hobbit.info, Node: Building Closures, Next: Lambda-lifting, Prev: Macro-Expansion and Analysis, Up: Principles of Compilation -Building Closures -================= +5.2 Building Closures +===================== Here Hobbit produces code for creating real closures for all the lambda-terms which are not marked as being liftable by the previous @@ -1388,8 +1388,8 @@ called using an internal apply.  File: hobbit.info, Node: Lambda-lifting, Next: Statement-lifting, Prev: Building Closures, Up: Principles of Compilation -Lambda-lifting -============== +5.3 Lambda-lifting +================== When this pass starts, all the real (nonliftable) closures have been translated to closure-creating code. The remaining lambda-terms are @@ -1415,7 +1415,7 @@ is converted to (define foo (lambda (x y) (foo-fn1 x y) )) - + (define foo-fn1 (lambda (x u) (+ u x) )) @@ -1435,10 +1435,10 @@ of these variables: (define (foo x y z i) (foo-fn2 x z i) ) - + (define foo-fn1 (lambda (x z u) (if x (+ (foo-fn2 x z u) 1))) ) - + (define foo-fn2 (lambda (x z v) (if (zero? v) 1 (foo-fn1 x z z))) ) @@ -1462,7 +1462,7 @@ is converted to incorrect scheme: (lambda (x y z) (foo-fn1 x (**c-adr** z) y) z)) - + (define foo-fn1 (lambda (x (**c-adr** z) u) (set! (**c-fetch** z) (+ u x (**c-fetch** z))) )) @@ -1475,7 +1475,7 @@ The last two will finally be compiled into correct C as: foo_fn1(x, &z, y); return z; } - + SCM foo_fn1(x, z, u) SCM x, u; SCM *z; @@ -1486,8 +1486,8 @@ The last two will finally be compiled into correct C as:  File: hobbit.info, Node: Statement-lifting, Next: Higher-order Arglists, Prev: Lambda-lifting, Up: Principles of Compilation -Statement-lifting -================= +5.4 Statement-lifting +===================== As the scheme do-construction is compiled into C for, but for cannot occur in all places in C (it is a statement), then if the do in a @@ -1517,8 +1517,8 @@ the beginning of the procedure body.  File: hobbit.info, Node: Higher-order Arglists, Next: Typing and Constants, Prev: Statement-lifting, Up: Principles of Compilation -Higher-order Arglists -===================== +5.5 Higher-order Arglists +========================= All procedures taking a list argument are converted into ordinary non-list taking procedures and they are called with the list-making @@ -1583,8 +1583,8 @@ FUN is the name of the original procedure.  File: hobbit.info, Node: Typing and Constants, Prev: Higher-order Arglists, Up: Principles of Compilation -Typing and Constants -==================== +5.6 Typing and Constants +======================== All C<->Scheme conversions for immediate objects like numbers, booleans and characters are introduced. Internal apply is used for undefined @@ -1623,8 +1623,8 @@ instead of the default:  File: hobbit.info, Node: About Hobbit, Next: Index, Prev: Principles of Compilation, Up: Top -About Hobbit -************ +6 About Hobbit +************** * Menu: @@ -1637,8 +1637,8 @@ About Hobbit  File: hobbit.info, Node: The Aims of Developing Hobbit, Next: Manifest, Prev: About Hobbit, Up: About Hobbit -The Aims of Developing Hobbit -============================= +6.1 The Aims of Developing Hobbit +================================= 1. Producing maximally fast C code from simple scheme code. @@ -1657,8 +1657,8 @@ The Aims of Developing Hobbit  File: hobbit.info, Node: Manifest, Next: Author and Contributors, Prev: The Aims of Developing Hobbit, Up: About Hobbit -Manifest -======== +6.2 Manifest +============ `hobbit.scm' the hobbit compiler. `scmhob.scm' the file defining some additional procedures recognized @@ -1670,8 +1670,8 @@ Manifest  File: hobbit.info, Node: Author and Contributors, Next: Future Improvements, Prev: Manifest, Up: About Hobbit -Author and Contributors -======================= +6.3 Author and Contributors +=========================== Tanel Tammet Department of Computing Science @@ -1696,8 +1696,8 @@ NMICHAEL@us.oracle.com, Lee Iverson (leei@ai.sri.com), Burt Leavenworth  File: hobbit.info, Node: Future Improvements, Next: Release History, Prev: Author and Contributors, Up: About Hobbit -Future Improvements -=================== +6.4 Future Improvements +======================= 1. Optimisations: @@ -1727,8 +1727,8 @@ Future Improvements  File: hobbit.info, Node: Release History, Prev: Future Improvements, Up: About Hobbit -Release History -=============== +6.5 Release History +=================== [In February 2002, hobbit5x was integrated into the SCM distribution. Changes since then are recorded in `scm/ChangeLog'.] @@ -1916,55 +1916,59 @@ File: hobbit.info, Node: Index, Prev: About Hobbit, Up: Top Index ***** +[index] * Menu: * compile->executable: Compiling And Linking. + (line 67) * compile-file: Compiling And Linking. + (line 13) * hobbit: Compiling And Linking. + (line 9)  Tag Table: Node: Top199 Node: Introduction1227 -Node: Compiling with Hobbit2540 -Node: Compiling And Linking2793 -Node: Error Detection7538 -Node: Hobbit Options8836 -Node: CC Optimizations15557 -Node: The Language Compiled16505 -Node: Macros17160 -Node: SCM Primitive Procedures17756 -Node: SLIB Logical Procedures18607 -Node: Fast Integer Calculations19763 +Node: Compiling with Hobbit2543 +Node: Compiling And Linking2801 +Node: Error Detection7487 +Node: Hobbit Options8793 +Node: CC Optimizations15522 +Node: The Language Compiled16478 +Node: Macros17137 +Node: SCM Primitive Procedures17741 +Node: SLIB Logical Procedures18600 +Node: Fast Integer Calculations19755 Node: Force and Delay20889 -Node: Suggestions for writing fast code21466 -Node: Performance of Compiled Code31657 -Node: Gain in Speed31913 -Node: Benchmarks33490 -Node: Benchmark Sources36582 -Node: Destruct36920 -Node: Recfib38495 -Node: div-iter and div-rec38738 -Node: Hanoi39812 -Node: Tak40381 -Node: Ctak40724 -Node: Takl41707 -Node: Cpstak42366 -Node: Pi43133 -Node: Principles of Compilation44250 -Node: Macro-Expansion and Analysis44672 -Node: Building Closures48469 -Node: Lambda-lifting51352 -Node: Statement-lifting54100 -Node: Higher-order Arglists55200 -Node: Typing and Constants56998 -Node: About Hobbit58254 -Node: The Aims of Developing Hobbit58510 -Node: Manifest59393 -Node: Author and Contributors59844 -Node: Future Improvements60891 -Node: Release History61648 -Node: Index68429 +Node: Suggestions for writing fast code21474 +Node: Performance of Compiled Code31673 +Node: Gain in Speed31933 +Node: Benchmarks33518 +Node: Benchmark Sources36618 +Node: Destruct36964 +Node: Recfib38551 +Node: div-iter and div-rec38806 +Node: Hanoi39892 +Node: Tak40473 +Node: Ctak40828 +Node: Takl41808 +Node: Cpstak42464 +Node: Pi43243 +Node: Principles of Compilation44372 +Node: Macro-Expansion and Analysis44798 +Node: Building Closures48603 +Node: Lambda-lifting51494 +Node: Statement-lifting54225 +Node: Higher-order Arglists55333 +Node: Typing and Constants57139 +Node: About Hobbit58403 +Node: The Aims of Developing Hobbit58663 +Node: Manifest59554 +Node: Author and Contributors60013 +Node: Future Improvements61068 +Node: Release History61833 +Node: Index68622  End Tag Table diff --git a/hobbit.scm b/hobbit.scm index 8f1d896..65dfff1 100644 --- a/hobbit.scm +++ b/hobbit.scm @@ -2,7 +2,7 @@ ; ; HOBBIT: an optimizing scheme -> C compiler for SCM ; -; scm5d9 +; scm5e1 ; 2002-04-11 ; ; Copyright (C) 1992-1997: Tanel Tammet diff --git a/hobbit.texi b/hobbit.texi index f87c1b0..1afa9c4 100644 --- a/hobbit.texi +++ b/hobbit.texi @@ -123,7 +123,7 @@ Hobbit (derived from hobbit5x) is now part of the SCM Scheme implementation. The most recent information about SCM can be found on SCM's @dfn{WWW} home page: -@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM} +@center @url{http://swiss.csail.mit.edu/~jaffer/SCM} Hobbit4d has also been ported to the Guile Scheme implementation: @@ -665,9 +665,10 @@ upper row, C ops below): @end group @end example -The following alternative names @t{logical:logand}, @t{logical:logior}, -@t{logical:logxor}, @t{logical:lognot}, @t{ash}, @t{logical:ash} are compiled for the -generic case, not immediate-integers-only and are thus much slower. +The following alternative names @t{logical:logand}, +@t{logical:logior}, @t{logical:logxor}, @t{logical:lognot}, and +@t{ash} are compiled for the generic case, not immediate-integers-only +and are thus much slower. Notice that the procedures @t{logsleft}, @t{logsright} are @b{NOT} in the the library file @file{logical.scm:} the universal procedure diff --git a/inc2scm b/inc2scm index 951104b..9e00ed7 100755 --- a/inc2scm +++ b/inc2scm @@ -1,4 +1,4 @@ -#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 +#! /usr/local/bin/scm \ %0 %* - !# ;; Copyright (C) 1991-1999 Free Software Foundation, Inc. ;; @@ -60,7 +60,7 @@ Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ... /USR/INCLUDE/ defaults to /usr/include/. -http://swissnet.ai.mit.edu/~jaffer/SCM +http://swiss.csail.mit.edu/~jaffer/SCM " (current-error-port)) #f) diff --git a/mkimpcat.scm b/mkimpcat.scm index 8f5929a..c745cfc 100644 --- a/mkimpcat.scm +++ b/mkimpcat.scm @@ -92,6 +92,20 @@ (in-implementation-vicinity "byte" link:able-suffix)))) (cond ((or + (add-link 'db + (in-implementation-vicinity "db.so")) + (add-link 'db + (in-implementation-vicinity "db" link:able-suffix) + (in-implementation-vicinity "handle" link:able-suffix) + (in-implementation-vicinity "blink" link:able-suffix) + (in-implementation-vicinity "prev" link:able-suffix) + (in-implementation-vicinity "ent" link:able-suffix) + (in-implementation-vicinity "sys" link:able-suffix) + (in-implementation-vicinity "del" link:able-suffix) + (in-implementation-vicinity "stats" link:able-suffix) + (in-implementation-vicinity "blkio" link:able-suffix) + (in-implementation-vicinity "scan" link:able-suffix) + (usr:lib "c")) (add-link 'db (in-wb-vicinity "db.so")) (add-link 'db @@ -106,8 +120,12 @@ (in-wb-vicinity "blkio" link:able-suffix) (in-wb-vicinity "scan" link:able-suffix) (usr:lib "c"))) + (add-source 'wb-table + (in-implementation-vicinity "wbtab")) (add-source 'wb-table (in-wb-vicinity "wbtab")) + (add-source 'rwb-isam + (in-implementation-vicinity "rwb-isam")) (add-source 'rwb-isam (in-wb-vicinity "rwb-isam")) (add-alias 'wb 'db))) @@ -159,6 +177,8 @@ (add-link 'socket (in-implementation-vicinity "socket" link:able-suffix) (usr:lib "c")) + (add-link 'diff + (in-implementation-vicinity "differ" link:able-suffix)) (add-link 'record (in-implementation-vicinity "record" link:able-suffix)) (add-link 'generalized-c-arguments diff --git a/patchlvl.h b/patchlvl.h index cd637d3..779b7d8 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=5d9 +VERSION=5e1 #endif #ifndef SCMVERSION -# define SCMVERSION "5d9" +# define SCMVERSION "5e1" #endif #ifdef nosve # define INIT_FILE_NAME "Init"SCMVERSION"_scm"; diff --git a/r4rstest.scm b/r4rstest.scm index f6f3ae0..7768f03 100644 --- a/r4rstest.scm +++ b/r4rstest.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003, 2004 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 @@ -13,10 +13,14 @@ ;; To receive a copy of the GNU General Public License, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA; or view -;; http://swissnet.ai.mit.edu/~jaffer/GPL.html +;; http://swiss.csail.mit.edu/~jaffer/GPL.html -;;;; "r4rstest.scm" Test correctness of scheme implementations. -;;; Author: Aubrey Jaffer +;;;;"r4rstest.scm": Test R4RS correctness of scheme implementations. +;;; Author: Aubrey Jaffer +;;; Home-page: http://swiss.csail.mit.edu/~jaffer/Scheme +;;; Current version: http://swiss.csail.mit.edu/ftpdir/scm/r4rstest.scm +;;; CVS Head: +;;; http://savannah.gnu.org/cgi-bin/viewcvs/scm/scm/r4rstest.scm?rev=HEAD&only_with_tag=HEAD&content-type=text/vnd.viewcvs-markup ;;; This includes examples from ;;; William Clinger and Jonathan Rees, editors. @@ -478,6 +482,23 @@ (test #t exact? 3) (test #f inexact? 3) +;;(test 1 expt 0 0) +(test 0 expt 0 1) +(test 0 expt 0 256) +;;(test 0 expt 0 -255) +(test 1 expt -1 256) +(test -1 expt -1 255) +(test 1 expt -1 -256) +(test -1 expt -1 -255) +(test 1 expt 256 0) +(test 1 expt -256 0) +(test 256 expt 256 1) +(test -256 expt -256 1) +(test 8 expt 2 3) +(test -8 expt -2 3) +(test 9 expt 3 2) +(test 9 expt -3 2) + (test #t = 22 22 22) (test #t = 22 22) (test #f = 34 34 35) @@ -608,8 +629,18 @@ (test f1.0 round f0.8) (test f4.0 round f3.5) (test f4.0 round f4.5) - (test 1 expt 0 0) - (test 0 expt 0 1) + + ;;(test f1.0 expt f0.0 f0.0) + ;;(test f1.0 expt f0.0 0) + ;;(test f1.0 expt 0 f0.0) + (test f0.0 expt f0.0 f1.0) + (test f0.0 expt f0.0 1) + (test f0.0 expt 0 f1.0) + (test f1.0 expt -25 f0.0) + (test f1.0 expt f-3.25 f0.0) + (test f1.0 expt f-3.25 0) + ;;(test f0.0 expt f0.0 f-3.25) + (test (atan 1) atan 1 1) (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) @@ -757,7 +788,7 @@ (report-errs)) (define (test-numeric-predicates) - (let* ((big-ex (expt 2 90)) + (let* ((big-ex (expt 2 150)) (big-inex (exact->inexact big-ex))) (newline) (display ";testing bignum-inexact comparisons;") @@ -1215,7 +1246,8 @@ (let ((have-inexacts? (and (string->number "0.0") (inexact? (string->number "0.0")))) (have-bignums? - (let ((n (string->number "281474976710655325431"))) + (let ((n (string->number + "1427247692705959881058285969449495136382746625"))) (and n (exact? n))))) (cond (have-inexacts? (test-inexact) diff --git a/ramap.c b/ramap.c index 42181ee..1ebafce 100644 --- a/ramap.c +++ b/ramap.c @@ -287,8 +287,8 @@ SCM array_fill(ra, fill) return UNSPECIFIED; } -static char s_sarray_copy[] = "serial-array-copy!"; -# define s_array_copy (s_sarray_copy + 7) +static char s_sarray_copy[] = "serial-array:copy!"; +static char s_array_copy[] = "array:copy!"; static int racp(src, dst) SCM dst, src; { @@ -439,9 +439,9 @@ static int racp(src, dst) } return 1; } -SCM array_copy(src, dst) - SCM src; +SCM array_copy(dst, src) SCM dst; + SCM src; { #ifndef RECKLESS if (INUM0==array_rank(dst)) @@ -480,7 +480,7 @@ SCM ra2contig(ra, copy) } CAR(ret) |= ARRAY_CONTIGUOUS; ARRAY_V(ret) = make_uve(inc+0L, array_prot(ra)); - if (copy) array_copy(ra, ret); + if (copy) array_copy(ret, ra); return ret; } @@ -492,7 +492,7 @@ SCM ura_read(ra, port) if (NIMP(ra) && ARRAYP(ra)) { cra = ra2contig(ra, 0); ret = uve_read(cra, port); - if (cra != ra) array_copy(cra, ra); + if (cra != ra) array_copy(ra, cra); return ret; } else return uve_read(ra, port); @@ -1377,7 +1377,7 @@ static int rafe(ra0, proc, ras) SCM heap_ve, auto_rav[5], auto_argv[5]; SCM *rav = &auto_rav[0], *argv = &auto_argv[0]; long argc = ilength(ras) + 1; - long i, k, inc, n, base; + long i, k, n; scm_protect_temp(&heap_ve); if (argc >= 5) { heap_ve = make_vector(MAKINUM(2*argc), BOOL_F); @@ -1642,11 +1642,15 @@ static iproc subr2os[] = { {s_ura_wr, ura_write}, {0, 0}}; +/* MinGW complains during a dll build that the string members are not + constants, since they are defined in another dll. These functions + individually initialized below. static iproc subr2s[] = { {s_array_fill, array_fill}, {s_array_copy, array_copy}, {s_sarray_copy, array_copy}, {0, 0}}; +*/ static iproc lsubr2s[] = { {s_sc2array, sc2array}, @@ -1670,18 +1674,21 @@ void init_ramap() init_raprocs(ra_rpsubrs); init_raprocs(ra_asubrs); init_iprocs(subr2os, tc7_subr_2o); - init_iprocs(subr2s, tc7_subr_2); + /* init_iprocs(subr2s, tc7_subr_2); */ init_iprocs(lsubr2s, tc7_lsubr_2); + make_subr(s_array_fill, tc7_subr_2, array_fill); + make_subr(s_array_copy, tc7_subr_2, array_copy); + make_subr(s_sarray_copy, tc7_subr_2, array_copy); make_subr(s_array_equalp, tc7_rpsubr, array_equal); smobs[0x0ff & (tc16_array>>8)].equalp = raequal; add_feature(s_array_for_each); scm_ldstr("\n\ (define (array-indexes ra)\n\ - (let ((ra0 (apply create-array '#() (array-shape ra))))\n\ + (let ((ra0 (apply make-array '#() (array-shape ra))))\n\ (array-index-map! ra0 list)\n\ ra0))\n\ (define (array-map prototype proc ra1 . ras)\n\ - (define nra (apply create-array prototype (array-shape ra1)))\n\ + (define nra (apply make-array prototype (array-shape ra1)))\n\ (apply array-map! nra proc ra1 ras)\n\ nra)\n\ "); diff --git a/repl.c b/repl.c index 07b357c..a3204dc 100644 --- a/repl.c +++ b/repl.c @@ -316,7 +316,22 @@ taloop: break; } case tcs_symbols: - lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port); + if (writing) { /* slashified symbol */ + for(i = 0;i= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf); switch (c = lgetc(port)) { @@ -1103,6 +1121,9 @@ static sizet read_token(ic, tok_buf, port) case EOF: p[j] = 0; return j; + case '\\': /* slashified symbol */ + p[j++] = lgetc(port); + break; default: p[j++] = downcase[c]; } @@ -1260,20 +1281,25 @@ int handle_it(i) char *name = errmsgs[i-WNA].s_response; if (errjmp_bad || errjmp_recursive) wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */ + /* NEWCELL does not defer interrupts; so be careful to maintain the + freelist integrity. */ if (name) { - SCM n[2]; int j; + SCM n[2]; /* GC-protect discarded cells (possibly being used + by interrupted code). */ DEFER_INTS; - for (j=0; j<2; j++) { - NEWCELL(n[j]); /* discard 2 possibly-used cells */ - } - CDR(n[1]) = EOL; + /* Two cells are discarded because NEWCELL may have been + interrupted between computing the right-hand-side of + freelist = CDR(freelist) + and assigning it to freelist. */ + for (j=0; j<2; j++) NEWCELL(n[j]); /* discard 2 possibly-used cells */ + CDR(n[1]) = EOL; /* lose pointer to freelist */ 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 when applying proc. Do an ecache gc - to protect contents of stack. */ - + 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; DEFER_INTS; #ifndef NO_ENV_CACHE @@ -1299,6 +1325,10 @@ int handle_it(i) return i; } } + /* Ensure that freelist is not empty when returning from interrupt */ + DEFER_INTS; + scm_fill_freelist(); + ALLOW_INTS; return errmsgs[i-WNA].parent_err; } @@ -1314,13 +1344,12 @@ SCM scm_top_level(initpath, toplvl_fun) #else long i; #endif + if (!toplvl_fun) toplvl_fun = repl; CONT(rootcont)->stkbse = (STACKITEM *)&i; i = setjump(CONT(rootcont)->jmpbuf); #ifndef SHORT_INT if (i) i = UNCOOK(i); #endif - if (!toplvl_fun) toplvl_fun = repl; - /* printf("scm_top_level got %d\n", i); */ drloop: switch ((int)i) { default: @@ -1914,16 +1943,17 @@ static void err_head(str) int oerrno = errno; exitval = MAKINUM(EXIT_FAILURE); if (NIMP(cur_outp) && OPOUTPORTP(cur_outp)) lfflush(cur_outp); - for (lps = loadports; NIMP(lps); lps = CDR(lps)) { - lputs(lps==loadports ? "\n;While loading " : "\n ;loaded from ", - cur_errp); - iprin1(scm_port_filename(CAR(lps)), cur_errp, 1); - lputs(", line ", cur_errp); - iprin1(scm_port_line(CAR(lps)), cur_errp, 1); - lputs(": ", cur_errp); + lps = IMP(loadports) ? loadports : CDR(loadports); + if (NIMP(lps)) { + lputs("\n;In file loaded from ", cur_errp); + for (; NIMP(lps); lps = CDR(lps)) { + iprin1(scm_port_filename(CAR(lps)), cur_errp, 0); + lputs(":", cur_errp); + iprin1(scm_port_line(CAR(lps)), cur_errp, 1); + lputs(IMP(CDR(lps)) ? ":" : ",\n; loaded from ", cur_errp); + } } - if (NIMP(loadports) && NIMP(CDR(loadports))) - lputs("\n;", cur_errp); + lputs("\n;", cur_errp); lfflush(cur_errp); errno = oerrno; /* if (NIMP(cur_errp) && stderr==STREAM(cur_errp)) { ... } */ diff --git a/scl.c b/scl.c index 13f6023..2858989 100644 --- a/scl.c +++ b/scl.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 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 @@ -140,13 +140,13 @@ static double lpow10(x, n) return x/p10[-n]; } -int NaN2str(f, a) +int inf2str(f, a) double f; char *a; { sizet ch = 0; if (f < 0.0) a[ch++] = '-'; - a[ch++] = IS_INF(f)?'1':'0'; + a[ch++] = (f != f) ? '0' : '1'; a[ch++] = '/'; a[ch++] = '0'; return ch; } @@ -164,10 +164,10 @@ static sizet idbl2str(f, a) sizet ch = 0; if (f==0.0) {exp = 0; goto zero;} /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/ - if IS_INF(f) return NaN2str(f, a); + if (f==2*f) return inf2str(f, a); if (f < 0.0) {f = -f;a[ch++]='-';} else if (f > 0.0) ; - else return NaN2str(f, a); + else return inf2str(f, a); exp = apx_log10(f); f = lpow10(f, -exp); fprec = lpow10(fprec, -exp); @@ -177,12 +177,12 @@ static sizet idbl2str(f, a) while (f < 1.0) { f *= 10.0; fprec *= 10.0; - if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) return NaN2str(f, a); + if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) return inf2str(f, a); } while (f > 10.0) { f /= 10.0; fprec /= 10.0; - if (exp++ > DBL_MAX_10_EXP) return NaN2str(f, a); + if (exp++ > DBL_MAX_10_EXP) return inf2str(f, a); } # else while (f < 1.0) {f *= 10.0; fprec *= 10.0; exp--;} @@ -264,6 +264,7 @@ static sizet iflo2str(flt, str) else # endif i = idbl2str(REAL(flt), str); + if (scm_narn==flt) return i; if CPLXP(flt) { if (!(0 > IMAG(flt))) str[i++] = '+'; i += idbl2str(IMAG(flt), &str[i]); @@ -685,9 +686,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; @@ -804,6 +805,12 @@ SCM makdbl (x, y) { SCM z; 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; +# endif +# endif DEFER_INTS; if (y==0.0) { # ifdef SINGLES @@ -962,13 +969,12 @@ SCM bigequal(x, y) } #endif #ifdef FLOATS -# define REALLY_UNEQUAL(x,y) ((x) != (y) && !((x)!=(x) && (y)!=(y))) SCM floequal(x, y) SCM x, y; { - if (REALLY_UNEQUAL(REALPART(x), REALPART(y))) return BOOL_F; + if ((REALPART(x) != REALPART(y))) return BOOL_F; if (CPLXP(x)) - return (CPLXP(y) && !REALLY_UNEQUAL(IMAG(x), IMAG(y))) ? BOOL_T : BOOL_F; + return (CPLXP(y) && (IMAG(x)==IMAG(y))) ? BOOL_T : BOOL_F; return CPLXP(y) ? BOOL_F : BOOL_T; } #endif @@ -1008,20 +1014,27 @@ SCM equal(x, y) } } -SCM numberp(x) - SCM x; +SCM numberp(obj) + SCM obj; { - if INUMP(x) return BOOL_T; + if INUMP(obj) return BOOL_T; #ifdef FLOATS - if (NIMP(x) && NUMP(x)) return BOOL_T; + if (NIMP(obj) && NUMP(obj)) return BOOL_T; #else # ifdef BIGDIG - if (NIMP(x) && NUMP(x)) return BOOL_T; + if (NIMP(obj) && NUMP(obj)) return BOOL_T; # endif #endif return BOOL_F; } #ifdef FLOATS +SCM scm_complex_p(obj) + SCM obj; +{ + if (obj==scm_narn) return BOOL_F; + return numberp(obj); +} + # ifdef BIGDIG int scm_bigdblcomp(b, d) SCM b; @@ -1056,6 +1069,21 @@ SCM realp(x) # 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) { + 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; +# endif + return BOOL_F; +} SCM intp(x) SCM x; { @@ -1068,8 +1096,9 @@ SCM intp(x) if (!INEXP(x)) return BOOL_F; if CPLXP(x) return BOOL_F; r = REALPART(x); - if (r==floor(r)) return BOOL_T; - return BOOL_F; + if (r != floor(r)) return BOOL_F; + if (r==2*r && r != 0.0) return BOOL_F; + return BOOL_T; } #endif /* FLOATS */ @@ -2079,6 +2108,9 @@ SCM scm_intexpt(z1, z2) acc = long2num(iacc); break; } + if (0==iz1) + if (0==recip) return z1; + else goto overflow; if (1==z2) { tmp = iacc*iz1; if (tmp/iacc != iz1) { @@ -2356,7 +2388,7 @@ SCM in2ex(z) SCM ans = MAKINUM((long)u); if (INUM(ans)==(long)u) return ans; } - ASRTGO(!(IS_INF(u) || (u)!=(u)), badz); /* problem? */ + ASRTGO(!((u==2*u) || (u)!=(u)), badz); /* problem? */ return dbl2big(u); } # else @@ -2647,11 +2679,11 @@ SCM hashq(obj, n) static iproc subr1s[] = { {"number?", numberp}, - {"complex?", numberp}, {s_inexactp, inexactp}, #ifdef FLOATS + {"complex?", scm_complex_p}, {"real?", realp}, - {"rational?", realp}, + {"rational?", scm_rationalp}, {"integer?", intp}, {s_real_part, real_part}, {s_imag_part, imag_part}, @@ -2663,6 +2695,7 @@ static iproc subr1s[] = { {s_dfloat_parts, scm_dfloat_parts}, # endif #else + {"complex?", numberp}, {"real?", numberp}, {"rational?", numberp}, {"integer?", exactp}, @@ -2791,6 +2824,13 @@ void init_scl() REAL(flo0) = 0.0; ALLOW_INTS; # endif +# ifndef _MSC_VER + DEFER_INTS; + scm_narn = must_malloc_cell(2L*sizeof(double), (SCM)tc_dblc, "complex"); + REAL(scm_narn) = 0.0/0.0; + IMAG(scm_narn) = 0.0/0.0; + ALLOW_INTS; +# endif # ifdef DBL_DIG dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG; # else diff --git a/scm.h b/scm.h index 504f849..4fb3afe 100644 --- a/scm.h +++ b/scm.h @@ -80,22 +80,15 @@ typedef struct {const char *name;} subr_info; #include "scmfig.h" #ifdef _WIN32 -# ifdef DLLSCM +# ifdef SCM_WIN_DLL # define SCM_DLL_EXPORT __declspec(dllexport) -# define SCM_DLL_IMPORT __declspec(dllimport) -# ifdef SCM_DLL -# define SCM_EXPORT SCM_DLL_EXPORT -# else -# define SCM_EXPORT SCM_DLL_IMPORT -# endif +# define SCM_EXPORT SCM_DLL_EXPORT # else # define SCM_DLL_EXPORT /**/ -# define SCM_DLL_IMPORT extern # define SCM_EXPORT extern -# endif +# endif #else # define SCM_DLL_EXPORT /**/ -# define SCM_DLL_IMPORT extern # define SCM_EXPORT extern #endif @@ -115,31 +108,31 @@ typedef struct { #endif #ifndef STDC_HEADERS - int isatty P((int)); + int isatty P((int)); #endif typedef struct { - SCM (*mark)P((SCM)); - sizet (*free)P((CELLPTR)); - int (*print)P((SCM exp, SCM port, int writing)); - SCM (*equalp)P((SCM, SCM)); + SCM (*mark)P((SCM)); + sizet (*free)P((CELLPTR)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); } smobfuns; typedef struct { - char *name; - SCM (*mark)P((SCM ptr)); - int (*free)P((FILE *p)); - int (*print)P((SCM exp, SCM port, int writing)); - SCM (*equalp)P((SCM, SCM)); - int (*fputc)P((int c, FILE *p)); -/* int (*fputs)P((char *s, FILE *p)); */ -/* sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p)); */ - int (*fputs)P((const char *s, FILE *p)); + char *name; + SCM (*mark)P((SCM ptr)); + int (*free)P((FILE *p)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); + int (*fputc)P((int c, FILE *p)); +/* int (*fputs)P((char *s, FILE *p)); */ +/* sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p)); */ + int (*fputs)P((const char *s, FILE *p)); sizet (*fwrite)P((const void *s, sizet siz, sizet num, FILE *p)); - int (*fflush)P((FILE *stream)); - int (*fgetc)P((FILE *p)); - int (*fclose)P((FILE *p)); - int (*ungetc)P((int c, SCM p)); + int (*fflush)P((FILE *stream)); + int (*fgetc)P((FILE *p)); + int (*fclose)P((FILE *p)); + int (*ungetc)P((int c, SCM p)); } ptobfuns; typedef struct { @@ -184,7 +177,7 @@ typedef struct {SCM type;double *real;} dbl; #define ICHR(x) ((unsigned char)((x)>>8)) #define MAKICHR(x) (((x)<<8)+0xf4L) -#define ILOC00 (0x000000fcL) +#define ILOC00 (0x000000fcL) #define ILOCP(n) ((0xff & (int)(n))==(int)ILOC00) #define MAKILOC(if, id) (ILOC00 + (((long)id)<<8) + (((long)if)<<16)) #define IDIST(n) (((int)(n)>>8) & 0x7f) @@ -484,45 +477,45 @@ SCM_EXPORT long tc16_array; #define SCM_SET_PTOBNUM(x, typ) (CAR(x)=(typ)|(CAR(x) & ~0x0ffffL)) #define DIGITS '0':case '1':case '2':case '3':case '4':\ - case '5':case '6':case '7':case '8':case '9' + case '5':case '6':case '7':case '8':case '9' /* Aggregated types for dispatch in switch statements. */ #define tcs_cons_inum 2: case 6:case 10:case 14:\ - case 18:case 22:case 26:case 30:\ - case 34:case 38:case 42:case 46:\ - case 50:case 54:case 58:case 62:\ - case 66:case 70:case 74:case 78:\ - case 82:case 86:case 90:case 94:\ - case 98:case 102:case 106:case 110:\ - case 114:case 118:case 122:case 126 + case 18:case 22:case 26:case 30:\ + case 34:case 38:case 42:case 46:\ + case 50:case 54:case 58:case 62:\ + case 66:case 70:case 74:case 78:\ + case 82:case 86:case 90:case 94:\ + case 98:case 102:case 106:case 110:\ + case 114:case 118:case 122:case 126 #define tcs_cons_iloc 124 #define tcs_cons_ispcsym 4:case 12:case 20:case 28:\ - case 36:case 44:case 52:case 60:\ - case 68:case 76:case 84:case 92:\ - case 100:case 108 -#define tcs_cons_chflag 116 /* char *or* flag */ + case 36:case 44:case 52:case 60:\ + case 68:case 76:case 84:case 92:\ + case 100:case 108 +#define tcs_cons_chflag 116 /* char *or* flag */ #define tcs_cons_imcar tcs_cons_inum:\ - case tcs_cons_iloc:\ - case tcs_cons_ispcsym:\ - case tcs_cons_chflag + case tcs_cons_iloc:\ + case tcs_cons_ispcsym:\ + case tcs_cons_chflag #define tcs_cons_nimcar 0:case 8:case 16:case 24:\ - case 32:case 40:case 48:case 56:\ - case 64:case 72:case 80:case 88:\ - case 96:case 104:case 112:case 120 + case 32:case 40:case 48:case 56:\ + case 64:case 72:case 80:case 88:\ + case 96:case 104:case 112:case 120 #define tcs_cons_gloc 1:case 9:case 17:case 25:\ - case 33:case 41:case 49:case 57:\ - case 65:case 73:case 81:case 89:\ - case 97:case 105:case 113:case 121 + case 33:case 41:case 49:case 57:\ + case 65:case 73:case 81:case 89:\ + case 97:case 105:case 113:case 121 #define tcs_closures 3:case 11:case 19:case 27:\ - case 35:case 43:case 51:case 59:\ - case 67:case 75:case 83:case 91:\ - case 99:case 107:case 115:case 123 + case 35:case 43:case 51:case 59:\ + case 67:case 75:case 83:case 91:\ + case 99:case 107:case 115:case 123 #define tcs_subrs tc7_asubr:case tc7_subr_0:case tc7_subr_1:case tc7_cxr:\ - case tc7_subr_3:case tc7_subr_2:case tc7_rpsubr:case tc7_subr_1o:\ - case tc7_subr_2o:case tc7_lsubr_2:case tc7_lsubr + case tc7_subr_3:case tc7_subr_2:case tc7_rpsubr:case tc7_subr_1o:\ + case tc7_subr_2o:case tc7_lsubr_2:case tc7_lsubr #define tcs_symbols tc7_ssymbol:case tc7_msymbol #define tcs_bignums tc16_bigpos:case tc16_bigneg #define tcs_uves tc7_string:case tc7_bvect:\ @@ -531,74 +524,74 @@ SCM_EXPORT long tc16_array; #define tc3_cons_nimcar 0 #define tc3_cons_imcar 2:case 4:case 6 -#define tc3_cons_gloc 1 -#define tc3_closure 3 -#define tc3_tc7_types 5:case 7 - -#define tc7_ssymbol 5 -#define tc7_msymbol 7 -#define tc7_string 13 -#define tc7_vector 15 -#define tc7_bvect 21 +#define tc3_cons_gloc 1 +#define tc3_closure 3 +#define tc3_tc7_types 5:case 7 + +#define tc7_ssymbol 5 +#define tc7_msymbol 7 +#define tc7_string 13 +#define tc7_vector 15 +#define tc7_bvect 21 /* spare 23 */ -#define tc7_ivect 29 -#define tc7_uvect 31 -#define tc7_svect 37 +#define tc7_ivect 29 +#define tc7_uvect 31 +#define tc7_svect 37 /* spare 39 */ -#define tc7_fvect 45 -#define tc7_dvect 47 -#define tc7_cvect 53 -#define tc7_port 55 -#define tc7_contin 61 -#define tc7_specfun 63 +#define tc7_fvect 45 +#define tc7_dvect 47 +#define tc7_cvect 53 +#define tc7_port 55 +#define tc7_contin 61 +#define tc7_specfun 63 /* spare 69 71 77 79 */ -#define tc7_subr_0 85 -#define tc7_subr_1 87 -#define tc7_cxr 93 -#define tc7_subr_3 95 -#define tc7_subr_2 101 -#define tc7_asubr 103 -#define tc7_subr_1o 109 -#define tc7_subr_2o 111 -#define tc7_lsubr_2 117 -#define tc7_lsubr 119 -#define tc7_rpsubr 125 - -#define tc7_smob 127 -#define tc_free_cell 127 +#define tc7_subr_0 85 +#define tc7_subr_1 87 +#define tc7_cxr 93 +#define tc7_subr_3 95 +#define tc7_subr_2 101 +#define tc7_asubr 103 +#define tc7_subr_1o 109 +#define tc7_subr_2o 111 +#define tc7_lsubr_2 117 +#define tc7_lsubr 119 +#define tc7_rpsubr 125 + +#define tc7_smob 127 +#define tc_free_cell 127 #define tc_broken_heart (tc_free_cell+0x10000) -#define tc16_apply (tc7_specfun | (0L<<8)) -#define tc16_call_cc (tc7_specfun | (1L<<8)) -#define tc16_cclo (tc7_specfun | (2L<<8)) -#define tc16_eval (tc7_specfun | (3L<<8)) -#define tc16_values (tc7_specfun | (4L<<8)) -#define tc16_call_wv (tc7_specfun | (5L<<8)) +#define tc16_apply (tc7_specfun | (0L<<8)) +#define tc16_call_cc (tc7_specfun | (1L<<8)) +#define tc16_cclo (tc7_specfun | (2L<<8)) +#define tc16_eval (tc7_specfun | (3L<<8)) +#define tc16_values (tc7_specfun | (4L<<8)) +#define tc16_call_wv (tc7_specfun | (5L<<8)) -#define tc16_flo 0x017f -#define tc_flo 0x017fL +#define tc16_flo 0x017f +#define tc_flo 0x017fL -#define REAL_PART (1L<<16) -#define IMAG_PART (2L<<16) -#define tc_dblr (tc16_flo|REAL_PART) -#define tc_dblc (tc16_flo|REAL_PART|IMAG_PART) +#define REAL_PART (1L<<16) +#define IMAG_PART (2L<<16) +#define tc_dblr (tc16_flo|REAL_PART) +#define tc_dblc (tc16_flo|REAL_PART|IMAG_PART) -#define tc16_bigpos 0x027f -#define tc16_bigneg 0x037f +#define tc16_bigpos 0x027f +#define tc16_bigneg 0x037f /* The first four flags fit in the car of a port cell, remaining flags only in the port table */ -#define OPN (1L<<16) -#define RDNG (2L<<16) -#define WRTNG (4L<<16) -#define CRDY (8L<<16) +#define OPN (1L<<16) +#define RDNG (2L<<16) +#define WRTNG (4L<<16) +#define CRDY (8L<<16) -#define TRACKED (16L<<16) -#define BINARY (32L<<16) -#define BUF0 (64L<<16) -#define EXCLUSIVE (128L<<16) - /* LSB is used for gc mark */ +#define TRACKED (16L<<16) +#define BINARY (32L<<16) +#define BUF0 (64L<<16) +#define EXCLUSIVE (128L<<16) + /* LSB is used for gc mark */ SCM_EXPORT scm_gra subrs_gra; #define subrs ((subr_info *)(subrs_gra.elts)) @@ -622,29 +615,30 @@ SCM_EXPORT long tc16_dir; SCM_EXPORT long tc16_clport; SCM_EXPORT SCM sys_protects[]; -#define cur_inp sys_protects[0] -#define cur_outp sys_protects[1] -#define cur_errp sys_protects[2] +#define cur_inp sys_protects[0] +#define cur_outp sys_protects[1] +#define cur_errp sys_protects[2] #define def_inp sys_protects[3] -#define def_outp sys_protects[4] -#define def_errp sys_protects[5] -#define sys_errp sys_protects[6] -#define sys_safep sys_protects[7] -#define listofnull sys_protects[8] -#define undefineds sys_protects[9] -#define nullvect sys_protects[10] -#define nullstr sys_protects[11] -#define progargs sys_protects[12] -#define loadports sys_protects[13] -#define rootcont sys_protects[14] -#define dynwinds sys_protects[15] +#define def_outp sys_protects[4] +#define def_errp sys_protects[5] +#define sys_errp sys_protects[6] +#define sys_safep sys_protects[7] +#define listofnull sys_protects[8] +#define undefineds sys_protects[9] +#define nullvect sys_protects[10] +#define nullstr sys_protects[11] +#define progargs sys_protects[12] +#define loadports sys_protects[13] +#define rootcont sys_protects[14] +#define dynwinds sys_protects[15] #define list_unspecified sys_protects[16] -#define f_evapply sys_protects[17] -#define eval_env sys_protects[18] +#define f_evapply sys_protects[17] +#define eval_env sys_protects[18] #define f_apply_closure sys_protects[19] -#define flo0 sys_protects[20] -#define scm_uprotects sys_protects[21] -#define NUM_PROTECTS 22 +#define flo0 sys_protects[20] +#define scm_uprotects sys_protects[21] +#define scm_narn sys_protects[22] +#define NUM_PROTECTS 23 /* now for connects between source files */ @@ -684,7 +678,7 @@ SCM_EXPORT const char dirsep[]; /* strings used in several source files */ -SCM_EXPORT char s_read[], s_write[], s_newline[], s_system[]; +SCM_EXPORT char s_write[], s_newline[], s_system[]; SCM_EXPORT char s_make_string[], s_make_vector[], s_list[], s_op_pipe[]; #define s_string (s_make_string+5) #define s_vector (s_make_vector+5) @@ -706,315 +700,315 @@ SCM_EXPORT void (*init_user_scm) P((void)); /* function prototypes */ 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 void must_free P((char *obj, sizet len)); -SCM_EXPORT void scm_protect_temp P((SCM *ptr)); -SCM_EXPORT long ilength P((SCM sx)); -SCM_EXPORT SCM hash P((SCM obj, SCM n)); -SCM_EXPORT SCM hashv P((SCM obj, SCM n)); -SCM_EXPORT SCM hashq P((SCM obj, SCM n)); -SCM_EXPORT SCM obhash P((SCM obj)); -SCM_EXPORT SCM obunhash P((SCM obj)); +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 void must_free P((char *obj, sizet len)); +SCM_EXPORT void scm_protect_temp P((SCM *ptr)); +SCM_EXPORT long ilength P((SCM sx)); +SCM_EXPORT SCM hash P((SCM obj, SCM n)); +SCM_EXPORT SCM hashv P((SCM obj, SCM n)); +SCM_EXPORT SCM hashq P((SCM obj, SCM n)); +SCM_EXPORT SCM obhash P((SCM obj)); +SCM_EXPORT SCM obunhash P((SCM obj)); SCM_EXPORT unsigned long strhash P((unsigned char *str, sizet len, unsigned long n)); 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)); -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)); -SCM_EXPORT long newsmob P((smobfuns *smob)); -SCM_EXPORT long newptob P((ptobfuns *ptob)); -SCM_EXPORT SCM scm_port_entry P((FILE *stream, long ptype, long flags)); -SCM_EXPORT SCM scm_open_ports P((void)); -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_end P((void)); -SCM_EXPORT void gc_mark P((SCM p)); -SCM_EXPORT void scm_gc_hook P((void)); +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)); +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)); +SCM_EXPORT long newsmob P((smobfuns *smob)); +SCM_EXPORT long newptob P((ptobfuns *ptob)); +SCM_EXPORT SCM scm_port_entry P((FILE *stream, long ptype, long flags)); +SCM_EXPORT SCM scm_open_ports P((void)); +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_end P((void)); +SCM_EXPORT void gc_mark P((SCM p)); +SCM_EXPORT void scm_gc_hook P((void)); SCM_EXPORT SCM scm_gc_protect P((SCM obj)); -SCM_EXPORT SCM scm_add_finalizer P((SCM value, SCM finalizer)); -SCM_EXPORT void scm_run_finalizers P((int exiting)); +SCM_EXPORT SCM scm_add_finalizer P((SCM value, SCM finalizer)); +SCM_EXPORT void scm_run_finalizers P((int exiting)); SCM_EXPORT void scm_egc_start P((void)); SCM_EXPORT void scm_egc_end P((void)); -SCM_EXPORT void heap_report P((void)); -SCM_EXPORT void gra_report P((void)); -SCM_EXPORT void exit_report P((void)); -SCM_EXPORT void stack_report P((void)); -SCM_EXPORT SCM scm_stack_trace P((SCM contin)); -SCM_EXPORT SCM scm_scope_trace P((SCM env)); -SCM_EXPORT SCM scm_frame_trace P((SCM contin, SCM nf)); -SCM_EXPORT SCM scm_frame2env P((SCM contin, SCM nf)); -SCM_EXPORT SCM scm_frame_eval P((SCM contin, SCM nf, SCM expr)); -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_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)); -SCM_EXPORT SCM *estk_frame P((SCM estk, int i, int nf)); -SCM_EXPORT SCM *cont_frame P((SCM contin, int nf)); -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 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)); -SCM_EXPORT char *grow_tok_buf P((SCM tok_buf)); -SCM_EXPORT long mode_bits P((char *modes, char *cmodes)); -SCM_EXPORT long time_in_msec P((long x)); -SCM_EXPORT SCM my_time P((void)); -SCM_EXPORT SCM your_time P((void)); -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, - 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 void init_scm P((int iverbose, int buf0stdin, long init_heap_size)); +SCM_EXPORT void heap_report P((void)); +SCM_EXPORT void gra_report P((void)); +SCM_EXPORT void exit_report P((void)); +SCM_EXPORT void stack_report P((void)); +SCM_EXPORT SCM scm_stack_trace P((SCM contin)); +SCM_EXPORT SCM scm_scope_trace P((SCM env)); +SCM_EXPORT SCM scm_frame_trace P((SCM contin, SCM nf)); +SCM_EXPORT SCM scm_frame2env P((SCM contin, SCM nf)); +SCM_EXPORT SCM scm_frame_eval P((SCM contin, SCM nf, SCM expr)); +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_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)); +SCM_EXPORT SCM *estk_frame P((SCM estk, int i, int nf)); +SCM_EXPORT SCM *cont_frame P((SCM contin, int nf)); +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 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)); +SCM_EXPORT char *grow_tok_buf P((SCM tok_buf)); +SCM_EXPORT long mode_bits P((char *modes, char *cmodes)); +SCM_EXPORT long time_in_msec P((long x)); +SCM_EXPORT SCM my_time P((void)); +SCM_EXPORT SCM your_time P((void)); +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, + 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 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)); -SCM_EXPORT void ignore_signals P((void)); -SCM_EXPORT void unignore_signals P((void)); +SCM_EXPORT SCM scm_init_extensions P((void)); +SCM_EXPORT void ignore_signals P((void)); +SCM_EXPORT void unignore_signals P((void)); -SCM_EXPORT void add_feature P((char *str)); -SCM_EXPORT int raprin1 P((SCM exp, SCM port, int writing)); -SCM_EXPORT SCM markcdr P((SCM ptr)); +SCM_EXPORT void add_feature P((char *str)); +SCM_EXPORT int raprin1 P((SCM exp, SCM port, int writing)); +SCM_EXPORT SCM markcdr P((SCM ptr)); #define mark0 (0) /*SCM mark0 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 SCM intern P((char *name, sizet len)); -SCM_EXPORT SCM sysintern P((const char *name, SCM val)); -SCM_EXPORT SCM sym2vcell P((SCM sym)); -SCM_EXPORT SCM makstr P((long len)); -SCM_EXPORT SCM scm_maksubr P((const char *name, int type, SCM (*fcn)())); -SCM_EXPORT SCM make_subr P((const char *name, int type, SCM (*fcn)())); -SCM_EXPORT SCM make_synt P((const char *name, long flags, SCM (*fcn)())); -SCM_EXPORT SCM make_gsubr P((const char *name, int req, int opt, int rst, - SCM (*fcn)())); -SCM_EXPORT SCM closure P((SCM code, int nargs)); -SCM_EXPORT SCM makprom P((SCM code)); -SCM_EXPORT SCM force P((SCM x)); -SCM_EXPORT SCM makarb P((SCM name)); -SCM_EXPORT SCM tryarb P((SCM arb)); -SCM_EXPORT SCM relarb P((SCM arb)); -SCM_EXPORT SCM ceval P((SCM x, SCM static_env, SCM env)); -SCM_EXPORT SCM scm_wrapcode P((SCM code, SCM env)); -SCM_EXPORT SCM scm_current_env P((void)); -SCM_EXPORT SCM prolixity P((SCM arg)); -SCM_EXPORT SCM gc_for_newcell P((void)); -SCM_EXPORT void gc_for_open_files P((void)); -SCM_EXPORT SCM gc P((SCM arg)); -SCM_EXPORT SCM tryload P((SCM filename, SCM reader)); -SCM_EXPORT SCM acons P((SCM w, SCM x, SCM y)); -SCM_EXPORT SCM cons2 P((SCM w, SCM x, SCM y)); -SCM_EXPORT SCM resizuve P((SCM vect, SCM len)); -SCM_EXPORT SCM lnot P((SCM x)); -SCM_EXPORT SCM booleanp P((SCM obj)); -SCM_EXPORT SCM eq P((SCM x, SCM y)); -SCM_EXPORT SCM equal P((SCM x, SCM y)); -SCM_EXPORT SCM consp P((SCM x)); -SCM_EXPORT SCM cons P((SCM x, SCM y)); -SCM_EXPORT SCM nullp P((SCM x)); -SCM_EXPORT SCM setcar P((SCM pair, SCM value)); -SCM_EXPORT SCM setcdr P((SCM pair, SCM value)); -SCM_EXPORT SCM listp P((SCM x)); -SCM_EXPORT SCM list P((SCM objs)); -SCM_EXPORT SCM length P((SCM x)); -SCM_EXPORT SCM append P((SCM args)); -SCM_EXPORT SCM reverse P((SCM lst)); -SCM_EXPORT SCM list_ref P((SCM lst, SCM k)); -SCM_EXPORT SCM memq P((SCM x, SCM lst)); -SCM_EXPORT SCM member P((SCM x, SCM lst)); -SCM_EXPORT SCM memv P((SCM x, SCM lst)); -SCM_EXPORT SCM assq P((SCM x, SCM alist)); -SCM_EXPORT SCM assoc P((SCM x, SCM alist)); -SCM_EXPORT SCM symbolp P((SCM x)); -SCM_EXPORT SCM symbol2string P((SCM s)); -SCM_EXPORT SCM string2symbol P((SCM s)); -SCM_EXPORT SCM numberp P((SCM x)); -SCM_EXPORT SCM exactp P((SCM x)); -SCM_EXPORT SCM inexactp P((SCM x)); -SCM_EXPORT SCM eqp P((SCM x, SCM y)); -SCM_EXPORT SCM lessp P((SCM x, SCM y)); -SCM_EXPORT SCM greaterp P((SCM x, SCM y)); -SCM_EXPORT SCM leqp P((SCM x, SCM y)); -SCM_EXPORT SCM greqp P((SCM x, SCM y)); -SCM_EXPORT SCM zerop P((SCM z)); -SCM_EXPORT SCM positivep P((SCM x)); -SCM_EXPORT SCM negativep P((SCM x)); -SCM_EXPORT SCM oddp P((SCM n)); -SCM_EXPORT SCM evenp P((SCM n)); -SCM_EXPORT SCM lmax P((SCM x, SCM y)); -SCM_EXPORT SCM lmin P((SCM x, SCM y)); -SCM_EXPORT SCM sum P((SCM x, SCM y)); -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 lremainder P((SCM x, SCM y)); -SCM_EXPORT SCM modulo P((SCM x, SCM y)); -SCM_EXPORT SCM lgcd P((SCM x, SCM y)); -SCM_EXPORT SCM llcm P((SCM n1, SCM n2)); -SCM_EXPORT SCM number2string P((SCM x, SCM radix)); -SCM_EXPORT SCM istring2number P((char *str, long len, long radix)); -SCM_EXPORT SCM string2number P((SCM str, SCM radix)); -SCM_EXPORT SCM istr2flo P((char *str, long len, long radix)); -SCM_EXPORT SCM mkbig P((sizet nlen, int sign)); -SCM_EXPORT SCM mkstrport P((SCM pos, SCM str, long modes, char *caller)); -SCM_EXPORT SCM mksafeport P((int maxlen, SCM port)); -SCM_EXPORT int reset_safeport P((SCM sfp, int maxlen, SCM port)); -SCM_EXPORT SCM long2big P((long n)); -SCM_EXPORT SCM ulong2big P((unsigned long n)); -SCM_EXPORT SCM big2inum P((SCM b, sizet l)); +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 SCM intern P((char *name, sizet len)); +SCM_EXPORT SCM sysintern P((const char *name, SCM val)); +SCM_EXPORT SCM sym2vcell P((SCM sym)); +SCM_EXPORT SCM makstr P((long len)); +SCM_EXPORT SCM scm_maksubr P((const char *name, int type, SCM (*fcn)())); +SCM_EXPORT SCM make_subr P((const char *name, int type, SCM (*fcn)())); +SCM_EXPORT SCM make_synt P((const char *name, long flags, SCM (*fcn)())); +SCM_EXPORT SCM make_gsubr P((const char *name, int req, int opt, int rst, + SCM (*fcn)())); +SCM_EXPORT SCM closure P((SCM code, int nargs)); +SCM_EXPORT SCM makprom P((SCM code)); +SCM_EXPORT SCM force P((SCM x)); +SCM_EXPORT SCM makarb P((SCM name)); +SCM_EXPORT SCM tryarb P((SCM arb)); +SCM_EXPORT SCM relarb P((SCM arb)); +SCM_EXPORT SCM ceval P((SCM x, SCM static_env, SCM env)); +SCM_EXPORT SCM scm_wrapcode P((SCM code, SCM env)); +SCM_EXPORT SCM scm_current_env P((void)); +SCM_EXPORT SCM prolixity P((SCM arg)); +SCM_EXPORT SCM gc_for_newcell P((void)); +SCM_EXPORT void gc_for_open_files P((void)); +SCM_EXPORT SCM gc P((SCM arg)); +SCM_EXPORT SCM tryload P((SCM filename, SCM reader)); +SCM_EXPORT SCM acons P((SCM w, SCM x, SCM y)); +SCM_EXPORT SCM cons2 P((SCM w, SCM x, SCM y)); +SCM_EXPORT SCM resizuve P((SCM vect, SCM len)); +SCM_EXPORT SCM lnot P((SCM x)); +SCM_EXPORT SCM booleanp P((SCM obj)); +SCM_EXPORT SCM eq P((SCM x, SCM y)); +SCM_EXPORT SCM equal P((SCM x, SCM y)); +SCM_EXPORT SCM consp P((SCM x)); +SCM_EXPORT SCM cons P((SCM x, SCM y)); +SCM_EXPORT SCM nullp P((SCM x)); +SCM_EXPORT SCM setcar P((SCM pair, SCM value)); +SCM_EXPORT SCM setcdr P((SCM pair, SCM value)); +SCM_EXPORT SCM listp P((SCM x)); +SCM_EXPORT SCM list P((SCM objs)); +SCM_EXPORT SCM length P((SCM x)); +SCM_EXPORT SCM append P((SCM args)); +SCM_EXPORT SCM reverse P((SCM lst)); +SCM_EXPORT SCM list_ref P((SCM lst, SCM k)); +SCM_EXPORT SCM memq P((SCM x, SCM lst)); +SCM_EXPORT SCM member P((SCM x, SCM lst)); +SCM_EXPORT SCM memv P((SCM x, SCM lst)); +SCM_EXPORT SCM assq P((SCM x, SCM alist)); +SCM_EXPORT SCM assoc P((SCM x, SCM alist)); +SCM_EXPORT SCM symbolp P((SCM x)); +SCM_EXPORT SCM symbol2string P((SCM s)); +SCM_EXPORT SCM string2symbol P((SCM s)); +SCM_EXPORT SCM numberp P((SCM x)); +SCM_EXPORT SCM exactp P((SCM x)); +SCM_EXPORT SCM inexactp P((SCM x)); +SCM_EXPORT SCM eqp P((SCM x, SCM y)); +SCM_EXPORT SCM lessp P((SCM x, SCM y)); +SCM_EXPORT SCM greaterp P((SCM x, SCM y)); +SCM_EXPORT SCM leqp P((SCM x, SCM y)); +SCM_EXPORT SCM greqp P((SCM x, SCM y)); +SCM_EXPORT SCM zerop P((SCM z)); +SCM_EXPORT SCM positivep P((SCM x)); +SCM_EXPORT SCM negativep P((SCM x)); +SCM_EXPORT SCM oddp P((SCM n)); +SCM_EXPORT SCM evenp P((SCM n)); +SCM_EXPORT SCM lmax P((SCM x, SCM y)); +SCM_EXPORT SCM lmin P((SCM x, SCM y)); +SCM_EXPORT SCM sum P((SCM x, SCM y)); +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 lremainder P((SCM x, SCM y)); +SCM_EXPORT SCM modulo P((SCM x, SCM y)); +SCM_EXPORT SCM lgcd P((SCM x, SCM y)); +SCM_EXPORT SCM llcm P((SCM n1, SCM n2)); +SCM_EXPORT SCM number2string P((SCM x, SCM radix)); +SCM_EXPORT SCM istring2number P((char *str, long len, long radix)); +SCM_EXPORT SCM string2number P((SCM str, SCM radix)); +SCM_EXPORT SCM istr2flo P((char *str, long len, long radix)); +SCM_EXPORT SCM mkbig P((sizet nlen, int sign)); +SCM_EXPORT SCM mkstrport P((SCM pos, SCM str, long modes, char *caller)); +SCM_EXPORT SCM mksafeport P((int maxlen, SCM port)); +SCM_EXPORT int reset_safeport P((SCM sfp, int maxlen, SCM port)); +SCM_EXPORT SCM long2big P((long n)); +SCM_EXPORT SCM ulong2big P((unsigned long n)); +SCM_EXPORT SCM big2inum P((SCM b, sizet l)); SCM_EXPORT sizet iint2str P((long num, int rad, char *p)); -SCM_EXPORT SCM floequal P((SCM x, SCM y)); -SCM_EXPORT SCM uve_equal P((SCM u, SCM v)); +SCM_EXPORT SCM floequal P((SCM x, SCM y)); +SCM_EXPORT SCM uve_equal P((SCM u, SCM v)); SCM_EXPORT SCM uve_read P((SCM v, SCM port)); SCM_EXPORT SCM uve_write P((SCM v, SCM port)); -SCM_EXPORT SCM raequal P((SCM ra0, SCM ra1)); -SCM_EXPORT SCM array_equal P((SCM u, SCM v)); -SCM_EXPORT SCM array_rank P((SCM ra)); +SCM_EXPORT SCM raequal P((SCM ra0, SCM ra1)); +SCM_EXPORT SCM array_equal P((SCM u, SCM v)); +SCM_EXPORT SCM array_rank P((SCM ra)); SCM_EXPORT int rafill P((SCM ra, SCM fill, SCM ignore)); -SCM_EXPORT SCM uve_fill P((SCM uve, SCM fill)); -SCM_EXPORT SCM array_fill P((SCM ra, SCM fill)); -SCM_EXPORT SCM array_prot P((SCM ra)); +SCM_EXPORT SCM uve_fill P((SCM uve, SCM fill)); +SCM_EXPORT SCM array_fill P((SCM ra, SCM fill)); +SCM_EXPORT SCM array_prot P((SCM ra)); SCM_EXPORT SCM array_rank P((SCM ra)); SCM_EXPORT SCM array_contents P((SCM ra, SCM strict)); -SCM_EXPORT int bigprint P((SCM exp, SCM port, int writing)); -SCM_EXPORT int floprint P((SCM sexp, SCM port, int writing)); -SCM_EXPORT SCM istr2int P((char *str, long len, long radix)); -SCM_EXPORT SCM istr2bve P((char *str, long len)); -SCM_EXPORT void ipruk P((char *hdr, SCM ptr, SCM port)); -SCM_EXPORT SCM charp P((SCM x)); -SCM_EXPORT SCM char_lessp P((SCM x, SCM y)); -SCM_EXPORT SCM chci_eq P((SCM x, SCM y)); -SCM_EXPORT SCM chci_lessp P((SCM x, SCM y)); -SCM_EXPORT SCM char_alphap P((SCM chr)); -SCM_EXPORT SCM char_nump P((SCM chr)); -SCM_EXPORT SCM char_whitep P((SCM chr)); -SCM_EXPORT SCM char_upperp P((SCM chr)); -SCM_EXPORT SCM char_lowerp P((SCM chr)); -SCM_EXPORT SCM char2int P((SCM chr)); -SCM_EXPORT SCM int2char P((SCM n)); -SCM_EXPORT SCM char_upcase P((SCM chr)); -SCM_EXPORT SCM char_downcase P((SCM chr)); -SCM_EXPORT SCM stringp P((SCM x)); -SCM_EXPORT SCM string P((SCM chrs)); -SCM_EXPORT SCM make_string P((SCM k, SCM chr)); -SCM_EXPORT SCM string2list P((SCM str)); -SCM_EXPORT SCM st_length P((SCM str)); -SCM_EXPORT SCM st_ref P((SCM str, SCM k)); -SCM_EXPORT SCM st_set P((SCM str, SCM k, SCM chr)); -SCM_EXPORT SCM st_equal P((SCM s1, SCM s2)); -SCM_EXPORT SCM stci_equal P((SCM s1, SCM s2)); -SCM_EXPORT SCM st_lessp P((SCM s1, SCM s2)); -SCM_EXPORT SCM stci_lessp P((SCM s1, SCM s2)); -SCM_EXPORT SCM substring P((SCM str, SCM start, SCM end)); -SCM_EXPORT SCM st_append P((SCM args)); -SCM_EXPORT SCM vectorp P((SCM x)); -SCM_EXPORT SCM vector_length P((SCM v)); -SCM_EXPORT SCM vector P((SCM l)); -SCM_EXPORT SCM vector_ref P((SCM v, SCM k)); -SCM_EXPORT SCM vector_set P((SCM v, SCM k, SCM obj)); -SCM_EXPORT SCM make_vector P((SCM k, SCM fill)); -SCM_EXPORT SCM vector2list P((SCM v)); -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 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_eval_values P((SCM x, SCM static_env, SCM env)); -SCM_EXPORT SCM identp P((SCM obj)); -SCM_EXPORT SCM ident2sym P((SCM id)); -SCM_EXPORT SCM ident_eqp P((SCM id1, SCM id2, SCM env)); -SCM_EXPORT int scm_nullenv_p P((SCM env)); -SCM_EXPORT SCM env2tree P((SCM env)); -SCM_EXPORT SCM renamed_ident P((SCM id, SCM env)); -SCM_EXPORT SCM scm_check_linum P((SCM x, SCM *linum)); -SCM_EXPORT SCM scm_add_linum P((SCM linum, SCM x)); -SCM_EXPORT SCM input_portp P((SCM x)); -SCM_EXPORT SCM output_portp P((SCM x)); -SCM_EXPORT SCM cur_input_port P((void)); -SCM_EXPORT SCM cur_output_port P((void)); -SCM_EXPORT SCM i_setbuf0 P((SCM port)); -SCM_EXPORT SCM try_open_file P((SCM filename, SCM modes)); -SCM_EXPORT SCM open_file P((SCM filename, SCM modes)); -SCM_EXPORT SCM open_pipe P((SCM pipestr, SCM modes)); -SCM_EXPORT SCM close_port P((SCM port)); -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 SCM lwrite P((SCM obj, SCM port)); -SCM_EXPORT SCM display P((SCM obj, SCM port)); -SCM_EXPORT SCM newline P((SCM port)); -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 SCM lgetenv P((SCM nam)); -SCM_EXPORT SCM prog_args P((void)); -SCM_EXPORT SCM makacro P((SCM code)); -SCM_EXPORT SCM makmacro P((SCM code)); -SCM_EXPORT SCM makmmacro P((SCM code)); -SCM_EXPORT SCM makidmacro P((SCM code)); -SCM_EXPORT void poll_routine P((void)); -SCM_EXPORT void tick_signal P((void)); -SCM_EXPORT void stack_check P((void)); -SCM_EXPORT SCM list2ura P((SCM ndim, SCM prot, SCM lst)); -SCM_EXPORT SCM make_ra P((int ndim)); -SCM_EXPORT SCM makflo P((float x)); -SCM_EXPORT SCM arrayp P((SCM v, SCM prot)); -SCM_EXPORT SCM aset P((SCM v, SCM obj, SCM args)); -SCM_EXPORT SCM aref P((SCM v, SCM args)); +SCM_EXPORT int bigprint P((SCM exp, SCM port, int writing)); +SCM_EXPORT int floprint P((SCM sexp, SCM port, int writing)); +SCM_EXPORT SCM istr2int P((char *str, long len, long radix)); +SCM_EXPORT SCM istr2bve P((char *str, long len)); +SCM_EXPORT void ipruk P((char *hdr, SCM ptr, SCM port)); +SCM_EXPORT SCM charp P((SCM x)); +SCM_EXPORT SCM char_lessp P((SCM x, SCM y)); +SCM_EXPORT SCM chci_eq P((SCM x, SCM y)); +SCM_EXPORT SCM chci_lessp P((SCM x, SCM y)); +SCM_EXPORT SCM char_alphap P((SCM chr)); +SCM_EXPORT SCM char_nump P((SCM chr)); +SCM_EXPORT SCM char_whitep P((SCM chr)); +SCM_EXPORT SCM char_upperp P((SCM chr)); +SCM_EXPORT SCM char_lowerp P((SCM chr)); +SCM_EXPORT SCM char2int P((SCM chr)); +SCM_EXPORT SCM int2char P((SCM n)); +SCM_EXPORT SCM char_upcase P((SCM chr)); +SCM_EXPORT SCM char_downcase P((SCM chr)); +SCM_EXPORT SCM stringp P((SCM x)); +SCM_EXPORT SCM string P((SCM chrs)); +SCM_EXPORT SCM make_string P((SCM k, SCM chr)); +SCM_EXPORT SCM string2list P((SCM str)); +SCM_EXPORT SCM st_length P((SCM str)); +SCM_EXPORT SCM st_ref P((SCM str, SCM k)); +SCM_EXPORT SCM st_set P((SCM str, SCM k, SCM chr)); +SCM_EXPORT SCM st_equal P((SCM s1, SCM s2)); +SCM_EXPORT SCM stci_equal P((SCM s1, SCM s2)); +SCM_EXPORT SCM st_lessp P((SCM s1, SCM s2)); +SCM_EXPORT SCM stci_lessp P((SCM s1, SCM s2)); +SCM_EXPORT SCM substring P((SCM str, SCM start, SCM end)); +SCM_EXPORT SCM st_append P((SCM args)); +SCM_EXPORT SCM vectorp P((SCM x)); +SCM_EXPORT SCM vector_length P((SCM v)); +SCM_EXPORT SCM vector P((SCM l)); +SCM_EXPORT SCM vector_ref P((SCM v, SCM k)); +SCM_EXPORT SCM vector_set P((SCM v, SCM k, SCM obj)); +SCM_EXPORT SCM make_vector P((SCM k, SCM fill)); +SCM_EXPORT SCM vector2list P((SCM v)); +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 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_eval_values P((SCM x, SCM static_env, SCM env)); +SCM_EXPORT SCM identp P((SCM obj)); +SCM_EXPORT SCM ident2sym P((SCM id)); +SCM_EXPORT SCM ident_eqp P((SCM id1, SCM id2, SCM env)); +SCM_EXPORT int scm_nullenv_p P((SCM env)); +SCM_EXPORT SCM env2tree P((SCM env)); +SCM_EXPORT SCM renamed_ident P((SCM id, SCM env)); +SCM_EXPORT SCM scm_check_linum P((SCM x, SCM *linum)); +SCM_EXPORT SCM scm_add_linum P((SCM linum, SCM x)); +SCM_EXPORT SCM input_portp P((SCM x)); +SCM_EXPORT SCM output_portp P((SCM x)); +SCM_EXPORT SCM cur_input_port P((void)); +SCM_EXPORT SCM cur_output_port P((void)); +SCM_EXPORT SCM i_setbuf0 P((SCM port)); +SCM_EXPORT SCM try_open_file P((SCM filename, SCM modes)); +SCM_EXPORT SCM open_file P((SCM filename, SCM modes)); +SCM_EXPORT SCM open_pipe P((SCM pipestr, SCM modes)); +SCM_EXPORT SCM close_port P((SCM port)); +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 SCM lwrite P((SCM obj, SCM port)); +SCM_EXPORT SCM display P((SCM obj, SCM port)); +SCM_EXPORT SCM newline P((SCM port)); +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 SCM lgetenv P((SCM nam)); +SCM_EXPORT SCM prog_args P((void)); +SCM_EXPORT SCM makacro P((SCM code)); +SCM_EXPORT SCM makmacro P((SCM code)); +SCM_EXPORT SCM makmmacro P((SCM code)); +SCM_EXPORT SCM makidmacro P((SCM code)); +SCM_EXPORT void poll_routine P((void)); +SCM_EXPORT void tick_signal P((void)); +SCM_EXPORT void stack_check P((void)); +SCM_EXPORT SCM list2ura P((SCM ndim, SCM prot, SCM lst)); +SCM_EXPORT SCM make_ra P((int ndim)); +SCM_EXPORT SCM makflo P((float x)); +SCM_EXPORT SCM arrayp P((SCM v, SCM prot)); +SCM_EXPORT SCM aset P((SCM v, SCM obj, SCM args)); +SCM_EXPORT SCM aref P((SCM v, SCM args)); SCM_EXPORT SCM scm_array_ref P((SCM args)); -SCM_EXPORT SCM cvref P((SCM v, sizet pos, SCM last)); -SCM_EXPORT SCM quit P((SCM n)); +SCM_EXPORT SCM cvref P((SCM v, sizet pos, SCM last)); +SCM_EXPORT SCM quit P((SCM n)); #ifdef CAREFUL_INTS -SCM_EXPORT void ints_viol P((ints_infot *info, int sense)); +SCM_EXPORT void ints_viol P((ints_infot *info, int sense)); SCM_EXPORT void ints_warn P((char *s1, char* s2, char *fname, int linum)); #endif -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 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)); +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 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)); SCM_EXPORT SCM scm_logbitp P((SCM index, SCM j1)); SCM_EXPORT SCM scm_logtest P((SCM x, SCM y)); SCM_EXPORT SCM scm_logxor P((SCM x, SCM y)); @@ -1027,68 +1021,68 @@ SCM_EXPORT SCM scm_bitfield P((SCM n, SCM start, SCM end)); SCM_EXPORT SCM scm_logcount P((SCM n)); SCM_EXPORT SCM scm_intlength P((SCM n)); SCM_EXPORT SCM scm_copybit P((SCM index, SCM j1, SCM bit)); -SCM_EXPORT SCM scm_bitif P((SCM mask, SCM n0, SCM n1)); -SCM_EXPORT SCM scm_copybitfield P((SCM to, SCM start, SCM rest)); +SCM_EXPORT SCM scm_bitif P((SCM mask, SCM n0, SCM n1)); +SCM_EXPORT SCM scm_copybitfield P((SCM to, SCM start, SCM rest)); - /* Defined in "rope.c" */ -SCM_EXPORT SCM long2num P((long n)); -SCM_EXPORT SCM ulong2num P((unsigned long n)); + /* Defined in "rope.c" */ +SCM_EXPORT SCM long2num P((long n)); +SCM_EXPORT SCM ulong2num P((unsigned long n)); SCM_EXPORT unsigned char num2uchar P((SCM num, char *pos, char *s_caller)); SCM_EXPORT unsigned short num2ushort P((SCM num, char *pos, char *s_caller)); 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 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 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 scm_evstr P((char *str)); -SCM_EXPORT void scm_ldstr P((char *str)); -SCM_EXPORT int scm_ldfile P((char *path)); -SCM_EXPORT int scm_ldprog P((char *path)); +SCM_EXPORT void must_free_argv P((char **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)); +SCM_EXPORT int scm_ldprog P((char *path)); SCM_EXPORT unsigned long scm_addr P((SCM args, char *name)); SCM_EXPORT unsigned long scm_base_addr P((SCM v, char *name)); -SCM_EXPORT int scm_cell_p P((SCM x)); +SCM_EXPORT int scm_cell_p P((SCM x)); #ifdef FLOATS -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_round P((double x)); -SCM_EXPORT double floident P((double 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_round P((double x)); +SCM_EXPORT double floident P((double x)); #endif #ifdef BIGDIG -SCM_EXPORT void longdigs P((long x, BIGDIG digs[DIGSPERLONG])); -SCM_EXPORT SCM adjbig P((SCM b, sizet nlen)); -SCM_EXPORT SCM normbig P((SCM b)); -SCM_EXPORT SCM copybig P((SCM b, int sign)); -SCM_EXPORT SCM addbig P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int sgny)); -SCM_EXPORT SCM mulbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn)); +SCM_EXPORT void longdigs P((long x, BIGDIG digs[DIGSPERLONG])); +SCM_EXPORT SCM adjbig P((SCM b, sizet nlen)); +SCM_EXPORT SCM normbig P((SCM b)); +SCM_EXPORT SCM copybig P((SCM b, int sign)); +SCM_EXPORT SCM addbig P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int sgny)); +SCM_EXPORT SCM mulbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn)); SCM_EXPORT unsigned int divbigdig P((BIGDIG *ds, sizet h, BIGDIG div)); -SCM_EXPORT SCM divbigint P((SCM x, long z, int sgn, int mode)); -SCM_EXPORT SCM divbigbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn, - int modes)); -SCM_EXPORT long pseudolong P((long x)); +SCM_EXPORT SCM divbigint P((SCM x, long z, int sgn, int mode)); +SCM_EXPORT SCM divbigbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn, + int modes)); +SCM_EXPORT long pseudolong P((long x)); #endif -SCM_EXPORT int bigcomp P((SCM x, SCM y)); -SCM_EXPORT SCM bigequal P((SCM x, SCM y)); -SCM_EXPORT int scm_bigdblcomp P((SCM b, double d)); +SCM_EXPORT int bigcomp P((SCM x, SCM y)); +SCM_EXPORT SCM bigequal P((SCM x, SCM y)); +SCM_EXPORT int scm_bigdblcomp P((SCM b, double d)); /* "script.c" functions */ -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, - const char *initname, const char *sep)); +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, + const char *initname, const char *sep)); /* environment cache functions */ SCM_EXPORT void scm_ecache_report P((void)); @@ -1121,36 +1115,36 @@ SCM_EXPORT SCM scm_trace, scm_trace_env; # define ASRTGO(_cond, _label) if(!(_cond)) goto _label; #endif -#define ARGn 1 -#define ARG1 2 -#define ARG2 3 -#define ARG3 4 -#define ARG4 5 -#define ARG5 6 +#define ARGn 1 +#define ARG1 2 +#define ARG2 3 +#define ARG3 4 +#define ARG4 5 +#define ARG5 6 /* following must match entry indexes in errmsgs[] */ -#define WNA 7 -#define OVFLOW 8 -#define OUTOFRANGE 9 -#define NALLOC 10 -#define THRASH 11 -#define EXIT 12 -#define HUP_SIGNAL 13 -#define INT_SIGNAL 14 -#define FPE_SIGNAL 15 -#define BUS_SIGNAL 16 -#define SEGV_SIGNAL 17 -#define ALRM_SIGNAL 18 +#define WNA 7 +#define OVFLOW 8 +#define OUTOFRANGE 9 +#define NALLOC 10 +#define THRASH 11 +#define EXIT 12 +#define HUP_SIGNAL 13 +#define INT_SIGNAL 14 +#define FPE_SIGNAL 15 +#define BUS_SIGNAL 16 +#define SEGV_SIGNAL 17 +#define ALRM_SIGNAL 18 #define VTALRM_SIGNAL 19 -#define PROF_SIGNAL 20 +#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 NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\ - else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}} + else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}} /* #define NEWCELL(_into) {DEFER_INTS;if IMP(freelist) _into = gc_for_newcell();\ - else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}\ + else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}\ ALLOW_INTS;} */ diff --git a/scm.info b/scm.info index c7f80bd..f554663 100644 --- a/scm.info +++ b/scm.info @@ -1,4 +1,4 @@ -This is scm.info, produced by makeinfo version 4.0 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 -5d9 was released November 2003. The most recent information about SCM | -can be found on SCM's "WWW" home page: +5e1 was released June 2005. The most recent information about SCM can | +be found on SCM's "WWW" home page: | - + `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 -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 -Features -======== +1.1 Features | +============ | * Conforms to Revised^5 Report on the Algorithmic Language Scheme [R5RS] and the [IEEE] P1178 specification. @@ -109,8 +109,8 @@ Features  File: scm.info, Node: SCM Authors, Next: Copying, Prev: SCM Features, Up: Overview -Authors -======= +1.2 Authors | +=========== | Aubrey Jaffer (agj @ alum.mit.edu) Most of SCM. @@ -138,16 +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 -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:: | + | + +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. | + | 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 @@ -176,14 +230,15 @@ INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. -SIOD copyright -============== + +File: scm.info, Node: SIOD copyright, Prev: The SCM License, Up: Copying + | +1.3.2 SIOD copyright | +-------------------- | COPYRIGHT (c) 1989 BY - PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. - ALL RIGHTS RESERVED Permission to use, copy, modify, distribute and sell this software and @@ -212,8 +267,8 @@ Cambridge, MA 02138  File: scm.info, Node: Bibliography, Prev: Copying, Up: Overview -Bibliography -============ +1.4 Bibliography | +================ | [IEEE] `IEEE Standard 1178-1990. IEEE Standard for the Scheme @@ -276,8 +331,8 @@ Bibliography  File: scm.info, Node: Installing SCM, Next: Operational Features, Prev: Overview, Up: Top -Installing SCM -************** +2 Installing SCM | +**************** | * Menu: @@ -297,8 +352,8 @@ Installing SCM  File: scm.info, Node: Making SCM, Next: SLIB, Prev: Installing SCM, Up: Installing SCM -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'. @@ -309,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://swissnet.ai.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 @@ -323,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 -SLIB -==== +2.2 SLIB | +======== | [SLIB] is a portable Scheme library meant to provide compatibility and utility functions for all standard Scheme implementations. Although @@ -332,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: - * swissnet.ai.mit.edu:/pub/scm/slib3a1.tar.gz | + * swiss.csail.mit.edu:/pub/scm/slib3a2.tar.gz | - * ftp.gnu.org:/pub/gnu/jacal/slib3a1.tar.gz | + * ftp.gnu.org:/pub/gnu/jacal/slib3a2.tar.gz | - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a1.tar.gz | + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a2.tar.gz | -Unpack SLIB (`tar xzf slib3a1.tar.gz' or `unzip -ao slib3a1.zip') in an | +Unpack SLIB (`tar xzf slib3a2.tar.gz' or `unzip -ao slib3a2.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 `Init5d9.scm' is | +(this is the same directory as where the file `Init5e1.scm' is | installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -367,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 -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. @@ -386,8 +441,8 @@ ai.mit.edu.  File: scm.info, Node: Invoking Build, Next: Build Options, Prev: Building SCM, Up: Building SCM -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'. @@ -405,6 +460,7 @@ _all_ `(load "build")'. Alternatively, start `scm' or `scmlit' with the command line argument `-ilbuild'. + Invoking build without the `-F' option will build or create a shell script with the `arrays', `inexact', and `bignums' options as defaults. @@ -414,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 "Init5d9.scm"'>>scmflags.h | + echo '#define IMPLINIT "Init5e1.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -433,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 "Init5d9.scm"'>>scmflags.h | + echo '#define IMPLINIT "Init5e1.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 @@ -443,18 +499,18 @@ in the `-p' or `--platform=' option.  File: scm.info, Node: Build Options, Next: Compiling and Linking Custom Files, Prev: Invoking Build, Up: Building SCM -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: @@ -507,11 +563,11 @@ the SCM command line options. vms-gcc vax vms gcc | watcom-9.0 i386 ms-dos wcc386p | - - Build Option: -f PATHNAME + -- 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' | @@ -527,65 +583,65 @@ the SCM command line options. Options for pgscm, which instruments C functions. | | `udscm4.opt' | - Options for targets udscm4 and myscm4 (scm). | + Options for targets udscm4 and dscm4 (scm). | | `udscm5.opt' | - Options for targets udscm5 and myscm5 (scm). | + 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 + | + -- 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 `Init5d9.scm'. SCM tries several likely | + initialization file `Init5e1.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' @@ -602,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: @@ -624,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: @@ -684,6 +740,9 @@ the SCM command line options. `careful-interrupt-masking', and `stack-limit'; uses `-g' flags for debugging SCM source code. + "differ" | + Sequence comparison | + | "dump" Convert a running scheme program into an executable file. @@ -768,7 +827,8 @@ the SCM command line options. numbers. "socket" - BSD "socket" interface. + 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 @@ -788,6 +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. | + | "windows" Microsoft Windows executable. @@ -801,8 +864,8 @@ the SCM command line options.  File: scm.info, Node: Compiling and Linking Custom Files, Prev: Build Options, Up: Building SCM -Compiling and Linking Custom Files ----------------------------------- +2.3.3 Compiling and Linking Custom Files | +---------------------------------------- | A correspondent asks: @@ -811,16 +874,15 @@ A correspondent asks: functions we want access to). Would this involve changing 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: +(*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: | bash$ ./build -c foo.c -i init_foo -| #! /bin/sh rm -f scmflags.h - echo '#define IMPLINIT "/home/jaffer/scm/Init5d9.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5e1.scm"'>>scmflags.h | echo '#define COMPILED_INITS init_foo();'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h @@ -836,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/Init5d9.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5e1.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -852,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 -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". @@ -892,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 -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'. @@ -921,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. @@ -929,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 @@ -942,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 -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 @@ -959,8 +1021,8 @@ file from emacs.  File: scm.info, Node: Automatic C Preprocessor Definitions, Next: Problems Compiling, Prev: Saving Images, Up: Installing SCM -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 @@ -990,7 +1052,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of __USE_POSIX ?? __WATCOMC__ Watcom C on MS-DOS __ZTC__ Zortech C - + _AIX AIX operating system __APPLE__ Apple Darwin AMIGA SAS/C 5.10 or Dice C on AMIGA @@ -1010,6 +1072,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of __NetBSD__ NetBSD nosve Control Data NOS/VE SVR2 System V Revision 2. + sun SunOS | __SVR4 SunOS THINK_C developement environment for the Macintosh ultrix VAX with ULTRIX operating system. @@ -1024,7 +1087,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of _WIN32 MS VisualC++ 4.2 and Cygwin (Win32 API) _WIN32_WCE MS Windows CE vms (and VMS) VAX-11 C under VMS. - + __alpha DEC Alpha processor __alpha__ DEC Alpha processor hp9000s800 HP RISC processor @@ -1048,8 +1111,8 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of  File: scm.info, Node: Problems Compiling, Next: Problems Linking, Prev: Automatic C Preprocessor Definitions, Up: Installing SCM -Problems Compiling -================== +2.8 Problems Compiling | +====================== | FILE PROBLEM / MESSAGE HOW TO FIX *.c include file not found. Correct the status of @@ -1081,8 +1144,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 -Problems Linking -================ +2.9 Problems Linking | +==================== | PROBLEM HOW TO FIX _sin etc. missing. Uncomment LIBS in makefile. @@ -1090,8 +1153,8 @@ _sin etc. missing. Uncomment LIBS in makefile.  File: scm.info, Node: Problems Running, Next: Testing, Prev: Problems Linking, Up: Installing SCM -Problems Running -================ +2.10 Problems Running | +===================== | PROBLEM HOW TO FIX Opening message and then machine Change memory model option to C @@ -1110,17 +1173,17 @@ remove in scmfig.h and Do so and recompile files. recompile scm. add in scmfig.h and recompile scm. -ERROR: Init5d9.scm not found. Assign correct IMPLINIT in makefile | +ERROR: Init5e1.scm not found. Assign correct IMPLINIT in makefile | or scmfig.h. Define environment variable SCM_INIT_PATH to be the full - pathname of Init5d9.scm. | + pathname of Init5e1.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 - Init5d9.scm to point to library or | + Init5e1.scm to point to library or | remove. Make sure the value of (library-vicinity) has a trailing @@ -1129,8 +1192,8 @@ WARNING: require.scm not found. Define environment variable  File: scm.info, Node: Testing, Next: Reporting Problems, Prev: Problems Running, Up: Installing SCM -Testing -======= +2.11 Testing | +============ | Loading `r4rstest.scm' in the distribution will run an [R4RS] conformance test on `scm'. @@ -1180,7 +1243,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. `Init5d9.scm'). | +output files. `Init5e1.scm'). | Spaces or control characters appear Check character defines in in symbol names. `scmfig.h'. Negative numbers turn positive. Check SRS in `scmfig.h'. @@ -1195,13 +1258,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. + 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 -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 @@ -1226,8 +1290,8 @@ include:  File: scm.info, Node: Operational Features, Next: The Language, Prev: Installing SCM, Up: Top -Operational Features -******************** +3 Operational Features | +********************** | * Menu: @@ -1238,6 +1302,7 @@ Operational Features * SCM Session:: * Editing Scheme Code:: * Debugging Scheme Code:: +* Debugging Continuations:: | * Errors:: * Memoized Expressions:: * Internal State:: @@ -1246,8 +1311,8 @@ Operational Features  File: scm.info, Node: Invoking SCM, Next: SCM Options, Prev: Operational Features, Up: Operational Features -Invoking SCM -============ +3.1 Invoking SCM | +================ | scm [-a kbytes] [-muvbiq] [-version] [-help] [[-]-no-init-file] [-p int] [-r feature] [-h feature] @@ -1261,7 +1326,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 `Init5d9.scm') in platform-dependent directories relative | +file (usually `Init5e1.scm') in platform-dependent directories relative | to this directory. See *Note File-System Habitat:: for a blow-by-blow description. @@ -1270,12 +1335,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, `Init5d9.scm' checks to see if there is file | +command line, `Init5e1.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. -`Init5d9.scm' then looks for command input from one of three sources: | +`Init5e1.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. @@ -1287,55 +1352,55 @@ Lexical Conventions.  File: scm.info, Node: SCM Options, Next: Invocation Examples, Prev: Invoking SCM, Up: Operational Features -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. | - - 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::). @@ -1345,33 +1410,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 @@ -1381,26 +1446,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 -Invocation Examples -=================== +3.3 Invocation Examples | +======================= | `% scm foo.scm' Loads and executes the contents of `foo.scm' and then enters @@ -1431,39 +1496,39 @@ Invocation Examples  File: scm.info, Node: SCM Variables, Next: SCM Session, Prev: Invocation Examples, Up: Operational Features -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 `Init5d9.scm' in the source directory. | + The default is the file `Init5e1.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 `Init5d9.scm' will look for the user | + -- Environment Variable: HOME | + is the directory where `Init5e1.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'. -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. @@ -1471,8 +1536,8 @@ Scheme Variables  File: scm.info, Node: SCM Session, Next: Editing Scheme Code, Prev: SCM Variables, Up: Operational Features -SCM Session -=========== +3.6 SCM Session | +=============== | * Options, file loading and features can be specified from the command line. *Note System interface: (scm)System interface. @@ -1484,23 +1549,23 @@ SCM Session * 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. @@ -1508,21 +1573,21 @@ SCM Session 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 -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. @@ -1561,10 +1626,10 @@ other systems: After editing, the modified file will be loaded.  -File: scm.info, Node: Debugging Scheme Code, Next: Errors, Prev: Editing Scheme Code, Up: Operational Features - -Debugging Scheme Code -===================== +File: scm.info, Node: Debugging Scheme Code, Next: Debugging Continuations, Prev: Editing Scheme Code, Up: Operational Features + | +3.8 Debugging Scheme Code | +========================= | The `cautious' and `stack-limit' options of `build' (*note Build Options::) support debugging in Scheme. @@ -1600,34 +1665,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: - - Procedure: 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 '' and `)' around an - expression in order to see its value as a program operates. + One can just insert `(print '