From 710a97992705d67c3ded0d4b270c5978ce29b11f Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:37 -0800 Subject: Import Upstream version 5e4 --- .gdbinit | 14 +- ANNOUNCE | 185 ++----- ChangeLog | 243 +++++++++ Idiffer.scm | 31 +- Iedline.scm | 2 +- Init5e3.scm | 1631 --------------------------------------------------------- Init5e4.scm | 1643 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Makefile | 256 +++++---- README | 23 +- Transcen.scm | 3 + Xlibscm.info | 40 +- Xlibscm.texi | 2 +- build | 16 + build.scm | 99 ++-- byte.c | 10 +- bytenumb.c | 469 +++++++++++++++++ continue.h | 2 +- debug.c | 40 +- dynl.c | 18 +- eval.c | 36 +- features.txi | 4 + findexec.c | 19 +- hobbit.info | 101 ++-- hobbit.scm | 23 +- hobbit.texi | 4 +- indexes.texi | 18 +- ioext.c | 47 +- mkimpcat.scm | 2 + patchlvl.h | 4 +- platform.txi | 8 +- posix.c | 2 +- r4rstest.scm | 9 +- ramap.c | 76 ++- record.c | 22 +- repl.c | 432 ++++++++------- requires.scm | 12 +- rgx.c | 10 +- rope.c | 18 +- scl.c | 24 +- scm.1 | 9 +- scm.c | 39 +- scm.doc | 8 +- scm.h | 86 +-- scm.info | 1088 +++++++++++++++++++------------------- scm.nsi | 477 +++++++++++++++++ scm.spec | 4 +- scm.texi | 280 +++++----- scmfig.h | 22 +- scmhob.h | 8 +- script.c | 4 +- socket.c | 8 +- subr.c | 76 ++- sys.c | 91 ++-- time.c | 2 +- unif.c | 40 +- version.txi | 4 +- x.c | 16 +- 57 files changed, 4618 insertions(+), 3242 deletions(-) delete mode 100644 Init5e3.scm create mode 100644 Init5e4.scm create mode 100644 bytenumb.c create mode 100644 scm.nsi diff --git a/.gdbinit b/.gdbinit index a1d20b0..54def8d 100644 --- a/.gdbinit +++ b/.gdbinit @@ -55,18 +55,18 @@ define verbose end define errobj - call iprin1(*loc_errobj, sys_protects[2], 1),(void)0 - call newline(sys_protects[2]),(void)0 + call scm_iprin1(*loc_errobj, sys_protects[2], 1),(void)0 + call scm_newline(sys_protects[2]),(void)0 end define scm - call iprin1($arg0, sys_protects[2], 1),(void)0 - call newline(sys_protects[2]),(void)0 + call scm_iprin1($arg0, sys_protects[2], 1),(void)0 + call scm_newline(sys_protects[2]),(void)0 end define code call scm_princode($arg0, scm_estk_ptr[2], sys_protects[2], 1),(void)0 - call newline(sys_protects[2]),(void)0 + call scm_newline(sys_protects[2]),(void)0 end define lload @@ -101,12 +101,12 @@ CDR of $ end define disp - call iprin1($arg0, sys_protects[2], 0) + call scm_iprin1($arg0, sys_protects[2], 0) echo \n end define writ - call iprin1($arg0, sys_protects[2], 1) + call scm_iprin1($arg0, sys_protects[2], 1) echo \n end diff --git a/ANNOUNCE b/ANNOUNCE index de05441..5583c92 100644 --- a/ANNOUNCE +++ b/ANNOUNCE @@ -1,4 +1,4 @@ -This message announces the availability of Scheme release scm5e3. +This message announces the availability of Scheme release scm5e4. SCM conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. SCM is written in C and runs under @@ -12,176 +12,87 @@ programs (see http://swiss.csail.mit.edu/~jaffer/SCM_LICENSE). Documentation and distributions in several formats are linked from SCM's home page: - http://swissnet.ai.mit.edu/~jaffer/SCM.html + http://swiss.csail.mit.edu/~jaffer/SCM Links to distributions of SCM and related softwares are at the end of this message. -=-=- -scm5e3 news: +scm5e4 news: -Richard Harke ported SCM to the Linux-ia64. +* Jerry van Dijk wrote NSIS script to create MS-Windows installers. -SRFI-94 Type-Restricted Numerical Functions. +* Added (compiled) byte-number module. -SRFI-63 uniform array type support expanded to: +* scm-file-position replaces file-position and file-set-position!; + moved from i/o-extensions module to SCM core functionality. - A:floC64b inexact 64.bit binary flonum complex - A:floC32b inexact 32.bit binary flonum complex - A:floC16b inexact 16.bit binary flonum complex - A:floR64b inexact 64.bit binary flonum real - A:floR32b inexact 32.bit binary flonum real - A:floR16b inexact 16.bit binary flonum real - A:fixZ32b exact 32.bit binary fixnum - A:fixZ16b exact 16.bit binary fixnum - A:fixZ8b exact 8.bit binary fixnum - A:fixN32b exact 32.bit nonnegative binary fixnum - A:fixN16b exact 16.bit nonnegative binary fixnum - A:fixN8b exact 8.bit nonnegative binary fixnum - A:bool boolean - string char +* Added --no-symbol-case-fold command-line option to make symbol + reading case-sensitive. -Radey Shouman has changed LETREC to behave like LETREC*: +* Added (R6RS) bitwise-bit-count. - * eval.c (ceval_1): Change LETREC behavior to that of LETREC*: - initializers are run in left to right order, and may use - previously evaluated variables bound in the same contour. This - change also applies to LETRECs resulting from internal DEFINE. - - * eval.c (macroexp1): Add #ifdef to switch case handling line numbers - in ceval_1 so that they are safely discarded when MEMOIZE_LOCALS is - not #defined. Perhaps line number generation should be disabled in - that case. - - * scl.c: Changes to allow compilation with MinGW (gnu-win32); - asinh, acosh, and atanh are not yet supported. - -From Aubrey Jaffer: - - * indexes.texi (Indexes): Give each index its own node when not in - info mode. Moved index stuff here so it doesn't break - texinfo-every-node-update. - - * scm.texi (Index): Replaced nodes under Indexes with node Index - when in info mode; fixes indexing in Emacs 21.4.1. - Converted to use @copying. - (Indexes): Reorganized. - (Data Type Representations): Corrected pattern for specfun and cclo. - - * byte.c (subbytes): Added. - (scm_subbytes_read, scm_subbytes_write): Renamed from substring. - - * Makefile (dscm4, dscm5): != is string operator in shell. - "mv -f" for previous scm, slibcat, and implcat. - - * Init5e2.scm (boot-tail): Don't load ScmInit.scm if *script*. - (string-index, read-line): Defined for login->home-directory, which - may be called before REQUIRE is defined. - - * Makefile (dscm4, dscm5): Added randomize_va_space machinations. - (dvi, pdf): New tetex-3.0(-20.FC5) broke them -- fixed. - (SETARCH): Workarounds allow dumping in recent Linux. - - * time.c (linux): defined CLKTCK to (sysconf(_SC_CLK_TCK)). - - * repl.c (scm_read_numbered): Don't #ifndef MEMOIZED_LOCALS. - - * build.scm (dont-memoize-locals): Added feature. - (stack-limit): Removed feature. - - * scmfig.h (STACK_LIMIT): Always defined. - (CHECK_STACK): Condition on scm_verbose. - - * sys.c (stack_check): Always present. - - * Makefile (docs): Added target to make all documentation files; - then invoke xdvi. - - * ugsetjmp.s (_setjump, _longjump): For Ultrix VAX circa 1997. - - * subr.c (mkbig, adjbig): Improved overflow message. - - * mkimpcat.scm (wbtab, rwb-isam): moved to "Simple associations". - (add-source): Use 'source form and check file's existence. - - * scl.c (scm_magnitude): Extend dynamic range by eliminating - intermediate expression swell. - (divide): Use "Smith's formula" to extend dynamic range; - but makes an insignificant difference when compiled with -O3. - (atanh, acosh, asinh): define if #ifndef HAVE_ATANH. - - * scmfig.h (HAVE_ATANH): Decides whether atanh, asinh, and acosh - are supported. - - * r4rstest.scm (5 2 1): Expose Bigloo tprint redefinition bug. - (test-bignum): Convert test bignums from strings. - (have-bignums?): Check bignum arithmetic works. - (test-inexact): Do complex tests only if non-real numbers are - supported. - (test-inexact): Added equal? tests. - (test-inexact): Test for -0.0 lossage. - (test-inexact): Check that / and magnitude work for - very large and very small complex numbers (1e300; 1e-300); +* Makefile (install*): Added $(DESTDIR) prefix. -=-=- SCM source is available from: - http://swissnet.ai.mit.edu/ftpdir/scm/scm5e3.zip - swissnet.ai.mit.edu:/pub/scm/scm5e3.zip - http://swissnet.ai.mit.edu/ftpdir/scm/scm-5e3-1.src.rpm - swissnet.ai.mit.edu:/pub/scm/scm-5e3-1.src.rpm + http://swiss.csail.mit.edu/ftpdir/scm/scm5e4.zip + swiss.csail.mit.edu:/pub/scm/scm5e4.zip + http://swiss.csail.mit.edu/ftpdir/scm/scm-5e4-1.src.rpm + swiss.csail.mit.edu:/pub/scm/scm-5e4-1.src.rpm Also available as i386 binary RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/scm-5e3-1.i386.rpm - swissnet.ai.mit.edu:/pub/scm/scm-5e3-1.i386.rpm + http://swiss.csail.mit.edu/ftpdir/scm/scm-5e4-1.i386.rpm + swiss.csail.mit.edu:/pub/scm/scm-5e4-1.i386.rpm SLIB is a portable Scheme library which SCM uses: - http://swissnet.ai.mit.edu/ftpdir/scm/slib3a4.zip - swissnet.ai.mit.edu:/pub/scm/slib3a4.zip + http://swiss.csail.mit.edu/ftpdir/scm/slib3a5.zip + swiss.csail.mit.edu:/pub/scm/slib3a5.zip Also available as RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a4-1.noarch.rpm - swissnet.ai.mit.edu:/pub/scm/slib-3a4-1.noarch.rpm + http://swiss.csail.mit.edu/ftpdir/scm/slib-3a5-1.noarch.rpm + swiss.csail.mit.edu:/pub/scm/slib-3a5-1.noarch.rpm JACAL is a symbolic math system written in Scheme: - http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b7.zip - swissnet.ai.mit.edu:/pub/scm/jacal1b7.zip + http://swiss.csail.mit.edu/ftpdir/scm/jacal1b8.zip + swiss.csail.mit.edu:/pub/scm/jacal1b8.zip SLIB-PSD is a portable debugger for Scheme (requires emacs editor): - http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz - swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz + http://swiss.csail.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + swiss.csail.mit.edu:/pub/scm/slib-psd1-3.tar.gz SMG-SCM is an SMG interface package which works with SCM on VMS. - http://swissnet.ai.mit.edu/ftpdir/scm/smg-scm2a1.zip - swissnet.ai.mit.edu:/pub/scm/smg-scm2a1.zip + http://swiss.csail.mit.edu/ftpdir/scm/smg-scm2a1.zip + swiss.csail.mit.edu:/pub/scm/smg-scm2a1.zip A VMS version of Unzip is available by anonymous FTP from ftp.spc.edu:[ANONYMOUS.MACRO32]UNZIP.EXE. TURTLSCM is a turtle graphics package which works with SCM on MS-DOS or X11 machines: - http://swissnet.ai.mit.edu/ftpdir/scm/turtlegr.tar.gz - swissnet.ai.mit.edu:/pub/scm/turtlegr.tar.gz + http://swiss.csail.mit.edu/ftpdir/scm/turtlegr.tar.gz + swiss.csail.mit.edu:/pub/scm/turtlegr.tar.gz XSCM is a X windows interface package which works with SCM: - http://swissnet.ai.mit.edu/ftpdir/scm/xscm-2.01.tar.gz - swissnet.ai.mit.edu:/pub/scm/xscm-2.01.tar.gz + http://swiss.csail.mit.edu/ftpdir/scm/xscm-2.01.tar.gz + swiss.csail.mit.edu:/pub/scm/xscm-2.01.tar.gz MacSCM is a Macintosh applications building package which works with SCM (similar to XSCM). - http://swissnet.ai.mit.edu/ftpdir/scm/macscm.tar.Z - swissnet.ai.mit.edu:/pub/scm/macscm.tar.Z + http://swiss.csail.mit.edu/ftpdir/scm/macscm.tar.Z + swiss.csail.mit.edu:/pub/scm/macscm.tar.Z WB is a disk based, sorted associative array (B-tree) library for SCM. Using WB, large databases can be created and managed from SCM. - http://swissnet.ai.mit.edu/ftpdir/scm/wb1c3.zip - swissnet.ai.mit.edu:/pub/scm/wb1c3.zip - http://swissnet.ai.mit.edu/ftpdir/scm/wb-1c3-1.src.rpm - swissnet.ai.mit.edu:/pub/scm/wb-1c3-1.src.rpm + http://swiss.csail.mit.edu/ftpdir/scm/wb2a1.zip + swiss.csail.mit.edu:/pub/scm/wb2a1.zip + http://swiss.csail.mit.edu/ftpdir/scm/wb-2a1-1.src.rpm + swiss.csail.mit.edu:/pub/scm/wb-2a1-1.src.rpm Also available as i386 binary RPM: - http://swissnet.ai.mit.edu/ftpdir/scm/wb-1c3-1.i386.rpm - swissnet.ai.mit.edu:/pub/scm/wb-1c3-1.i386.rpm + http://swiss.csail.mit.edu/ftpdir/scm/wb-2a1-1.i386.rpm + swiss.csail.mit.edu:/pub/scm/wb-2a1-1.i386.rpm SIMSYNCH is a digital logic simulation system written in SCM. - http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip - swissnet.ai.mit.edu:/pub/scm/synch1b0.zip + http://swiss.csail.mit.edu/ftpdir/scm/synch1b0.zip + swiss.csail.mit.edu:/pub/scm/synch1b0.zip DLD is a C library package allowing SCM to dynamically load object files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation @@ -190,15 +101,15 @@ systems. ftp.gnu.org:pub/gnu/dld/dld-3.3.tar.gz SCM.EXE (314k) is a SCM executable for DOS and MS-Windows. -Note: SCM.EXE still requires slib3a4 and scm5e3 above. - http://swissnet.ai.mit.edu/ftpdir/scm/scm.exe - swissnet.ai.mit.edu:/pub/scm/scm.exe +Note: SCM.EXE still requires slib3a5 and scm5e4 above. + http://swiss.csail.mit.edu/ftpdir/scm/scm.exe + swiss.csail.mit.edu:/pub/scm/scm.exe #! implements "#!" (POSIX) shell-scripts for MS-DOS batch files. - http://swissnet.ai.mit.edu/ftpdir/scm/sharpbang.zip - swissnet.ai.mit.edu:/pub/scm/sharpbang.zip - http://swissnet.ai.mit.edu/ftpdir/scm/#!.zip - swissnet.ai.mit.edu:/pub/scm/#!.zip + http://swiss.csail.mit.edu/ftpdir/scm/sharpbang.zip + swiss.csail.mit.edu:/pub/scm/sharpbang.zip + http://swiss.csail.mit.edu/ftpdir/scm/#!.zip + swiss.csail.mit.edu:/pub/scm/#!.zip Programs for printing and viewing TexInfo documentation (which SCM has) come with GNU Emacs or can be obtained via ftp from: diff --git a/ChangeLog b/ChangeLog index 7e3e778..5a69843 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,246 @@ +2007-11-28 Aubrey Jaffer + + * bytenumb.c (scm_integer_to_bytes): Declaration must start block. + + * Makefile (Checklit, Check): Added case-sensitive checks. + + * repl.c (scm_lreadr): Made case-insensitive for character names. + +2007-11-25 Aubrey Jaffer + + * patchlvl.h (SCMVERSION): Bumped from 5e3 to 5e4. + +2007-11-24 Aubrey Jaffer + + * Makefile (release): Upload scm.pdf. + + * repl.c (scm_lreadparen): Fixed case-sensitive symbol reading. + +2007-11-23 Aubrey Jaffer + + * requires.scm, Iedline.scm, Init5e4.scm: Downcased symbols to + work with case-sensitive symbols (--no-symbol-case-fold). + +2007-11-03 Aubrey Jaffer + + * repl.c (scm_file_position): Added replacement for + file_set_position and file_position. + + * Init5e3.scm (file-position, file-set-position): Added stub. + + * ioext.c (file_set_position, file_position): Moved to repl.c. + + * scm.texi (Port Properties): Moved file-position from + I/O-Extensions. + +2007-10-24 Aubrey Jaffer + + * build.scm (wb): Added "../wb/segs.c". + +2007-10-20 Aubrey Jaffer + + * scm.nsi: Install "mkimpcat.scm", "wbtab.scm", and "rwb-isam.scm". + +2007-10-14 Aubrey Jaffer + + * Init5e3.scm (slib:load): Is not the same as slib:load-source. + +2007-09-07 Aubrey Jaffer + + * scm.texi (Making SCM): Added cross reference to "Building SCM". + +2007-09-04 Aubrey Jaffer + + * Makefile (install): Remove wb dependencies. + + * build.scm, build: Changed copyright and license to match others. + +2007-09-03 Aubrey Jaffer + + * Makefile (scm4): Added target. + (install*): Added $(DESTDIR) prefix. + +2007-08-05 Aubrey Jaffer + + * findexec.c (__DragonflyBSD__, __OpenBSD__): Added. Made BSD + derivative includes more uniform. + + * scm.texi (Automatic C Preprocessor Definitions): Added + __DragonflyBSD__ and __OpenBSD__. + + * repl.c, scl.c, scm.h: Replaced (int) casts with PTR2INT(). + + * scmfig.h (PTR2INT): Added; conditioned on 64.bit processor. + +2007-07-22 Aubrey Jaffer + + * repl.c (linux): Adding "#include " fixes implicit + declaration warnings. + +2007-07-21 Aubrey Jaffer + + * scm.h (num2char): Added declaration. + + * scmfig.h (linux): Adding "#include " fixes implicit + declaration warnings. + + * findexec.c (linux): Adding "#include " fixes implicit + declaration warnings. + +2007-07-19 Aubrey Jaffer + + * dynl.c (l_dyn_main_call): Removed const from argv. + + * rope.c, scm.h (must_free_argv): Removed `const's from argv. + +2007-07-16 Aubrey Jaffer + + * Makefile (udscm5): strip udscm5. + + * scmfig.h: __FreeBSD__ now includes . + +2007-07-15 Aubrey Jaffer + + * sys.c (prinport): Don't choke if ttyname returns NULL. + +2007-06-18 Aubrey Jaffer + + * subr.c (scm_bitwise_bit_count): Added; returns negative integer + for negative input. + +2007-06-08 Aubrey Jaffer + + * Makefile: Changed to use "mkdir -p". + +2007-05-31 Aubrey Jaffer + + * ramap.c (scm_array_index_for_each): Added. + +2007-04-28 Aubrey Jaffer + + * Makefile (gdb.opt): Clear when copying from udscm5.opt. + (scm.html, hobbit.html): Make in unix for w32install because MinGW + chokes on @syncodeindex. + +2007-04-19 Aubrey Jaffer + + * scm.texi: Don't break @ref fields over lines. + +2007-04-19 Jerry van Dijk + + * scm.nsi: Added "scmhob.scm". + +2007-04-16 Aubrey Jaffer + + * repl.c (scm_write): Renamed from lwrite. + (scm_display): Renamed from display. + (scm_newline): Renamed from newline. + (scm_write_char): Renamed from write_char. + (scm_peek_char): Renamed from peek_char. + + * Makefile (udgdbscm, gdbscm): Added dependencies. + +2007-04-15 Aubrey Jaffer + + * sys.c (sysputs): Don't lfflush cur_errp. + (sysflush): Removed call to syswrite() which doesn't flush. + + * scm.c (process_signals): Don't lfflush. + + * sys.c (marksafep, syswrite): Internal calls to lflush replaced + by conditioned calls to lfflush. + + * repl.c (scm_force_output): Renamed from lflush. + Internal calls replaced by conditioned calls to lfflush. + +2007-04-14 Aubrey Jaffer + + * Makefile (udscm5): Depends on ufiles. + (ufiles): Moved earlier in file so dependencies work. + +2007-03-28 Aubrey Jaffer + + * build.scm (build): atari.st --> atari-st. + +2007-03-27 Aubrey Jaffer + + * Makefile (gw32scmwb.sh, scm.exe): Run in MinGW MSYS. + +2007-03-26 Aubrey Jaffer + + * Transcen.scm: Provide math-real and srfi-94. + + * Makefile ($(DOSCM)dist/scm$(VERSION).zip): Don't fail if there + is nothing to be updated in zip file. + +2007-03-25 Aubrey Jaffer + + * build.scm (wb): Trailing "/" on -I ../scm/ choked MinGW. + + * Makefile (gw32scmwb.sh): Added target for GNU-Win32 compilation. + (mfiles): Added "scm.nsi". + + * build.scm (wb): wb/ent.c --> wb/ents.c. + +2007-03-24 Aubrey Jaffer + + * indexes.texi: Made like SLIB's; doesn't choke makeinfo --html. + +2007-03-09 Aubrey Jaffer + + * r4rstest.scm (5 2 1): Added tests for top-level define scope + violation (Kawa). + +2007-03-05 Jerry van Dijk + + * Makefile (w32install): Added target. + + * make-scm-msys.sh: Compile script for MS-Windows. + + * scm.nsi: NSIS Windows installer script. + +2007-01-06 Aubrey Jaffer + + * build.scm (byte-number): Added feature. + + * mkimpcat.scm (byte-number): Added. + + * Makefile (cfiles, mydlls): Added bytenumb.c. + (bytenumb.so): Added. + + * bytenumb.c: Byte/integer and byte/IEEE-floating-point + conversions. + +2007-01-03 Aubrey Jaffer + + * rope.c (scm_addr, scm_base_addr): Added const to s_name arg. + +2006-11-24 Aubrey Jaffer + + * Init5e3.scm, scm.1, scm.doc, scm.texi (--no-symbol-case-fold): + Added command-line option. + +2006-11-22 Aubrey Jaffer + + * repl.c: Prefixed lread* functions with scm_ (like Guile). + (scm_iprin1): Don't slashify capitals if case_sensitize_symbols. + (scm_read_token): Don't downcase if case_sensitize_symbols. + + * scm.c (case_sensitize_symbols): Added variable. + (scm_init_from_argv): Set case_sensitize_symbols (to 8) if option + "--no-symbol-case-fold" given. + + * x.c, unif.c, sys.c, socket.c, scm.h, scl.c, rgx.c, record.c, + hobbit.scm, .gdbinit, eval.c, dynl.c, debug.c: Prefixed ipr* + functions with scm_ (like Guile). + +2006-10-28 Aubrey Jaffer + + * build.scm (C-libraries): Regularized lib-path field. + (make-defaulting-platform-lookup): Default to OS before *unknown*. + + * Makefile (scm5, udscm4, udscm5): Don't fail deleting *.o files. + 2006-10-21 Aubrey Jaffer * patchlvl.h (SCMVERSION): Bumped from 5e2 to 5e3. diff --git a/Idiffer.scm b/Idiffer.scm index ee36485..58373f9 100644 --- a/Idiffer.scm +++ b/Idiffer.scm @@ -83,22 +83,21 @@ (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 est (diff:edit-length A B (if (null? p-lim) -1 (car p-lim)))) + (and est + (let ((CCRR (make-array (A:fixZ32b) (* 2 (+ (max M N) 1)))) + (edits (make-array (A:fixZ32b) est))) + (define fp (make-array (A:fixZ32b) + (+ (max (- N (quotient M 2)) + (- M (quotient N 2))) + (- est (abs (- N M))) ; 2 * p-lim + 3))) + (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))) diff --git a/Iedline.scm b/Iedline.scm index 1d49559..e25c1c0 100644 --- a/Iedline.scm +++ b/Iedline.scm @@ -77,7 +77,7 @@ (tail (read-char strp))) str))))) #f) - OPEN_BOTH))) + open_both))) (define line-editing (let ((edit-port #f) diff --git a/Init5e3.scm b/Init5e3.scm deleted file mode 100644 index 305cea0..0000000 --- a/Init5e3.scm +++ /dev/null @@ -1,1631 +0,0 @@ -;; Copyright (C) 1991-2006 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) "5e3") -(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))))))) - -(define slib: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-23 srfi-94 - srfi-60) ;logical - (if (defined? *features*) *features* slib:features))) -(if (defined? *features*) (set! *features* slib: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 #\space 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 #\space 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 #\space)) 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 #\space) "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 #\space) - "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) - -(if (not (defined? getpw)) - (define read-line - (if (defined? read-line) - read-line - (lambda port - (let* ((chr (apply read-char port))) - (if (eof-object? chr) - chr - (do ((chr chr (apply read-char port)) - (clist '() (cons chr clist))) - ((or (eof-object? chr) (char=? #\newline chr)) - (list->string (reverse clist)))))))))) -(if (not (defined? getpw)) - (define string-index - (if (defined? string-index) - string-index - (lambda (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))))))) - -(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) - (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")))) - -;;; Redefine to ease transition from *features* to slib:features. -(define (provide feature) - (cond ((not (memq feature slib:features)) - (set! slib:features (cons feature slib:features)) - (if (defined? *features*) (set! *features* slib:features))))) - -(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) - (if (defined? *features*) (set! slib:features *features*))) - (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 #\space) (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 #\space cep) (write x cep)) - (cdr args)))) - (newline cep) - (cond ((stack-trace) (newline cep))) - (display " * Breakpoint established: (continue ) to return." cep) - (newline cep) (force-output cep) - (require 'debug) (apply breakpoint args)) - (lambda () (set! error nerror)))))) - nerror)) - -(define (user-interrupt . args) - (define cep (current-error-port)) - (newline cep) - (if (defined? print-call-stack) - (print-call-stack cep)) - (display "ERROR: user interrupt" cep) - (newline cep) - (cond ((stack-trace) (newline cep))) - (display " * Breakpoint established: (continue ) to return." cep) - (newline cep) (force-output cep) - (require 'debug) (apply breakpoint args)) - )) - -(cond ((and (inexact? (string->number "0.0")) (not (defined? exp))) - (or (and (defined? usr:lib) - (usr:lib "m") - (load (in-vicinity (implementation-vicinity) "Transcen") - (usr:lib "m"))) - (load (in-vicinity (implementation-vicinity) "Transcen")))) - (else - (define (infinite? z) #f) - (define finite? number?) - (define inexact->exact identity) - (define exact->inexact identity) - (define round->exact identity) - (define floor->exact identity) - (define ceiling->exact identity) - (define truncate->exact identity) - (define expt integer-expt))) - -(define (numerator q) - (if (not (rational? q)) (error 'numerator q)) - (do ((num q (* 2 num))) - ((integer? num) num))) - -(define (denominator q) - (if (not (rational? q)) (error 'denominator q)) - (do ((num q (* 2 num)) - (den (- q q -1) (* 2 den))) - ((integer? num) den))) -;@ -(define (integer-log base k) - (define (ilog m b k) - (cond ((< k b) k) - (else - (set! n (+ n m)) - (let ((q (ilog (+ m m) (* b b) (quotient k b)))) - (cond ((< q b) q) - (else (set! n (+ m n)) - (quotient q b))))))) - (define n 1) - (define (eigt? k j) (and (exact? k) (integer? k) (> k j))) - (cond ((not (and (eigt? base 1) (eigt? k 0))) - (slib:error 'integer-log base k)) - ((< k base) 0) - (else (ilog 1 base (quotient k base)) n))) - -;;;; http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/math/isqrt/isqrt.txt -;;; Akira Kurihara -;;; School of Mathematics -;;; Japan Women's University -;@ -(define integer-sqrt - (let ((table '#(0 - 1 1 1 - 2 2 2 2 2 - 3 3 3 3 3 3 3 - 4 4 4 4 4 4 4 4 4)) - (square (lambda (x) (* x x)))) - (lambda (n) - (define (isqrt n) - (if (> n 24) - (let* ((len/4 (quotient (- (integer-length n) 1) 4)) - (top (isqrt (ash n (* -2 len/4)))) - (init (ash top len/4)) - (q (quotient n init)) - (iter (quotient (+ init q) 2))) - (cond ((odd? q) iter) - ((< (remainder n init) (square (- iter init))) (- iter 1)) - (else iter))) - (vector-ref table n))) - (if (and (exact? n) (integer? n) (not (negative? n))) - (isqrt n) - (type-error 'integer-sqrt n))))) - -(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) - (if (defined? *features*) (set! slib:features *features*)) - (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 *script* - (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 #\space)) - (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/Init5e4.scm b/Init5e4.scm new file mode 100644 index 0000000..bd5874f --- /dev/null +++ b/Init5e4.scm @@ -0,0 +1,1643 @@ +;; Copyright (C) 1991-2006 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) "5e4") +(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))))))) + +(define slib: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 + math-integer ;math-real and srfi-94 provided in "Transcen.scm" + vicinity srfi-59 srfi-23 + srfi-60) ;logical + (if (defined? *features*) *features* slib:features))) +(if (defined? *features*) (set! *features* slib: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)))))))))) + +(if (not (defined? file-position)) +(define (file-position . args) #f)) +(if (not (defined? file-set-position)) +(define file-set-position file-position)) + +(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 #\space 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 #\space 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 #\space)) 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 #\space) "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 #\space) + "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) + +(if (not (defined? getpw)) + (define read-line + (if (defined? read-line) + read-line + (lambda port + (let* ((chr (apply read-char port))) + (if (eof-object? chr) + chr + (do ((chr chr (apply read-char port)) + (clist '() (cons chr clist))) + ((or (eof-object? chr) (char=? #\newline chr)) + (list->string (reverse clist)))))))))) +(if (not (defined? getpw)) + (define string-index + (if (defined? string-index) + string-index + (lambda (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))))))) + +(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) + (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) + (fluid-let ((*load-reader* *slib-load-reader*)) + (scm:load-source file))) +(define (slib:load file . libs) + (fluid-let ((*load-reader* *slib-load-reader*)) + (apply scm:load file libs))) + +;;; 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")))) + +;;; Redefine to ease transition from *features* to slib:features. +(define (provide feature) + (cond ((not (memq feature slib:features)) + (set! slib:features (cons feature slib:features)) + (if (defined? *features*) (set! *features* slib:features))))) + +(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) + (if (defined? *features*) (set! slib:features *features*))) + (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 +;;BITWISE-BIT-COUNT returns negative count for negative inputs. +(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 #\space) (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 #\space cep) (write x cep)) + (cdr args)))) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue ) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + (lambda () (set! error nerror)))))) + nerror)) + +(define (user-interrupt . args) + (define cep (current-error-port)) + (newline cep) + (if (defined? print-call-stack) + (print-call-stack cep)) + (display "ERROR: user interrupt" cep) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue ) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + )) + +(cond ((and (inexact? (string->number "0.0")) (not (defined? exp))) + (or (and (defined? usr:lib) + (usr:lib "m") + (load (in-vicinity (implementation-vicinity) "Transcen") + (usr:lib "m"))) + (load (in-vicinity (implementation-vicinity) "Transcen")))) + (else + (define (infinite? z) #f) + (define finite? number?) + (define inexact->exact identity) + (define exact->inexact identity) + (define round->exact identity) + (define floor->exact identity) + (define ceiling->exact identity) + (define truncate->exact identity) + (define expt integer-expt))) + +(define (numerator q) + (if (not (rational? q)) (error 'numerator q)) + (do ((num q (* 2 num))) + ((integer? num) num))) + +(define (denominator q) + (if (not (rational? q)) (error 'denominator q)) + (do ((num q (* 2 num)) + (den (- q q -1) (* 2 den))) + ((integer? num) den))) +;@ +(define (integer-log base k) + (define (ilog m b k) + (cond ((< k b) k) + (else + (set! n (+ n m)) + (let ((q (ilog (+ m m) (* b b) (quotient k b)))) + (cond ((< q b) q) + (else (set! n (+ m n)) + (quotient q b))))))) + (define n 1) + (define (eigt? k j) (and (exact? k) (integer? k) (> k j))) + (cond ((not (and (eigt? base 1) (eigt? k 0))) + (slib:error 'integer-log base k)) + ((< k base) 0) + (else (ilog 1 base (quotient k base)) n))) + +;;;; http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/math/isqrt/isqrt.txt +;;; Akira Kurihara +;;; School of Mathematics +;;; Japan Women's University +;@ +(define integer-sqrt + (let ((table '#(0 + 1 1 1 + 2 2 2 2 2 + 3 3 3 3 3 3 3 + 4 4 4 4 4 4 4 4 4)) + (square (lambda (x) (* x x)))) + (lambda (n) + (define (isqrt n) + (if (> n 24) + (let* ((len/4 (quotient (- (integer-length n) 1) 4)) + (top (isqrt (ash n (* -2 len/4)))) + (init (ash top len/4)) + (q (quotient n init)) + (iter (quotient (+ init q) 2))) + (cond ((odd? q) iter) + ((< (remainder n init) (square (- iter init))) (- iter 1)) + (else iter))) + (vector-ref table n))) + (if (and (exact? n) (integer? n) (not (negative? n))) + (isqrt n) + (slib:error 'integer-sqrt n))))) + +(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) + (if (defined? *features*) (set! slib:features *features*)) + (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 *script* + (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-symbol-case-fold" + "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 #\space)) + (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-symbol-case-fold => symbols preserve character case + ;; -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=? "no-symbol-case-fold" option)) + ((string-ci=? "version" option) + (display + (string-append exe-name " " + (scheme-implementation-version) + " +Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. +" + up-name + " may be distributed under the terms of" + " the GNU General Public Licence; +certain other uses are permitted as well." + " For details, see the file `COPYING', +which is included in the " + up-name " distribution. +There is no warranty, to the extent permitted by law. +" + )) + (cond ((execpath) => + (lambda (path) + (display " This executable was loaded from ") + (write path) + (newline)))) + (quit #t)) + ((string-ci=? "help" option) + (usage "This is " + up-name + ", a Scheme interpreter." + (let ((sihp (scheme-implementation-home-page))) + (if sihp + (string-append "Latest info: " sihp " +") + ""))) + (quit #t)) + (else #f)) + (usage "scm: unknown option `--" option "'" #f)))) + + (cond ((and moreopts (< *optind* (length *argv*))) + (loop (getopt-- opts))) + ((< *optind* (length *argv*)) ;No more opts + (set! *argv* (list-tail *argv* *optind*)) + (set! *optind* 1) + (cond ((and (not didsomething) *script*) + (do-load *script*) + (set! *optind* (+ 1 *optind*)))) + (cond ((and (> (verbose) 2) + (not (= (+ -1 *optind*) (length *argv*)))) + (display "scm: extra command arguments unused:" + (current-error-port)) + (for-each (lambda (x) (display (string-append " " x) + (current-error-port))) + (list-tail *argv* (+ -1 *optind*))) + (newline (current-error-port))))) + ((and (not didsomething) (= *optind* (length *argv*))) + (set! *interactive* #t))))) + + (cond ((not *interactive*) (quit)) + ((and *syntax-rules* (not (provided? 'macro))) + (require 'repl) + (require 'macro) + (let* ((oquit quit)) + (set! quit (lambda () (repl:quit))) + (set! exit quit) + (repl:top-level macro:eval) + (oquit)))) + ;;otherwise, fall into natural SCM repl. + ) + (else (errno 0) + (set! *interactive* #t) + (for-each load (cdr (program-arguments)))))) diff --git a/Makefile b/Makefile index 76d3c99..1f01857 100644 --- a/Makefile +++ b/Makefile @@ -55,7 +55,7 @@ SHOBJS = *.so #BUILD = ./build -hsystem -p svr4-gcc-sun-ld BUILD = ./build -hsystem -# Workaround for unexec on Fedora Core 1 Linux i386 +# Workaround for unexec on Fedora Core 1 GNU/Linux i386 #SETARCH = setarch i386 # http://jamesthornton.com/writing/emacs-compile.html @@ -104,7 +104,13 @@ hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h cfiles = scmmain.c scm.c time.c repl.c ioext.c scl.c sys.c eval.c \ subr.c sc2.c unif.c rgx.c crs.c dynl.c record.c posix.c socket.c\ unix.c rope.c ramap.c gsubr.c edline.c continue.c \ - findexec.c script.c debug.c byte.c differ.c + findexec.c script.c debug.c byte.c bytenumb.c differ.c +ufiles = pre-crt0.c ecrt0.c gmalloc.c unexec.c unexelf.c unexhp9k800.c \ + unexsunos4.c unexalpha.c unexsgi.c +# cxux-crt0.s ecrt0.c gmalloc.c pre-crt0.c unexaix.c unexalpha.c \ +# unexapollo.c unexconvex.c unexec.c unexelf.c unexelf1.c \ +# unexencap.c unexenix.c unexfx2800.c unexhp9k800.c unexmips.c \ +# unexnext.c unexnt.c unexsgi.c unexsni.c unexsunos4.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 # continue-ia64.o @@ -161,6 +167,16 @@ scm: scmlit $(BUILD) -s $(IMPLPATH) -F cautious bignums arrays # i/o-extensions $(MAKE) check +# R4RS interpreter (not dumpable) +scm4.opt: + echo "-F cautious bignums arrays inexact" >> scm4.opt + echo "-F engineering-notation dynamic-linking" >> scm4.opt +# if type gcc; then echo "--compiler-options=\"-fno-guess-branch-probability\"" >> scm4.opt; fi +scm4: $(cfiles) $(hfiles) build.scm build scm4.opt + $(BUILD) -f scm4.opt -o scm -s $(IMPLPATH) + -rm $(ofiles) scmmain.o + -$(MAKE) check + # R5RS interpreter (not dumpable) scm5.opt: echo "-F cautious bignums arrays inexact" >> scm5.opt @@ -169,7 +185,7 @@ scm5.opt: # if type gcc; then echo "--compiler-options=\"-fno-guess-branch-probability\"" >> scm5.opt; fi scm5: $(cfiles) $(hfiles) build.scm build scm5.opt $(BUILD) -f scm5.opt -o scm -s $(IMPLPATH) - rm $(ofiles) scmmain.o + -rm $(ofiles) scmmain.o -$(MAKE) check -$(MAKE) checkmacro @@ -180,7 +196,7 @@ udscm4.opt: # if type gcc; then echo "--compiler-options=\"-fno-guess-branch-probability\"" >> udscm4.opt; fi udscm4: $(cfiles) $(hfiles) build.scm build udscm4.opt $(BUILD) -f udscm4.opt -o udscm4 -s $(IMPLPATH) - rm $(ofiles) scmmain.o + -rm $(ofiles) scmmain.o dscm4: udscm4 $(ifiles) require.scm if [ -f /proc/sys/kernel/randomize_va_space -a\ "`cat /proc/sys/kernel/randomize_va_space`" != "0" ]; then {\ @@ -200,9 +216,10 @@ udscm5.opt: $(MAKE) udscm4.opt cat udscm4.opt >> udscm5.opt echo "-F macro" >> udscm5.opt -udscm5: $(cfiles) $(hfiles) build.scm build udscm5.opt +udscm5: $(cfiles) $(ufiles) $(hfiles) build.scm build udscm5.opt $(BUILD) -f udscm5.opt -o udscm5 -s $(IMPLPATH) - rm $(ofiles) scmmain.o + -rm $(ofiles) scmmain.o + strip udscm5 dscm5: udscm5 $(ifiles) require.scm if [ -f /proc/sys/kernel/randomize_va_space -a\ "`cat /proc/sys/kernel/randomize_va_space`" != "0" ]; then {\ @@ -221,15 +238,15 @@ dscm5: udscm5 $(ifiles) require.scm # R5RS interpreter for debugging with GDB. gdb.opt: udscm5.opt - cat udscm5.opt >> gdb.opt + cat udscm5.opt > gdb.opt echo "-F debug" >> gdb.opt echo "--compiler-options=-Wall" >> gdb.opt echo "--linker-options=-Wall" >> gdb.opt echo "-D NO_ENV_CACHE" >> gdb.opt # echo "-DTEST_FARLOC -DTEST_SCM2PTR" >> gdb.opt -udgdbscm: gdb.opt +udgdbscm: gdb.opt $(cfiles) $(ufiles) $(hfiles) build.scm build $(BUILD) -f gdb.opt -o udgdbscm -s $(IMPLPATH) -gdbscm: udgdbscm +gdbscm: udgdbscm $(ifiles) require.scm echo "(quit)" | $(SETARCH) ./udgdbscm -no-init-file -r5 -o gdbscm # R4RS interpreter for profiling @@ -259,7 +276,7 @@ libtest: libscm.a libtest.c dlls.opt: echo "--compiler-options=-Wall" >> dlls.opt echo "--linker-options=-Wall" >> dlls.opt -mydlls: dlls.opt +mydlls: dlls.opt bytenumb.so $(BUILD) -t dll -f dlls.opt -c ramap.c $(BUILD) -t dll -f dlls.opt -c record.c $(BUILD) -t dll -f dlls.opt -c gsubr.c @@ -280,6 +297,8 @@ db.so: dlls.opt rwb-isam.scm wbtab.scm if [ -f ../wb/blink.c ]; then \ $(BUILD) -t dll -f dlls.opt -F wb; fi +bytenumb.so: bytenumb.c scm.h Makefile + $(BUILD) -t dll -f dlls.opt -F byte-number inexact bignums differ.so: differ.c $(BUILD) -t dll -f dlls.opt -F differ myturtle: dlls.opt @@ -292,13 +311,13 @@ x.so: x.c x.h xevent.h dlls.opt incdir=/usr/include/ x11.scm: inc2scm rm -f x11.scm - $(SCMLIT) -l inc2scm x11.scm x: $(incdir) X11/X.h X11/cursorfont.h X11/Xlib.h \ + $(SCMLIT) -l inc2scm x11.scm x: $(DESTDIR)$(incdir) X11/X.h X11/cursorfont.h X11/Xlib.h \ X11/Xutil.h keysymdef.scm: inc2scm rm -f keysymdef.scm - $(SCMLIT) -l inc2scm keysymdef.scm x: $(incdir) X11/keysym.h X11/keysymdef.h + $(SCMLIT) -l inc2scm keysymdef.scm x: $(DESTDIR)$(incdir) X11/keysym.h X11/keysymdef.h xevent.h xevent.scm xatoms.scm: xgen.scm Makefile - $(SCMLIT) -l xgen.scm $(incdir)X11/Xlib.h + $(SCMLIT) -l xgen.scm $(DESTDIR)$(incdir)X11/Xlib.h x.h: x.c xevent.h if [ -x "$(CPROTO)" ]; then $(CPROTO) x.c > x.h; fi @@ -306,9 +325,15 @@ x.h: x.c xevent.h checklit: $(SCMLIT) -fr4rstest.scm -e'(test-sc4)(test-delay)(gc)' \ -e '(or (null? errs) (quit 1))' +Checklit: + $(SCMLIT) --no-symbol-case-fold -fr4rstest.scm -e'(test-sc4)(test-delay)(gc)' \ + -e '(or (null? errs) (quit 1))' check: r4rstest.scm $(SCMEXE) -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' \ -e '(or (null? errs) (quit 1))' +Check: r4rstest.scm + $(SCMEXE) --no-symbol-case-fold -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' \ + -e '(or (null? errs) (quit 1))' checkmacro: syntest1.scm syntest2.scm r4rstest.scm $(SCMEXE) -rmacro -fsyntest1.scm -fsyntest2.scm \ -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)' -fsyntest1 \ @@ -355,12 +380,12 @@ implcat: $(SHOBJS) mkimpcat.scm htmldir=../public_html/ dvi: scm.dvi Xlibscm.dvi hobbit.dvi -scm.dvi: version.txi scm.texi platform.txi features.txi Makefile - texi2dvi -b -c $(srcdir)scm.texi +scm.dvi: version.txi scm.texi indexes.texi platform.txi features.txi Makefile + texi2dvi -b -c scm.texi Xlibscm.dvi: version.txi Xlibscm.texi Makefile - texi2dvi -b -c $(srcdir)Xlibscm.texi + texi2dvi -b -c Xlibscm.texi hobbit.dvi: version.txi hobbit.texi Makefile - texi2dvi -b -c $(srcdir)hobbit.texi + texi2dvi -b -c hobbit.texi xdvi: scm.dvi xdvi scm.dvi Xdvi: Xlibscm.dvi @@ -369,14 +394,14 @@ hobdvi: hobbit.dvi xdvi hobbit.dvi pdf: $(htmldir)scm.pdf $(htmldir)Xlibscm.pdf $(htmldir)hobbit.pdf -$(htmldir)scm.pdf: version.txi scm.texi platform.txi features.txi Makefile - texi2pdf -b -c $(srcdir)scm.texi +$(htmldir)scm.pdf: version.txi scm.texi indexes.texi platform.txi features.txi Makefile + texi2pdf -b -c scm.texi mv scm.pdf $(htmldir) $(htmldir)Xlibscm.pdf: version.txi Xlibscm.texi Makefile - texi2pdf -b -c $(srcdir)Xlibscm.texi + texi2pdf -b -c Xlibscm.texi mv Xlibscm.pdf $(htmldir) $(htmldir)hobbit.pdf: version.txi hobbit.texi Makefile - texi2pdf -b -c $(srcdir)hobbit.texi + texi2pdf -b -c hobbit.texi mv hobbit.pdf $(htmldir) xpdf: $(htmldir)scm.pdf xpdf $(htmldir)scm.pdf @@ -389,7 +414,7 @@ PREVDOCS = prevdocs/ html: $(htmldir)scm_toc.html $(htmldir)Xlibscm_toc.html $(htmldir)hobbit_toc.html TEXI2HTML = /usr/local/bin/texi2html -split -verbose -scm_toc.html: version.txi scm.texi platform.txi features.txi +scm_toc.html: version.txi scm.texi indexes.texi platform.txi features.txi ${TEXI2HTML} scm.texi Xlibscm_toc.html: version.txi Xlibscm.texi ${TEXI2HTML} Xlibscm.texi @@ -409,7 +434,7 @@ $(htmldir)hobbit_toc.html: hobbit_toc.html Makefile cp hobbit_*.html $(htmldir) $(PREVDOCS)scm_toc.html: -$(PREVDOCS)scm.info: srcdir.mk Makefile +$(PREVDOCS)scm.info: Makefile cd $(PREVDOCS); unzip -a $(dest)scm*.zip rm $(PREVDOCS)scm/scm.info cd $(PREVDOCS)scm; make scm.info; make scm_toc.html @@ -435,92 +460,116 @@ includedir = $(prefix)include/ README: build build.scm scm.info $(SCMEXE) -l build -e"(make-readme)" -info: installinfo -installinfo: $(infodir)scm.info $(infodir)Xlibscm.info $(infodir)hobbit.info - platform.txi: build.scm $(SCMLIT) -r database-browse -l build.scm -e "(browse build 'platform)" \ > platform.txi features.txi: build build.scm $(SCMLIT) -l build -e"(make-features-txi)" -scm.info: version.txi scm.texi platform.txi features.txi +scm.info: version.txi scm.texi indexes.texi platform.txi features.txi makeinfo scm.texi --no-split -o scm.info mv scm.info scm$(VERSION).info if [ -f $(PREVDOCS)scm.info ]; \ then infobar $(PREVDOCS)scm.info scm$(VERSION).info scm.info; \ else cp scm$(VERSION).info scm.info; fi -$(infodir)scm.info: scm.info - cp -p scm.info $(infodir)scm.info - -install-info $(infodir)scm.info $(infodir)dir - -rm $(infodir)scm.info.gz +$(DESTDIR)$(infodir)scm.info: scm.info + mkdir -p $(DESTDIR)$(infodir) + cp -p scm.info $(DESTDIR)$(infodir)scm.info + -install-info $(DESTDIR)$(infodir)scm.info $(DESTDIR)$(infodir)dir + -rm $(DESTDIR)$(infodir)scm.info.gz Xlibscm.info: version.txi Xlibscm.texi makeinfo Xlibscm.texi --no-split -o Xlibscm.info -$(infodir)Xlibscm.info: Xlibscm.info - cp Xlibscm.info $(infodir)Xlibscm.info - -install-info $(infodir)Xlibscm.info $(infodir)dir - -rm $(infodir)Xlibscm.info*.gz +$(DESTDIR)$(infodir)Xlibscm.info: Xlibscm.info + mkdir -p $(DESTDIR)$(infodir) + cp Xlibscm.info $(DESTDIR)$(infodir)Xlibscm.info + -install-info $(DESTDIR)$(infodir)Xlibscm.info $(DESTDIR)$(infodir)dir + -rm $(DESTDIR)$(infodir)Xlibscm.info*.gz hobbit.info: version.txi hobbit.texi makeinfo hobbit.texi --no-split -o hobbit.info -$(infodir)hobbit.info: hobbit.info - cp hobbit.info $(infodir)hobbit.info - -install-info $(infodir)hobbit.info $(infodir)dir - -rm $(infodir)hobbit.info*.gz +$(DESTDIR)$(infodir)hobbit.info: hobbit.info + mkdir -p $(DESTDIR)$(infodir) + cp hobbit.info $(DESTDIR)$(infodir)hobbit.info + -install-info $(DESTDIR)$(infodir)hobbit.info $(DESTDIR)$(infodir)dir + -rm $(DESTDIR)$(infodir)hobbit.info*.gz + +info: installinfo +installinfo: $(DESTDIR)$(infodir)scm.info $(DESTDIR)$(infodir)Xlibscm.info $(DESTDIR)$(infodir)hobbit.info infoz: installinfoz -installinfoz: $(infodir)scm.info.gz $(infodir)Xlibscm.info.gz $(infodir)hobbit.info.gz -$(infodir)scm.info.gz: $(infodir)scm.info - gzip -f $(infodir)scm.info -$(infodir)Xlibscm.info.gz: $(infodir)Xlibscm.info - gzip -f $(infodir)Xlibscm.info -$(infodir)hobbit.info.gz: $(infodir)hobbit.info - gzip -f $(infodir)hobbit.info - -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) - -cp scm scmlit $(bindir) - -strip $(bindir)scmlit - -cp scm.1 $(man1dir) - test -d $(libdir) || mkdir $(libdir) - test -d $(libscmdir) || mkdir $(libscmdir) - -cp $(ifiles) $(hobfiles) COPYING r4rstest.scm $(libscmdir) - test -f $(libscmdir)require.scm || \ - cp requires.scm $(libscmdir)require.scm +installinfoz: $(DESTDIR)$(infodir)scm.info.gz $(DESTDIR)$(infodir)Xlibscm.info.gz $(DESTDIR)$(infodir)hobbit.info.gz +$(DESTDIR)$(infodir)scm.info.gz: $(DESTDIR)$(infodir)scm.info + gzip -f $(DESTDIR)$(infodir)scm.info +$(DESTDIR)$(infodir)Xlibscm.info.gz: $(DESTDIR)$(infodir)Xlibscm.info + gzip -f $(DESTDIR)$(infodir)Xlibscm.info +$(DESTDIR)$(infodir)hobbit.info.gz: $(DESTDIR)$(infodir)hobbit.info + gzip -f $(DESTDIR)$(infodir)hobbit.info + +install: scm.1 + test -d $(DESTDIR)$(bindir) || mkdir $(DESTDIR)$(bindir) + test -d $(DESTDIR)$(mandir) || mkdir $(DESTDIR)$(mandir) + test -d $(DESTDIR)$(man1dir) || mkdir $(DESTDIR)$(man1dir) + -cp scm scmlit $(DESTDIR)$(bindir) + -strip $(DESTDIR)$(bindir)scmlit + -cp scm.1 $(DESTDIR)$(man1dir) + test -d $(DESTDIR)$(libdir) || mkdir $(DESTDIR)$(libdir) + test -d $(DESTDIR)$(libscmdir) || mkdir $(DESTDIR)$(libscmdir) + -cp $(ifiles) $(hobfiles) COPYING r4rstest.scm $(DESTDIR)$(libscmdir) + test -f $(DESTDIR)$(libscmdir)require.scm || \ + cp requires.scm $(DESTDIR)$(libscmdir)require.scm -cp build build.scm mkimpcat.scm Iedline.scm $(SHOBJS) patchlvl.h\ - $(xafiles) $(libscmdir) - -cp db.so wbtab.scm rwb-isam.scm $(libscmdir) + $(xafiles) $(DESTDIR)$(libscmdir) + -cp db.so wbtab.scm rwb-isam.scm $(DESTDIR)$(libscmdir) + -cp libscm.dylib $(DESTDIR)$(libdir) installlib: - test -d $(includedir) || mkdir $(includedir) - cp scm.h scmfig.h scmflags.h $(includedir) - test -d $(libdir) || mkdir $(libdir) - cp libscm.a $(libdir)libscm.a + test -d $(DESTDIR)$(includedir) || mkdir $(DESTDIR)$(includedir) + cp scm.h scmfig.h scmflags.h $(DESTDIR)$(includedir) + test -d $(DESTDIR)$(libdir) || mkdir $(DESTDIR)$(libdir) + cp libscm.a $(DESTDIR)$(libdir)libscm.a uninstall: - -rm $(bindir)scm $(bindir)scmlit - -rm $(man1dir)scm.1 - -rm $(includedir)scm.h $(includedir)scmfig.h $(includedir)scmflags.h - -rm $(libdir)libscm.a - -(cd $(libscmdir); rm $(ifiles) $(hobfiles) COPYING r4rstest.scm) - -(cd $(libscmdir); rm build build.scm mkimpcat.scm \ + -rm $(DESTDIR)$(bindir)scm $(DESTDIR)$(bindir)scmlit + -rm $(DESTDIR)$(man1dir)scm.1 + -rm $(DESTDIR)$(includedir)scm.h $(DESTDIR)$(includedir)scmfig.h $(DESTDIR)$(includedir)scmflags.h + -rm $(DESTDIR)$(libdir)libscm.a + -(cd $(DESTDIR)$(libscmdir); rm $(ifiles) $(hobfiles) COPYING r4rstest.scm) + -(cd $(DESTDIR)$(libscmdir); rm build build.scm mkimpcat.scm \ $(SHOBJS) patchlvl.h $(xafiles)) - -(cd $(libscmdir); rm db.so wbtab.scm rwb-isam.scm require.scm) + -(cd $(DESTDIR)$(libscmdir); rm db.so wbtab.scm rwb-isam.scm require.scm) uninstallinfo: - -rm $(infodir)scm.info.gz $(infodir)Xlibscm.info.gz\ - $(infodir)hobbit.info.gz + -rm $(DESTDIR)$(infodir)scm.info.gz $(DESTDIR)$(infodir)Xlibscm.info.gz\ + $(DESTDIR)$(infodir)hobbit.info.gz scm.doc: scm.1 nroff -man $< | ul -tunknown >$@ -docs: $(infodir)scm.info.gz $(htmldir)scm_toc.html scm.doc \ +docs: $(DESTDIR)$(infodir)scm.info.gz $(htmldir)scm_toc.html scm.doc \ scm.dvi Xlibscm.dvi hobbit.dvi \ $(htmldir)scm.pdf $(htmldir)Xlibscm.pdf $(htmldir)hobbit.pdf xdvi -s 4 scm.dvi +winscm5.opt: + echo "-F arrays array-for-each byte i/o-extensions" >> winscm5.opt + echo "-F bignums inexact engineering-notation" >> winscm5.opt + echo "-F cautious rev2-procedures macro" >> winscm5.opt + echo "-F wb" >> winscm5.opt +gw32scmwb.sh: winscm5.opt build.scm Makefile version.txi scmlit + ./build -p gnu-win32 -f winscm5.opt -w gw32scmwb.sh +scm.exe: gw32scmwb.sh + ./gw32scmwb.sh + +hobbit.html: hobbit.texi + makeinfo --html --no-split --no-warn hobbit.texi +scm.html: scm.texi + makeinfo --html --no-split --no-warn --force scm.texi + +## to build a windows installer +## make sure makeinfo and NSIS are available on the commandline +w32install: scm.exe hobbit.html scm.html + makensis scm.nsi + #### Stuff for maintaining SCM below #### ver = $(VERSION) @@ -529,13 +578,6 @@ version.txi: patchlvl.h echo @set SCMDATE `date +"%B %Y"` >> version.txi RM_R = rm -rf -ufiles = pre-crt0.c ecrt0.c gmalloc.c unexec.c unexelf.c unexhp9k800.c \ - unexsunos4.c unexalpha.c unexsgi.c - -# cxux-crt0.s ecrt0.c gmalloc.c pre-crt0.c unexaix.c unexalpha.c \ -# unexapollo.c unexconvex.c unexec.c unexelf.c unexelf1.c \ -# unexencap.c unexenix.c unexfx2800.c unexhp9k800.c unexmips.c \ -# unexnext.c unexnt.c unexsgi.c unexsni.c unexsunos4.c confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \ configure configure.in Makefile.in COPYING README.unix @@ -543,10 +585,10 @@ confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \ tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm \ syntest2.scm syntest1.scm dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \ - scm.info scm.texi Xlibscm.info Xlibscm.texi hobbit.info hobbit.texi \ + scm.info scm.texi indexes.texi Xlibscm.info Xlibscm.texi hobbit.info hobbit.texi \ version.txi platform.txi features.txi ChangeLog mfiles = Makefile build.scm build build.bat requires.scm \ - .gdbinit mkimpcat.scm disarm.scm scm.spec + .gdbinit mkimpcat.scm disarm.scm scm.spec scm.nsi sfiles = setjump.mar setjump.s ugsetjump.s continue-ia64.S \ get-contoffset-ia64.c wbfiles = wbtab.scm rwb-isam.scm @@ -558,35 +600,21 @@ CHPAT=$(HOME)/bin/chpat RSYNC=rsync --rsync-path=bin/rsync -bav UPLOADEE=swissnet_upload dest = $(HOME)/dist/ -DOSCM = /misc/usb1/scm/ +DOSCM = /c/Voluntocracy/dist/ temp/scm: $(afiles) -$(RM_R) temp - mkdir temp - mkdir temp/scm + mkdir -p temp/scm ln $(afiles) temp/scm release: dist pdf # rpm cvs tag -F scm$(VERSION) - cp $(srcdir)ANNOUNCE $(htmldir)SCM_ANNOUNCE.txt + cp ANNOUNCE $(htmldir)SCM_ANNOUNCE.txt $(RSYNC) $(htmldir)SCM.html $(htmldir)SCM_ANNOUNCE.txt $(UPLOADEE):public_html/ $(RSYNC) $(dest)README $(dest)scm$(VERSION).zip \ $(dest)scm-$(VERSION)-$(RELEASE).src.rpm $(dest)scm-$(VERSION)-$(RELEASE).i386.rpm \ $(htmldir)hobbit.pdf $(htmldir)Xlibscm.pdf $(UPLOADEE):dist/ # upload $(dest)README $(dest)scm$(VERSION).zip ftp.gnu.org:gnu/jacal/ -# $(MAKE) indiana -indiana: - upload $(dest)scm$(VERSION).zip ftp@ftp.cs.indiana.edu:/pub/scheme-repository/incoming - echo -e \ - 'I have uploaded scm$(VERSION).zip to ftp.cs.indiana.edu:/pub/scheme-repository/incoming\n' \ - 'for placement into ftp.cs.indiana.edu:/pub/scheme-repository/imp/' \ - | mail -s 'SCM upload' -b jaffer scheme-repository-request@cs.indiana.edu - -postnews: - echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \ - inews -h -O -S \ - -f "announce@voluntocracy.org (Aubrey Jaffer & Radey Shouman)" \ - -t "SCM$(VERSION) Released" -d world upzip: $(HOME)/pub/scm.zip $(RSYNC) $(HOME)/pub/scm.zip $(UPLOADEE):pub/ @@ -615,12 +643,13 @@ scm.com: temp/scm zip: scm.zip scm.zip: temp/scm $(makedev) PROD=scm 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 $(DOSCM)dist/scm$(VERSION).zip scm/scm.info scm/Xlibscm.info scm/hobbit.info +doszip: $(DOSCM)scm$(VERSION).zip +$(DOSCM)scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm SCM.lnk scm.html hobbit.html + $(makedev) DEST=$(DOSCM) PROD=scm ver=$(VERSION) zip + -cd ..; zip -9ur $(DOSCM)scm$(VERSION).zip \ + scm/turtle scm/turtlegr.c scm/grtest.scm scm/SCM.lnk \ + scm/scm.html scm/hobbit.html + zip -d $(DOSCM)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 @@ -637,13 +666,13 @@ CITERS = ANNOUNCE ../jacal/ANNOUNCE \ $(htmldir)SLIB.html $(htmldir)JACAL.html \ $(htmldir)SCM.html $(htmldir)SIMSYNCH.html \ ../jacal/jacal.texi ../wb/wb.texi \ - $(DOSCM)dist/install.bat $(DOSCM)dist/makefile \ - $(DOSCM)dist/mkdisk.bat hobbit.texi hobbit.scm + $(DOSCM)install.bat $(DOSCM)makefile \ + $(DOSCM)mkdisk.bat hobbit.texi hobbit.scm updates: Init$(ver).scm $(CHPAT) scm$(VERSION) scm$(ver) $(CITERS) $(CHPAT) scm-$(VERSION) scm-$(ver) $(CITERS) - $(CHPAT) $(VERSION) $(ver) ../wb/wb.spec $(htmldir)SCM.html scm.spec + $(CHPAT) $(VERSION) $(ver) ../wb/wb.spec $(htmldir)SCM.html scm.spec scm.nsi Init$(ver).scm: mv -f Init$(VERSION).scm Init$(ver).scm @@ -665,8 +694,7 @@ new: updates configtemp/scm: $(confiles) -$(RM_R) configtemp/scm - -mkdir configtemp - mkdir configtemp/scm + -mkdir -p configtemp/scm ln $(confiles) configtemp/scm confdist: scmconfig.tar.gz scmconfig.tar.gz: configtemp/scm @@ -707,7 +735,7 @@ ctags: $(ctagfiles) etags $(ctagfiles) TAGFILES = $(hfiles) $(cfiles) $(ifiles) $(sfiles)\ - version.txi scm.texi Xlibscm.texi hobbit.texi build $(xfiles) $(mfiles)\ + version.txi scm.texi indexes.texi Xlibscm.texi hobbit.texi build $(xfiles) $(mfiles)\ hobbit.scm # # $(ufiles) ChangeLog TAGS: $(TAGFILES) @@ -721,7 +749,7 @@ clean: distclean: clean -rm -f $(EXECFILES) *.o *.obj a.out TAGS implcat slibcat gdbscm realclean: distclean - -rm -f scm.doc + -rm -f scm.doc scm.html hobbit.html scm.exe scmlit.exe scm~ SCM-*.exe realempty: temp/scm -rm -f $(afiles) myclean: clean diff --git a/README b/README index 8266887..7c177fc 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -This directory contains the distribution of scm5e3. Scm conforms to +This directory contains the distribution of scm5e4. 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. @@ -26,6 +26,7 @@ NOS/VE, Unicos, VMS, Unix and similar systems. `build.bat' invokes build.scm for MS-DOS `build.scm' database for compiling and linking new SCM programs. `byte.c' strings as bytes. +`bytenumb.c' Byte-number conversions. `compile.scm' Hobbit compilation to C. `continue-ia64.S'replaces make_root_continuation(), make_continuation(), and dynthrow() in continue.c @@ -107,18 +108,16 @@ SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and install it. Bug reports about running SCM without SLIB have very low priority. SLIB is available from the same sites as SCM: - * swiss.csail.mit.edu:/pub/scm/slib3a4.tar.gz + * swiss.csail.mit.edu:/pub/scm/slib3a5.tar.gz - * ftp.gnu.org:/pub/gnu/jacal/slib3a4.tar.gz + * ftp.gnu.org:/pub/gnu/jacal/slib3a5.tar.gz - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a4.tar.gz - -Unpack SLIB (`tar xzf slib3a4.tar.gz' or `unzip -ao slib3a4.zip') in an +Unpack SLIB (`tar xzf slib3a5.tar.gz' or `unzip -ao slib3a5.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 `Init5e3.scm' is +(this is the same directory as where the file `Init5e4.scm' is installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -149,7 +148,7 @@ File: scm.info, Node: Making SCM, Next: SLIB, Prev: Installing SCM, Up: Inst The SCM distribution has "Makefile" which contains rules for making "scmlit", a "bare-bones" version of SCM sufficient for running `build'. `build' is used to compile (or create scripts to compile) full -featured versions. +featured versions (*note Building SCM::). 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 @@ -283,17 +282,17 @@ remove in scmfig.h and Do so and recompile files. recompile scm. add in scmfig.h and recompile scm. -ERROR: Init5e3.scm not found. Assign correct IMPLINIT in makefile +ERROR: Init5e4.scm not found. Assign correct IMPLINIT in makefile or scmfig.h. Define environment variable SCM_INIT_PATH to be the full - pathname of Init5e3.scm. + pathname of Init5e4.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 - Init5e3.scm to point to library or + Init5e4.scm to point to library or remove. Make sure the value of (library-vicinity) has a trailing @@ -354,7 +353,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. `Init5e3.scm'). +output files. `Init5e4.scm'). Spaces or control characters appear Check character defines in in symbol names. `scmfig.h'. Negative numbers turn positive. Check SRS in `scmfig.h'. diff --git a/Transcen.scm b/Transcen.scm index fe0330d..ad42140 100644 --- a/Transcen.scm +++ b/Transcen.scm @@ -209,3 +209,6 @@ (define (infinite? z) (and (= z (* 2 z)) (not (zero? z)))) (define (finite? z) (not (infinite? z))) + +(provide 'math-real) +(provide 'srfi-94) diff --git a/Xlibscm.info b/Xlibscm.info index 606fe3a..76b614a 100644 --- a/Xlibscm.info +++ b/Xlibscm.info @@ -2,7 +2,7 @@ This is Xlibscm.info, produced by makeinfo version 4.8 from Xlibscm.texi. This manual documents the X Interface for SCM Language (version -5e3, October 2006). +5e4, November 2007). Copyright (C) 1999 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ XlibScm ******* This manual documents the X Interface for SCM Language (version -5e3, October 2006). +5e4, November 2007). Copyright (C) 1999 Free Software Foundation, Inc. @@ -1417,7 +1417,7 @@ blue intensities respectively. The integers are in the range 0 - 65535. of 3 nonnegative integers. If NCOLORS colors, NREDS reds, NGREENS greens, and NBLUES blues are requested, NCOLORS pixels are returned; and the masks have NREDS, NGREENS, and NBLUES bits set - to 1, respectively. If CONTIGUOUS? is non-false, each mask will + to 1, respectively. If CONTIGUOUS? is non-false, each mask will have a contiguous set of bits set to 1. No mask will have any bits set to 1 in common with any other mask or with any of the pixels. @@ -2114,22 +2114,22 @@ Concept Index  Tag Table: -Node: Top1053 -Node: XlibScm2136 -Node: Display and Screens4930 -Node: Drawables11972 -Node: Windows and Pixmaps12237 -Node: Window Attributes19339 -Node: Window Properties and Visibility35344 -Node: Graphics Context39816 -Node: Cursor55556 -Node: Colormap58067 -Node: Rendering67963 -Node: Images75543 -Node: Event75689 -Node: Indexes90176 -Node: Procedure and Macro Index90332 -Node: Variable Index95784 -Node: Concept Index99237 +Node: Top1054 +Node: XlibScm2138 +Node: Display and Screens4932 +Node: Drawables11974 +Node: Windows and Pixmaps12239 +Node: Window Attributes19341 +Node: Window Properties and Visibility35346 +Node: Graphics Context39818 +Node: Cursor55558 +Node: Colormap58069 +Node: Rendering67964 +Node: Images75544 +Node: Event75690 +Node: Indexes90177 +Node: Procedure and Macro Index90333 +Node: Variable Index95785 +Node: Concept Index99238  End Tag Table diff --git a/Xlibscm.texi b/Xlibscm.texi index a9d82fb..71e22ef 100644 --- a/Xlibscm.texi +++ b/Xlibscm.texi @@ -1548,7 +1548,7 @@ vector of 3 nonnegative integers. If @var{ncolors} colors, @var{nreds} reds, @var{ngreens} greens, and @var{nblues} blues are requested, @var{ncolors} pixels are returned; and the masks have @var{nreds}, @var{ngreens}, and @var{nblues} bits set to 1, respectively. If -@var{contiguous?} is non-false, each mask will have a contiguous set of +@var{contiguous?} is non-false, each mask will have a contiguous set of bits set to 1. No mask will have any bits set to 1 in common with any other mask or with any of the pixels. diff --git a/build b/build index 450726d..6a4d884 100755 --- a/build +++ b/build @@ -1,5 +1,21 @@ #! /bin/sh :;exec ./scmlit -no-init-file -f $0 -e"(bi)" build "$@" +;; +;; Copyright (C) 1994-2006 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. (require 'getopt) (require 'getopt-parameters) diff --git a/build.scm b/build.scm index 52af8ac..1baa9c0 100644 --- a/build.scm +++ b/build.scm @@ -1,19 +1,19 @@ ;; "build.scm" Build database and program -*-scheme-*- -;; Copyright (C) 1994-2004 Aubrey Jaffer. +;; Copyright (C) 1994-2006 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 of the License, or (at -;; your option) any later version. +;; 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. +;; 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 program; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;; 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. (require 'parameters) (require 'databases) @@ -124,6 +124,7 @@ ("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.") + ("bytenumb.c" c-source linkable "Byte-number conversions.") ("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.") @@ -375,6 +376,11 @@ 'differ '((c-file "differ.c") (compiled-init "init_differ"))) +#;Byte/number conversions +(define-build-feature + 'byte-number + '((c-file "bytenumb.c") (compiled-init "init_bytenumb"))) + #;Microsoft Windows executable. (define-build-feature 'windows @@ -425,10 +431,10 @@ #;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/") + '((c-file "../wb/blink.c" "../wb/blkio.c" "../wb/del.c" "../wb/ents.c" + "../wb/handle.c" "../wb/prev.c" "../wb/scan.c" "../wb/segs.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. @@ -478,17 +484,17 @@ (amiga-dice-c m68000 amiga dcc ) ;dcc (amiga-gcc m68000 amiga gcc ) ;gcc (amiga-sas m68000 amiga lc ) ;link - (atari-st-gcc m68000 atari.st gcc ) ;gcc - (atari-st-turbo-c m68000 atari.st tcc ) ;tlink + (atari-st-gcc m68000 atari-st gcc ) ;gcc + (atari-st-turbo-c m68000 atari-st tcc ) ;tlink (borland-c i8086 ms-dos bcc ) ;bcc (gnu-win32 i386 unix gcc ) ;gcc (djgpp i386 ms-dos gcc ) ;gcc - (freebsd i386 unix cc ) ;cc + (freebsd *unknown* unix cc ) ;cc (gcc *unknown* unix gcc ) ;gcc (highc i386 ms-dos hc386 ) ;bind386 (hp-ux hp-risc hp-ux cc ) ;cc (irix mips irix gcc ) ;gcc - (linux i386 linux gcc ) ;gcc + (linux *unknown* linux gcc ) ;gcc (linux-aout i386 linux gcc ) ;gcc (linux-ia64 ia64 linux gcc ) ;gcc (darwin powerpc unix cc ) ;gcc @@ -535,14 +541,13 @@ (mysql *unknown* "-I/usr/include/mysql" "-L/usr/lib/mysql -lmysqlclient" "/usr/lib/mysql/libmysqlclient.a" () ()) - (m gnu-win32 "" "" "" () ()) - (c gnu-win32 "" "" "" () ()) + (m gnu-win32 "" "" #f () ()) + (c gnu-win32 "" "" #f () ()) (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")) - (regex linux-aout "" "" "" () ()) (curses linux-aout "-I/usr/include/ncurses" "-lncurses" "/usr/lib/libncurses.a" () ()) (nostart linux-aout "" "-nostartfiles" #f ("pre-crt0.c") ()) @@ -551,7 +556,7 @@ (m linux "" "-lm" "/lib/libm.so" () ()) (c linux "" "-lc" "/lib/libc.so" () ()) (dlll linux "-DSUN_DL" "-ldl" #f () ()) - (regex linux "" "" "" () ()) + (regex linux "" "" #f () ()) (graphics linux "-I/usr/include/X11 -DX11" "-L/usr/X11R6/lib -lX11" "/usr/X11R6/lib/libX11.so" () ()) (curses linux "" "-lcurses" "/lib/libncurses.so" () ()) @@ -992,15 +997,6 @@ ; (batch:rebuild-catalog parms) ; (string-append oname ".sl")))) -(defcommand compile-c-files linux-aout - (lambda (files parms) - (and (batch:try-chopped-command parms - "gcc" "-c" - (include-spec "-I" parms) - (c-includes parms) - (c-flags parms) - files) - (truncate-up-to (map c->o files) #\/)))) (defcommand compile-dll-c-files linux-aout (lambda (files parms) (and (batch:try-chopped-command @@ -1018,21 +1014,21 @@ (defcommand compile-c-files linux (lambda (files parms) - (and (batch:try-chopped-command - parms - "gcc" - ;;(if (member "-g" (c-includes parms)) "" "-O2") - "-c" (c-includes parms) - (include-spec "-I" parms) - (c-flags parms) - files) + (and (batch:try-chopped-command parms + "gcc" "-c" + (include-spec "-I" parms) + (c-includes parms) + (c-flags parms) + files) (truncate-up-to (map c->o files) #\/)))) (defcommand compile-dll-c-files linux (lambda (files parms) (and - (batch:try-chopped-command - parms "gcc" "-fpic" "-c" - (include-spec "-I" parms) (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))) (fnames (truncate-up-to (map c-> files) #\/)) (fname.so (string-append (car fnames) ".so")) @@ -1051,8 +1047,7 @@ result)))) (defcommand make-dll-archive linux (lambda (oname objects libs parms) - (let ((platform (car (parameter-list-ref - parms 'platform)))) + (let ((platform (car (parameter-list-ref parms 'platform)))) (and (batch:try-command parms "gcc" "-shared" "-o" @@ -1264,8 +1259,7 @@ (list (string-append (car fnames) ".so"))))))) (defcommand make-dll-archive osf1 (lambda (oname objects libs parms) - (let ((platform (car (parameter-list-ref - parms 'platform)))) + (let ((platform (car (parameter-list-ref parms 'platform)))) (and (batch:try-command parms "cc" "-shared" "-o" @@ -1864,10 +1858,10 @@ (define (look platform) (let ((ans (getter thing platform))) (cond (ans ans) - ((eq? '*unknown* platform) - ;;(slib:warn "Couldn't find: " plat thing) - '()) - (else (look '*unknown*))))) + (else (let ((os (platform->os platform))) + (cond ((eq? os platform) (look '*unknown*)) + ((eq? platform '*unknown*) '()) + (else (look os)))))))) (look plat))) (define (build:command rdb) @@ -2098,7 +2092,8 @@ (define build:initializer (lambda (rdb) - (set! build:c-libraries (open-table rdb 'c-libraries)) + (set! build:c-libraries + (open-table rdb 'c-libraries)) (set! build:lib-cc-flag (make-defaulting-platform-lookup (build:c-libraries 'get 'compiler-flags))) @@ -2111,8 +2106,8 @@ (set! build:c-suppress (make-defaulting-platform-lookup (build:c-libraries 'get 'suppress-files))) - (set! platform->os ((open-table rdb 'platform) - 'get 'operating-system)) + (set! platform->os + ((open-table rdb 'platform) 'get 'operating-system)) (set! plan-command (let ((lookup (make-defaulting-platform-lookup ((open-table rdb 'compile-commands) diff --git a/byte.c b/byte.c index 644966f..c737139 100644 --- a/byte.c +++ b/byte.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2003 Free Software Foundation, Inc. +/* Copyright (C) 2003, 2006 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 @@ -57,7 +57,7 @@ SCM scm_make_bytes(k, n) dst = UCHARS(res); if (!UNBNDP(n)) { ASRTER(INUMP(n) && 0 <= n && n <= MAKINUM(255), n, ARG2, s_make_bytes); - for(i--;i >= 0;i--) dst[i] = INUM(n); + for (i--;i >= 0;i--) dst[i] = INUM(n); } return res; } @@ -71,7 +71,7 @@ SCM scm_bytes(ints) ASRTER(i >= 0, ints, ARG1, s_bytes); res = makstr(i); data = UCHARS(res); - for(;NNULLP(ints);ints = CDR(ints)) { + for (;NNULLP(ints);ints = CDR(ints)) { int n = INUM(CAR(ints)); ASRTER(INUMP(CAR(ints)) && 0 <= n && n <= 255, ints, ARG1, s_bytes); *data++ = n; @@ -107,7 +107,7 @@ SCM scm_bytes2list(str) unsigned char *src; ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bytes2list); src = UCHARS(str); - for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKINUM(src[i]), res); + for (i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKINUM(src[i]), res); return res; } static char s_bt_reverse[] = "bytes-reverse!"; @@ -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 - 1)/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; diff --git a/bytenumb.c b/bytenumb.c new file mode 100644 index 0000000..ba7e584 --- /dev/null +++ b/bytenumb.c @@ -0,0 +1,469 @@ +/* "bytenumb.scm" Byte integer and IEEE floating-point conversions. */ +/* Copyright (C) 2007 Aubrey Jaffer */ +/* */ +/* Permission to copy this software, to modify it, to redistribute it, */ +/* to distribute modified versions, and to use it for any purpose is */ +/* granted, subject to the following restrictions and understandings. */ +/* */ +/* 1. Any copy made of this software must include this copyright notice */ +/* in full. */ +/* */ +/* 2. I have made no warranty or representation that the operation of */ +/* this software will be error-free, and I am under no obligation to */ +/* provide any services, by way of maintenance, update, or otherwise. */ +/* */ +/* 3. In conjunction with products arising from the use of this */ +/* material, there shall be no use of my name in any advertising, */ +/* promotional, or sales literature without prior written consent in */ +/* each case. */ + +/* For documentation see: */ +/* http://cvs.savannah.gnu.org/viewcvs/slib/slib/bytenumb.scm?view=markup */ + +#include +#include + +#include "scm.h" + +int get_bytes_length(obj) + SCM obj; +{ + array_dim *s; + if (IMP(obj)) return -1; + switch (TYP7(obj)) { + case tc7_string: + case tc7_VfixN8: + case tc7_VfixZ8: + return LENGTH(obj); + case tc7_smob: + if (!ARRAYP(obj)) return -1; + if (1 != ARRAY_NDIM(obj)) return -1; + s = ARRAY_DIMS(obj); + if (1 != s[0].inc) return -1; + return s[0].ubnd - s[0].lbnd; + default: return -1; + } +} + +static char s_wrong_length[] = "wrong length"; +static SCM list_of_0; + +char * get_bytes(obj, minlen, s_name) + SCM obj; + int minlen; + const char *s_name; +{ + ASRTER(NIMP(obj) && (TYP7(obj)==tc7_string || + TYP7(obj)==tc7_VfixN8 || + TYP7(obj)==tc7_VfixZ8), + obj, ARG1, s_name); + { + int byvlen = get_bytes_length(obj); + ASRTER(byvlen >= minlen, obj, s_wrong_length, s_name); + return (char*)scm_addr(cons(obj, list_of_0), s_name); + } +} + +static char s_bytes_to_integer[] = "bytes->integer"; +SCM scm_bytes_to_integer(sbyts, sn) + SCM sbyts; + SCM sn; +{ + long n = INUM(sn); + if (!(n)) return INUM0; + { + int cnt = abs(n); + char *byts = get_bytes(sbyts, cnt, s_bytes_to_integer); + int iu = 0, id = cnt - sizeof(BIGDIG); + sizet ndigs = (cnt + sizeof(BIGDIG) - 1) / sizeof(BIGDIG); + int negp = (0x80 & byts[0]) && (0 > n); + SCM retval = mkbig(ndigs, negp); + BIGDIG *digs = BDIGITS(retval), carry = 1; + if (negp) + for (; iu < ndigs; iu++) { + int j = 0; + unsigned long dig = 0; + for (; j < sizeof(BIGDIG); j++) { + dig = (dig<<8) + + (0xFF ^ ((id + j >= 0) ? (((unsigned char *)byts)[id + j]) : 255)); + /* printf("byts[%d + %d] = %lx\n", id, j, 0xFF & dig); */ + } + dig = dig + carry; + digs[iu] = dig; + carry = dig >> (8 * sizeof(BIGDIG)); + /* printf("id = %d; iu = %d; dig = %04lx\n", id, iu, dig); */ + id = id - sizeof(BIGDIG); + } else + for (; iu < ndigs; iu++) { + int j = 0; + BIGDIG dig = 0; + for (; j < sizeof(BIGDIG); j++) { + dig = (dig<<8) + + ((id + j >= 0) ? (((unsigned char *)byts)[id + j]) : 0); + } + digs[iu] = dig; + /* printf("id = %d; iu = %d; dig = %04x\n", id, iu, dig); */ + id = id - sizeof(BIGDIG); + } + return normbig(retval); + } +} + +static char s_integer_to_bytes[] = "integer->bytes"; +SCM scm_integer_to_bytes(sn, slen) + SCM sn; + SCM slen; +{ + ASRTER(INUMP(slen), slen, ARG2, s_integer_to_bytes); + { + int len = INUM(slen); + SCM sbyts = make_string(scm_iabs(slen), MAKICHR(0)); + char *byts = CHARS(sbyts); + if (INUMP(sn)) { + int idx = -1 + (abs(len)); + long n = num2long(sn, (char *)ARG1, s_integer_to_bytes); + if ((0 > n) && (0 > len)) { + long res = -1 - n; + while (!(0 > idx)) { + byts[idx--] = 0xFF ^ (res % 0x100); + res = res>>8; + } + } + else { + unsigned long res = n; + while (!(0 > idx)) { + byts[idx--] = res % 0x100; + res = res>>8; + } + } + } else { + ASRTER(NIMP(sn) && BIGP(sn), sn, ARG1, s_integer_to_bytes); + { + BIGDIG *digs = BDIGITS(sn), borrow = 1; + sizet ndigs = NUMDIGS(sn); + int iu = 0, id = abs(len) - 1; + unsigned long dig; + if ((0 > len) && (TYP16(sn)==tc16_bigneg)) + for (; 0 <= id ; iu++) { + sizet j = sizeof(BIGDIG); + dig = (iu < ndigs) ? digs[iu] : 0; + dig = dig ^ ((1 << (8 * sizeof(BIGDIG))) - 1); + /* printf("j = %d; id = %d; iu = %d; dig = %04x; borrow = %d\n", j, id, iu, dig, borrow); */ + for (; 0 < j-- && 0 <= id;) { + /* printf("byts[%d] = %02x\n", id, 0xFF & dig); */ + int dg = (0xFF & dig) + borrow; + borrow = dg >> 8; + ((unsigned char *)byts)[id--] = dg; + dig = (dig)>>8; + } + } + else + for (; 0 <= id ; iu++) { + BIGDIG dig = (iu < ndigs) ? digs[iu] : 0; + sizet j = sizeof(BIGDIG); + /* printf("j = %d; id = %d; iu = %d; dig = %04x\n", j, id, iu, dig); */ + for (; 0 < j-- && 0 <= id;) { + /* printf("byts[%d] = %02x\n", id, 0xFF & dig); */ + ((unsigned char *)byts)[id--] = 0xFF & dig; + dig = (dig>>8); + } + } + } + } + return sbyts; + } +} + +static char s_bytes_to_ieee_float[] = "bytes->ieee-float"; +SCM scm_bytes_to_ieee_float(sbyts) + SCM sbyts; +{ + char *byts = get_bytes(sbyts, 4, s_bytes_to_ieee_float); + int len = LENGTH(sbyts); + int s = (1<<(7)) & ((((unsigned char*)(byts))[0])); + int e = ((0x7f&((((unsigned char*)(byts))[0])))<<1) + + ((0x80&((((unsigned char*)(byts))[1])))>>7); + float f = (((unsigned char*)(byts))[ -1 + (len)]); + int idx = -2 + (len); + while (!((idx)<=1)) { + { + int T_idx = -1 + (idx); + f = ((((unsigned char*)(byts))[idx])) + ((f) / 0x100); + idx = T_idx; + } + } + f = ((0x7f&((((unsigned char*)(byts))[1]))) + ((f) / 0x100)) / 0x80; + if ((0<(e)) + && ((e)<0xff)) + return makdbl(ldexpf((s ? -1 : 1) * (1 + (f)), (e) - 0x7f), 0.0); + else if (!(e)) + if (!(f)) return flo0; + else return makdbl(ldexpf((s ? -1 : 1) * (f), -126), 0.0); + else if (f) + return scm_narn; + else return makdbl((s ? -(1.0) : 1.0) / 0.0, 0.0); +} + +static char s_bytes_to_ieee_double[] = "bytes->ieee-double"; +SCM scm_bytes_to_ieee_double(sbyts) + SCM sbyts; +{ + char *byts = get_bytes(sbyts, 8, s_bytes_to_ieee_double); + int len = LENGTH(sbyts); + int s = (1<<(7)) & ((((unsigned char*)(byts))[0])); + int e = ((0x7f&((((unsigned char*)(byts))[0])))<<4) + + ((0xf0&((((unsigned char*)(byts))[1])))>>4); + double f = (((unsigned char*)(byts))[ -1 + (len)]); + int idx = -2 + (len); + while (!((idx)<=1)) { + { + int T_idx = -1 + (idx); + f = ((((unsigned char*)(byts))[idx])) + ((f) / 0x100); + idx = T_idx; + } + } + f = ((0xf&((((unsigned char*)(byts))[1]))) + ((f) / 0x100)) / 0x10; + if ((0<(e)) + && ((e)<0x7ff)) + return makdbl(ldexp((s ? -1 : 1) * (1 + (f)), (e) - 0x3ff), 0.0); + else if (!(e)) + if (!(f)) return flo0; + else return makdbl(ldexp((s ? -1 : 1) * (f), -1022), 0.0); + else if (f) + return scm_narn; + else return makdbl((s ? -(1.0) : 1.0) / 0.0, 0.0); +} + +static char s_ieee_float_to_bytes[] = "ieee-float->bytes"; +SCM scm_ieee_float_to_bytes(in_flt) + SCM in_flt; +{ + double dbl = num2dbl(in_flt, (char *)ARG1, s_ieee_float_to_bytes); + float flt = (float) dbl; + SCM sbyts = make_string(MAKINUM(4), MAKICHR(0)); + char *byts = CHARS(sbyts); + int s = flt < 0.0; + int scl = 0x7f; + flt = fabs(flt); + if (0.0==flt) { + if (s) + byts[0] = 0x80; + return sbyts; + } + else if (flt != flt) { + byts[0] = 0x7f; + byts[1] = 0xc0; + return sbyts; + } + else goto L_scale; + L_out: + { + float T_flt = 0x80 * (flt); + int val = (int)(floor(0x80 * (flt))); + int idx = 1; + float flt = T_flt; + while (!((idx) > 3)) { + byts[idx] = val; + { + float T_flt = 0x100 * ((flt) - (val)); + int T_val = (int)(floor(0x100 * ((flt) - (val)))); + idx = 1 + (idx); + flt = T_flt; + val = T_val; + } + } + byts[1] = (0x80 & (scl<<7)) | (0x7f & (((unsigned char*)(byts))[1])); + byts[0] = (s ? 0x80 : 0) + ((scl)>>1); + return sbyts; + } + L_scale: + if (!(scl)) { + flt = (flt)/2; + goto L_out; + } + else if ((flt)>=0x10) { + float flt16 = (flt) / 0x10; + if ((flt16)==(flt)) { + byts[0] = s ? 0xff : 0x7f; + byts[1] = 0x80; + return sbyts; + } + else { + flt = flt16; + scl = (scl) + 4; + goto L_scale; + } + } + else if ((flt) >= 2) { + flt = (flt) / 2; + scl = (scl) + 1; + goto L_scale; + } + else if (((scl) >= 4) && ((0x10 * (flt))<1)) { + flt = (flt) * 0x10; + scl = (scl)+ -4; + goto L_scale; + } + else if ((flt)<1) { + flt = (flt) * 2; + scl = (scl) + -1; + goto L_scale; + } + else { + flt = -1+(flt); + goto L_out; + } +} + +static char s_ieee_double_to_bytes[] = "ieee-double->bytes"; +SCM scm_ieee_double_to_bytes(in_flt) + SCM in_flt; +{ + double flt = num2dbl(in_flt, (char *)ARG1, s_ieee_double_to_bytes); + SCM sbyts = make_string(MAKINUM(8), MAKICHR(0)); + char *byts = CHARS(sbyts); + int s = flt < 0.0; + int scl = 0x3ff; + flt = fabs(flt); + if (0.0==flt) { + if (s) + byts[0] = 0x80; + return sbyts; + } + else if (flt != flt) { + byts[0] = 0x7f; + byts[1] = 0xf8; + return sbyts; + } + else goto L_scale; + L_out: + { + double T_flt = 0x10 * (flt); + int val = (int)(floor(0x10 * (flt))); + int idx = 1; + double flt = T_flt; + while (!((idx) > 7)) { + byts[idx] = val; + { + double T_flt = 0x100 * (flt - val); + int T_val = (int)floor(0x100 * (flt - val)); + idx = 1 + (idx); + flt = T_flt; + val = T_val; + } + } + byts[1] = (0xf0 & (scl<<4)) | (0x0f & (((unsigned char*)(byts))[1])); + byts[0] = (s ? 0x80 : 0) + ((scl)>>4); + return sbyts; + } + L_scale: + if (!(scl)) { + flt = (flt) / 2; + goto L_out; + } + else if ((flt) >= 0x10) { + double flt16 = (flt) / 0x10; + if ((flt16)==(flt)) { + byts[0] = s ? 0xff : 0x7f; + byts[1] = 0xf0; + return sbyts; + } + else { + flt = flt16; + scl = (scl) + 4; + goto L_scale; + } + } + else if ((flt) >= 2) { + flt = (flt) / 2; + scl = (scl) + 1; + goto L_scale; + } + else if (((scl) >= 4) && ((0x10 * flt) < 1)) { + flt = (flt) * 0x10; + scl = (scl) + -4; + goto L_scale; + } + else if ((flt) < 1) { + flt = (flt) * 2; + scl = (scl) + -1; + goto L_scale; + } + else { + flt = -1 + (flt); + goto L_out; + } +} + +static char s_integer_byte_collate_M[] = "integer-byte-collate!"; +SCM scm_integer_byte_collate_M(byte_vector) + SCM byte_vector; +{ + char* bv = get_bytes(byte_vector, 1, s_integer_byte_collate_M); + bv[0] = 0x80^(bv[0]); + return byte_vector; +} + +static char s_ieee_byte_collate_M[] = "ieee-byte-collate!"; +SCM scm_ieee_byte_collate_M(byte_vector) + SCM byte_vector; +{ + char* byv = get_bytes(byte_vector, 4, s_ieee_byte_collate_M); + int byvlen = get_bytes_length(byte_vector); + if (0x80&(byv[0])) { + int idx = -1 + byvlen; + while (!(0 > (idx))) { + byv[idx] = 0xff^(byv[idx]); + idx = -1+(idx); + } + } + else + byv[0] = 0x80^(byv[0]); + return byte_vector; +} + +static char s_ieee_byte_decollate_M[] = "ieee-byte-decollate!"; +SCM scm_ieee_byte_decollate_M(byte_vector) + SCM byte_vector; +{ + char* byv = get_bytes(byte_vector, 4, s_ieee_byte_collate_M); + int byvlen = get_bytes_length(byte_vector); + if (!(0x80&(byv[0]))) { + int idx = -1 + byvlen; + while (!(0 > (idx))) { + byv[idx] = 0xff^(byv[idx]); + idx = -1+(idx); + } + } + else + byv[0] = 0x80^(byv[0]); + return byte_vector; +} + +static iproc subr1s[] = { + {s_bytes_to_ieee_float, scm_bytes_to_ieee_float}, + {s_bytes_to_ieee_double, scm_bytes_to_ieee_double}, + {s_ieee_float_to_bytes, scm_ieee_float_to_bytes}, + {s_ieee_double_to_bytes, scm_ieee_double_to_bytes}, + {s_integer_byte_collate_M, scm_integer_byte_collate_M}, + {s_ieee_byte_collate_M, scm_ieee_byte_collate_M}, + {s_ieee_byte_decollate_M, scm_ieee_byte_decollate_M}, + {0, 0}}; + +void init_bytenumb() +{ + list_of_0 = cons(INUM0, EOL); + scm_gc_protect(list_of_0); + make_subr(s_bytes_to_integer, tc7_subr_2, scm_bytes_to_integer); + make_subr(s_integer_to_bytes, tc7_subr_2, scm_integer_to_bytes); + init_iprocs(subr1s, tc7_subr_1); + scm_ldstr("\n\ +(define (integer-byte-collate byte-vector)\n\ + (integer-byte-collate! (bytes-copy byte-vector)))\n\ +(define (ieee-byte-collate byte-vector)\n\ + (ieee-byte-collate! (bytes-copy byte-vector)))\n\ +(define (ieee-byte-decollate byte-vector)\n\ + (ieee-byte-decollate! (bytes-copy byte-vector)))\n\ +"); + /* add_feature("byte-number"); */ +} diff --git a/continue.h b/continue.h index e1703bf..3e0d919 100644 --- a/continue.h +++ b/continue.h @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2006 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 diff --git a/debug.c b/debug.c index e270a7a..5d34581 100644 --- a/debug.c +++ b/debug.c @@ -135,7 +135,7 @@ static SCM prinhead(x, port, writing) int writing; { lputc('(', port); - iprin1(CAR(x), port, writing); + scm_iprin1(CAR(x), port, writing); lputc(' ', port); return CDR(x); } @@ -148,7 +148,7 @@ static void prinbindings(names, inits, init_env, lputc('(', port); while (NIMP(names) && NIMP(inits)) { lputc('(', port); - iprin1(CAR(names), port, writing); + scm_iprin1(CAR(names), port, writing); lputc(' ', port); scm_princode(CAR(inits), init_env, port, writing); if (NIMP(steps)) { @@ -170,7 +170,7 @@ void scm_princode(code, env, port, writing) { SCM oenv = env, name, init, bdgs, x = code; if (UNBNDP(env)) { - iprin1(code, port, writing); + scm_iprin1(code, port, writing); return; } tail: @@ -180,19 +180,19 @@ void scm_princode(code, env, port, writing) name = scm_env_rlookup(x, env, "princode"); if (FALSEP(name)) goto gencase; lputs("#@", port); - iprin1(name, port, writing); + scm_iprin1(name, port, writing); return; } else goto gencase; } if (SCM_GLOCP(x)) { - iprin1(x, port, writing); + scm_iprin1(x, port, writing); return; } switch (TYP7(x)) { default: gencase: - iprin1(x, port, writing); + scm_iprin1(x, port, writing); return; gencode: case tcs_cons_gloc: @@ -209,7 +209,7 @@ void scm_princode(code, env, port, writing) for (; NNULLP(x); x = CDR(x)) { if (IMP(x) || NECONSP(x)) { lputs(" . ", port); - iprin1(x, port, writing); + scm_iprin1(x, port, writing); break; } lputc(' ', port); @@ -222,19 +222,19 @@ void scm_princode(code, env, port, writing) env = CAR(x); bdgs = SCM_ENV_FORMALS(env); if (IMP(bdgs) || NECONSP(bdgs)) - iprin1(bdgs, port, writing); + scm_iprin1(bdgs, port, writing); else { lputc('(', port); while (!0) { if (NECONSP(bdgs)) break; - iprin1(CAR(bdgs), port, writing); + scm_iprin1(CAR(bdgs), port, writing); if (NIMP(bdgs = CDR(bdgs))) lputc(' ', port); else break; } if (NIMP(bdgs)) { lputs(". ", port); - iprin1(bdgs, port, writing); + scm_iprin1(bdgs, port, writing); } lputc(')', port); } @@ -259,7 +259,7 @@ void scm_princode(code, env, port, writing) bdgs = CDR(bdgs); env = CAR(bdgs); lputc('(', port); - iprin1(SCM_ENV_FORMALS(env), port, writing); + scm_iprin1(SCM_ENV_FORMALS(env), port, writing); lputc(' ', port); scm_princode(init, oenv, port, writing); oenv = env; @@ -320,7 +320,7 @@ void scm_princlosure(proc, port, writing) env = CAR(proc); #ifdef CAUTIOUS if (NIMP(env=scm_env_getprop(SCM_ENV_PROCNAME, env))) { - iprin1(CAR(env), port, 1); + scm_iprin1(CAR(env), port, 1); lputc(' ', port); env = CDR(env); if (NIMP(env) && SCM_LINUMP(CAR(env))) @@ -333,9 +333,9 @@ void scm_princlosure(proc, port, writing) scm_line_msg(CAR(env), linum, port); #endif env = CAR(proc); - iprin1(SCM_ENV_FORMALS(env), port, writing); + scm_iprin1(SCM_ENV_FORMALS(env), port, writing); if (writing) { - for(proc = CDR(proc); NIMP(proc); proc = CDR(proc)) { + for (proc = CDR(proc); NIMP(proc); proc = CDR(proc)) { lputc(' ', port); scm_princode(CAR(proc), env, port, writing); } @@ -451,7 +451,7 @@ SCM stacktrace1(estk, i) /* The usual C setjmp, not SCM's setjump. */ if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { lputc('\n', cur_errp); - intprint((long)n, -10, sys_safep); + scm_intprint((long)n, -10, sys_safep); lputs("; ", sys_safep); scm_princode(ste, env, sys_safep, 1); } @@ -572,7 +572,7 @@ SCM scm_scope_trace(env) if (NCONSP(env)) { badenv: lputs("\n; corrupted environment ", cur_errp); - iprin1(env, cur_errp, 1); + scm_iprin1(env, cur_errp, 1); return UNSPECIFIED; } ef = CAR(env); @@ -589,19 +589,19 @@ SCM scm_scope_trace(env) default: break; case SCM_ENV_PROCNAME: lputs(" procedure ", cur_errp); - iprin1(CAR(env), cur_errp, 1); + scm_iprin1(CAR(env), cur_errp, 1); break; } #endif } else if (NIMP(ef) && CONSP(ef) && NIMP(CAR(ef)) && CONSP(CAR(ef))) { lputs("\n; ", cur_errp); - iprin1(CAR(ef), cur_errp, 1); + scm_iprin1(CAR(ef), cur_errp, 1); lputs(" syntax bindings", cur_errp); } else { lputs("\n; ", cur_errp); - iprin1(ef, cur_errp, 1); + scm_iprin1(ef, cur_errp, 1); } } #ifdef CAUTIOUS @@ -609,7 +609,7 @@ SCM scm_scope_trace(env) lputs("\n; defined by ", cur_errp); if (NIMP(file) && STRINGP(file)) lputs("load: ", cur_errp); - iprin1(file, cur_errp, 1); + scm_iprin1(file, cur_errp, 1); lputc('\n', cur_errp); } #endif diff --git a/dynl.c b/dynl.c index d8eeae4..736ce11 100644 --- a/dynl.c +++ b/dynl.c @@ -60,7 +60,7 @@ void listundefs() int i; char **undefs = dld_list_undefined_sym(); puts(" undefs:"); - for(i = dld_undefined_sym_count;i--;) { + for (i = dld_undefined_sym_count;i--;) { putc('"', stdout); fputs(undefs[i], stdout); puts("\""); @@ -181,7 +181,7 @@ int prinshl(exp, port, writing) SCM exp; SCM port; int writing; { lputs("#', port); return 1; } @@ -379,7 +379,7 @@ int prinshl(exp, port, writing) SCM exp; SCM port; int writing; { lputs("#', port); return 1; } @@ -405,7 +405,7 @@ SCM l_dyn_link(fname) lputs(s_link, cur_errp); lputs(": ", cur_errp); lputs(dlr, cur_errp); - newline(cur_errp); + scm_newline(cur_errp); }} return BOOL_F; } @@ -432,7 +432,7 @@ SCM l_dyn_call(symb, shl) lputs(s_call, cur_errp); lputs(": ", cur_errp); lputs(dlr, cur_errp); - newline(cur_errp); + scm_newline(cur_errp); } return BOOL_F; } @@ -448,7 +448,7 @@ SCM l_dyn_main_call(symb, shl, args) { int i; int (*func)P((int argc, const char **argv)) = 0; - const char **argv; + char **argv; /* SCM oloadpath = *loc_loadpath; */ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call); @@ -461,7 +461,7 @@ SCM l_dyn_main_call(symb, shl, args) lputs(s_main_call, cur_errp); lputs(": ", cur_errp); lputs(dlr, cur_errp); - newline(cur_errp); + scm_newline(cur_errp); } return BOOL_F; } @@ -529,7 +529,7 @@ int prinshl(exp, port, writing) SCM exp; SCM port; int writing; { lputs("#', port); return 1; } @@ -673,7 +673,7 @@ int prinshl(exp, port, writing) SCM exp; SCM port; int writing; { lputs("#', port); return 1; } diff --git a/eval.c b/eval.c index e616382..86c56a3 100644 --- a/eval.c +++ b/eval.c @@ -356,7 +356,7 @@ static void debug_env_warn(fnam, line, what) { lputs(fnam, cur_errp); lputc(':', cur_errp); - intprint(line+0L, 10, cur_errp); + scm_intprint(line+0L, 10, cur_errp); lputs(": unprotected ", cur_errp); lputs(what, cur_errp); lputs(" of ecache value\n", cur_errp); @@ -415,7 +415,7 @@ SCM *ilookup(iloc) /* shortcut the two most common cases. */ if (iloc==MAKILOC(0, 0)) return &CAR(CAR(er)); if (iloc==MAKILOC(0, 1)) return &CAR(CDR(CAR(er))); - for(;0 != ir;--ir) er = CDR(er); + for (;0 != ir;--ir) er = CDR(er); eloc = &CAR(er); for (ir = IDIST(iloc); 0 != ir; --ir) eloc = &CDR(*eloc); @@ -436,7 +436,7 @@ SCM *farlookup(farloc) return &CAR(CAR(er)); } er = CAR(er); - for(--ir;0 != ir;--ir) er = CDR(er); + for (--ir;0 != ir;--ir) er = CDR(er); if (IM_FARLOC_CDR==CAR(farloc)) return &CDR(er); return &CAR(CDR(er)); } @@ -813,13 +813,13 @@ static void ecache_undefs(x) SCM x; { static SCM argv[10] = {UNDEFINED, UNDEFINED, UNDEFINED, - UNDEFINED, UNDEFINED, UNDEFINED, + UNDEFINED, UNDEFINED, UNDEFINED, UNDEFINED, UNDEFINED, UNDEFINED, UNDEFINED}; int imax = sizeof(argv)/sizeof(SCM); int i = 0; - + scm_env_tmp = EOL; while NIMP(x) { if (imax==i) { @@ -1390,7 +1390,7 @@ static SCM iqq(form) long i = LENGTH(form); SCM *data = VELTS(form); tmp = EOL; - for(;--i >= 0;) tmp = cons(data[i], tmp); + for (;--i >= 0;) tmp = cons(data[i], tmp); return vector(iqq(tmp)); } if (NCONSP(form)) return form; @@ -1413,9 +1413,9 @@ static SCM m_iqq(form, depth, env, ctxt) long i = LENGTH(form); SCM *data = VELTS(form); tmp = EOL; - for(;--i >= 0;) tmp = cons(data[i], tmp); + for (;--i >= 0;) tmp = cons(data[i], tmp); tmp = m_iqq(tmp, depth, env, ctxt); - for(i = 0; i < LENGTH(form); i++) { + for (i = 0; i < LENGTH(form); i++) { data[i] = CAR(tmp); tmp = CDR(tmp); } @@ -2219,7 +2219,7 @@ static SCM ceval_1(x) EXTEND_VALENV; x = CDR(CDR(x)); while (proc = CAR(x), FALSEP(EVALCAR(proc))) { - for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) { + for (proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) { arg1 = CAR(proc); /* body */ SIDEVAL_1(arg1); } @@ -2872,7 +2872,7 @@ SCM nconc2copy(lst) #endif last = CAR(*lloc); *lloc = EOL; - for(; NIMP(last); last=CDR(last)) { + for (; NIMP(last); last=CDR(last)) { *lloc = cons(CAR(last), EOL); lloc = &CDR(*lloc); } @@ -2886,7 +2886,7 @@ SCM scm_cp_list(lst, minlen) { SCM res, *lloc = &res; res = EOL; - for(; NIMP(lst) && CONSP(lst); lst = CDR(lst)) { + for (; NIMP(lst) && CONSP(lst); lst = CDR(lst)) { *lloc = cons(CAR(lst), EOL); lloc = &CDR(*lloc); minlen--; @@ -2900,7 +2900,7 @@ SCM scm_v2lst(n, v, end) SCM *v, end; { SCM res = end; - for(n--; n >= 0; n--) res = cons(v[n], res); + for (n--; n >= 0; n--) res = cons(v[n], res); return res; } SCM apply(proc, arg1, args) @@ -3214,7 +3214,7 @@ static int prinprom(exp, port, writing) lputs("#', port); return !0; } @@ -3312,7 +3312,7 @@ static int prinmacro(exp, port, writing) } if (MAC_TYPE(exp) & MAC_MEMOIZING) lputc('!', port); lputc(' ', port); - iprin1(CDR(exp), port, writing); + scm_iprin1(CDR(exp), port, writing); lputc('>', port); return !0; } @@ -3322,8 +3322,8 @@ static int prinenv(exp, port, writing) int writing; { lputs("#', port); return !0; } @@ -3336,9 +3336,9 @@ static int prinid(exp, port, writing) SCM s = IDENT_PARENT(exp); while (M_IDENTP(s)) s = IDENT_PARENT(s); lputs("#', port); return !0; } diff --git a/features.txi b/features.txi index 1df8107..83afb22 100644 --- a/features.txi +++ b/features.txi @@ -18,6 +18,10 @@ Large precision integers. @cindex byte Treating strings as byte-vectors. +@item byte-number +@cindex byte-number +Byte/number conversions + @item careful-interrupt-masking @cindex careful-interrupt-masking Define this for extra checking of interrupt masking and some simple diff --git a/findexec.c b/findexec.c index 9769ef5..8edc6fc 100644 --- a/findexec.c +++ b/findexec.c @@ -43,6 +43,7 @@ Wed Feb 21 23:06:35 1996 Aubrey Jaffer # include # endif # ifdef linux +# include # include # include # include /* for X_OK define */ @@ -63,7 +64,7 @@ Wed Feb 21 23:06:35 1996 Aubrey Jaffer # include # include # define getcwd getwd -# define MAXPATHLEN 256 /* arbitrary? */ +# define MAXPATHLEN 256 /* arbitrary? */ # define X_OK AEXEC # else # include @@ -80,18 +81,30 @@ Wed Feb 21 23:06:35 1996 Aubrey Jaffer # endif # ifdef __FreeBSD__ /* This might be same for 44bsd derived system. */ -# include +# include +# include +# include +# include +# endif +# ifdef __DragonflyBSD__ +/* This might be same for 44bsd derived system. */ +# include +# include +# include # include # endif # ifdef __NetBSD__ # include +# include # include +# include # endif # ifdef __OpenBSD__ /* This might be same for 44bsd derived system. */ # include # include -# include +# include +/* # include */ # include # endif # ifdef __alpha diff --git a/hobbit.info b/hobbit.info index 7dae5f2..423e7c1 100644 --- a/hobbit.info +++ b/hobbit.info @@ -1,7 +1,7 @@ This is hobbit.info, produced by makeinfo version 4.8 from hobbit.texi. -This manual is for the Hobbit compiler for SCM (version 5e3, October -2006), +This manual is for the Hobbit compiler for SCM (version 5e4, November +2007), Copyright (C) 2002 Free Software Foundation @@ -30,8 +30,8 @@ File: hobbit.info, Node: Top, Next: Introduction, Prev: (dir), Up: (dir) Hobbit ****** -This manual is for the Hobbit compiler for SCM (version 5e3, October -2006), +This manual is for the Hobbit compiler for SCM (version 5e4, November +2007), Copyright (C) 2002 Free Software Foundation @@ -160,7 +160,7 @@ File: hobbit.info, Node: Compiling And Linking, Next: Error Detection, Prev: (lambda (fp) (for-each (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"Init5e3.scm\"" + '("#define IMPLINIT \"Init5e4.scm\"" "#define BIGNUMS" "#define FLOATS" "#define ARRAYS" @@ -212,7 +212,7 @@ File: hobbit.info, Node: Compiling And Linking, Next: Error Detection, Prev: (lambda (fp) (for-each (lambda (string) (write-line string fp)) - '("#define IMPLINIT \"Init5e3.scm\"" + '("#define IMPLINIT \"Init5e4.scm\"" "#define COMPILED_INITS init_example();" "#define CCLO" "#define FLOATS")))) @@ -310,7 +310,7 @@ File: hobbit.info, Node: Hobbit Options, Next: CC Optimizations, Prev: Error initialized, during its work or later via the interpreter. Hobbit checks the compiled source and whenever some variable bar is - defined as a procedure, but is later redefined, or set! is applied + defined as a procedure, but is later redefined, or set! is applied to bar, then hobbit assumes thas this particular variable bar is redefinable. bar may be a primitive (eg `car') or a name of a compiled procedure. @@ -1784,8 +1784,9 @@ hobbit4b: @ alum.mit.edu). * A bug occurring in case arguments are evaluated right-to-left, - which happens with Hobbit compiled by gcc on Linux. Reported - and patched by George K. Bronnikov (goga@bronnikov.msk.su) + which happens with Hobbit compiled by gcc on GNU/Linux. + Reported and patched by George K. Bronnikov + (goga@bronnikov.msk.su) * A closure-building bug sometimes leading to a serious loss of efficiency (liftability not recognized), reported by @@ -1952,46 +1953,46 @@ Index  Tag Table: -Node: Top1023 -Node: Introduction2111 -Node: Compiling with Hobbit3427 -Node: Compiling And Linking3685 -Node: Error Detection8371 -Node: Hobbit Options9677 -Node: CC Optimizations16410 -Node: The Language Compiled17366 -Node: Macros18025 -Node: SCM Primitive Procedures18629 -Node: SLIB Logical Procedures19551 -Node: Fast Integer Calculations20706 -Node: Force and Delay21840 -Node: Suggestions for writing fast code22425 -Node: Performance of Compiled Code32624 -Node: Gain in Speed32884 -Node: Benchmarks34469 -Node: Benchmark Sources37569 -Node: Destruct37915 -Node: Recfib39502 -Node: div-iter and div-rec39757 -Node: Hanoi40843 -Node: Tak41424 -Node: Ctak41779 -Node: Takl42759 -Node: Cpstak43415 -Node: Pi44194 -Node: Principles of Compilation45327 -Node: Macro-Expansion and Analysis45753 -Node: Building Closures49558 -Node: Lambda-lifting52449 -Node: Statement-lifting55180 -Node: Higher-order Arglists56288 -Node: Typing and Constants58094 -Node: About Hobbit59358 -Node: The Aims of Developing Hobbit59618 -Node: Manifest60509 -Node: Author and Contributors60968 -Node: Future Improvements62023 -Node: Release History62788 -Node: Index69577 +Node: Top1024 +Node: Introduction2113 +Node: Compiling with Hobbit3429 +Node: Compiling And Linking3687 +Node: Error Detection8373 +Node: Hobbit Options9679 +Node: CC Optimizations16411 +Node: The Language Compiled17367 +Node: Macros18026 +Node: SCM Primitive Procedures18630 +Node: SLIB Logical Procedures19552 +Node: Fast Integer Calculations20707 +Node: Force and Delay21841 +Node: Suggestions for writing fast code22426 +Node: Performance of Compiled Code32625 +Node: Gain in Speed32885 +Node: Benchmarks34470 +Node: Benchmark Sources37570 +Node: Destruct37916 +Node: Recfib39503 +Node: div-iter and div-rec39758 +Node: Hanoi40844 +Node: Tak41425 +Node: Ctak41780 +Node: Takl42760 +Node: Cpstak43416 +Node: Pi44195 +Node: Principles of Compilation45328 +Node: Macro-Expansion and Analysis45754 +Node: Building Closures49559 +Node: Lambda-lifting52450 +Node: Statement-lifting55181 +Node: Higher-order Arglists56289 +Node: Typing and Constants58095 +Node: About Hobbit59359 +Node: The Aims of Developing Hobbit59619 +Node: Manifest60510 +Node: Author and Contributors60969 +Node: Future Improvements62024 +Node: Release History62789 +Node: Index69591  End Tag Table diff --git a/hobbit.scm b/hobbit.scm index 5505bf1..eff85ba 100644 --- a/hobbit.scm +++ b/hobbit.scm @@ -6,7 +6,7 @@ ; 2002-04-11 ; ; Copyright (C) 1992-1997: Tanel Tammet -; Copyright (C) 1998-2002: Free Software Foundation +; Copyright (C) 1998-2006: Free Software Foundation ; ; tammet@staff.ttu.ee, tammet@cs.chalmers.se ; @@ -228,7 +228,7 @@ errjmp-ok ints-disabled sig-deferred alrm-deferred han-sig han-alrm must-malloc ilength s-read s-write s-newline s-make-string s-make-vector s-list s-string s-vector repl-driver newsmob lthrow repl - gc-end gc-start growth-mon iprin1 intprint iprlist lputc lputs + gc-end gc-start growth-mon scm_iprin1 scm_intprint scm_iprlist lputc lputs lfwrite time-in-msec my-time init-tables init-storage init-subrs init-features init-iprocs init- init-scl init-io init-repl init-time init-signals ignore-signals unignore-signals init-eval init-sc2 @@ -259,8 +259,9 @@ ;;; eval throwval quit input-portp output-portp cur-input-port cur-output-port open-file open-pipe close-port - close-pipe lread read-char peek-char eof-objectp lwrite display - newline write-char file-position file-set-position lgetenv prog-args + close-pipe read-char peek-char eof-objectp scm_write scm_display + scm_newline scm_write-char + file-position file-set-position scm_file-position lgetenv prog-args makacro makmacro makmmacro remove ash round array-ref array_ref sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh sqrt expt @@ -2115,7 +2116,7 @@ ;; (display-c-newline)) ((eq? 'if (car term)) (display-c-indent n) - (display-c "if(") + (display-c "if (") (display-c-expression (cadr term) #t) (display-c #\)) (cond ((not (pair? (caddr term))) @@ -2170,7 +2171,7 @@ (display-c-statement (car (cdddr term)) n)))) ((eq? (car term) *do-not*) (display-c-indent n) - (display-c "for(") + (display-c "for (") (let ((lst1 (map (lambda (x) (list 'set! (car x) (cadr x))) (cadr term))) (lst2 (map (lambda (x) (list 'set! (car x) (caddr x))) @@ -2561,12 +2562,12 @@ (read "scm_read" 1) (read-char "scm_read_char" 1) - (peek-char "peek_char" 1) + (peek-char "scm_peek_char" 1) (eof-object? "eof_objectp" 1) - (write "lwrite" 2) - (display "display" 2) - (newline "newline" 1) - (write-char "write_char" 2) + (write "scm_write" 2) + (display "scm_display" 2) + (newline "scm_newline" 1) + (write-char "scm_write_char" 2) (input-port? "input_portp" 1) (output-port? "output_portp" 1) diff --git a/hobbit.texi b/hobbit.texi index 0e59bf3..a04c8f8 100644 --- a/hobbit.texi +++ b/hobbit.texi @@ -351,7 +351,7 @@ procedures are redefined, neither before the compiled program is initialized, during its work or later via the interpreter. Hobbit checks the compiled source and whenever some variable bar is -defined as a procedure, but is later redefined, or @t{set!} is applied +defined as a procedure, but is later redefined, or @t{set!} is applied to bar, then hobbit assumes thas this particular variable bar is redefinable. bar may be a primitive (eg @samp{car}) or a name of a compiled procedure. @@ -2080,7 +2080,7 @@ A bug in the liftability analysis, reported by A. Jaffer (agj @@ alum.mit.edu). @item A bug occurring in case arguments are evaluated right-to-left, -which happens with Hobbit compiled by gcc on Linux. +which happens with Hobbit compiled by gcc on GNU/Linux. Reported and patched by George K. Bronnikov (goga@@bronnikov.msk.su) @item A closure-building bug sometimes leading to a serious loss of diff --git a/indexes.texi b/indexes.texi index 0aff554..758700a 100644 --- a/indexes.texi +++ b/indexes.texi @@ -1,6 +1,6 @@ @ifhtml -@node Index, , The Implementation, Top +@node Index, Procedure and Macro Index, The Implementation, Top @unnumbered Index @end ifhtml @@ -14,36 +14,36 @@ @end ifnotinfo @ifnotinfo -@node Procedure and Macro Index, Variable Index, Indexes, Indexes +@node Procedure and Macro Index, Variable Index, Index, Index @end ifnotinfo -@unnumberedsec Procedure and Macro Index +@unnumbered Procedure and Macro Index @c This is an alphabetical list of all the procedures and macros in SCM. @printindex fn @ifnotinfo -@node Variable Index, Type Index, Procedure and Macro Index, Indexes +@node Variable Index, Type Index, Procedure and Macro Index, Index @end ifnotinfo -@unnumberedsec Variable Index +@unnumbered Variable Index @c This is an alphabetical list of all the global variables in SCM. @printindex vr @ifnotinfo -@node Type Index, Concept Index, Variable Index, Indexes +@node Type Index, Concept Index, Variable Index, Index @end ifnotinfo -@unnumberedsec Type Index +@unnumbered Type Index @c This is an alphabetical list of data types and feature names in SCM. @printindex tp @ifnotinfo -@node Concept Index, , Type Index, Indexes +@node Concept Index, , Type Index, Index @end ifnotinfo -@unnumberedsec Concept Index +@unnumbered Concept Index @c This is an alphabetical list of concepts introduced in this manual. diff --git a/ioext.c b/ioext.c index 62efc2b..9f4ada7 100644 --- a/ioext.c +++ b/ioext.c @@ -193,49 +193,8 @@ static char s_write_line[] = "write-line"; SCM l_write_line(obj, port) SCM obj, port; { - display(obj, port); - return newline(port); -} - -static char s_file_position[] = "file-position", - s_file_set_pos[] = "file-set-position"; -SCM file_position(port) - SCM port; -{ - long ans; - ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position); - SYSCALL(ans = ftell(STREAM(port));); - if (CRDYP(port)) ans--; - return MAKINUM(ans); - } -SCM file_set_position(port, pos) - SCM port, pos; -{ - SCM ans; - ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos); -#ifndef RECKLESS - if (TRACKED & SCM_PORTFLAGS(port)) { - if (INUM0==pos) { - int i = SCM_PORTNUM(port); - scm_port_table[i].line = 1L; - scm_port_table[i].col = 1; - } - else { - if (2 <= verbose) - scm_warn("Setting file position for tracked port: ", "", port); - SCM_PORTFLAGS(port) &= (~TRACKED); - } - } -#endif - CLRDY(port); /* Clear ungetted char */ - SYSCALL(ans = (fseek(STREAM(port), INUM(pos), 0)) ? BOOL_F : BOOL_T;); -#ifdef HAVE_PIPE -# ifdef ESPIPE - if (!OPIOPORTP(port)) - ASRTER(ESPIPE != errno, port, ARG1, s_file_set_pos); -# endif -#endif - return ans; + scm_display(obj, port); + return scm_newline(port); } static char s_reopen_file[] = "reopen-file"; @@ -792,7 +751,6 @@ SCM l_putenv(str) #endif static iproc subr1s[] = { - {s_file_position, file_position}, {s_fileno, l_fileno}, #ifndef MCH_AMIGA # ifndef vms @@ -877,7 +835,6 @@ SCM scm_try_create_file(fname, modes, perms) #endif static iproc subr2os[] = { - {s_file_set_pos, file_set_position}, {s_read_line1, read_line1}, {s_write_line, l_write_line}, {0, 0}}; diff --git a/mkimpcat.scm b/mkimpcat.scm index 02d1323..ad39438 100644 --- a/mkimpcat.scm +++ b/mkimpcat.scm @@ -184,6 +184,8 @@ (in-implementation-vicinity "gsubr" link:able-suffix)) (add-link 'array-for-each (in-implementation-vicinity "ramap" link:able-suffix)) + (add-link 'byte-number + (in-implementation-vicinity "bytenumb" link:able-suffix)) ) (display* ")") ) diff --git a/patchlvl.h b/patchlvl.h index e7ddcfa..7d4b210 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=5e3 +VERSION=5e4 #endif #ifndef SCMVERSION -# define SCMVERSION "5e3" +# define SCMVERSION "5e4" #endif #ifdef nosve # define INIT_FILE_NAME "Init"SCMVERSION"_scm"; diff --git a/platform.txi b/platform.txi index ef3d033..199e0df 100644 --- a/platform.txi +++ b/platform.txi @@ -13,18 +13,18 @@ amiga-aztec m68000 amiga cc amiga-dice-c m68000 amiga dcc amiga-gcc m68000 amiga gcc amiga-sas m68000 amiga lc -atari-st-gcc m68000 atari.st gcc -atari-st-turbo-c m68000 atari.st tcc +atari-st-gcc m68000 atari-st gcc +atari-st-turbo-c m68000 atari-st tcc borland-c i8086 ms-dos bcc darwin powerpc unix cc djgpp i386 ms-dos gcc -freebsd i386 unix cc +freebsd *unknown* unix cc gcc *unknown* unix gcc gnu-win32 i386 unix gcc highc i386 ms-dos hc386 hp-ux hp-risc hp-ux cc irix mips irix gcc -linux i386 linux gcc +linux *unknown* linux gcc linux-aout i386 linux gcc linux-ia64 ia64 linux gcc microsoft-c i8086 ms-dos cl diff --git a/posix.c b/posix.c index 06e6b5f..1413930 100644 --- a/posix.c +++ b/posix.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1994, 1995, 1998 Free Software Foundation, Inc. +/* Copyright (C) 1994, 1995, 1998, 2006 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 diff --git a/r4rstest.scm b/r4rstest.scm index 5025733..95298f0 100644 --- a/r4rstest.scm +++ b/r4rstest.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003, 2004 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003, 2004, 2006, 2007 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 @@ -180,6 +180,7 @@ (test 34 'let x) (test 6 'let (let () (define x 6) x)) (test 34 'let x) +(test 34 'let (let ((x x)) x)) (test 7 'let* (let* ((x 3)) (define x 7) x)) (test 34 'let* x) (test 8 'let* (let* () (define x 8) x)) @@ -248,6 +249,12 @@ (test 6 'define (add3 3)) (define first car) (test 1 'define (first '(1 2))) +(define foo (lambda () 9)) +(test 9 'define (foo)) +(define foo foo) +(test 9 'define (foo)) +(define foo (let ((foo foo)) (lambda () (+ 1 (foo))))) +(test 10 'define (foo)) (define old-+ +) (begin (begin (begin) (begin (begin (begin) (define + (lambda (x y) (list y x))) diff --git a/ramap.c b/ramap.c index 53357e7..ad3a74e 100644 --- a/ramap.c +++ b/ramap.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1994, 1995 Free Software Foundation, Inc. +/* Copyright (C) 1994, 1995, 2006 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 @@ -1546,6 +1546,77 @@ SCM array_for_each(proc, ra0, lra) } } +static char s_array_index_for_each[] = "array-index-for-each"; +SCM scm_array_index_for_each(ra, proc) + SCM ra, proc; +{ + SCM hp_av, hp_indv, auto_av[5]; + SCM *av = &auto_av[0]; + long auto_indv[5]; + long *indv = &auto_indv[0]; + sizet i; + ASRTER(NIMP(ra), ra, ARG1, s_array_index_for_each); + i = INUM(array_rank(ra)); +#ifndef RECKLESS + scm_arity_check(proc, i+0L, s_array_index_for_each); +#endif + if (i >= 5) { + scm_protect_temp(&hp_av); + scm_protect_temp(&hp_indv); + hp_av = make_vector(MAKINUM(i), BOOL_F); + av = VELTS(hp_av); + hp_indv = make_uve(i+0L, MAKINUM(-32L)); + indv = (long *)VELTS(hp_indv); + } + switch TYP7(ra) { + default: badarg: wta(ra, (char *)ARG1, s_array_index_for_each); + case tc7_vector: { + for (i = 0; i < LENGTH(ra); i++) { + av[0] = MAKINUM(i); + scm_cvapply(proc, 1L, av); + } + return UNSPECIFIED; + } + case tcs_uves: + for (i = 0; i < LENGTH(ra); i++) { + av[0] = MAKINUM(i); + scm_cvapply(proc, 1L, auto_av); + } + return UNSPECIFIED; + case tc7_smob: ASRTGO(ARRAYP(ra), badarg); + { + int j, k, kmax = ARRAY_NDIM(ra) - 1; + if (kmax < 0) + return apply(proc, EOL, EOL); + for (k = 0; k <= kmax; k++) + indv[k] = ARRAY_DIMS(ra)[k].lbnd; + k = kmax; + do { + if (k==kmax) { + indv[k] = ARRAY_DIMS(ra)[k].lbnd; + i = cind(ra, indv); + for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) { + for (j = kmax+1; j--;) + av[j] = MAKINUM(indv[j]); + scm_cvapply(proc, kmax+1L, av); + i += ARRAY_DIMS(ra)[k].inc; + } + k--; + continue; + } + if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) { + indv[k]++; + k++; + continue; + } + indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1; + k--; + } while (k >= 0); + return UNSPECIFIED; + } + } +} + static char s_array_imap[] = "array-index-map!"; SCM array_imap(ra, proc) SCM ra, proc; @@ -1788,12 +1859,13 @@ static iproc lsubr2s[] = { {s_sarray_map, array_map}, {s_array_for_each, array_for_each}, {s_array_imap, array_imap}, + {s_array_index_for_each, scm_array_index_for_each}, {0, 0}}; static void init_raprocs(subra) ra_iproc *subra; { - for(; subra->name; subra++) + for (; subra->name; subra++) subra->sproc = CDR(sysintern(subra->name, UNDEFINED)); } diff --git a/record.c b/record.c index de72dce..30fa677 100644 --- a/record.c +++ b/record.c @@ -133,7 +133,7 @@ SCM rec_constr(rtd, flds) i = ilength(flds); ASRTER(i>=0, flds, ARG2, s_rec_constr); indices = MAKE_REC_INDS(i); - for(i = 0; NIMP(flds); i++, flds = CDR(flds)) { + for (i = 0; NIMP(flds); i++, flds = CDR(flds)) { fld = CAR(flds); ASRTER(NIMP(fld) && SYMBOLP(fld), fld, ARG2, s_rec_constr); flst = RTD_FIELDS(rtd); @@ -319,26 +319,26 @@ static int recprin1(exp, port, writing) } names = RTD_FIELDS(REC_RTD(exp)); lputs("#s(", port); - iprin1(RTD_NAME(REC_RTD(exp)), port, 0); + scm_iprin1(RTD_NAME(REC_RTD(exp)), port, 0); if (writing) { lputc(':', port); - intprint(((long)REC_RTD(exp))>>1, 16, port); + scm_intprint(((long)REC_RTD(exp))>>1, 16, port); } for (i = 1; i < NUMDIGS(exp); i++) { lputc(' ', port); - iprin1(CAR(names), port, 0); + scm_iprin1(CAR(names), port, 0); names = CDR(names); lputc(' ', port); - iprin1(VELTS(exp)[i], port, writing); + scm_iprin1(VELTS(exp)[i], port, writing); } lputc(')', port); /* lputs("#', port); - for(i = 1; i < NUMDIGS(exp); i++) { + for (i = 1; i < NUMDIGS(exp); i++) { lputc(' ', port); - iprin1(VELTS(exp)[i], port, writing); + scm_iprin1(VELTS(exp)[i], port, writing); } lputc('>', port); */ @@ -350,11 +350,11 @@ SCM rec_rtdprin1(rtd, port, writing_p) SCM rtd, port, writing_p; { lputs("#s(record-type ", port); - iprin1(RTD_NAME(rtd), port, 0); + scm_iprin1(RTD_NAME(rtd), port, 0); lputc(':', port); - intprint(((long)rtd)>>1, 16, port); + scm_intprint(((long)rtd)>>1, 16, port); lputs(" fields ", port); - iprin1(RTD_FIELDS(rtd), port, 0); + scm_iprin1(RTD_FIELDS(rtd), port, 0); if (NIMP(RTD_PRINTER(rtd))) lputs(" P)", port); else diff --git a/repl.c b/repl.c index b6d2602..5fa98d9 100644 --- a/repl.c +++ b/repl.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1990-2002 Free Software Foundation, Inc. +/* Copyright (C) 1990-2006 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 @@ -67,6 +67,10 @@ void scm_fill_freelist P((void)); # include #endif +#ifdef linux +# include +#endif + #ifdef ARM_ULIB # include int set_erase() @@ -88,8 +92,8 @@ unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; void init_tables() { int i; - for(i = 0;i', port); } -void iprlist(hdr, exp, tlr, port, writing) +void scm_iprlist(hdr, exp, tlr, port, writing) char *hdr, tlr; SCM exp; SCM port; @@ -199,32 +204,32 @@ void iprlist(hdr, exp, tlr, port, writing) { lputs(hdr, port); /* CHECK_INTS; */ - iprin1(CAR(exp), port, writing); + scm_iprin1(CAR(exp), port, writing); exp = GCCDR(exp); /* CDR(exp); */ - for(;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) { + for (;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) { if (!scm_cell_p(~1L & exp)) break; if (NECONSP(exp)) break; lputc(' ', port); /* CHECK_INTS; */ - iprin1(CAR(exp), port, writing); + scm_iprin1(CAR(exp), port, writing); } if (NNULLP(exp)) { lputs(" . ", port); - iprin1(exp, port, writing); + scm_iprin1(exp, port, writing); } lputc(tlr, port); } -void iprin1(exp, port, writing) +void scm_iprin1(exp, port, writing) SCM exp; SCM port; int writing; { register long i; taloop: - switch (7 & (int)exp) { + switch (7 & PTR2INT(exp)) { case 2: case 6: - intprint(INUM(exp), 10, port); + scm_intprint(INUM(exp), 10, port); break; case 4: if (ICHRP(exp)) { @@ -237,27 +242,27 @@ taloop: lputs(charnames[(sizeof charnames/sizeof(char *))-1], port); #endif /* ndef EBCDIC */ else if (i > '\177') - intprint(i, -8, port); + scm_intprint(i, -8, port); else lputc((int)i, port); } else if (SCM_LINUMP(exp)) { lputs("#', port); } else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *)))) lputs(ISYMCHARS(exp), port); else if (ILOCP(exp)) { lputs("#@", port); - intprint((long)IFRAME(exp), -10, port); + scm_intprint((long)IFRAME(exp), -10, port); lputc(ICDRP(exp)?'-':'+', port); - intprint((long)IDIST(exp), -10, port); + scm_intprint((long)IDIST(exp), -10, port); } else goto idef; break; case 1: /* gloc */ if (!scm_cell_p(exp-1)) { - ipruk("gloc", exp, port); + scm_ipruk("gloc", exp, port); break; } lputs("#@", port); @@ -270,11 +275,11 @@ taloop: goto taloop; default: idef: - ipruk("immediate", exp, port); + scm_ipruk("immediate", exp, port); break; case 0: if (!scm_cell_p(exp)) { - ipruk("heap", exp, port); + scm_ipruk("heap", exp, port); break; } switch TYP7(exp) { @@ -282,8 +287,8 @@ taloop: if (CAR(exp) != IM_LET) { lputs("(#@call ", port); exp = CDR(exp); - iprin1(CAR(exp), port, writing); - iprlist(" ", CAR(CDR(exp)), ')', port, writing); + scm_iprin1(CAR(exp), port, writing); + scm_iprlist(" ", CAR(CDR(exp)), ')', port, writing); break; } /* else fall through */ @@ -297,7 +302,7 @@ taloop: case tcs_cons_chflag: case tcs_cons_gloc: case tcs_cons_nimcar: - iprlist("(", exp, ')', port, writing); + scm_iprlist("(", exp, ')', port, writing); break; case tcs_closures: scm_princlosure(exp, port, writing); @@ -305,7 +310,7 @@ taloop: case tc7_string: if (writing) { lputc('\"', port); - for(i = 0;i', port); break; } @@ -373,9 +380,9 @@ taloop: break; case tc7_contin: lputs("#', port); break; case tc7_port: @@ -393,7 +400,7 @@ taloop: if (i= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf); - switch (c = lgetc(port)) { + register sizet j = 1; + register int c = ic; + register char *p = CHARS(tok_buf); + p[0] = '\\'==c ? lgetc(port) : 8 & flgs ? c : downcase[c]; + while(1) { + if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf); + switch (c = lgetc(port)) { #ifdef BRACKETS_AS_PARENS - case '[': case ']': + case '[': case ']': #endif - case '(': case ')': case '\"': case ';': - case ',': case '`': - /* case '#': */ - case WHITE_SPACES: - case LINE_INCREMENTORS: - lungetc(c, port); - case EOF: - p[j] = 0; - return j; - case '\\': /* slashified symbol */ - p[j++] = lgetc(port); - break; - default: - p[j++] = downcase[c]; - } - } + case '(': case ')': case '\"': case ';': + case ',': case '`': + /* case '#': */ + case WHITE_SPACES: + case LINE_INCREMENTORS: + lungetc(c, port); + case EOF: + p[j] = 0; + return j; + case '\\': /* slashified symbol */ + p[j++] = lgetc(port); + break; + default: + p[j++] = 8 & flgs ? c : downcase[c]; + } + } } #ifdef _UNICOS _Pragma("opt"); /* # pragma _CRI opt */ @@ -1150,28 +1152,28 @@ _Pragma("opt"); /* # pragma _CRI opt */ /* 5 - top level read when adding line-numbers. Uses LOAD:SHARP */ /* 6 - recursive read when adding line-numbers. Uses LOAD:SHARP */ -static SCM lreadparen(tok_buf, port, flgs, name) +static SCM scm_lreadparen(tok_buf, port, flgs, name) SCM tok_buf; SCM port; int flgs; char *name; { SCM lst, fst, - tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0)); + tmp = scm_lreadpr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 2 : 0)); if (UNDEFINED==tmp) return EOL; if (i_dot==tmp) { - fst = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0)); + fst = scm_lreadr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 1 : 0)); closeit: - tmp = lreadpr(tok_buf, port, 0); + tmp = scm_lreadpr(tok_buf, port, 0); if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name); return fst; } fst = lst = cons(tmp, EOL); while (UNDEFINED != - (tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0)))) { + (tmp = scm_lreadpr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 2 : 0)))) { if (EOF_VAL==tmp) wta(lst, s_eofin, s_list); if (i_dot==tmp) { - CDR(lst) = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0)); + CDR(lst) = scm_lreadr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 1 : 0)); goto closeit; } lst = (CDR(lst) = cons(tmp, EOL)); @@ -1233,7 +1235,7 @@ static int prinarb(exp, port, writing) { lputs("#', port); return !0; } @@ -1359,7 +1361,7 @@ SCM scm_top_level(initpath, toplvl_fun) if (i) i = UNCOOK(i); #endif drloop: - switch ((int)i) { + switch (PTR2INT(i)) { default: { char *name = errmsgs[i-WNA].s_response; @@ -1376,7 +1378,7 @@ SCM scm_top_level(initpath, toplvl_fun) exitval = MAKINUM(EXIT_SUCCESS); errjmp_bad = (char *)0; errjmp_recursive = 0; - lflush(sys_errp); + if (NIMP(sys_errp) && OPOUTPORTP(sys_errp)) lfflush(sys_errp); errno = 0; SIG_deferred = 0; deferred_proc = 0; @@ -1404,7 +1406,7 @@ SCM scm_top_level(initpath, toplvl_fun) ints_disabled = 1; errjmp_bad = (char *)0; errjmp_recursive = 0; - lflush(sys_errp); + if (NIMP(sys_errp) && OPOUTPORTP(sys_errp)) lfflush(sys_errp); SIG_deferred = 0; deferred_proc = 0; gc_hook_active = 0; @@ -1416,8 +1418,8 @@ SCM scm_top_level(initpath, toplvl_fun) if (NIMP(loadports) && OPINPORTP(CAR(loadports))) { if (scm_verbose > 1) { lputs("; Aborting load (closing): ", cur_errp); - display(*loc_loadpath, cur_errp); - newline(cur_errp); + scm_display(*loc_loadpath, cur_errp); + scm_newline(cur_errp); } close_port(CAR(loadports)); /* close loading file. */ } @@ -1436,8 +1438,8 @@ SCM scm_top_level(initpath, toplvl_fun) dowinds(EOL); if (MAKINUM(EXIT_SUCCESS) != exitval) { lputs("; program args: ", cur_errp); - lwrite(progargs, cur_errp); - newline(cur_errp); + scm_write(progargs, cur_errp); + scm_newline(cur_errp); } return exitval; case -3: /* restart. */ @@ -1506,6 +1508,50 @@ SCM scm_port_col(port) } return MAKINUM(col); } + +static char s_file_position[] = "file-position"; +SCM scm_file_position(port, pos) + SCM port, pos; +{ + ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position); + if (UNBNDP(pos) || FALSEP(pos)) { + long ans; + SYSCALL(ans = ftell(STREAM(port));); + if (ans < 0) return BOOL_F; + if (CRDYP(port)) ans--; + return MAKINUM(ans); + } + ASRTER((INUMP(pos) && (INUM(pos) >= 0)) + || (NIMP(pos) && (TYP16(pos)==tc16_bigpos)), + port, ARG2, s_file_position); +#ifndef RECKLESS + if (TRACKED & SCM_PORTFLAGS(port)) { + if (INUM0==pos) { + int i = SCM_PORTNUM(port); + scm_port_table[i].line = 1L; + scm_port_table[i].col = 1; + } + else { + if (2 <= verbose) + scm_warn("Setting file position for tracked port: ", "", port); + SCM_PORTFLAGS(port) &= (~TRACKED); + } + } +#endif + { + int ans; + CLRDY(port); /* Clear ungetted char */ + SYSCALL(ans = fseek(STREAM(port), INUM(pos), 0);); +#ifdef HAVE_PIPE +# ifdef ESPIPE + if (!OPIOPORTP(port)) + ASRTER(ESPIPE != errno, port, ARG1, s_file_position); +# endif +#endif + return ans ? BOOL_F : BOOL_T; + } +} + static char s_port_filename[] = "port-filename"; SCM scm_port_filename(port) SCM port; @@ -1535,7 +1581,7 @@ void growth_mon(obj, size, units, grewp) lputs((grewp ? "; grew " : "; shrank "), sys_errp); lputs(obj, sys_errp); lputs(" to ", sys_errp); - intprint(size, -10, sys_errp); + scm_intprint(size, -10, sys_errp); lputc(' ', sys_errp); lputs(units, sys_errp); if ((verbose > 4) && (obj==s_heap)) heap_report(); @@ -1563,15 +1609,15 @@ void gc_end() gc_rt = INUM(my_time()) - gc_rt; gc_time_taken = gc_time_taken + gc_rt; if (verbose > 4) { - intprint(time_in_msec(gc_rt), -10, sys_errp); + scm_intprint(time_in_msec(gc_rt), -10, sys_errp); lputs(".ms cpu, ", sys_errp); - intprint(gc_cells_collected, -10, sys_errp); + scm_intprint(gc_cells_collected, -10, sys_errp); lputs(" cells, ", sys_errp); - intprint(gc_malloc_collected, -10, sys_errp); + scm_intprint(gc_malloc_collected, -10, sys_errp); lputs(" malloc, ", sys_errp); - intprint(gc_syms_collected, -10, sys_errp); + scm_intprint(gc_syms_collected, -10, sys_errp); lputs(" syms, ", sys_errp); - intprint(gc_ports_collected, -10, sys_errp); + scm_intprint(gc_ports_collected, -10, sys_errp); lputs(" ports collected\n", sys_errp); } } @@ -1590,26 +1636,26 @@ void repl_report() if (verbose > 2) { lfflush(cur_outp); lputs(";Evaluation took ", cur_errp); - intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp); + scm_intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp); lputs(".ms (", cur_errp); - intprint(time_in_msec(gc_time_taken), -10, cur_errp); + scm_intprint(time_in_msec(gc_time_taken), -10, cur_errp); lputs(".ms in gc) ", cur_errp); - intprint(cells_allocated - lcells_allocated, -10, cur_errp); + scm_intprint(cells_allocated - lcells_allocated, -10, cur_errp); lputs(" cells work, ", cur_errp); scm_env_work += scm_ecache_len - scm_ecache_index; - intprint(scm_env_work, -10, cur_errp); + scm_intprint(scm_env_work, -10, cur_errp); lputs(" env, ", cur_errp); - intprint(mallocated - lmallocated, -10, cur_errp); + scm_intprint(mallocated - lmallocated, -10, cur_errp); lputs(".B other\n", cur_errp); if (verbose > 3) { lputc(';', cur_errp); - intprint(scm_gcs, -10, cur_errp); + scm_intprint(scm_gcs, -10, cur_errp); lputs( " gc, ", cur_errp); - intprint(scm_egcs, -10, cur_errp); + scm_intprint(scm_egcs, -10, cur_errp); lputs( " ecache gc, ", cur_errp); - intprint(scm_clo_moved, -10, cur_errp); + scm_intprint(scm_clo_moved, -10, cur_errp); lputs(" env migrated from closures, ", cur_errp); - intprint(scm_stk_moved, -10, cur_errp); + scm_intprint(scm_stk_moved, -10, cur_errp); lputs(" from stack\n", cur_errp); } lfflush(cur_errp); @@ -1631,18 +1677,18 @@ void scm_brk_report() dif2 = (scm_curbrk - scm_dumped_brk)/1024; lputs("initial brk = 0x", cur_errp); - intprint(scm_init_brk, -16, cur_errp); + scm_intprint(scm_init_brk, -16, cur_errp); if (dumped) { lputs(", dumped = 0x", cur_errp); - intprint(scm_dumped_brk, -16, cur_errp); + scm_intprint(scm_dumped_brk, -16, cur_errp); } lputs(", current = 0x", cur_errp); - intprint(scm_curbrk, -16, cur_errp); + scm_intprint(scm_curbrk, -16, cur_errp); lputs("; ", cur_errp); - intprint(dif1, 10, cur_errp); + scm_intprint(dif1, 10, cur_errp); if (dumped) { lputs(dif2 < 0 ? " - " : " + ", cur_errp); - intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp); + scm_intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp); } lputs(".kiB\n", cur_errp); } @@ -1650,13 +1696,13 @@ void scm_brk_report() SCM lroom(opt) SCM opt; { - intprint(cells_allocated, -10, cur_errp); + scm_intprint(cells_allocated, -10, cur_errp); lputs(" out of ", cur_errp); - intprint(heap_cells, -10, cur_errp); + scm_intprint(heap_cells, -10, cur_errp); lputs(" cells in use, ", cur_errp); - intprint(mallocated, -10, cur_errp); + scm_intprint(mallocated, -10, cur_errp); lputs(".B allocated (of ", cur_errp); - intprint(mtrigger, 10, cur_errp); + scm_intprint(mtrigger, 10, cur_errp); lputs(")\n", cur_errp); if (!UNBNDP(opt)) { #ifndef LACK_SBRK @@ -1671,20 +1717,20 @@ SCM lroom(opt) } void scm_ecache_report() { - intprint(scm_estk_size, 10 , cur_errp); + scm_intprint(scm_estk_size, 10 , cur_errp); lputs(" env stack items, ", cur_errp); - intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp); + scm_intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp); lputs(" out of ", cur_errp); - intprint(scm_ecache_len, 10, cur_errp); + scm_intprint(scm_ecache_len, 10, cur_errp); lputs(" env cells in use.\n", cur_errp); } void exit_report() { if (verbose > 2) { lputs(";Totals: ", cur_errp); - intprint(time_in_msec(INUM(my_time())), -10, cur_errp); + scm_intprint(time_in_msec(INUM(my_time())), -10, cur_errp); lputs(".ms my time, ", cur_errp); - intprint(time_in_msec(INUM(your_time())), -10, cur_errp); + scm_intprint(time_in_msec(INUM(your_time())), -10, cur_errp); lputs(".ms your time\n", cur_errp); } } @@ -1737,8 +1783,8 @@ SCM repl() #ifdef __MSDOS__ if ('\n' != CGETUN(cur_inp)) if (OPOUTPORTP(cur_inp)) /* This case for curses window */ - {lfflush(cur_outp); newline(cur_inp);} - else newline(cur_outp); + {lfflush(cur_outp); scm_newline(cur_inp);} + else scm_newline(cur_outp); #endif if (NIMP(x)) { x = CONSP(x) ? @@ -1751,13 +1797,13 @@ SCM repl() if (IMP(x)) {if (verbose > 2) lputs(";;no values\n", cur_outp);} else if (IMP(CDR(x))) { - iprin1(CAR(x), cur_outp, 1); + scm_iprin1(CAR(x), cur_outp, 1); lputc('\n', cur_outp); } else while (NIMP(x)) { lputc(' ', cur_outp); - iprin1(CAR(x), cur_outp, 1); + scm_iprin1(CAR(x), cur_outp, 1); lputc('\n', cur_outp); x = CDR(x); } @@ -1918,10 +1964,10 @@ SCM scm_load_string(str) void scm_line_msg(file, linum, port) SCM file, linum, port; { - iprin1(file, port, 1); + scm_iprin1(file, port, 1); if (SCM_LINUMP(linum)) { lputs(", line ", port); - intprint(SCM_LINUM(linum), -10, port); + scm_intprint(SCM_LINUM(linum), -10, port); } lputs(": ", port); } @@ -1955,9 +2001,9 @@ static void err_head(str) 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); + scm_iprin1(scm_port_filename(CAR(lps)), cur_errp, 0); lputs(":", cur_errp); - iprin1(scm_port_line(CAR(lps)), cur_errp, 1); + scm_iprin1(scm_port_line(CAR(lps)), cur_errp, 1); lputs(IMP(CDR(lps)) ? ":" : ",\n; loaded from ", cur_errp); } } @@ -1980,7 +2026,7 @@ void scm_warn(str1, str2, obj) lputc('\n', cur_errp); } if (!UNBNDP(obj)) { - iprin1(obj, cur_errp, 1); + scm_iprin1(obj, cur_errp, 1); lputc('\n', cur_errp); } lfflush(cur_errp); @@ -2017,7 +2063,7 @@ static void def_err_response() lputs("RECURSIVE ERROR: ", def_errp); if (badport || TYP16(cur_errp)==tc16_sfport) { lputs("reverting from ", def_errp); - iprin1(cur_errp, def_errp, 2); + scm_iprin1(cur_errp, def_errp, 2); lputs("to default error port\n", def_errp); cur_errp = def_errp; errjmp_recursive = 0; @@ -2061,7 +2107,7 @@ static void def_err_response() if (reset_safeport(sys_safep, 55, cur_errp)) if (0==setjmp(SAFEP_JMPBUF(sys_safep))) { if (codep) scm_princode(obj, EOL, sys_safep, writing); - else iprin1(obj, sys_safep, writing); + else scm_iprin1(obj, sys_safep, writing); } if (UNBNDP(err_exp)) goto getout; if (NIMP(err_exp)) { @@ -2070,9 +2116,9 @@ static void def_err_response() lputs("\n; in expression: ", cur_errp); if (NCONSP(err_exp)) scm_princode(err_exp, env, sys_safep, writing); else if (UNDEFINED==CDR(err_exp)) - iprin1(CAR(err_exp), sys_safep, writing); + scm_iprin1(CAR(err_exp), sys_safep, writing); else { - if (UNBNDP(env)) iprlist("(... ", err_exp, ')', sys_safep, writing); + if (UNBNDP(env)) scm_iprlist("(... ", err_exp, ')', sys_safep, writing); else scm_princode(err_exp, env, sys_safep, writing); } } @@ -2188,9 +2234,11 @@ static char s_isatty[] = "isatty?"; SCM l_isatty(port) SCM port; { + int fn; ASRTER(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty); if (tc16_fport != TYP16(port)) return BOOL_F; - return isatty(fileno(STREAM(port)))?BOOL_T:BOOL_F; + fn = fileno(STREAM(port)); + return (fn >= 0 && isatty(fn)) ? BOOL_T : BOOL_F; } static iproc subr0s[] = { @@ -2221,10 +2269,10 @@ static iproc subr1s[] = { static iproc subr1os[] = { {s_read_char, scm_read_char}, - {s_peek_char, peek_char}, - {s_newline, newline}, + {s_peek_char, scm_peek_char}, + {s_newline, scm_newline}, {s_freshline, scm_freshline}, - {s_flush, lflush}, + {s_force_output, scm_force_output}, {s_char_readyp, char_readyp}, {"quit", quit}, {"verbose", prolixity}, @@ -2233,10 +2281,11 @@ static iproc subr1os[] = { {0, 0}}; static iproc subr2os[] = { - {s_write, lwrite}, - {s_display, display}, - {s_write_char, write_char}, + {s_write, scm_write}, + {s_display, scm_display}, + {s_write_char, scm_write_char}, {s_tryload, tryload}, + {s_file_position, scm_file_position}, #ifdef CAN_DUMP {s_unexec, scm_unexec}, #endif @@ -2274,6 +2323,9 @@ void init_repl( iverbose ) make_subr(s_read, tc7_subr_1o, scm_read); i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED)); i_load_string = CAR(sysintern(s_load_string, UNDEFINED)); + scm_ldstr("\n\ +(define file-set-position file-position)\n\ +"); #ifdef CAN_DUMP add_feature("dump"); scm_ldstr("\ diff --git a/requires.scm b/requires.scm index cad8db0..3703bf9 100644 --- a/requires.scm +++ b/requires.scm @@ -2,12 +2,12 @@ (define library-vicinity (let* ((vl (case (software-type) - ((AMIGA) '(#\: #\/)) - ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) - ((MACOS THINKC) '(#\:)) - ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT PLAN9) '(#\/)) - ((VMS) '(#\: #\])))) + ((amiga) '(#\: #\/)) + ((ms-dos windows atarist os/2) '(#\\ #\/)) + ((macos thinkc) '(#\:)) + ((nosve) '(#\: #\.)) + ((unix coherent plan9) '(#\/)) + ((vms) '(#\: #\])))) (iv (implementation-vicinity)) (vc (and (positive? (string-length iv)) (string-ref iv (+ -1 (string-length iv))))) diff --git a/rgx.c b/rgx.c index 1f3b4f0..81af5c4 100644 --- a/rgx.c +++ b/rgx.c @@ -55,7 +55,7 @@ #endif static char rcsid[] = - "$Id: rgx.c,v 1.16 2002/11/25 20:34:31 jaffer Exp $"; + "$Id: rgx.c,v 1.18 2007/11/24 19:56:56 jaffer Exp $"; #ifdef HAVE_ALLOCA # include @@ -135,9 +135,9 @@ int prinregex(exp, port, writing) SCM exp; SCM port; int writing; { lputs("#', port); return 1; } @@ -201,12 +201,12 @@ SCM lregcomp(pattern, flags) info=(regex_info*)CHARS(z); prog = &(info->rgx); #ifdef __REGEXP_LIBRARY_H__ - for(i=sizeof(regex_t);i--;((char *)prog)[i] = 0); + for (i=sizeof(regex_t);i--;((char *)prog)[i] = 0); # ifndef _GNU_SOURCE { regex_t *prog2; prog2 = &(info->rgx_anchored); - for(i=sizeof(regex_t);i--;((char *)prog2)[i] = 0); + for (i=sizeof(regex_t);i--;((char *)prog2)[i] = 0); } # endif #endif diff --git a/rope.c b/rope.c index 6f48982..d4fc16a 100644 --- a/rope.c +++ b/rope.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, 2006 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 @@ -121,7 +121,7 @@ unsigned long num2ulong(num, pos, s_caller) sizet l = NUMDIGS(num); ASRTGO(DIGSPERLONG >= l, errout); res = 0; - for(;l--;) res = BIGUP(res) + BDIGITS(num)[l]; + for (;l--;) res = BIGUP(res) + BDIGITS(num)[l]; return res; } #endif @@ -152,7 +152,7 @@ long num2long(num, pos, s_caller) sizet l = NUMDIGS(num); ASRTGO(DIGSPERLONG >= l, errout); res = 0; - for(;l--;) res = BIGUP(res) + BDIGITS(num)[l]; + for (;l--;) res = BIGUP(res) + BDIGITS(num)[l]; ASRTGO(0 i) for(i = 0; argv[i]; i++); + if (0 > i) for (i = 0; argv[i]; i++); while (i--) lst = cons(makfrom0str(argv[i]), lst); return lst; } @@ -232,7 +232,7 @@ char **makargvfrmstrs(args, s_name) char ** argv; int argc = ilength(args); argv = (char **)must_malloc((1L+argc)*sizeof(char *), s_vector); - for(argc = 0; NNULLP(args); args=CDR(args), ++argc) { + for (argc = 0; NNULLP(args); args=CDR(args), ++argc) { ASRTER(NIMP(CAR(args)) && STRINGP(CAR(args)), CAR(args), ARG2, s_name); { sizet len = 1 + LENGTH(CAR(args)); @@ -246,10 +246,10 @@ char **makargvfrmstrs(args, s_name) return argv; } void must_free_argv(argv) - const char * const *argv; + char **argv; { sizet i; - for(i = 0; argv[i]; i++) { + for (i = 0; argv[i]; i++) { must_free(argv[i], 1+strlen(argv[i])); } must_free((char *)argv, i*sizeof(char *)); @@ -295,7 +295,7 @@ int scm_ldprog(path) long aind P((SCM ra, SCM args, const char *what)); unsigned long scm_addr(args, s_name) SCM args; - char *s_name; + const char *s_name; { long pos; unsigned long ptr = 0; /* gratuitous assignment squelches cc warn. */ @@ -356,7 +356,7 @@ unsigned long scm_addr(args, s_name) } unsigned long scm_base_addr(v, s_name) SCM v; - char *s_name; + const char *s_name; { long pos = 0; unsigned long ptr = 0; /* gratuitous assignment squelches cc warn. */ diff --git a/scl.c b/scl.c index 7f17cc6..b7c3f35 100644 --- a/scl.c +++ b/scl.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 2005 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 2005, 2006 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 @@ -350,7 +350,7 @@ static SCM big2str(b, radix) } ch = s[0]=='-' ? 1 : 0; /* jeh */ if (ch < j) { /* jeh */ - for(i = j;j < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */ + for (i = j;j < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */ resizuve(ss, (SCM)MAKINUM(ch+LENGTH(ss)-i)); /* jeh */ } return ss; @@ -405,7 +405,7 @@ int floprint(sexp, port, writing) return !0; } else #endif - ipruk("float", sexp, port); + scm_ipruk("float", sexp, port); return !0; } int bigprint(exp, port, writing) @@ -420,7 +420,7 @@ int bigprint(exp, port, writing) return !0; } else #endif - ipruk("bignum", exp, port); + scm_ipruk("bignum", exp, port); return !0; } /*** END nums->strs ***/ @@ -884,7 +884,7 @@ SCM eqv(x, y) SCM memv(x, lst) /* m.borza 12.2.91 */ SCM x, lst; { - for(;NIMP(lst);lst = CDR(lst)) { + for (;NIMP(lst);lst = CDR(lst)) { ASRTGO(CONSP(lst), badlst); if (NFALSEP(eqv(CAR(lst), x))) return lst; } @@ -898,7 +898,7 @@ SCM assv(x, alist) /* m.borza 12.2.91 */ SCM x, alist; { SCM tmp; - for(;NIMP(alist);alist = CDR(alist)) { + for (;NIMP(alist);alist = CDR(alist)) { ASRTGO(CONSP(alist), badlst); tmp = CAR(alist); ASRTGO(NIMP(tmp) && CONSP(tmp), badlst); @@ -933,7 +933,7 @@ SCM string2list(str) unsigned char *src; ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_str2list); src = UCHARS(str); - for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKICHR(src[i]), res); + for (i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKICHR(src[i]), res); return res; } SCM string_copy(str) @@ -951,7 +951,7 @@ SCM string_fill(str, chr) ASRTER(ICHRP(chr), chr, ARG2, s_st_fill); c = ICHR(chr); dst = CHARS(str); - for(k = LENGTH(str)-1;k >= 0;k--) dst[k] = c; + for (k = LENGTH(str)-1;k >= 0;k--) dst[k] = c; return UNSPECIFIED; } SCM vector2list(v) @@ -962,7 +962,7 @@ SCM vector2list(v) SCM *data; ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list); data = VELTS(v); - for(i = LENGTH(v)-1;i >= 0;i--) res = cons(data[i], res); + for (i = LENGTH(v)-1;i >= 0;i--) res = cons(data[i], res); return res; } SCM vector_fill(v, fill) @@ -972,14 +972,14 @@ SCM vector_fill(v, fill) register SCM *data; ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill); data = VELTS(v); - for(i = LENGTH(v)-1;i >= 0;i--) data[i] = fill; + for (i = LENGTH(v)-1;i >= 0;i--) data[i] = fill; return UNSPECIFIED; } static SCM vector_equal(x, y) SCM x, y; { long i; - for(i = LENGTH(x)-1;i >= 0;i--) + for (i = LENGTH(x)-1;i >= 0;i--) if (FALSEP(equal(VELTS(x)[i], VELTS(y)[i]))) return BOOL_F; return BOOL_T; } @@ -2697,7 +2697,7 @@ unsigned long hasher(obj, n, d) unsigned long n; sizet d; { - switch (7 & (int) obj) { + switch (7 & PTR2INT(obj)) { case 2: case 6: /* INUMP(obj) */ return INUM(obj) % n; case 4: diff --git a/scm.1 b/scm.1 index 5ab98cf..5ab0180 100644 --- a/scm.1 +++ b/scm.1 @@ -12,7 +12,9 @@ scm \- a Scheme Language Interpreter [--version] [--help] .br -[[-]-no-init-file] [-p +[[-]-no-init-file] [--no-symbol-case-fold] +.br +[-p .I int ] [-r .I feature @@ -80,9 +82,12 @@ should allocate an initial heapsize of .I kbytes. This option, if present, must be the first on the command line. .TP -.BI -no-init-file +.BI --no-init-file Inhibits the loading of "ScmInit.scm" as described above. .TP +.BI --no-symbol-case-fold +Symbol (and identifier) names are case-sensitive. +.TP .BI -e expression .TP .BI -c expression diff --git a/scm.c b/scm.c index 90b14a1..dc0ad7b 100644 --- a/scm.c +++ b/scm.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1990-2002 Free Software Foundation, Inc. +/* Copyright (C) 1990-2006 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 @@ -51,7 +51,7 @@ #include "patchlvl.h" #ifdef _WIN32 -#include +# include #endif #ifdef __IBMC__ @@ -111,7 +111,7 @@ void final_repl P((void)); void init_banner() { - fputs("SCM version "SCMVERSION", Copyright (C) 1990-2002 \ + fputs("SCM version "SCMVERSION", Copyright (C) 1990-2006 \ Free Software Foundation.\n\ SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\ This is free software, and you are welcome to redistribute it\n\ @@ -175,19 +175,22 @@ SCM scm_init_extensions() #endif #define SIGNAL_BASE HUP_SIGNAL -#define NUM_SIGNALS (sizeof(sigdesc)/sizeof(sigdesc[0])) /* PROF_SIGNAL appears below because it is the last signal defined in scm.h and in errmsgs in repl.c */ static struct { int signo; SIGRETTYPE (*osig)(); SIGRETTYPE (*nsig)(); } sigdesc[PROF_SIGNAL - SIGNAL_BASE + 1]; + +#define NUM_SIGNALS (sizeof(sigdesc)/sizeof(sigdesc[0])) + void process_signals() { int i, n; unsigned long mask = 1L; + /* printf("process_signals; output_deferred=%d\n", output_deferred); fflush(stdout); */ if (output_deferred) { output_deferred = 0; - lflush(sys_errp); + /* if (NIMP(sys_errp) && OPOUTPORTP(sys_errp)) lfflush(sys_errp); */ } for (n = 0; SIG_deferred && n < NUM_SIGNALS; n++) { if (SIG_deferred & mask) { @@ -289,11 +292,10 @@ static SIGRETTYPE scmable_signal(sig) if (sig == sigdesc[i].signo) break; ASRTER(i >= 0, MAKINUM(sig), s_unksig, ""); #ifdef WINSIGNALS - if (SIGINT == sig) - signal(sig, win32_sigint); + if (SIGINT == sig) signal(sig, win32_sigint); else #endif - signal(sig, scmable_signal); + signal(sig, scmable_signal); if (ints_disabled) { deferred_proc = process_signals; SIG_deferred |= (1L << i); @@ -503,6 +505,7 @@ SCM lticks(i) static SIGRETTYPE (*oldpipe) (); #endif +int case_sensitize_symbols = 0; /* set to 8 to read case-sensitive symbols */ int dumped = 0; /* Is this an invocation of unexec exe? */ #ifdef SHORT_ALIGN @@ -684,20 +687,16 @@ void scm_init_from_argv(argc, argv, script_arg, iverbose, buf0stdin) int buf0stdin; { long i = 0L; - if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) { - const char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2]; - do { - switch (*str) { - case DIGITS: - i = i * 10 + (*str - '0'); - if (i <= 10000L) continue; /* the size limit should match Init.scm */ - default: - i = 0L; - } + int j = 0; + if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) + i = atol((0==argv[1][2] && 3 <= argc && argv[2]) ? argv[2] : &argv[1][2]); + init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in kB */ + for (j = 0; argv[j]; j++) { + if (0==strcmp(argv[j], "--no-symbol-case-fold")) { + case_sensitize_symbols = 8; break; - } while (* ++str); + } } - init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in kB */ progargs = EOL; progargs = makfromstrs(argc, argv); sysintern("*script*", script_arg ? makfrom0str(script_arg) : BOOL_F); diff --git a/scm.doc b/scm.doc index 54372b7..23a90d9 100644 --- a/scm.doc +++ b/scm.doc @@ -7,7 +7,8 @@ NAME SYNOPSIS scm [-a kbytes ] [-muvqib] [--version] [--help] - [[-]-no-init-file] [-p int ] [-r feature ] [-h feature ] + [[-]-no-init-file] [--no-symbol-case-fold] + [-p int ] [-r feature ] [-h feature ] [-d filename ] [-f filename ] [-l filename ] [-c expression ] [-e expression ] [-o dumpname ] [-- | - | -s] [ filename ] [ arguments ... ] @@ -38,9 +39,12 @@ OPTIONS specifies that scm should allocate an initial heapsize of kbytes. This option, if present, must be the first on the command line. - -no-init-file + --no-init-file Inhibits the loading of "ScmInit.scm" as described above. + --no-symbol-case-fold + Symbol (and identifier) names are case-sensitive. + -eexpression -cexpression diff --git a/scm.h b/scm.h index bf17d06..9608d87 100644 --- a/scm.h +++ b/scm.h @@ -1,4 +1,4 @@ -/* Copyright (C) 1990-1999 Free Software Foundation, Inc. +/* Copyright (C) 1990-2006 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 @@ -169,30 +169,30 @@ typedef struct {SCM type;double *real;} dbl; /* Conditionals should always expect immediates */ /* GCC __builtin_expect() is stubbed in scmfig.h */ -#define IMP(x) SCM_EXPECT_TRUE(6 & (int)(x)) +#define IMP(x) SCM_EXPECT_TRUE(6 & PTR2INT(x)) #define NIMP(x) (!IMP(x)) -#define INUMP(x) SCM_EXPECT_TRUE(2 & (int)(x)) +#define INUMP(x) SCM_EXPECT_TRUE(2 & PTR2INT(x)) #define NINUMP(x) (!INUMP(x)) #define INUM0 ((SCM) 2) -#define ICHRP(x) ((0xff & (int)(x))==0xf4) +#define ICHRP(x) ((0xff & PTR2INT(x))==0xf4) #define ICHR(x) ((unsigned char)((x)>>8)) #define MAKICHR(x) (((x)<<8)+0xf4L) #define ILOC00 (0x000000fcL) -#define ILOCP(n) ((0xff & (int)(n))==(int)ILOC00) +#define ILOCP(n) ((0xff & PTR2INT(n))==PTR2INT(ILOC00)) #define MAKILOC(if, id) (ILOC00 + (((long)id)<<8) + (((long)if)<<16)) -#define IDIST(n) (((int)(n)>>8) & 0x7f) -#define IFRAME(n) (((int)(n)>>16)) +#define IDIST(n) ((PTR2INT(n)>>8) & 0x7f) +#define IFRAME(n) ((PTR2INT(n)>>16)) #define ICDRP(n) (ICDR & (n)) #define ICDR (1L<<15) /* ISYMP tests for ISPCSYM and ISYM */ -#define ISYMP(n) ((0x187 & (int)(n))==4) +#define ISYMP(n) ((0x187 & PTR2INT(n))==4) /* IFLAGP tests for ISPCSYM, ISYM and IFLAG */ -#define IFLAGP(n) ((0x87 & (int)(n))==4) -#define ISYMNUM(n) (((int)((n)>>9)) & 0x7f) -#define ISYMVAL(n) ((int)((n)>>16)) +#define IFLAGP(n) ((0x87 & PTR2INT(n))==4) +#define ISYMNUM(n) ((PTR2INT((n)>>9)) & 0x7f) +#define ISYMVAL(n) (PTR2INT((n)>>16)) #define MAKISYMVAL(isym, val) ((isym) | ((long)(val) <<16)) #define ISYMCHARS(n) (isymnames[ISYMNUM(n)]) #define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) @@ -299,26 +299,26 @@ SCM_EXPORT SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; #define NNULLP(x) (EOL != (x)) #define UNBNDP(x) (UNDEFINED==(x)) #define CELLP(x) (!NCELLP(x)) -#define NCELLP(x) ((sizeof(cell)-1) & (int)(x)) +#define NCELLP(x) ((sizeof(cell)-1) & PTR2INT(x)) -#define GCMARKP(x) (1 & (int)CDR(x)) -#define GC8MARKP(x) (0x80 & (int)CAR(x)) +#define GCMARKP(x) (1 & PTR2INT(CDR(x))) +#define GC8MARKP(x) (0x80 & PTR2INT(CAR(x))) #define SETGCMARK(x) CDR(x) |= 1; #define CLRGCMARK(x) CDR(x) &= ~1L; #define SETGC8MARK(x) CAR(x) |= 0x80; #define CLRGC8MARK(x) CAR(x) &= ~0x80L; -#define TYP3(x) (7 & (int)CAR(x)) -#define TYP7(x) (0x7f & (int)CAR(x)) -#define TYP7S(x) (0x7d & (int)CAR(x)) -#define TYP16(x) (0xffff & (int)CAR(x)) -#define TYP16S(x) (0xfeff & (int)CAR(x)) -#define GCTYP16(x) (0xff7f & (int)CAR(x)) - -#define NCONSP(x) (1 & (int)CAR(x)) +#define TYP3(x) (7 & PTR2INT(CAR(x))) +#define TYP7(x) (0x7f & PTR2INT(CAR(x))) +#define TYP7S(x) (0x7d & PTR2INT(CAR(x))) +#define TYP16(x) (0xffff & PTR2INT(CAR(x))) +#define TYP16S(x) (0xfeff & PTR2INT(CAR(x))) +#define GCTYP16(x) (0xff7f & PTR2INT(CAR(x))) + +#define NCONSP(x) (1 & PTR2INT(CAR(x))) #define CONSP(x) (!NCONSP(x)) #define ECONSP(x) (CONSP(x) || (1==TYP3(x))) #define NECONSP(x) (NCONSP(x) && (1 != TYP3(x))) -#define SCM_GLOCP(x) (tc3_cons_gloc==(7 & (int)(x))) +#define SCM_GLOCP(x) (tc3_cons_gloc==(7 & PTR2INT(x))) #define CAR(x) (((cell *)(SCM2PTR(x)))->car) #define CDR(x) (((cell *)(SCM2PTR(x)))->cdr) @@ -425,9 +425,9 @@ SCM_EXPORT long tc16_env, tc16_ident; # define NUMBERP INUMP # endif #endif -#define NUMP(x) ((0xfcff & (int)CAR(x))==tc7_smob) +#define NUMP(x) ((0xfcff & PTR2INT(CAR(x)))==tc7_smob) #define BIGP(x) (TYP16S(x)==tc16_bigpos) -#define BIGSIGN(x) (0x0100 & (int)CAR(x)) +#define BIGSIGN(x) (0x0100 & PTR2INT(CAR(x))) #define BDIGITS(x) ((BIGDIG *)(CDR(x))) #define NUMDIGS(x) ((sizet)(((unsigned long)CAR(x))>>16)) #define MAKE_NUMDIGS(v, t) ((((v)+0L)<<16)+(t)) @@ -462,7 +462,7 @@ SCM_EXPORT long tc16_array; /*#define ARRAY_NDIM(x) NUMDIGS(x)*/ #define ARRAY_NDIM(x) ((sizet)(CAR(x)>>17)) #define ARRAY_CONTIGUOUS 0x10000 -#define ARRAY_CONTP(x) (ARRAY_CONTIGUOUS & (int)CAR(x)) +#define ARRAY_CONTP(x) (ARRAY_CONTIGUOUS & PTR2INT(CAR(x))) #define ARRAY_BASE(a) (((array *)CDR(a))->base) #define ARRAY_DIMS(a) ((array_dim *)(CHARS(a)+sizeof(array))) @@ -728,7 +728,8 @@ 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 lfflush P((SCM port)); +SCM_EXPORT SCM scm_force_output P((SCM port)); SCM_EXPORT void scm_init_gra P((scm_gra *gra, sizet eltsize, sizet len, sizet maxlen, const char *what)); SCM_EXPORT int scm_grow_gra P((scm_gra *gra, char *elt)); @@ -760,9 +761,9 @@ 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 void scm_iprin1 P((SCM exp, SCM port, int writing)); +SCM_EXPORT void scm_intprint P((long n, int radix, SCM port)); +SCM_EXPORT void scm_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, const char *what)); SCM_EXPORT SCM scm_env_getprop P((SCM prop, SCM env)); @@ -861,6 +862,7 @@ 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 string_copy P((SCM s)); SCM_EXPORT SCM numberp P((SCM x)); SCM_EXPORT SCM exactp P((SCM x)); SCM_EXPORT SCM inexactp P((SCM x)); @@ -916,7 +918,7 @@ 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 void scm_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)); @@ -978,15 +980,18 @@ 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_file_position P((SCM port, SCM pos)); +#define file_position(port) scm_file_position(port, BOOL_F) +#define file_set_position scm_file_position 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 scm_peek_char P((SCM port)); SCM_EXPORT SCM eof_objectp P((SCM x)); SCM_EXPORT int scm_io_error P((SCM port, const char *what)); -SCM_EXPORT SCM lwrite P((SCM obj, SCM port)); -SCM_EXPORT SCM display P((SCM obj, SCM port)); -SCM_EXPORT SCM newline P((SCM port)); -SCM_EXPORT SCM write_char P((SCM chr, SCM port)); +SCM_EXPORT SCM scm_write P((SCM obj, SCM port)); +SCM_EXPORT SCM scm_display P((SCM obj, SCM port)); +SCM_EXPORT SCM scm_newline P((SCM port)); +SCM_EXPORT SCM 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)); @@ -1040,22 +1045,23 @@ SCM_EXPORT SCM scm_copybitfield P((SCM to, SCM start, SCM rest)); 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 signed char num2char P((SCM num, char *pos, char *s_caller)); SCM_EXPORT unsigned short num2ushort P((SCM num, char *pos, char *s_caller)); +SCM_EXPORT short num2short 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 double num2dbl P((SCM num, char *pos, char *s_caller)); SCM_EXPORT SCM makfromstr P((const char *src, sizet len)); SCM_EXPORT SCM makfromstrs P((int argc, const char * const *argv)); SCM_EXPORT SCM makfrom0str P((const char *scr)); SCM_EXPORT char **makargvfrmstrs P((SCM args, const char *s_v)); -SCM_EXPORT void must_free_argv P((const char * const *argv)); +SCM_EXPORT 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 unsigned long scm_addr P((SCM args, const char *name)); +SCM_EXPORT unsigned long scm_base_addr P((SCM v, const char *name)); SCM_EXPORT int scm_cell_p P((SCM x)); #ifdef FLOATS diff --git a/scm.info b/scm.info index cb7ebef..367942a 100644 --- a/scm.info +++ b/scm.info @@ -1,24 +1,24 @@ This is scm.info, produced by makeinfo version 4.8 from scm.texi. -This manual is for SCM (version 5e3, October 2006), and algorithmic | -language Scheme implementation. | - | -Copyright (C) 1990-2006 Free Software Foundation, Inc. | - | - Permission is granted to make and distribute verbatim copies of | - this manual provided the copyright notice and this permission | - notice are preserved on all copies. | - | - Permission is granted to copy and distribute modified versions of | - this manual under the conditions for verbatim copying, provided | - that the entire resulting derived work is distributed under the | - terms of a permission notice identical to this one. | - | - Permission is granted to copy and distribute translations of this | - manual into another language, under the above conditions for | - modified versions, except that this permission notice may be | - stated in a translation approved by the author. | - | +This manual is for SCM (version 5e4, November 2007), and algorithmic | +language Scheme implementation. + +Copyright (C) 1990-2007 Free Software Foundation, Inc. | + + Permission is granted to make and distribute verbatim copies of + this manual provided the copyright notice and this permission + notice are preserved on all copies. + + Permission is granted to copy and distribute modified versions of + this manual under the conditions for verbatim copying, provided + that the entire resulting derived work is distributed under the + terms of a permission notice identical to this one. + + Permission is granted to copy and distribute translations of this + manual into another language, under the above conditions for + modified versions, except that this permission notice may be + stated in a translation approved by the author. + INFO-DIR-SECTION The Algorithmic Language Scheme START-INFO-DIR-ENTRY * SCM: (scm). A Scheme interpreter. @@ -27,27 +27,27 @@ END-INFO-DIR-ENTRY  File: scm.info, Node: Top, Next: Overview, Prev: (dir), Up: (dir) -SCM | -*** | +SCM +*** -This manual is for SCM (version 5e3, October 2006), and algorithmic | -language Scheme implementation. | +This manual is for SCM (version 5e4, November 2007), and algorithmic | +language Scheme implementation. -Copyright (C) 1990-2006 Free Software Foundation, Inc. | +Copyright (C) 1990-2007 Free Software Foundation, Inc. | - Permission is granted to make and distribute verbatim copies of | - this manual provided the copyright notice and this permission | - notice are preserved on all copies. | + Permission is granted to make and distribute verbatim copies of + this manual provided the copyright notice and this permission + notice are preserved on all copies. - Permission is granted to copy and distribute modified versions of | - this manual under the conditions for verbatim copying, provided | - that the entire resulting derived work is distributed under the | - terms of a permission notice identical to this one. | + Permission is granted to copy and distribute modified versions of + this manual under the conditions for verbatim copying, provided + that the entire resulting derived work is distributed under the + terms of a permission notice identical to this one. - Permission is granted to copy and distribute translations of this | - manual into another language, under the above conditions for | - modified versions, except that this permission notice may be | - stated in a translation approved by the author. | + Permission is granted to copy and distribute translations of this + manual into another language, under the above conditions for + modified versions, except that this permission notice may be + stated in a translation approved by the author. * Menu: @@ -104,8 +104,8 @@ File: scm.info, Node: SCM Features, Next: SCM Authors, Prev: Overview, Up: O `copy-tree', `acons', and `eval'. * `Char-code-limit', `most-positive-fixnum', `most-negative-fixnum', - `and internal-time-units-per-second' constants. `slib:features' | - and `*load-pathname*' variables. | + `and internal-time-units-per-second' constants. `slib:features' + and `*load-pathname*' variables. * Arrays and bit-vectors. String ports and software emulation ports. I/O extensions providing ANSI C and POSIX.1 facilities. @@ -256,7 +256,7 @@ File: scm.info, Node: SIOD copyright, Prev: The SCM License, Up: Copying -------------------- - COPYRIGHT (C) 1989 BY | + COPYRIGHT (C) 1989 BY PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. ALL RIGHTS RESERVED @@ -377,7 +377,7 @@ File: scm.info, Node: Making SCM, Next: SLIB, Prev: Installing SCM, Up: Inst The SCM distribution has "Makefile" which contains rules for making "scmlit", a "bare-bones" version of SCM sufficient for running `build'. `build' is used to compile (or create scripts to compile) full -featured versions. +featured versions (*note Building SCM::). | 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 @@ -406,18 +406,16 @@ SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and install it. Bug reports about running SCM without SLIB have very low priority. SLIB is available from the same sites as SCM: - * swiss.csail.mit.edu:/pub/scm/slib3a4.tar.gz | - - * ftp.gnu.org:/pub/gnu/jacal/slib3a4.tar.gz | + * swiss.csail.mit.edu:/pub/scm/slib3a5.tar.gz | - * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a4.tar.gz | + * ftp.gnu.org:/pub/gnu/jacal/slib3a5.tar.gz | -Unpack SLIB (`tar xzf slib3a4.tar.gz' or `unzip -ao slib3a4.zip') in an | +Unpack SLIB (`tar xzf slib3a5.tar.gz' or `unzip -ao slib3a5.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 `Init5e3.scm' is | +(this is the same directory as where the file `Init5e4.scm' is | installed). `require.scm' should have the contents: (define (library-vicinity) "/usr/local/lib/slib/") @@ -489,7 +487,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 "Init5e3.scm"'>>scmflags.h | + echo '#define IMPLINIT "Init5e4.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -508,7 +506,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 "Init5e3.scm"'>>scmflags.h | + echo '#define IMPLINIT "Init5e4.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 @@ -549,20 +547,20 @@ the SCM command line options. amiga-dice-c m68000 amiga dcc amiga-gcc m68000 amiga gcc amiga-sas m68000 amiga lc - atari-st-gcc m68000 atari.st gcc - atari-st-turbo-c m68000 atari.st tcc + atari-st-gcc m68000 atari-st gcc | + atari-st-turbo-c m68000 atari-st tcc | borland-c i8086 ms-dos bcc darwin powerpc unix cc djgpp i386 ms-dos gcc - freebsd i386 unix cc + freebsd *unknown* unix cc | gcc *unknown* unix gcc gnu-win32 i386 unix gcc highc i386 ms-dos hc386 hp-ux hp-risc hp-ux cc irix mips irix gcc - linux i386 linux gcc + linux *unknown* linux gcc | linux-aout i386 linux gcc - linux-ia64 ia64 linux gcc | + linux-ia64 ia64 linux gcc microsoft-c i8086 ms-dos cl microsoft-c-nt i386 ms-dos cl microsoft-quick-c i8086 ms-dos qcl @@ -642,7 +640,7 @@ the SCM command line options. -- Build Option: -s PATHNAME -- Build Option: --scheme-initial=PATHNAME specifies that PATHNAME should be the default location of the SCM - initialization file `Init5e3.scm'. SCM tries several likely | + initialization file `Init5e4.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. @@ -725,6 +723,9 @@ the SCM command line options. "byte" Treating strings as byte-vectors. + "byte-number" | + Byte/number conversions | + | "careful-interrupt-masking" Define this for extra checking of interrupt masking and some simple checks for proper use of malloc and free. This is for @@ -756,18 +757,18 @@ the SCM command line options. For the "curses" screen management package. "debug" - Turns on the features `cautious' and | - `careful-interrupt-masking'; uses `-g' flags for debugging | - SCM source code. | + Turns on the features `cautious' and + `careful-interrupt-masking'; uses `-g' flags for debugging + SCM source code. "differ" Sequence comparison - "dont-memoize-locals" | - SCM normally converts references to local variables to ILOCs, | - which make programs run faster. If SCM is badly broken, try | - using this option to disable the MEMOIZE_LOCALS feature. | - | + "dont-memoize-locals" + SCM normally converts references to local variables to ILOCs, + which make programs run faster. If SCM is badly broken, try + using this option to disable the MEMOIZE_LOCALS feature. + "dump" Convert a running scheme program into an executable file. @@ -854,7 +855,7 @@ the SCM command line options. "socket" BSD "socket" interface. Socket addr functions require inexacts or bignums for 32-bit precision. - | + "tick-interrupts" Use if you want the ticks and ticks-interrupt functions. @@ -900,7 +901,7 @@ link your file at compile time, use the `-c' and `-i' options to build: -| #! /bin/sh rm -f scmflags.h - echo '#define IMPLINIT "/home/jaffer/scm/Init5e3.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5e4.scm"'>>scmflags.h | echo '#define COMPILED_INITS init_foo();'>>scmflags.h echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h @@ -916,7 +917,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/Init5e3.scm"'>>scmflags.h | + echo '#define IMPLINIT "/home/jaffer/scm/Init5e4.scm"'>>scmflags.h | echo '#define BIGNUMS'>>scmflags.h echo '#define FLOATS'>>scmflags.h echo '#define ARRAYS'>>scmflags.h @@ -943,9 +944,9 @@ format. For notes about porting to MS-Windows and finishing the port to VMS *Note VMS Dynamic Linking::. "DLD" is a library package of C functions that performs "dynamic link -editing" on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), -SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST. It is -available from: +editing" on GNU/Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), | +SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST. It | +is available from: | * ftp.gnu.org:pub/gnu/dld-3.3.tar.gz @@ -1036,36 +1037,36 @@ No modifications to the emacs source code were required to use or `unexelf.c' don't work for you, try using the appropriate `unex*.c' file from emacs. -The `dscm4' and `dscm5' targets in the SCM `Makefile' save images from | -`udscm4' and `udscm5' executables respectively. | - | -Recent Linux innovations interfere with `dump'. For: | - | -Fedora-Core-1 | - Remove the `#' from the line `#SETARCH = setarch i386' in the | - `Makefile'. | - | -Fedora-Core-3 | - `http://jamesthornton.com/writing/emacs-compile.html' writes: [For | - FC3] combreloc has become the default for recent GNU ld, which | - breaks the unexec/undump on all versions of both Emacs and | - XEmacs... | - | - Override by adding the following to `udscm5.opt': | - `--linker-options="-z nocombreloc"' | - | -Kernels later than 2.6.11 | - `http://www.opensubscriber.com/message/emacs-devel@gnu.org/1007118.html' | - mentions the "exec-shield" feature. Kernels later than 2.6.11 | - must do (as root): | - | - echo 0 > /proc/sys/kernel/randomize_va_space | - | - before dumping. `Makefile' has this `randomize_va_space' stuffing | - scripted for targets `dscm4' and `dscm5'. You must either set | - `randomize_va_space' to 0 or run as root to dump. | - | - | +The `dscm4' and `dscm5' targets in the SCM `Makefile' save images from +`udscm4' and `udscm5' executables respectively. + +Recent GNU/Linux innovations interfere with `dump'. For: | + +Fedora-Core-1 + Remove the `#' from the line `#SETARCH = setarch i386' in the + `Makefile'. + +Fedora-Core-3 + `http://jamesthornton.com/writing/emacs-compile.html' writes: [For + FC3] combreloc has become the default for recent GNU ld, which + breaks the unexec/undump on all versions of both Emacs and + XEmacs... + + Override by adding the following to `udscm5.opt': + `--linker-options="-z nocombreloc"' + +Kernels later than 2.6.11 + `http://www.opensubscriber.com/message/emacs-devel@gnu.org/1007118.html' + mentions the "exec-shield" feature. Kernels later than 2.6.11 + must do (as root): + + echo 0 > /proc/sys/kernel/randomize_va_space + + before dumping. `Makefile' has this `randomize_va_space' stuffing + scripted for targets `dscm4' and `dscm5'. You must either set + `randomize_va_space' to 0 or run as root to dump. + +  File: scm.info, Node: Automatic C Preprocessor Definitions, Next: Problems Compiling, Prev: Saving Images, Up: Installing SCM @@ -1107,11 +1108,12 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of AMIGA SAS/C 5.10 or Dice C on AMIGA __amigaos__ Gnu CC on AMIGA atarist ATARI-ST under Gnu CC + __DragonflyBSD__ DragonflyBSD | __FreeBSD__ FreeBSD GNUDOS DJGPP (obsolete in version 1.08) __GO32__ DJGPP (future?) hpux HP-UX - linux Linux + linux GNU/Linux | macintosh Macintosh (THINK_C and __MWERKS__ define) MCH_AMIGA Aztec_c 5.2a on AMIGA __MACH__ Apple Darwin @@ -1121,6 +1123,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of __MSDOS__ Turbo C, Borland C, and DJGPP __NetBSD__ NetBSD nosve Control Data NOS/VE + __OpenBSD__ OpenBSD | SVR2 System V Revision 2. sun SunOS __SVR4 SunOS @@ -1224,17 +1227,17 @@ remove in scmfig.h and Do so and recompile files. recompile scm. add in scmfig.h and recompile scm. -ERROR: Init5e3.scm not found. Assign correct IMPLINIT in makefile | +ERROR: Init5e4.scm not found. Assign correct IMPLINIT in makefile | or scmfig.h. Define environment variable SCM_INIT_PATH to be the full - pathname of Init5e3.scm. | + pathname of Init5e4.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 - Init5e3.scm to point to library or | + Init5e4.scm to point to library or | remove. Make sure the value of (library-vicinity) has a trailing @@ -1294,13 +1297,13 @@ 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. `Init5e3.scm'). | +output files. `Init5e4.scm'). | Spaces or control characters appear Check character defines in in symbol names. `scmfig.h'. Negative numbers turn positive. Check SRS in `scmfig.h'. -;ERROR: bignum: numerical overflow Increase NUMDIGS_MAX in `scmfig.h' | - and recompile. | -VMS: Couldn't unwind stack. #define CHEAP_CONTINUATIONS in | +;ERROR: bignum: numerical overflow Increase NUMDIGS_MAX in `scmfig.h' + and recompile. +VMS: Couldn't unwind stack. #define CHEAP_CONTINUATIONS in `scmfig.h'. VAX: botched longjmp. @@ -1368,7 +1371,8 @@ File: scm.info, Node: Invoking SCM, Next: SCM Options, Prev: Operational Feat ================ scm [-a kbytes] [-muvbiq] [-version] [-help] - [[-]-no-init-file] [-p int] [-r feature] [-h feature] + [[-]-no-init-file] [--no-symbol-case-fold] | + [-p int] [-r feature] [-h feature] | [-d filename] [-f filename] [-l filename] [-c expression] [-e expression] [-o dumpname] [-- | - | -s] [filename] [arguments ...] @@ -1379,7 +1383,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 `Init5e3.scm') in platform-dependent directories relative | +file (usually `Init5e4.scm') in platform-dependent directories relative | to this directory. See *Note File-System Habitat:: for a blow-by-blow description. @@ -1388,12 +1392,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, or if `scm' is being invoked as a script, `Init5e3.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, then it is loaded. | +command line, or if `scm' is being invoked as a script, `Init5e4.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, then it is loaded. -`Init5e3.scm' then looks for command input from one of three sources: | +`Init5e4.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. @@ -1421,6 +1425,9 @@ The options are processed in the order specified on the command line. -- Command Option: --no-init-file Inhibits the loading of `ScmInit.scm' as described above. + -- Command Option: -no-symbol-case-fold | + Symbol (and identifier) names will be case sensitive. | + | -- Command Option: --help prints usage information and URI; then exit. @@ -1554,13 +1561,13 @@ File: scm.info, Node: SCM Variables, Next: SCM Session, Prev: Invocation Exam -- Environment Variable: SCM_INIT_PATH is the pathname where `scm' will look for its initialization code. - The default is the file `Init5e3.scm' in the source directory. | + The default is the file `Init5e4.scm' in the source directory. | -- Environment Variable: SCHEME_LIBRARY_PATH is the [SLIB] Scheme library directory. -- Environment Variable: HOME - is the directory where `Init5e3.scm' will look for the user | + is the directory where `Init5e4.scm' will look for the user | initialization file `ScmInit.scm'. -- Environment Variable: EDITOR @@ -1684,8 +1691,8 @@ File: scm.info, Node: Debugging Scheme Code, Next: Debugging Continuations, P 3.8 Debugging Scheme Code ========================= -The `cautious' option of `build' (*note Build Options::) supports | -debugging in Scheme. | +The `cautious' option of `build' (*note Build Options::) supports +debugging in Scheme. "CAUTIOUS" If SCM is built with the `CAUTIOUS' flag, then when an error @@ -1705,11 +1712,11 @@ debugging in Scheme. | with , inspect or modify top-level values, trace or untrace procedures, and continue execution with `(continue)'. -If `verbose' (*note verbose: Internal State.) is called with an | -argument greater than 2, then the interpreter will check stack size | -periodically. If the size of stack in use exceeds the C #define | -`STACK_LIMIT' (default is `HEAP_SEG_SIZE'), SCM generates a `stack' | -`segment violation'. | +If `verbose' (*note verbose: Internal State.) is called with an +argument greater than 2, then the interpreter will check stack size +periodically. If the size of stack in use exceeds the C #define +`STACK_LIMIT' (default is `HEAP_SEG_SIZE'), SCM generates a `stack' +`segment violation'. There are several SLIB macros which so useful that SCM automatically loads the appropriate module from SLIB if they are invoked. @@ -1979,13 +1986,13 @@ warnings and errors. -- Function: warn arg1 arg2 arg3 ... Alias for *Note slib:warn: (slib)System. Outputs an error message - containing the arguments. `warn' is defined in `Init5e3.scm'. | + containing the arguments. `warn' is defined in `Init5e4.scm'. | -- Function: error arg1 arg2 arg3 ... Alias for *Note slib:error: (slib)System. Outputs an error message containing the arguments, aborts evaluation of the current form and resumes the top level read-eval-print loop. `Error' is - defined in `Init5e3.scm'. | + defined in `Init5e4.scm'. | If SCM is built with the `CAUTIOUS' flag, then when an error occurs, a "stack trace" of certain pending calls are printed as part of the @@ -2003,7 +2010,7 @@ with Lisp systems. -- Function: stack-trace Prints information describing the stack of partially evaluated expressions. `stack-trace' returns `#t' if any lines were printed - and `#f' otherwise. See `Init5e3.scm' for an example of the use | + and `#f' otherwise. See `Init5e4.scm' for an example of the use | of `stack-trace'.  @@ -2028,10 +2035,10 @@ a convenient aid to locating bugs and untested expressions. * The names of identifiers which are not lexiallly bound but defined at top-level have #@ prepended. -For instance, `open-input-file' is defined as follows in `Init5e3.scm': | +For instance, `open-input-file' is defined as follows in `Init5e4.scm': | (define (open-input-file str) - (or (open-file str OPEN_READ) + (or (open-file str open_read) | (and (procedure? could-not-open) (could-not-open) #f) (error "OPEN-INPUT-FILE couldn't open file " str))) @@ -2077,7 +2084,7 @@ File: scm.info, Node: Internal State, Next: Scripting, Prev: Memoized Express *INTERACTIVE* is controlled directly by the command-line options `-b', `-i', and `-s' (*note Invoking SCM::). If none of these options are specified, the rules to determine interactivity are - more complicated; see `Init5e3.scm' for details. | + more complicated; see `Init5e4.scm' for details. | -- Function: abort Resumes the top level Read-Eval-Print loop. @@ -2111,8 +2118,8 @@ File: scm.info, Node: Internal State, Next: Scripting, Prev: Memoized Express >= 3 the CPU time is printed after each top level form evaluated; - notifications of heap growth printed; the interpreter checks | - stack depth periodically. | + notifications of heap growth printed; the interpreter checks + stack depth periodically. >= 4 a garbage collection summary is printed after each top level @@ -2132,7 +2139,7 @@ File: scm.info, Node: Internal State, Next: Scripting, Prev: Memoized Express #t)' also gives the hexadecimal heap segment and stack bounds. -- Constant: *scm-version* - Contains the version string (e.g. `5e3') of SCM. | + Contains the version string (e.g. `5e4') of SCM. | 3.12.1 Executable path ---------------------- @@ -2744,8 +2751,8 @@ File: scm.info, Node: Opening and Closing, Next: Port Properties, Prev: Files reading, writing, and both reading and writing respectively. Both input and output functions can be used with io-ports. An end - of file must be read or a file-set-position done on the port - between a read operation and a write operation or vice-versa. + of file must be read or a two-argument file-position done on the | + port between a read operation and a write operation or vice-versa. | -- Function: _ionbf modestr Returns a version of MODESTR which when `open-file' is called with @@ -2794,6 +2801,17 @@ File: scm.info, Node: Port Properties, Next: Port Redirection, Prev: Opening Returns the filename PORT was opened with. If PORT is not open to a file the result is unspecified. + -- Function: file-position port | + -- Function: file-position port #f | + Returns the current position of the character in PORT which will | + next be read or written. If PORT is open to a non-file then `#f' | + is returned. | + | + -- Function: file-position port k | + Sets the current position in PORT which will next be read or | + written. If successful, `#f' is returned. If PORT is open to a | + non-file, then `file-position' returns `#f'. | + | -- Function: port-line port -- Function: port-column port If PORT is a tracked port, return the current line (column) number, @@ -3050,13 +3068,13 @@ File: scm.info, Node: Common-Lisp Read Syntax, Next: Load Syntax, Prev: Lexic `m-' prefixes may be combined. -- Read syntax: #+ feature form - If feature is `provided?' then FORM is read as a scheme | - expression. If not, then FORM is treated as whitespace. | + If feature is `provided?' then FORM is read as a scheme + expression. If not, then FORM is treated as whitespace. Feature is a boolean expression composed of symbols and `and', `or', and `not' of boolean expressions. - For more information on `provided?', *Note Require: (slib)Require. | + For more information on `provided?', *Note Require: (slib)Require. -- Read syntax: #- feature form is equivalent to `#+(not feature) expression'. @@ -3707,7 +3725,7 @@ of load and ([SLIB]) require specified here are supported. The The LIB1 ... pathnames specify additional libraries which may be needed for object files not produced by the Hobbit compiler. For - instance, crs is linked on Linux by + instance, crs is linked on GNU/Linux by | (load (in-vicinity (implementation-vicinity) "crs.o") (usr:lib "ncurses") (usr:lib "c")) @@ -3908,35 +3926,35 @@ operations: (r5rs)Numerical operations. -- Function: atanh z Return the inverse hyperbolic sine, cosine, and tangent of Z - -- Function: real-sqrt x | - -- Function: real-exp x | - -- Function: real-ln x | - -- Function: real-sin x | - -- Function: real-cos x | - -- Function: real-tan x | - -- Function: real-asin x | - -- Function: real-acos x | - -- Function: real-atan x | - -- Function: real-sinh x | - -- Function: real-cosh x | - -- Function: real-tanh x | - -- Function: real-asinh x | - -- Function: real-acosh x | - -- Function: real-atanh x | + -- Function: real-sqrt x + -- Function: real-exp x + -- Function: real-ln x + -- Function: real-sin x + -- Function: real-cos x + -- Function: real-tan x + -- Function: real-asin x + -- Function: real-acos x + -- Function: real-atan x + -- Function: real-sinh x + -- Function: real-cosh x + -- Function: real-tanh x + -- Function: real-asinh x + -- Function: real-acosh x + -- Function: real-atanh x Real-only versions of these popular functions. The argument X must be a real number. It is an error if the value which should be returned by a call to these procedures is _not_ real. - -- Function: real-log10 x | + -- Function: real-log10 x Real-only base 10 logarithm. -- Function: $atan2 y x Computes `(angle (make-rectangular x y))' for real numbers Y and X. - -- Function: real-expt x1 x2 | + -- Function: real-expt x1 x2 Returns real number X1 raised to the real power X2. It is an - error if the value which should be returned by a call to | - `real-expt' is not real. | + error if the value which should be returned by a call to + `real-expt' is not real.  File: scm.info, Node: Arrays, Next: Records, Prev: Numeric, Up: Packages @@ -4193,7 +4211,7 @@ SCM has some extra functions in feature `array-for-each': -- Function: array-equal? array0 array1 ... Returns `#t' iff all arguments are arrays with the same shape, the same type, and have corresponding elements which are either - `equal?' or `array-equal?'. This function differs from `equal?' + `equal?' or `array-equal?'. This function differs from `equal?' in that a one dimensional shared array may be ARRAY-EQUAL? but not EQUAL? to a vector or uniform vector. @@ -4309,18 +4327,7 @@ I/O: (slib)Line I/O, and the following functions are defined: -- Function: getpid Returns the process ID of the current process. - - -- Function: file-position port - Returns the current position of the character in PORT which will - next be read or written. If PORT is not open to a file the result - is unspecified. - - -- Function: file-set-position port integer - Sets the current position in PORT which will next be read or - written. If PORT is not open to a file the action of - `file-set-position' is unspecified. The result of - `file-set-position' is unspecified. - + | -- Function: try-create-file name modes perms If the file with name NAME already exists, return `#f', otherwise try to create and open the file like `try-open-file', *Note Files @@ -4383,7 +4390,7 @@ I/O: (slib)Line I/O, and the following functions are defined: "Link.scm" "Macro.scm" "Transcen.scm" - "Init5e3.scm" | + "Init5e4.scm" | -- Function: mkdir path mode The `mkdir' function creates a new, empty directory whose name is @@ -5626,9 +5633,9 @@ sockets for multiple connections without input blocking. (next (cdr con-list))) (else (for-each (lambda (con) - (file-set-position con 0) + (file-position con 0) | (write-char c con) - (file-set-position con 0)) + (file-position con 0)) connections) (cons con (next (cdr con-list))))))) (else (cons con (next (cdr con-list))))))))))))) @@ -5654,9 +5661,9 @@ you can use a client written in scheme: (ct (and actives (memq (current-input-port) actives) (read-char)))) (cond ((or (eof-object? cs) (eof-object? ct)) (close-port con)) (else (cond (cs (display cs))) - (cond (ct (file-set-position con 0) + (cond (ct (file-position con 0) | (display ct con) - (file-set-position con 0))) + (file-position con 0))) | (go))))) (cond (con (display "Connecting to ") (display (getpeername con)) @@ -5968,34 +5975,34 @@ memory allocated by `malloc'. Returns the C array of `char's or as `unsigned char's holding the elements of string X or its length, respectively. - -- Header: tc7_Vbool | + -- Header: tc7_Vbool uniform vector of booleans (bit-vector) - -- Header: tc7_VfixZ32 | + -- Header: tc7_VfixZ32 uniform vector of integers - -- Header: tc7_VfixN32 | + -- Header: tc7_VfixN32 uniform vector of non-negative integers - -- Header: tc7_VfixN16 | - uniform vector of non-negative short integers | - | - -- Header: tc7_VfixZ16 | + -- Header: tc7_VfixN16 + uniform vector of non-negative short integers + + -- Header: tc7_VfixZ16 uniform vector of short integers - -- Header: tc7_VfixN8 | - uniform vector of non-negative bytes | - | - -- Header: tc7_VfixZ8 | - uniform vector of signed bytes | - | - -- Header: tc7_VfloR32 | + -- Header: tc7_VfixN8 + uniform vector of non-negative bytes + + -- Header: tc7_VfixZ8 + uniform vector of signed bytes + + -- Header: tc7_VfloR32 uniform vector of short inexact real numbers - -- Header: tc7_VfloR64 | + -- Header: tc7_VfloR64 uniform vector of double precision inexact real numbers - -- Header: tc7_VfloC64 | + -- Header: tc7_VfloC64 uniform vector of double precision inexact complex numbers -- Header: tc7_contin @@ -6052,11 +6059,11 @@ type `SCM'. enabled, the `CDR' should be a function which takes and returns type `double'. Conversions are handled in the interpreter. - `floor', `ceiling', `truncate', `round', `real-sqrt', `real-exp', | - `real-ln', `real-sin', `real-cos', `real-tan', `real-asin', | - `real-acos', `real-atan', `real-sinh', `real-cosh', `real-tanh', | - `real-asinh', `real-acosh', `real-atanh', and `exact->inexact' are | - defined this way. | + `floor', `ceiling', `truncate', `round', `real-sqrt', `real-exp', + `real-ln', `real-sin', `real-cos', `real-tan', `real-asin', + `real-acos', `real-atan', `real-sinh', `real-cosh', `real-tanh', + `real-asinh', `real-acosh', `real-atanh', and `exact->inexact' are + defined this way. If the `CDR' is `0' (`NULL'), the name string of the procedure is used to control traversal of its list structure argument. @@ -6237,8 +6244,8 @@ Defining Smobs::). These are the initial smobs: Conventional Arrays have a pointer to a vector for their `CDR'. Uniform Arrays have a pointer to a Uniform Vector type (string, - Vbool, VfixZ32, VfixN32, VfloR32, VfloR64, or VfloC64) in their | - `CDR'. | + Vbool, VfixZ32, VfixN32, VfloR32, VfloR64, or VfloC64) in their + `CDR'.  File: scm.info, Node: Data Type Representations, Prev: Smob Cells, Up: Data Types @@ -6268,34 +6275,34 @@ ssymbol .........long length....G0000101 ..........char *chars........... msymbol .........long length....G0000111 ..........char *chars........... string .........long length....G0001101 ..........char *chars........... vector .........long length....G0001111 ...........SCM **elts........... -Vbool .........long length....G0010101 ..........long *words........... | - spare 00010111 | -VfixN8 .........long length....G0011101 ......unsigned char *words...... | -VfixZ8 .........long length....G0011111 ..........char *words........... | -VfixN16 .........long length....G0100101 ......unsigned short *words..... | -VfixZ16 .........long length....G0100111 ........ short *words........... | -VfixN32 .........long length....G0101101 ......unsigned long *words...... | -VfixZ32 .........long length....G0101111 ..........long *words........... | -VfloR32 .........long length....G0110101 .........float *words........... | -VfloC32 .........long length....G0110111 .........float *words........... | -VfloR64 .........long length....G0111101 ........double *words........... | -VfloC64 .........long length....G0111111 ........double *words........... | - - spare 01000101 | -contin .........long length....G1001101 .............*regs.............. | -specfun ................xxxxxxxxG1001111 ...........SCM name............. | -cclo ..short length..xxxxxx10G1001111 ...........SCM **elts........... | +Vbool .........long length....G0010101 ..........long *words........... + spare 00010111 +VfixN8 .........long length....G0011101 ......unsigned char *words...... +VfixZ8 .........long length....G0011111 ..........char *words........... +VfixN16 .........long length....G0100101 ......unsigned short *words..... +VfixZ16 .........long length....G0100111 ........ short *words........... +VfixN32 .........long length....G0101101 ......unsigned long *words...... +VfixZ32 .........long length....G0101111 ..........long *words........... +VfloR32 .........long length....G0110101 .........float *words........... +VfloC32 .........long length....G0110111 .........float *words........... +VfloR64 .........long length....G0111101 ........double *words........... +VfloC64 .........long length....G0111111 ........double *words........... + + spare 01000101 +contin .........long length....G1001101 .............*regs.............. +specfun ................xxxxxxxxG1001111 ...........SCM name............. +cclo ..short length..xxxxxx10G1001111 ...........SCM **elts........... PTOBs - port int portnum.CwroxxxxxxxxG1000111 ..........FILE *stream.......... | - socket int portnum.C001xxxxxxxxG1000111 ..........FILE *stream.......... | - inport int portnum.C011xxxxxxxxG1000111 ..........FILE *stream.......... | -outport int portnum.0101xxxxxxxxG1000111 ..........FILE *stream.......... | - ioport int portnum.C111xxxxxxxxG1000111 ..........FILE *stream.......... | -fport int portnum.C 00000000G1000111 ..........FILE *stream.......... | -pipe int portnum.C 00000001G1000111 ..........FILE *stream.......... | -strport 00000000000.0 00000010G1000111 ..........FILE *stream.......... | -sfport int portnum.C 00000011G1000111 ..........FILE *stream.......... | - SUBRs | + port int portnum.CwroxxxxxxxxG1000111 ..........FILE *stream.......... + socket int portnum.C001xxxxxxxxG1000111 ..........FILE *stream.......... + inport int portnum.C011xxxxxxxxG1000111 ..........FILE *stream.......... +outport int portnum.0101xxxxxxxxG1000111 ..........FILE *stream.......... + ioport int portnum.C111xxxxxxxxG1000111 ..........FILE *stream.......... +fport int portnum.C 00000000G1000111 ..........FILE *stream.......... +pipe int portnum.C 00000001G1000111 ..........FILE *stream.......... +strport 00000000000.0 00000010G1000111 ..........FILE *stream.......... +sfport int portnum.C 00000011G1000111 ..........FILE *stream.......... + SUBRs subr_0 ..........int hpoff.....01010101 ...........SCM (*f)()........... subr_1 ..........int hpoff.....01010111 ...........SCM (*f)()........... cxr ..........int hpoff.....01011101 .........double (*f)().......... @@ -6397,7 +6404,7 @@ symbols, "symhash". mark bit in OBJ, then calls `gc_mark()' on any SCM components of OBJ. The last call to `gc_mark()' is tail-called (looped). - -- Function: void mark_locations (STACKITEM X[], sizet LEN) | + -- Function: void mark_locations (STACKITEM X[], sizet LEN) The function `mark_locations' is used for marking segments of C-stack or saved segments of C-stack (marked continuations). The argument LEN is the size of the stack in units of size @@ -6722,12 +6729,12 @@ To add a package of new procedures to scm (see `crs.c' for example): add_feature("foo"); - will append a symbol `'foo' to the (list) value of `slib:features'. | + will append a symbol `'foo' to the (list) value of `slib:features'. 7. put any scheme code which needs to be run as part of your package into `Ifoo.scm'. - 8. put an `if' into `Init5e3.scm' which loads `Ifoo.scm' if your | + 8. put an `if' into `Init5e4.scm' which loads `Ifoo.scm' if your | package is included: (if (defined? twiddle-bits!) @@ -7027,7 +7034,7 @@ SCM, then you can replace `scm_find_implpath'. environment variable is defined, its value will be returned from `scm_find_implpath'. Otherwise find_impl_file() is called with the arguments EXECPATH, GENERIC_NAME (default "scm"), INIT_FILE_NAME - (default "Init5e3_scm"), and the directory separator string | + (default "Init5e4_scm"), and the directory separator string | DIRSEP. If find_impl_file() returns 0 and IMPLINIT is defined, then a copy of the string IMPLINIT is returned. @@ -7150,7 +7157,7 @@ Here is a minimal embedding program `libtest.c': -| dld_find_executable(./libtest): /home/jaffer/scm/libtest - implpath: /home/jaffer/scm/Init5e3.scm | + implpath: /home/jaffer/scm/Init5e4.scm | This is libtest_init_user_scm hello world @@ -7166,7 +7173,7 @@ The source code for these routines are found in `rope.c'. -- Function: int scm_ldfile (char *FILE) Loads the Scheme source file FILE. Returns 0 if successful, non-0 if not. This function is used to load SCM's initialization file - `Init5e3.scm'. | + `Init5e4.scm'. | -- Function: int scm_ldprog (char *FILE) Loads the Scheme source file `(in-vicinity (program-vicinity) @@ -7586,7 +7593,7 @@ File: scm.info, Node: Executable Pathname, Next: Script Support, Prev: File-S 6.3.2 Executable Pathname ------------------------- -For purposes of finding `Init5e3.scm', dumping an executable, and | +For purposes of finding `Init5e4.scm', dumping an executable, and | dynamic linking, a SCM session needs the pathname of its executable image. @@ -7831,24 +7838,24 @@ with a VMS system needs to finish and debug it.  File: scm.info, Node: Index, Prev: The Implementation, Up: Top -Index | -***** | +Index +***** -Procedure and Macro Index | -========================= | +Procedure and Macro Index +************************* [index] * Menu: * #!: Unix Scheme Scripts. (line 40) * #': Common-Lisp Read Syntax. - (line 49) | + (line 49) * #+: Common-Lisp Read Syntax. (line 16) * #-: Common-Lisp Read Syntax. - (line 25) | + (line 25) * #.: Common-Lisp Read Syntax. - (line 38) | + (line 38) * #;text-till-end-of-line: Documentation and Comments. (line 31) * #?column: Load Syntax. (line 12) @@ -7857,58 +7864,59 @@ Procedure and Macro Index | * #\token: Common-Lisp Read Syntax. (line 7) * #|: Common-Lisp Read Syntax. - (line 28) | -* $atan2: Numeric. (line 59) | -* -: SCM Options. (line 108) -* ---: SCM Options. (line 109) -* ---c-source-files=: Build Options. (line 134) | -* ---compiler-options=: Build Options. (line 119) | -* ---defines=: Build Options. (line 112) | -* ---features=: Build Options. (line 192) | -* ---help: SCM Options. (line 20) -* ---initialization=: Build Options. (line 142) | -* ---libraries=: Build Options. (line 104) | -* ---linker-options=: Build Options. (line 122) | + (line 28) +* $atan2: Numeric. (line 59) +* -: SCM Options. (line 111) +* ---: SCM Options. (line 112) +* ---c-source-files=: Build Options. (line 134) +* ---compiler-options=: Build Options. (line 119) +* ---defines=: Build Options. (line 112) +* ---features=: Build Options. (line 192) +* ---help: SCM Options. (line 23) +* ---initialization=: Build Options. (line 142) +* ---libraries=: Build Options. (line 104) +* ---linker-options=: Build Options. (line 122) * ---no-init-file: SCM Options. (line 17) -* ---object-files=: Build Options. (line 138) | -* ---outname=: Build Options. (line 98) | +* ---object-files=: Build Options. (line 138) +* ---outname=: Build Options. (line 98) * ---platform=: Build Options. (line 12) -* ---scheme-initial=: Build Options. (line 126) | -* ---type=: Build Options. (line 147) | -* ---version: SCM Options. (line 23) -* --batch-dialect=: Build Options. (line 165) | -* --script-name=: Build Options. (line 187) | +* ---scheme-initial=: Build Options. (line 126) +* ---type=: Build Options. (line 147) +* ---version: SCM Options. (line 26) +* --batch-dialect=: Build Options. (line 165) +* --no-symbol-case-fold: SCM Options. (line 20) +* --script-name=: Build Options. (line 187) * -a: SCM Options. (line 9) -* -b: SCM Options. (line 98) -* -c <1>: SCM Options. (line 46) -* -c: Build Options. (line 133) | -* -d: SCM Options. (line 42) -* -D: Build Options. (line 111) | -* -e: SCM Options. (line 45) -* -f: SCM Options. (line 37) -* -F: Build Options. (line 191) | -* -f: Build Options. (line 69) | -* -h <1>: SCM Options. (line 33) -* -h: Build Options. (line 164) | -* -i <1>: SCM Options. (line 88) -* -i: Build Options. (line 141) | -* -j: Build Options. (line 137) | -* -l <1>: SCM Options. (line 36) -* -l: Build Options. (line 103) | -* -m: SCM Options. (line 75) +* -b: SCM Options. (line 101) +* -c <1>: SCM Options. (line 49) +* -c: Build Options. (line 133) +* -d: SCM Options. (line 45) +* -D: Build Options. (line 111) +* -e: SCM Options. (line 48) +* -f: SCM Options. (line 40) +* -F: Build Options. (line 191) +* -f: Build Options. (line 69) +* -h <1>: SCM Options. (line 36) +* -h: Build Options. (line 164) +* -i <1>: SCM Options. (line 91) +* -i: Build Options. (line 141) +* -j: Build Options. (line 137) +* -l <1>: SCM Options. (line 39) +* -l: Build Options. (line 103) +* -m: SCM Options. (line 78) * -no-init-file: SCM Options. (line 16) -* -o <1>: SCM Options. (line 52) -* -o: Build Options. (line 97) | -* -p <1>: SCM Options. (line 62) +* -o <1>: SCM Options. (line 55) +* -o: Build Options. (line 97) +* -p <1>: SCM Options. (line 65) * -p: Build Options. (line 11) -* -q: SCM Options. (line 71) -* -r: SCM Options. (line 26) -* -s <1>: SCM Options. (line 103) -* -s: Build Options. (line 125) | -* -t: Build Options. (line 146) | -* -u: SCM Options. (line 82) -* -v: SCM Options. (line 66) -* -w: Build Options. (line 186) | +* -q: SCM Options. (line 74) +* -r: SCM Options. (line 29) +* -s <1>: SCM Options. (line 106) +* -s: Build Options. (line 125) +* -t: Build Options. (line 146) +* -u: SCM Options. (line 85) +* -v: SCM Options. (line 69) +* -w: Build Options. (line 186) * @apply: Environment Frames. (line 54) * @copy-tree: Storage. (line 16) * @macroexpand1: Syntactic Hooks for Hygienic Macros. @@ -7917,7 +7925,7 @@ Procedure and Macro Index | * _ionbf: Opening and Closing. (line 28) * _tracked: Opening and Closing. (line 35) * abort: Internal State. (line 15) -* access: I/O-Extensions. (line 181) +* access: I/O-Extensions. (line 170) * acct: Unix Extensions. (line 34) * acons: Storage. (line 21) * acosh: Numeric. (line 33) @@ -7959,25 +7967,25 @@ Procedure and Macro Index | * CAR: Cells. (line 23) * cbreak: Terminal Mode Setting. (line 12) -* CCLO_LENGTH: Header Cells. (line 110) | +* CCLO_LENGTH: Header Cells. (line 110) * CDR: Cells. (line 24) * char: Type Conversions. (line 27) -* char-ready: Port Properties. (line 39) +* char-ready: Port Properties. (line 50) * char-ready? <1>: Socket. (line 66) -* char-ready?: Port Properties. (line 37) +* char-ready?: Port Properties. (line 48) * char:sharp: Modifying Read Syntax. (line 23) * CHARS: Header Cells. (line 35) -* chdir: I/O-Extensions. (line 145) +* chdir: I/O-Extensions. (line 134) * CHEAP_CONTINUATIONS: Continuations. (line 37) -* chmod: I/O-Extensions. (line 160) +* chmod: I/O-Extensions. (line 149) * chown: Posix Extensions. (line 255) * clearok: Output Options Setting. (line 11) * close-port <1>: Window Manipulation. (line 24) * close-port <2>: Posix Extensions. (line 35) * close-port: Opening and Closing. (line 55) -* closedir: I/O-Extensions. (line 101) +* closedir: I/O-Extensions. (line 90) * CLOSEDP: Ptob Cells. (line 43) * CLOSUREP: Cells. (line 49) * CODE: Cells. (line 52) @@ -7988,7 +7996,7 @@ Procedure and Macro Index | * cosh: Numeric. (line 28) * could-not-open: Interrupts. (line 66) * current-error-port: Port Redirection. (line 7) -* current-input-port: Port Properties. (line 43) +* current-input-port: Port Properties. (line 54) * current-time: Time. (line 24) * default-input-port: Line Editing. (line 21) * default-output-port: Line Editing. (line 25) @@ -7998,11 +8006,11 @@ Procedure and Macro Index | * defmacro: Defmacro. (line 6) * defsyntax: Macro Primitives. (line 36) * defvar: Define and Set. (line 13) -* directory-for-each: I/O-Extensions. (line 105) +* directory-for-each: I/O-Extensions. (line 94) * display: Output. (line 9) * dld_find_executable: Executable Pathname. (line 18) * dump: Dump. (line 33) -* duplicate-port: I/O-Extensions. (line 78) +* duplicate-port: I/O-Extensions. (line 67) * dyn:call: Dynamic Linking. (line 79) * dyn:link: Dynamic Linking. (line 71) * dyn:main-call: Dynamic Linking. (line 91) @@ -8021,17 +8029,16 @@ Procedure and Macro Index | * eval: Eval and Load. (line 21) * eval-string: Eval and Load. (line 24) * exec-self: Internal State. (line 27) -* execl: I/O-Extensions. (line 207) -* execlp: I/O-Extensions. (line 208) -* execpath: Internal State. (line 79) | -* execv: I/O-Extensions. (line 218) -* execvp: I/O-Extensions. (line 219) +* execl: I/O-Extensions. (line 196) +* execlp: I/O-Extensions. (line 197) +* execpath: Internal State. (line 79) +* execv: I/O-Extensions. (line 207) +* execvp: I/O-Extensions. (line 208) * exit: SCM Session. (line 19) * extended-environment: Syntactic Hooks for Hygienic Macros. (line 113) -* file-position: I/O-Extensions. (line 56) -* file-set-position: I/O-Extensions. (line 61) -* fileno: I/O-Extensions. (line 177) +* file-position: Port Properties. (line 18) +* fileno: I/O-Extensions. (line 166) * final_scm: Embedding SCM. (line 117) * find_impl_file: File-System Habitat. (line 35) * force-output: Window Manipulation. (line 30) @@ -8044,8 +8051,8 @@ Procedure and Macro Index | * frame-trace: Debugging Continuations. (line 10) * free_continuation: Continuations. (line 79) -* freshline: Port Properties. (line 26) -* gc: Internal State. (line 58) | +* freshline: Port Properties. (line 37) +* gc: Internal State. (line 58) * gc-hook: Storage. (line 28) * gc_mark: Marking Cells. (line 27) * GCCDR: Marking Cells. (line 15) @@ -8053,7 +8060,7 @@ Procedure and Macro Index | * gentemp: Defmacro. (line 6) * get-internal-real-time: Time. (line 17) * get-internal-run-time: Time. (line 10) -* getcwd: I/O-Extensions. (line 150) +* getcwd: I/O-Extensions. (line 139) * getegid: Posix Extensions. (line 63) * geteuid: Posix Extensions. (line 66) * getgid: Posix Extensions. (line 60) @@ -8110,7 +8117,7 @@ Procedure and Macro Index | * integer->line-number: Line Numbers. (line 37) * INUM: Immediates. (line 26) * INUMP: Immediates. (line 21) -* isatty?: Port Properties. (line 33) +* isatty?: Port Properties. (line 44) * ISYMCHARS: Immediates. (line 93) * ISYMNUM: Immediates. (line 89) * ISYMP: Immediates. (line 86) @@ -8137,7 +8144,7 @@ Procedure and Macro Index | * macroexpand-1: Defmacro. (line 6) * main: Embedding SCM. (line 12) * makargvfrmstrs: Type Conversions. (line 76) -* makcclo: Header Cells. (line 105) | +* makcclo: Header Cells. (line 105) * make-arbiter: Process Synchronization. (line 35) * make-edited-line-port: Line Editing. (line 29) @@ -8159,7 +8166,7 @@ Procedure and Macro Index | * MAKSPCSYM: Immediates. (line 97) * mark_locations: Marking Cells. (line 33) * milli-alarm: Interrupts. (line 30) -* mkdir: I/O-Extensions. (line 131) +* mkdir: I/O-Extensions. (line 120) * mknod: Unix Extensions. (line 43) * must_free: Allocating memory. (line 43) * must_free_argv: Type Conversions. (line 84) @@ -8196,7 +8203,7 @@ Procedure and Macro Index | * open-output-pipe: Posix Extensions. (line 22) * open-pipe: Posix Extensions. (line 10) * open-ports: Opening and Closing. (line 48) -* opendir: I/O-Extensions. (line 88) +* opendir: I/O-Extensions. (line 77) * OPENP: Ptob Cells. (line 42) * OPFPORTP: Ptob Cells. (line 54) * OPINFPORTP: Ptob Cells. (line 55) @@ -8213,19 +8220,19 @@ Procedure and Macro Index | * pi/: Numeric. (line 24) * pipe: Posix Extensions. (line 40) * port-closed?: Port Properties. (line 7) -* port-column: Port Properties. (line 19) +* port-column: Port Properties. (line 30) * port-filename: Port Properties. (line 14) -* port-line: Port Properties. (line 18) +* port-line: Port Properties. (line 29) * port-type: Port Properties. (line 10) * PORTP: Ptob Cells. (line 33) * pp: Debugging Scheme Code. - (line 75) | + (line 75) * pprint: Debugging Scheme Code. - (line 62) | + (line 62) * print: Debugging Scheme Code. - (line 54) | + (line 54) * print-args: Debugging Scheme Code. - (line 80) | + (line 80) * procedure->identifier-macro: Macro Primitives. (line 14) * procedure->macro: Macro Primitives. (line 12) * procedure->memoizing-macro: Macro Primitives. (line 13) @@ -8235,38 +8242,38 @@ Procedure and Macro Index | * profile-alarm: Interrupts. (line 32) * profile-alarm-interrupt: Interrupts. (line 52) * program-arguments: SCM Session. (line 30) -* putenv: I/O-Extensions. (line 223) +* putenv: I/O-Extensions. (line 212) * qase: Define and Set. (line 45) * quit: SCM Session. (line 17) * raw: Terminal Mode Setting. (line 28) * read-char <1>: Input. (line 7) -* read-char: Port Properties. (line 40) +* read-char: Port Properties. (line 51) * read-for-load: Line Numbers. (line 47) * read-numbered: Line Numbers. (line 26) * read:sharp: Modifying Read Syntax. (line 7) -* readdir: I/O-Extensions. (line 92) +* readdir: I/O-Extensions. (line 81) * readlink: Unix Extensions. (line 19) -* real-acos: Numeric. (line 44) | -* real-acosh: Numeric. (line 50) | -* real-asin: Numeric. (line 43) | -* real-asinh: Numeric. (line 49) | -* real-atan: Numeric. (line 45) | -* real-atanh: Numeric. (line 51) | -* real-cos: Numeric. (line 41) | -* real-cosh: Numeric. (line 47) | -* real-exp: Numeric. (line 38) | -* real-expt: Numeric. (line 62) | -* real-ln: Numeric. (line 39) | -* real-log10: Numeric. (line 56) | -* real-sin: Numeric. (line 40) | -* real-sinh: Numeric. (line 46) | -* real-sqrt: Numeric. (line 37) | -* real-tan: Numeric. (line 42) | -* real-tanh: Numeric. (line 48) | +* real-acos: Numeric. (line 44) +* real-acosh: Numeric. (line 50) +* real-asin: Numeric. (line 43) +* real-asinh: Numeric. (line 49) +* real-atan: Numeric. (line 45) +* real-atanh: Numeric. (line 51) +* real-cos: Numeric. (line 41) +* real-cosh: Numeric. (line 47) +* real-exp: Numeric. (line 38) +* real-expt: Numeric. (line 62) +* real-ln: Numeric. (line 39) +* real-log10: Numeric. (line 56) +* real-sin: Numeric. (line 40) +* real-sinh: Numeric. (line 46) +* real-sqrt: Numeric. (line 37) +* real-tan: Numeric. (line 42) +* real-tanh: Numeric. (line 48) * record-printer-set!: Records. (line 10) -* redirect-port!: I/O-Extensions. (line 83) +* redirect-port!: I/O-Extensions. (line 72) * refresh: Window Manipulation. (line 29) * regcomp: Regular Expression Pattern Matching. (line 12) @@ -8286,20 +8293,20 @@ Procedure and Macro Index | (line 52) * release-arbiter: Process Synchronization. (line 43) -* rename-file: I/O-Extensions. (line 155) +* rename-file: I/O-Extensions. (line 144) * renamed-identifier: Syntactic Hooks for Hygienic Macros. (line 26) * renaming-transformer: Syntactic Hooks for Hygienic Macros. (line 142) -* reopen-file: I/O-Extensions. (line 74) +* reopen-file: I/O-Extensions. (line 63) * require: Dynamic Linking. (line 11) * resetty: Terminal Mode Setting. (line 58) * restart: Internal State. (line 18) * restore_signals: Embedding SCM. (line 90) -* rewinddir: I/O-Extensions. (line 97) -* rmdir: I/O-Extensions. (line 140) -* room: Internal State. (line 62) | +* rewinddir: I/O-Extensions. (line 86) +* rmdir: I/O-Extensions. (line 129) +* room: Internal State. (line 62) * savetty: Terminal Mode Setting. (line 59) * scalar->array: Array Mapping. (line 51) @@ -8381,11 +8388,11 @@ Procedure and Macro Index | * touchline: Window Manipulation. (line 55) * touchwin: Window Manipulation. (line 54) * trace: Debugging Scheme Code. - (line 37) | + (line 37) * transpose-array: Conventional Arrays. (line 21) * try-arbiter: Process Synchronization. (line 39) -* try-create-file: I/O-Extensions. (line 67) +* try-create-file: I/O-Extensions. (line 56) * try-load <1>: Line Numbers. (line 12) * try-load: Eval and Load. (line 7) * try-open-file: Opening and Closing. (line 8) @@ -8395,16 +8402,16 @@ Procedure and Macro Index | * TYP7: Cells. (line 28) * UCHARS: Header Cells. (line 36) * ulong2num: Type Conversions. (line 11) -* umask: I/O-Extensions. (line 172) +* umask: I/O-Extensions. (line 161) * uname: Posix Extensions. (line 172) * unctrl: Curses Miscellany. (line 30) * uniform-array-read!: Uniform Array. (line 67) * uniform-array-write: Uniform Array. (line 79) * untrace: Debugging Scheme Code. - (line 45) | + (line 45) * user-interrupt: Interrupts. (line 49) * usr:lib: Dynamic Linking. (line 18) -* utime: I/O-Extensions. (line 167) +* utime: I/O-Extensions. (line 156) * vector-set-length!: Storage. (line 7) * VECTORP: Header Cells. (line 16) * VELTS: Header Cells. (line 21) @@ -8414,7 +8421,7 @@ Procedure and Macro Index | * vms-debug: SCM Session. (line 41) * void: Sweeping the Heap. (line 15) * wadd: Output. (line 11) -* wait-for-input: Port Properties. (line 55) +* wait-for-input: Port Properties. (line 66) * waitpid: Posix Extensions. (line 124) * warn: Errors. (line 109) * wclear: Output. (line 41) @@ -8436,7 +8443,7 @@ Procedure and Macro Index | * x:lib: Dynamic Linking. (line 23) Variable Index -============== | +************** [index] * Menu: @@ -8448,7 +8455,7 @@ Variable Index * *interactive*: SCM Variables. (line 36) * *load-pathname*: Eval and Load. (line 15) * *load-reader*: Line Numbers. (line 50) -* *scm-version*: Internal State. (line 67) | +* *scm-version*: Internal State. (line 67) * *slib-load-reader*: Line Numbers. (line 51) * *syntax-rules*: SCM Variables. (line 30) * af_inet: Host and Other Inquiries. @@ -8481,7 +8488,7 @@ Variable Index * UNSPECIFIED: Immediates. (line 78) Type Index -========== | +********** [index] * Menu: @@ -8539,40 +8546,40 @@ Type Index * tc3_closure: Cells. (line 39) * tc3_cons: Cells. (line 32) * tc7_asubr: Subr Cells. (line 12) -* tc7_contin: Header Cells. (line 85) | +* tc7_contin: Header Cells. (line 85) * tc7_cxr: Subr Cells. (line 22) -* tc7_lsubr: Subr Cells. (line 63) | -* tc7_lsubr_2: Subr Cells. (line 60) | +* tc7_lsubr: Subr Cells. (line 63) +* tc7_lsubr_2: Subr Cells. (line 60) * tc7_msymbol: Header Cells. (line 29) -* tc7_rpsubr: Subr Cells. (line 48) | -* tc7_specfun: Header Cells. (line 88) | +* tc7_rpsubr: Subr Cells. (line 48) +* tc7_specfun: Header Cells. (line 88) * tc7_ssymbol: Header Cells. (line 26) * tc7_string: Header Cells. (line 41) * tc7_subr_0: Subr Cells. (line 16) * tc7_subr_1: Subr Cells. (line 19) -* tc7_subr_1o: Subr Cells. (line 52) | -* tc7_subr_2: Subr Cells. (line 45) | -* tc7_subr_2o: Subr Cells. (line 56) | -* tc7_subr_3: Subr Cells. (line 42) | -* tc7_Vbool: Header Cells. (line 55) | +* tc7_subr_1o: Subr Cells. (line 52) +* tc7_subr_2: Subr Cells. (line 45) +* tc7_subr_2o: Subr Cells. (line 56) +* tc7_subr_3: Subr Cells. (line 42) +* tc7_Vbool: Header Cells. (line 55) * tc7_vector: Header Cells. (line 13) -* tc7_VfixN16: Header Cells. (line 64) | -* tc7_VfixN32: Header Cells. (line 61) | -* tc7_VfixN8: Header Cells. (line 70) | -* tc7_VfixZ16: Header Cells. (line 67) | -* tc7_VfixZ32: Header Cells. (line 58) | -* tc7_VfixZ8: Header Cells. (line 73) | -* tc7_VfloC64: Header Cells. (line 82) | -* tc7_VfloR32: Header Cells. (line 76) | -* tc7_VfloR64: Header Cells. (line 79) | +* tc7_VfixN16: Header Cells. (line 64) +* tc7_VfixN32: Header Cells. (line 61) +* tc7_VfixN8: Header Cells. (line 70) +* tc7_VfixZ16: Header Cells. (line 67) +* tc7_VfixZ32: Header Cells. (line 58) +* tc7_VfixZ8: Header Cells. (line 73) +* tc7_VfloC64: Header Cells. (line 82) +* tc7_VfloR32: Header Cells. (line 76) +* tc7_VfloR64: Header Cells. (line 79) * tc_dblc: Smob Cells. (line 33) * tc_dblr: Smob Cells. (line 30) * tc_free_cell: Smob Cells. (line 15) * turtle-graphics: Dynamic Linking. (line 56) * unexec: Dump. (line 6) - | + Concept Index -============= | +************* [index] * Menu: @@ -8586,32 +8593,33 @@ Concept Index * #!.bat: MS-DOS Compatible Scripts. (line 8) * array <1>: Conventional Arrays. (line 9) -* array: Build Options. (line 196) | -* array-for-each: Build Options. (line 199) | -* arrays: Build Options. (line 202) | -* bignums: Build Options. (line 205) | -* build: Building SCM. (line 6) | -* build.scm: Building SCM. (line 6) | -* byte: Build Options. (line 208) | +* array: Build Options. (line 196) +* array-for-each: Build Options. (line 199) +* arrays: Build Options. (line 202) +* bignums: Build Options. (line 205) +* build: Building SCM. (line 6) +* build.scm: Building SCM. (line 6) +* byte: Build Options. (line 208) +* byte-number: Build Options. (line 211) * callbacks: Callbacks. (line 6) -* careful-interrupt-masking: Build Options. (line 211) | -* cautious: Build Options. (line 217) | -* cheap-continuations: Build Options. (line 226) | -* compiled-closure: Build Options. (line 235) | +* careful-interrupt-masking: Build Options. (line 214) +* cautious: Build Options. (line 220) +* cheap-continuations: Build Options. (line 229) +* compiled-closure: Build Options. (line 238) * continuations: Continuations. (line 6) -* curses: Build Options. (line 238) | -* debug: Build Options. (line 241) | -* differ: Build Options. (line 246) | +* curses: Build Options. (line 241) +* debug: Build Options. (line 244) +* differ: Build Options. (line 249) * documentation string: Documentation and Comments. (line 13) -* dont-memoize-locals: Build Options. (line 249) | -* dump: Build Options. (line 254) | -* dynamic-linking: Build Options. (line 257) | +* dont-memoize-locals: Build Options. (line 252) +* dump: Build Options. (line 257) +* dynamic-linking: Build Options. (line 260) * ecache: Memory Management for Environments. (line 6) -* edit-line: Build Options. (line 260) | +* edit-line: Build Options. (line 263) * Embedding SCM: Embedding SCM. (line 6) -* engineering-notation: Build Options. (line 263) | +* engineering-notation: Build Options. (line 266) * environments: Memory Management for Environments. (line 6) * exchanger: Process Synchronization. @@ -8621,186 +8629,186 @@ Concept Index (line 13) * foo.c: Compiling and Linking Custom Files. (line 13) -* generalized-c-arguments: Build Options. (line 268) | +* generalized-c-arguments: Build Options. (line 271) * graphics: Packages. (line 23) * hobbit: Packages. (line 23) -* i/o-extensions: Build Options. (line 271) | +* i/o-extensions: Build Options. (line 274) * IEEE: Bibliography. (line 7) -* inexact: Build Options. (line 275) | +* inexact: Build Options. (line 278) * JACAL: Bibliography. (line 49) -* lit: Build Options. (line 278) | -* macro: Build Options. (line 281) | +* lit: Build Options. (line 281) +* macro: Build Options. (line 284) * memory management: Memory Management for Environments. (line 6) -* mysql: Build Options. (line 285) | -* no-heap-shrink: Build Options. (line 288) | +* mysql: Build Options. (line 288) +* no-heap-shrink: Build Options. (line 291) * NO_ENV_CACHE: Memory Management for Environments. (line 89) -* none: Build Options. (line 293) | +* none: Build Options. (line 296) * posix: Posix Extensions. (line 6) * Posix: Posix Extensions. (line 6) -* posix: Build Options. (line 296) | +* posix: Build Options. (line 299) * R4RS: Bibliography. (line 11) * R5RS: Bibliography. (line 18) -* reckless: Build Options. (line 301) | -* record: Build Options. (line 306) | -* regex: Build Options. (line 310) | -* rev2-procedures: Build Options. (line 313) | +* reckless: Build Options. (line 304) +* record: Build Options. (line 309) +* regex: Build Options. (line 313) +* rev2-procedures: Build Options. (line 316) * rope <1>: Type Conversions. (line 6) * rope: Callbacks. (line 6) * SchemePrimer: Bibliography. (line 39) -* SICP: Build Options. (line 319) | -* sicp: Build Options. (line 317) | +* SICP: Build Options. (line 322) +* sicp: Build Options. (line 320) * SICP: Bibliography. (line 30) * signals: Signals. (line 6) * Simply: Bibliography. (line 35) -* single-precision-only: Build Options. (line 331) | +* single-precision-only: Build Options. (line 334) * SLIB: Bibliography. (line 43) -* socket: Build Options. (line 337) | -* tick-interrupts: Build Options. (line 341) | -* turtlegr: Build Options. (line 344) | +* socket: Build Options. (line 340) +* tick-interrupts: Build Options. (line 344) +* turtlegr: Build Options. (line 347) * unix: Unix Extensions. (line 6) * Unix: Unix Extensions. (line 6) -* unix: Build Options. (line 348) | -* wb: Build Options. (line 352) | -* windows: Build Options. (line 355) | +* unix: Build Options. (line 351) +* wb: Build Options. (line 355) +* windows: Build Options. (line 358) * X: Packages. (line 23) * x <1>: Packages. (line 23) -* x: Build Options. (line 358) | +* x: Build Options. (line 361) * xlib: Packages. (line 23) * Xlib: Packages. (line 23) -* xlib: Build Options. (line 361) | +* xlib: Build Options. (line 364) * xlibscm: Packages. (line 23) * Xlibscm: Packages. (line 23)  Tag Table: -Node: Top1723 -Node: Overview3323 -Node: SCM Features3638 -Node: SCM Authors5713 -Node: Copying6614 -Node: The SCM License6943 -Node: SIOD copyright10867 -Node: Bibliography12253 -Node: Installing SCM14129 -Node: Making SCM14648 -Node: SLIB15573 -Node: Building SCM17489 -Node: Invoking Build18071 -Node: Build Options20408 -Node: Compiling and Linking Custom Files34079 -Node: Installing Dynamic Linking36075 -Node: Configure Module Catalog37861 -Node: Saving Images39869 -Node: Automatic C Preprocessor Definitions42952 -Node: Problems Compiling46727 -Node: Problems Linking48388 -Node: Problems Running48661 -Node: Testing50779 -Node: Reporting Problems54096 -Node: Operational Features54948 -Node: Invoking SCM55344 -Node: SCM Options57078 -Node: Invocation Examples61447 -Node: SCM Variables62407 -Node: SCM Session63887 -Node: Editing Scheme Code65418 -Node: Debugging Scheme Code67436 -Node: Debugging Continuations71888 -Node: Errors74448 -Node: Memoized Expressions78766 -Node: Internal State81130 -Node: Scripting84409 -Node: Unix Scheme Scripts84713 -Node: MS-DOS Compatible Scripts87745 -Node: Unix Shell Scripts89600 -Node: The Language91741 -Node: Standards Compliance92363 -Node: Storage94786 -Node: Time97266 -Node: Interrupts98282 -Node: Process Synchronization101915 -Node: Files and Ports103444 -Node: Opening and Closing103785 -Node: Port Properties106276 -Node: Port Redirection108962 -Node: Soft Ports110454 -Node: Eval and Load112236 -Node: Line Numbers113652 -Node: Lexical Conventions116075 -Node: Common-Lisp Read Syntax116337 -Node: Load Syntax118369 -Node: Documentation and Comments118989 -Node: Modifying Read Syntax120213 -Node: Syntax121936 -Node: Define and Set122840 -Node: Defmacro126374 -Node: Syntax-Rules127454 -Node: Macro Primitives129260 -Node: Environment Frames130899 -Node: Syntactic Hooks for Hygienic Macros133319 -Node: Packages140293 -Node: Dynamic Linking141173 -Node: Dump145848 -Node: Numeric149869 -Node: Arrays152669 -Node: Conventional Arrays152887 -Node: Uniform Array156426 -Node: Bit Vectors161238 -Node: Array Mapping162546 -Node: Records165240 -Node: I/O-Extensions166112 -Node: Posix Extensions174744 -Node: Unix Extensions184296 -Node: Sequence Comparison186197 -Node: Regular Expression Pattern Matching186527 -Node: Line Editing190505 -Node: Curses191866 -Node: Output Options Setting192801 -Node: Terminal Mode Setting195468 -Node: Window Manipulation198569 -Node: Output202054 -Node: Input205706 -Node: Curses Miscellany206750 -Node: Sockets208191 -Node: Host and Other Inquiries208554 -Node: Internet Addresses and Socket Names211695 -Node: Socket213268 -Node: SCMDB220501 -Node: The Implementation220739 -Node: Data Types221002 -Node: Immediates221831 -Node: Cells226213 -Node: Header Cells228331 -Node: Subr Cells232539 -Node: Ptob Cells234935 -Node: Smob Cells236504 -Node: Data Type Representations239806 -Node: Operations244944 -Node: Garbage Collection245538 -Node: Marking Cells246171 -Node: Sweeping the Heap248311 -Node: Memory Management for Environments249273 -Node: Signals253842 -Node: C Macros255403 -Node: Changing Scm256540 -Node: Defining Subrs261011 -Node: Defining Smobs262871 -Node: Defining Ptobs265928 -Node: Allocating memory267117 -Node: Embedding SCM269447 -Node: Callbacks277161 -Node: Type Conversions278982 -Node: Continuations283031 -Node: Evaluation287269 -Node: Program Self-Knowledge292452 -Node: File-System Habitat292706 -Node: Executable Pathname296319 -Node: Script Support297957 -Node: Improvements To Make299292 -Node: VMS Dynamic Linking301510 -Node: Index306223 +Node: Top1099 +Node: Overview2318 +Node: SCM Features2633 +Node: SCM Authors4656 +Node: Copying5557 +Node: The SCM License5886 +Node: SIOD copyright9810 +Node: Bibliography11163 +Node: Installing SCM13039 +Node: Making SCM13558 +Node: SLIB14544 +Node: Building SCM16379 +Node: Invoking Build16961 +Node: Build Options19298 +Node: Compiling and Linking Custom Files32922 +Node: Installing Dynamic Linking34918 +Node: Configure Module Catalog36795 +Node: Saving Images38803 +Node: Automatic C Preprocessor Definitions40567 +Node: Problems Compiling44555 +Node: Problems Linking46216 +Node: Problems Running46489 +Node: Testing48607 +Node: Reporting Problems51876 +Node: Operational Features52728 +Node: Invoking SCM53124 +Node: SCM Options54916 +Node: Invocation Examples59525 +Node: SCM Variables60485 +Node: SCM Session61965 +Node: Editing Scheme Code63496 +Node: Debugging Scheme Code65514 +Node: Debugging Continuations69779 +Node: Errors72339 +Node: Memoized Expressions76657 +Node: Internal State79064 +Node: Scripting82290 +Node: Unix Scheme Scripts82594 +Node: MS-DOS Compatible Scripts85626 +Node: Unix Shell Scripts87481 +Node: The Language89622 +Node: Standards Compliance90244 +Node: Storage92667 +Node: Time95147 +Node: Interrupts96163 +Node: Process Synchronization99796 +Node: Files and Ports101325 +Node: Opening and Closing101666 +Node: Port Properties104184 +Node: Port Redirection107750 +Node: Soft Ports109242 +Node: Eval and Load111024 +Node: Line Numbers112440 +Node: Lexical Conventions114863 +Node: Common-Lisp Read Syntax115125 +Node: Load Syntax117112 +Node: Documentation and Comments117732 +Node: Modifying Read Syntax118956 +Node: Syntax120679 +Node: Define and Set121583 +Node: Defmacro125117 +Node: Syntax-Rules126197 +Node: Macro Primitives128003 +Node: Environment Frames129642 +Node: Syntactic Hooks for Hygienic Macros132062 +Node: Packages139036 +Node: Dynamic Linking139916 +Node: Dump144630 +Node: Numeric148651 +Node: Arrays150467 +Node: Conventional Arrays150685 +Node: Uniform Array154224 +Node: Bit Vectors159036 +Node: Array Mapping160344 +Node: Records163037 +Node: I/O-Extensions163909 +Node: Posix Extensions172155 +Node: Unix Extensions181707 +Node: Sequence Comparison183608 +Node: Regular Expression Pattern Matching183938 +Node: Line Editing187916 +Node: Curses189277 +Node: Output Options Setting190212 +Node: Terminal Mode Setting192879 +Node: Window Manipulation195980 +Node: Output199465 +Node: Input203117 +Node: Curses Miscellany204161 +Node: Sockets205602 +Node: Host and Other Inquiries205965 +Node: Internet Addresses and Socket Names209106 +Node: Socket210679 +Node: SCMDB217950 +Node: The Implementation218188 +Node: Data Types218451 +Node: Immediates219280 +Node: Cells223662 +Node: Header Cells225780 +Node: Subr Cells229076 +Node: Ptob Cells231373 +Node: Smob Cells232942 +Node: Data Type Representations236165 +Node: Operations241044 +Node: Garbage Collection241638 +Node: Marking Cells242271 +Node: Sweeping the Heap244392 +Node: Memory Management for Environments245354 +Node: Signals249923 +Node: C Macros251484 +Node: Changing Scm252621 +Node: Defining Subrs257085 +Node: Defining Smobs258945 +Node: Defining Ptobs262002 +Node: Allocating memory263191 +Node: Embedding SCM265521 +Node: Callbacks273235 +Node: Type Conversions275056 +Node: Continuations279105 +Node: Evaluation283343 +Node: Program Self-Knowledge288526 +Node: File-System Habitat288780 +Node: Executable Pathname292393 +Node: Script Support294031 +Node: Improvements To Make295366 +Node: VMS Dynamic Linking297584 +Node: Index302297  End Tag Table diff --git a/scm.nsi b/scm.nsi new file mode 100644 index 0000000..0c06fc6 --- /dev/null +++ b/scm.nsi @@ -0,0 +1,477 @@ +; Install SCM on Windows for current user +; Basic script generated by the HM NIS Edit Script Wizard. +; Augmented by Jerry van Dijk, february 2007 +; placed in the public domain + +; *** version numbers *** +!define PRODUCT_VERSION "5e4-1" +!define REQ_SLIB_VERSION "3a5-1" + +; ----------------[ NO CHANGES BELOW ]---------------- + +; *** unless files are added or removed *** +; *** remember to edit both 'file' and 'delete' sections! + +; *** registry settings *** +!define KEY_VERSION "version" +!define SCM_KEY "Software\Voluntocracy\scm" +!define SLIB_KEY "Software\Voluntocracy\slib" + +; HM NIS Edit Wizard helper defines +!define PRODUCT_NAME "SCM" +!define PRODUCT_COMPANY "Voluntocracy" +!define PRODUCT_PUBLISHER "Aubrey Jaffer" +!define PRODUCT_WEB_SITE "http://swissnet.ai.mit.edu/~jaffer/SCM.html" +!define PRODUCT_DIR_REGKEY "Software\Microsoft\Windows\CurrentVersion\App Paths\scm-${PRODUCT_VERSION}.exe" +!define PRODUCT_UNINST_KEY "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PRODUCT_NAME}" +!define PRODUCT_UNINST_ROOT_KEY "HKLM" +!define PRODUCT_STARTMENU_REGVAL "NSIS:StartMenuDir" + +; MUI 1.67 compatible ------ +!include "MUI.nsh" + +; MUI Settings +!define MUI_ABORTWARNING +!define MUI_ICON "${NSISDIR}\Contrib\Graphics\Icons\modern-install.ico" +!define MUI_UNICON "${NSISDIR}\Contrib\Graphics\Icons\modern-uninstall.ico" + +; Welcome page +!insertmacro MUI_PAGE_WELCOME + +; License page +!insertmacro MUI_PAGE_LICENSE "COPYING" + +; Directory page +!insertmacro MUI_PAGE_DIRECTORY + +; Start menu page +var ICONS_GROUP +!define MUI_STARTMENUPAGE_NODISABLE +!define MUI_STARTMENUPAGE_DEFAULTFOLDER "scm" +!define MUI_STARTMENUPAGE_REGISTRY_ROOT "${PRODUCT_UNINST_ROOT_KEY}" +!define MUI_STARTMENUPAGE_REGISTRY_KEY "${PRODUCT_UNINST_KEY}" +!define MUI_STARTMENUPAGE_REGISTRY_VALUENAME "${PRODUCT_STARTMENU_REGVAL}" +!insertmacro MUI_PAGE_STARTMENU Application $ICONS_GROUP + +; Instfiles page +!insertmacro MUI_PAGE_INSTFILES + +; Finish page +!insertmacro MUI_PAGE_FINISH + +; Uninstaller pages +!insertmacro MUI_UNPAGE_INSTFILES + +; Language files +!insertmacro MUI_LANGUAGE "English" + +; MUI end ------ + +Name "${PRODUCT_NAME} ${PRODUCT_VERSION}" +OutFile "SCM-${PRODUCT_VERSION}.exe" +InstallDir "$PROGRAMFILES\scm" +InstallDirRegKey ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_DIR_REGKEY}" "" +ShowInstDetails show +ShowUnInstDetails show + +; Check that the correct slib is installed, and no other scm version is present +Function .onInit +; Check that slib is installed + ClearErrors + ReadRegStr $0 ${PRODUCT_UNINST_ROOT_KEY} "${SLIB_KEY}" "${KEY_VERSION}" + IfErrors 0 +3 + MessageBox MB_OK|MB_ICONSTOP "No SLIB found. Please install SLIB before installing SCM." + Abort + +; Check that the correct slib is installed + StrCmp $0 ${REQ_SLIB_VERSION} +3 0 + MessageBox MB_OK|MB_ICONSTOP "Found SLIB version $0. SCM ${PRODUCT_VERSION} requires SLIB ${REQ_SLIB_VERSION}. Please install this SLIB version first." + Abort + +; Check for older scm installed + ReadRegStr $0 ${PRODUCT_UNINST_ROOT_KEY} "${SCM_KEY}" "${KEY_VERSION}" + StrCmp $0 '' +4 0 + StrCmp $0 ${PRODUCT_VERSION} +3 0 + MessageBox MB_OK|MB_ICONSTOP "You already have SCM version $0 installed. Please uninstall this SCM first." + Abort + +FunctionEnd + +Section "MainSection" SEC01 + SetOutPath "$INSTDIR" + SetOverwrite try + File "SCM.lnk" + File "scm.exe" + File "scm.html" + File "Init5e4.scm" + File "Transcen.scm" + File "mkimpcat.scm" + File "hobbit.scm" + File "scmhob.scm" + File "hobbit.html" + File "wbtab.scm" + File "rwb-isam.scm" + File "r4rstest.scm" + File "pi.scm" + +; Shortcuts + !insertmacro MUI_STARTMENU_WRITE_BEGIN Application + CreateShortCut "$DESKTOP\SCM.lnk" "$INSTDIR\scm.lnk" + CreateDirectory "$SMPROGRAMS\$ICONS_GROUP" + CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\SCM Manual.lnk" "$INSTDIR\scm.html" + CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\SCM.lnk" "$INSTDIR\SCM.lnk" + CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\Hobbit Manual.lnk" "$INSTDIR\hobbit.html" + !insertmacro MUI_STARTMENU_WRITE_END + +; Jaffer scm registry settings + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${SCM_KEY}" "${KEY_VERSION}" "${PRODUCT_VERSION}" + +; Jaffer scm path settings + Push "$INSTDIR\" + Call AddToPath + +SectionEnd + +Section -AdditionalIcons + !insertmacro MUI_STARTMENU_WRITE_BEGIN Application + WriteIniStr "$INSTDIR\${PRODUCT_NAME}.url" "InternetShortcut" "URL" "${PRODUCT_WEB_SITE}" + CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\Website.lnk" "$INSTDIR\${PRODUCT_NAME}.url" + CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\Uninstall.lnk" "$INSTDIR\uninst.exe" + !insertmacro MUI_STARTMENU_WRITE_END +SectionEnd + +Section -Post + WriteUninstaller "$INSTDIR\uninst.exe" + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_DIR_REGKEY}" "" "$INSTDIR\scm-${PRODUCT_VERSION}.exe" + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "DisplayName" "$(^Name)" + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "UninstallString" "$INSTDIR\uninst.exe" + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "DisplayIcon" "$INSTDIR\scm-${PRODUCT_VERSION}.exe" + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "DisplayVersion" "${PRODUCT_VERSION}" + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "URLInfoAbout" "${PRODUCT_WEB_SITE}" + WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "Publisher" "${PRODUCT_PUBLISHER}" +SectionEnd + +Function .onInstSuccess + IfRebootFlag 0 noreboot + MessageBox MB_YESNO|MB_ICONQUESTION|MB_DEFBUTTON1 "A reboot is required to finish the installation. Do you wish to reboot now?" IDNO noreboot + Reboot + noreboot: +FunctionEnd + +Function un.onUninstSuccess + HideWindow + MessageBox MB_ICONINFORMATION|MB_OK "$(^Name) was successfully removed from your computer." +FunctionEnd + +Function un.onInit + MessageBox MB_ICONQUESTION|MB_YESNO|MB_DEFBUTTON2 "Are you sure you want to completely remove $(^Name) and all of its components?" IDYES +2 + Abort +FunctionEnd + +Section Uninstall + !insertmacro MUI_STARTMENU_GETFOLDER "Application" $ICONS_GROUP + Delete "$INSTDIR\${PRODUCT_NAME}.url" + Delete "$INSTDIR\uninst.exe" + Delete "$INSTDIR\pi.scm" + Delete "$INSTDIR\r4rstest.scm" + Delete "$INSTDIR\rwb-isam.scm" + Delete "$INSTDIR\wbtab.scm" + Delete "$INSTDIR\hobbit.html" + Delete "$INSTDIR\scmhob.scm" + Delete "$INSTDIR\hobbit.scm" + Delete "$INSTDIR\mkimpcat.scm" + Delete "$INSTDIR\Transcen.scm" + Delete "$INSTDIR\Init5e4.scm" + Delete "$INSTDIR\scm.html" + Delete "$INSTDIR\scm.exe" + Delete "$INSTDIR\SCM.lnk" + + Delete "$SMPROGRAMS\$ICONS_GROUP\Uninstall.lnk" + Delete "$SMPROGRAMS\$ICONS_GROUP\Website.lnk" + Delete "$SMPROGRAMS\$ICONS_GROUP\SCM.lnk" + Delete "$SMPROGRAMS\$ICONS_GROUP\SCM Manual.lnk" + Delete "$SMPROGRAMS\$ICONS_GROUP\Hobbit Manual.lnk" + Delete "$DESKTOP\SCM.lnk" + + RMDir "$SMPROGRAMS\$ICONS_GROUP" + RMDir "$INSTDIR" + + # remove from the path + Push "$INSTDIR\" + Call un.RemoveFromPath + + ; remove Jaffer registry entries + DeleteRegKey ${PRODUCT_UNINST_ROOT_KEY} "${SCM_KEY}" + + DeleteRegKey ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" + DeleteRegKey ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_DIR_REGKEY}" + SetAutoClose true + +SectionEnd + +; ----------------[ ENVIRONMENT MANIPULATION ]---------------- + +!ifndef WriteEnvStr_RegKey + !ifdef ALL_USERS + !define WriteEnvStr_RegKey \ + 'HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"' + !else + !define WriteEnvStr_RegKey 'HKCU "Environment"' + !endif +!endif + + +; ----------------[ EXECUTABLE PATH MANIPULATION ]---------------- + +; AddToPath - Adds the given dir to the search path. +; Input - head of the stack +; Note - Win9x systems requires reboot + +Function AddToPath + Exch $0 + Push $1 + Push $2 + Push $3 + + # don't add if the path doesn't exist + IfFileExists "$0\*.*" "" AddToPath_done + + ReadEnvStr $1 PATH + Push "$1;" + Push "$0;" + Call StrStr + Pop $2 + StrCmp $2 "" "" AddToPath_done + Push "$1;" + Push "$0\;" + Call StrStr + Pop $2 + StrCmp $2 "" "" AddToPath_done + GetFullPathName /SHORT $3 $0 + Push "$1;" + Push "$3;" + Call StrStr + Pop $2 + StrCmp $2 "" "" AddToPath_done + Push "$1;" + Push "$3\;" + Call StrStr + Pop $2 + StrCmp $2 "" "" AddToPath_done + + Call IsNT + Pop $1 + StrCmp $1 1 AddToPath_NT + ; Not on NT + StrCpy $1 $WINDIR 2 + FileOpen $1 "$1\autoexec.bat" a + FileSeek $1 -1 END + FileReadByte $1 $2 + IntCmp $2 26 0 +2 +2 # DOS EOF + FileSeek $1 -1 END # write over EOF + FileWrite $1 "$\r$\nSET PATH=%PATH%;$3$\r$\n" + FileClose $1 + SetRebootFlag true + Goto AddToPath_done + + AddToPath_NT: + ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH" + StrCmp $1 "" AddToPath_NTdoIt + Push $1 + Call Trim + Pop $1 + StrCpy $0 "$1;$0" + AddToPath_NTdoIt: + WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $0 + SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000 + + AddToPath_done: + Pop $3 + Pop $2 + Pop $1 + Pop $0 +FunctionEnd + +; RemoveFromPath - Remove a given dir from the path +; Input: head of the stack + +Function un.RemoveFromPath + Exch $0 + Push $1 + Push $2 + Push $3 + Push $4 + Push $5 + Push $6 + + IntFmt $6 "%c" 26 # DOS EOF + + Call un.IsNT + Pop $1 + StrCmp $1 1 unRemoveFromPath_NT + ; Not on NT + StrCpy $1 $WINDIR 2 + FileOpen $1 "$1\autoexec.bat" r + GetTempFileName $4 + FileOpen $2 $4 w + GetFullPathName /SHORT $0 $0 + StrCpy $0 "SET PATH=%PATH%;$0" + Goto unRemoveFromPath_dosLoop + + unRemoveFromPath_dosLoop: + FileRead $1 $3 + StrCpy $5 $3 1 -1 # read last char + StrCmp $5 $6 0 +2 # if DOS EOF + StrCpy $3 $3 -1 # remove DOS EOF so we can compare + StrCmp $3 "$0$\r$\n" unRemoveFromPath_dosLoopRemoveLine + StrCmp $3 "$0$\n" unRemoveFromPath_dosLoopRemoveLine + StrCmp $3 "$0" unRemoveFromPath_dosLoopRemoveLine + StrCmp $3 "" unRemoveFromPath_dosLoopEnd + FileWrite $2 $3 + Goto unRemoveFromPath_dosLoop + unRemoveFromPath_dosLoopRemoveLine: + SetRebootFlag true + Goto unRemoveFromPath_dosLoop + + unRemoveFromPath_dosLoopEnd: + FileClose $2 + FileClose $1 + StrCpy $1 $WINDIR 2 + Delete "$1\autoexec.bat" + CopyFiles /SILENT $4 "$1\autoexec.bat" + Delete $4 + Goto unRemoveFromPath_done + + unRemoveFromPath_NT: + ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH" + StrCpy $5 $1 1 -1 # copy last char + StrCmp $5 ";" +2 # if last char != ; + StrCpy $1 "$1;" # append ; + Push $1 + Push "$0;" + Call un.StrStr ; Find `$0;` in $1 + Pop $2 ; pos of our dir + StrCmp $2 "" unRemoveFromPath_done + ; else, it is in path + # $0 - path to add + # $1 - path var + StrLen $3 "$0;" + StrLen $4 $2 + StrCpy $5 $1 -$4 # $5 is now the part before the path to remove + StrCpy $6 $2 "" $3 # $6 is now the part after the path to remove + StrCpy $3 $5$6 + + StrCpy $5 $3 1 -1 # copy last char + StrCmp $5 ";" 0 +2 # if last char == ; + StrCpy $3 $3 -1 # remove last char + + WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $3 + SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000 + + unRemoveFromPath_done: + Pop $6 + Pop $5 + Pop $4 + Pop $3 + Pop $2 + Pop $1 + Pop $0 +FunctionEnd + +; ----------------[ OS TYPE DETERMINATION ]---------------- + +# +# [un.]IsNT - Pushes 1 if running on NT, 0 if not +# +# Example: +# Call IsNT +# Pop $0 +# StrCmp $0 1 +3 +# MessageBox MB_OK "Not running on NT!" +# Goto +2 +# MessageBox MB_OK "Running on NT!" +# +!macro IsNT UN +Function ${UN}IsNT + Push $0 + ReadRegStr $0 HKLM "SOFTWARE\Microsoft\Windows NT\CurrentVersion" CurrentVersion + StrCmp $0 "" 0 IsNT_yes + ; we are not NT. + Pop $0 + Push 0 + Return + + IsNT_yes: + ; NT!!! + Pop $0 + Push 1 +FunctionEnd +!macroend +!insertmacro IsNT "" +!insertmacro IsNT "un." + +; ----------------[ STRING MANIPULATION ]---------------- + +; StrStr +; input, top of stack = string to search for +; top of stack-1 = string to search in +; output, top of stack (replaces with the portion of the string remaining) +; modifies no other variables. +; +; Usage: +; Push "this is a long ass string" +; Push "ass" +; Call StrStr +; Pop $R0 +; ($R0 at this point is "ass string") + +!macro StrStr un +Function ${un}StrStr +Exch $R1 ; st=haystack,old$R1, $R1=needle + Exch ; st=old$R1,haystack + Exch $R2 ; st=old$R1,old$R2, $R2=haystack + Push $R3 + Push $R4 + Push $R5 + StrLen $R3 $R1 + StrCpy $R4 0 + ; $R1=needle + ; $R2=haystack + ; $R3=len(needle) + ; $R4=cnt + ; $R5=tmp + loop: + StrCpy $R5 $R2 $R3 $R4 + StrCmp $R5 $R1 done + StrCmp $R5 "" done + IntOp $R4 $R4 + 1 + Goto loop +done: + StrCpy $R1 $R2 "" $R4 + Pop $R5 + Pop $R4 + Pop $R3 + Pop $R2 + Exch $R1 +FunctionEnd +!macroend +!insertmacro StrStr "" +!insertmacro StrStr "un." + +Function Trim ; Added by Pelaca + Exch $R1 + Push $R2 +Loop: + StrCpy $R2 "$R1" 1 -1 + StrCmp "$R2" " " RTrim + StrCmp "$R2" "$\n" RTrim + StrCmp "$R2" "$\r" RTrim + StrCmp "$R2" ";" RTrim + GoTo Done +RTrim: + StrCpy $R1 "$R1" -1 + Goto Loop +Done: + Pop $R2 + Exch $R1 +FunctionEnd diff --git a/scm.spec b/scm.spec index c61ac06..7bf1c10 100644 --- a/scm.spec +++ b/scm.spec @@ -1,5 +1,5 @@ %define name scm -%define version 5e3 +%define version 5e4 %define release 1 %define implpath %{prefix}/lib/scm %define slibpath %{prefix}/lib/slib @@ -169,7 +169,7 @@ rm -f %{prefix}/bin/scm %{prefix}/lib/scm/keysymdef.scm %{prefix}/lib/scm/r4rstest.scm %{prefix}/lib/scm/byte.so -%{prefix}/lib/scm/db.so +# %{prefix}/lib/scm/db.so %{prefix}/lib/scm/wbtab.scm %{prefix}/lib/scm/rwb-isam.scm %{prefix}/lib/scm/COPYING diff --git a/scm.texi b/scm.texi index 02c9f49..b7f29a7 100644 --- a/scm.texi +++ b/scm.texi @@ -16,7 +16,7 @@ This manual is for SCM (version @value{SCMVERSION}, @value{SCMDATE}), and algorithmic language Scheme implementation. @noindent -Copyright @copyright{} 1990-2006 Free Software Foundation, Inc. +Copyright @copyright{} 1990-2007 Free Software Foundation, Inc. @quotation Permission is granted to make and distribute verbatim copies of @@ -154,6 +154,7 @@ timing information printed interactively (the @code{verbose} function). @code{Restart}, @code{quit}, and @code{exec}. @end itemize + @node SCM Authors, Copying, SCM Features, Overview @section Authors @@ -179,6 +180,7 @@ C-stack and being able to garbage collect off the C-stack There are many other contributors to SCM. They are acknowledged in the file @file{ChangeLog}, a log of changes that have been made to scm. + @node Copying, Bibliography, SCM Authors, Overview @section Copyright @@ -310,6 +312,7 @@ Paradigm Associates Inc Cambridge, MA 02138 @end flushleft + @node Bibliography, , Copying, Overview @section Bibliography @@ -334,8 +337,7 @@ Revised(4) Report on the Algorithmic Language Scheme. pp. 1-55. @ifinfo -@ref{Top, , , r4rs, Revised(4) Report on the Algorithmic Language -Scheme}. +@ref{Top, , , r4rs, Revised(4) Report on the Algorithmic Language Scheme}. @end ifinfo @item [R5RS] @@ -353,8 +355,7 @@ pp. 7-105, and @cite{ACM SIGPLAN Notices} 33(9), September 1998. @ifinfo -@ref{Top, , , r5rs, Revised(5) Report on the Algorithmic Language -Scheme}. +@ref{Top, , , r5rs, Revised(5) Report on the Algorithmic Language Scheme}. @end ifinfo @item [Exrename] @@ -455,6 +456,7 @@ include @code{scm} in other programs. Documentation of the Xlib - SCM Language X Interface. @end table + @node Installing SCM, Operational Features, Overview, Top @chapter Installing SCM @@ -476,10 +478,10 @@ Documentation of the Xlib - SCM Language X Interface. @node Making SCM, SLIB, Installing SCM, Installing SCM @section Making SCM -The SCM distribution has @dfn{Makefile} which contains rules for making -@dfn{scmlit}, a ``bare-bones'' version of SCM sufficient for running -@file{build}. @file{build} is used to compile (or create scripts to -compile) full featured versions. +The SCM distribution has @dfn{Makefile} which contains rules for +making @dfn{scmlit}, a ``bare-bones'' version of SCM sufficient for +running @file{build}. @file{build} is used to compile (or create +scripts to compile) full featured versions (@pxref{Building SCM}). Makefiles are not portable to the majority of platforms. If @file{Makefile} works for you, good; If not, I don't want to hear about @@ -517,34 +519,28 @@ low priority. SLIB is available from the same sites as SCM: @ifclear html @itemize @bullet @item -swiss.csail.mit.edu:/pub/scm/slib3a4.tar.gz -@item -ftp.gnu.org:/pub/gnu/jacal/slib3a4.tar.gz +swiss.csail.mit.edu:/pub/scm/slib3a5.tar.gz @item -ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a4.tar.gz +ftp.gnu.org:/pub/gnu/jacal/slib3a5.tar.gz @end itemize @end ifclear @ifset html @itemize @bullet @item - -http://swiss.csail.mit.edu/ftpdir/scm/slib3a4.zip + +http://swiss.csail.mit.edu/ftpdir/scm/slib3a5.zip @item - -ftp.gnu.org:/pub/gnu/jacal/slib3a4.tar.gz - -@item - -ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib3a4.tar.gz + +ftp.gnu.org:/pub/gnu/jacal/slib3a5.tar.gz @end itemize @end ifset @noindent -Unpack SLIB (@samp{tar xzf slib3a4.tar.gz} or @samp{unzip -ao -slib3a4.zip}) in an appropriate directory for your system; both +Unpack SLIB (@samp{tar xzf slib3a5.tar.gz} or @samp{unzip -ao +slib3a5.zip}) in an appropriate directory for your system; both @code{tar} and @code{unzip} will create the directory @file{slib}. @noindent @@ -835,6 +831,7 @@ features are: @end table @end deffn + @node Compiling and Linking Custom Files, , Build Options, Building SCM @subsection Compiling and Linking Custom Files @@ -895,6 +892,7 @@ dynamic-loading), you can load the compiled file with the Scheme command @code{(load "./foo.so")}. See @ref{Configure Module Catalog} for how to add a compiled dll file to SLIB's catalog. + @node Installing Dynamic Linking, Configure Module Catalog, Building SCM, Installing SCM @section Installing Dynamic Linking @@ -907,10 +905,10 @@ proposed POSIX standard and may be available on other machines with finishing the port to VMS @ref{VMS Dynamic Linking}. @noindent -@dfn{DLD} is a library package of C functions that performs @dfn{dynamic -link editing} on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), -SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST. It is -available from: +@dfn{DLD} is a library package of C functions that performs +@dfn{dynamic link editing} on GNU/Linux, VAX (Ultrix), Sun 3 (SunOS +3.4 and 4.0), SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), and +Atari ST. It is available from: @ifclear html @itemize @bullet @@ -1005,6 +1003,7 @@ will be @code{load}ed. An unspecified value is returned. Remember to delete the file @file{slibcat} after modifying the file @file{mkimpcat.scm} in order to force SLIB to rebuild its cache. + @node Saving Images, Automatic C Preprocessor Definitions, Configure Module Catalog, Installing SCM @section Saving Images @@ -1023,7 +1022,7 @@ The @samp{dscm4} and @samp{dscm5} targets in the SCM @file{Makefile} save images from @file{udscm4} and @file{udscm5} executables respectively. -Recent Linux innovations interfere with @code{dump}. For: +Recent GNU/Linux innovations interfere with @code{dump}. For: @table @asis @item Fedora-Core-1 @@ -1054,6 +1053,7 @@ either set @file{randomize_va_space} to 0 or run as root to dump. @end table + @node Automatic C Preprocessor Definitions, Problems Compiling, Saving Images, Installing SCM @section Automatic C Preprocessor Definitions @@ -1093,11 +1093,12 @@ __APPLE__ Apple Darwin AMIGA SAS/C 5.10 or Dice C on AMIGA __amigaos__ Gnu CC on AMIGA atarist ATARI-ST under Gnu CC +__DragonflyBSD__ DragonflyBSD __FreeBSD__ FreeBSD GNUDOS DJGPP (obsolete in version 1.08) __GO32__ DJGPP (future?) hpux HP-UX -linux Linux +linux GNU/Linux macintosh Macintosh (THINK_C and __MWERKS__ define) MCH_AMIGA Aztec_c 5.2a on AMIGA __MACH__ Apple Darwin @@ -1107,6 +1108,7 @@ _MSDOS Microsoft CLARM and CLTHUMB compilers. __MSDOS__ Turbo C, Borland C, and DJGPP __NetBSD__ NetBSD nosve Control Data NOS/VE +__OpenBSD__ OpenBSD SVR2 System V Revision 2. sun SunOS __SVR4 SunOS @@ -1146,6 +1148,7 @@ vax VAX processor __x86_64 AMD Opteron @end example + @node Problems Compiling, Problems Linking, Automatic C Preprocessor Definitions, Installing SCM @section Problems Compiling @@ -1200,6 +1203,7 @@ __x86_64 AMD Opteron @tab @t{#define SYSTNAME} to your system type in scl.c (softtype). @end multitable + @node Problems Linking, Problems Running, Problems Compiling, Installing SCM @section Problems Linking @@ -1210,6 +1214,7 @@ __x86_64 AMD Opteron @tab Uncomment @t{LIBS} in makefile. @end multitable + @node Problems Running, Testing, Problems Linking, Installing SCM @section Problems Running @@ -1248,6 +1253,7 @@ __x86_64 AMD Opteron @tab Make sure the value of @t{(library-vicinity)} has a trailing file separator (like @t{/} or @t{\}). @end multitable + @node Testing, Reporting Problems, Problems Running, Installing SCM @section Testing @@ -1334,6 +1340,7 @@ exacerbated by using lots of call-with-current-continuations. A possible fix for dynthrow() is commented out in @file{continue.c}. @end table + @node Reporting Problems, , Testing, Installing SCM @section Reporting Problems @@ -1361,6 +1368,7 @@ and date of that distribution. In this case, corresponding with the vendor is recommended. @end enumerate + @node Operational Features, The Language, Installing SCM, Top @chapter Operational Features @@ -1384,7 +1392,8 @@ vendor is recommended. @example @exdent @b{ scm } [-a @i{kbytes}] [-muvbiq] @w{[--version]} @w{[--help]} -@w{[[-]-no-init-file]} @w{[-p @i{int}]} @w{[-r @i{feature}]} @w{[-h @i{feature}]} +@w{[[-]-no-init-file]} @w{[--no-symbol-case-fold]} +@w{[-p @i{int}]} @w{[-r @i{feature}]} @w{[-h @i{feature}]} @w{[-d @i{filename}]} @w{[-f @i{filename}]} @w{[-l @i{filename}]} @w{[-c @i{expression}]} @w{[-e @i{expression}]} @w{[-o @i{dumpname}]} @w{[-- | - | -s]} @w{[@i{filename}]} @w{[@i{arguments} @dots{}]} @@ -1428,6 +1437,7 @@ This explanation applies to SCMLIT or other builds of SCM. Scheme-code files can also invoke SCM and its variants. @xref{Lexical Conventions, #!}. + @node SCM Options, Invocation Examples, Invoking SCM, Operational Features @section Options @@ -1447,6 +1457,10 @@ file @file{setjump.h} which the distribution sets at Inhibits the loading of @file{ScmInit.scm} as described above. @end deffn +@deffn {Command Option} --no-symbol-case-fold +Symbol (and identifier) names will be case sensitive. +@end deffn + @deffn {Command Option} ---help prints usage information and URI; then exit. @end deffn @@ -1556,6 +1570,7 @@ aguments. specifies that further options are to be treated as program aguments. @end deffn + @node Invocation Examples, SCM Variables, SCM Options, Operational Features @section Invocation Examples @@ -1588,6 +1603,7 @@ enters interactive (with macros) session. Like above but @code{rev4-optional-procedures} are also loaded. @end table + @node SCM Variables, SCM Session, Invocation Examples, Operational Features @section Environment Variables @@ -1633,14 +1649,15 @@ command line. This can be overridden by subsequent @code{-i} and @code{-b} options. @end defvar + @node SCM Session, Editing Scheme Code, SCM Variables, Operational Features @section SCM Session @itemize @bullet @item Options, file loading and features can be specified from the command -line. @xref{System interface, , , scm, SCM}. @xref{Require, , , slib, -SLIB}. +line. +@xref{System interface, , , scm, SCM}. @xref{Require, , , slib, SLIB}. @item Typing the end-of-file character at the top level session (while SCM is not waiting for parenthesis closure) causes SCM to exit. @@ -1654,8 +1671,8 @@ and resumes the top level read-eval-print loop. @defunx exit @defunx exit n Aliases for @code{exit} (@pxref{System, exit, , slib, SLIB}). On many -systems, SCM can also tail-call another program. @xref{I/O-Extensions, -execp}. +systems, SCM can also tail-call another program. +@xref{I/O-Extensions, execp}. @end defun @deffn {Callback procedure} boot-tail dumped? @@ -1755,9 +1772,10 @@ expressions. Also as the result of the @samp{CAUTIOUS} flag, both @code{error} and @code{user-interrupt} (invoked by @key{C-c}) to print stack traces and -conclude by calling @code{breakpoint} (@pxref{Breakpoints, , , slib, -SLIB}) instead of aborting to top level. Under either condition, -program execution can be resumed by @code{(continue)}. +conclude by calling @code{breakpoint} +(@pxref{Breakpoints, , , slib, SLIB}) instead of aborting to top +level. Under either condition, program execution can be resumed by +@code{(continue)}. In this configuration one can interrupt a running Scheme program with @key{C-c}, inspect or modify top-level values, trace or untrace @@ -1858,6 +1876,7 @@ ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz @end lisp + @node Debugging Continuations, Errors, Debugging Scheme Code, Operational Features @section Debugging Continuations @@ -2075,9 +2094,9 @@ expressions. @noindent Also as the result of the @samp{CAUTIOUS} flag, both @code{error} and @code{user-interrupt} (invoked by @key{C-c}) are defined to print stack -traces and conclude by calling @code{breakpoint} (@pxref{Breakpoints, , -, slib, SLIB}). This allows the user to interract with SCM as with Lisp -systems. +traces and conclude by calling @code{breakpoint} +(@pxref{Breakpoints, , , slib, SLIB}). This allows the user to +interract with SCM as with Lisp systems. @defun stack-trace Prints information describing the stack of partially evaluated @@ -2086,6 +2105,7 @@ printed and @code{#f} otherwise. See @file{Init@value{SCMVERSION}.scm} for an example of the use of @code{stack-trace}. @end defun + @node Memoized Expressions, Internal State, Errors, Operational Features @section Memoized Expressions @@ -2117,7 +2137,7 @@ For instance, @code{open-input-file} is defined as follows in @example (define (open-input-file str) - (or (open-file str OPEN_READ) + (or (open-file str open_read) (and (procedure? could-not-open) (could-not-open) #f) (error "OPEN-INPUT-FILE couldn't open file " str))) @end example @@ -2254,8 +2274,8 @@ is returned. @end defun @noindent -For other configuration constants and procedures @xref{Configuration, , -, slib, SLIB}. +For other configuration constants and procedures +@xref{Configuration, , , slib, SLIB}. @node Scripting, , Internal State, Operational Features @@ -2533,8 +2553,7 @@ and @end ifset @ifinfo -@ref{Top, , , r5rs, Revised(5) Report on the Algorithmic Language -Scheme}. +@ref{Top, , , r5rs, Revised(5) Report on the Algorithmic Language Scheme}. @end ifinfo All the required features of these specifications are supported. Many of the optional features are supported as well. @@ -2728,6 +2747,7 @@ seconds. @xref{Time and Date, current-time, , slib, SLIB}. @code{current-time} used in @ref{Time and Date, , , slib, SLIB}. @end defun + @node Interrupts, Process Synchronization, Time, The Language @section Interrupts @@ -2908,8 +2928,8 @@ Contain modes strings specifying that a file is to be opened for reading, writing, and both reading and writing respectively. Both input and output functions can be used with io-ports. An end of -file must be read or a file-set-position done on the port between a read -operation and a write operation or vice-versa. +file must be read or a two-argument file-position done on the port +between a read operation and a write operation or vice-versa. @end defvr @defun _ionbf modestr @@ -2965,6 +2985,18 @@ Returns the filename @var{port} was opened with. If @var{port} is not open to a file the result is unspecified. @end defun +@defun file-position port +@defunx file-position port #f +Returns the current position of the character in @var{port} which will +next be read or written. If @var{port} is open to a non-file then +@code{#f} is returned. + +@defunx file-position port k +Sets the current position in @var{port} which will next be read or +written. If successful, @code{#f} is returned. If @var{port} is open +to a non-file, then @code{file-position} returns @code{#f}. +@end defun + @defun port-line port @defunx port-column port If @var{port} is a tracked port, return the current line (column) number, @@ -3094,9 +3126,9 @@ procedures. For an input-only port only elements 3 and 4 need be procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful operation for them to perform. -If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, -eof-object?, ,r5rs, Revised(5) Scheme}) it indicates that the port has -reached end-of-file. For example: +If thunk 3 returns @code{#f} or an @code{eof-object} +(@pxref{Input, eof-object?, ,r5rs, Revised(5) Scheme}) it indicates +that the port has reached end-of-file. For example: If it is necessary to explicitly close the port when it is garbage collected, (@pxref{Interrupts, add-finalizer}). @@ -3117,7 +3149,6 @@ collected, (@pxref{Interrupts, add-finalizer}). @end defun - @node Eval and Load, Lexical Conventions, Files and Ports, The Language @section Eval and Load @@ -3528,7 +3559,6 @@ expansion. @code{defconst} constants should be defined before use. @end defspec - @node Defmacro, Syntax-Rules, Define and Set, Syntax @subsection Defmacro @@ -3758,15 +3788,16 @@ Thus a mutable environment can be treated as both a list and local bindings. @end defspec + @node Syntactic Hooks for Hygienic Macros, , Environment Frames, Syntax @subsection Syntactic Hooks for Hygienic Macros SCM provides a synthetic identifier type for efficient implementation of -hygienic macros (for example, @code{syntax-rules} @pxref{Macros, , , -r5rs, Revised(5) Scheme}) A synthetic identifier may be inserted in -Scheme code by a macro expander in any context where a symbol would -normally be used. Collectively, symbols and synthetic identifiers are -@emph{identifiers}. +hygienic macros (for example, @code{syntax-rules} +@pxref{Macros, , , r5rs, Revised(5) Scheme}) A synthetic identifier +may be inserted in Scheme code by a macro expander in any context +where a symbol would normally be used. Collectively, symbols and +synthetic identifiers are @emph{identifiers}. @defun identifier? obj Returns @code{#t} if @var{obj} is a symbol or a synthetic @@ -3929,6 +3960,7 @@ identifier renamed in the definition environment of the new syntax. both denote the same binding in the usage environment of the new syntax. @end defspec + @node Packages, The Implementation, The Language, Top @chapter Packages @@ -4009,7 +4041,7 @@ will load/link @file{sc2.o} if it exists. The @var{lib1} @dots{} pathnames specify additional libraries which may be needed for object files not produced by the Hobbit compiler. For -instance, crs is linked on Linux by +instance, crs is linked on GNU/Linux by @example (load (in-vicinity (implementation-vicinity) "crs.o") @@ -4027,8 +4059,8 @@ or (require 'turtle-graphics) @ftindex turtle-graphics @end example -And the string regular expression (@pxref{Regular Expression Pattern -Matching}) package is linked by: +And the string regular expression +(@pxref{Regular Expression Pattern Matching}) package is linked by: @example (load (in-vicinity (implementation-vicinity) "rgx") (usr:lib "c")) @@ -4205,6 +4237,7 @@ bash$ ./rscm -lpi.scm -e"(pi (random 200) 5)" bash$ @end example + @node Numeric, Arrays, Dump, Packages @section Numeric @@ -4223,8 +4256,8 @@ The ratio of the circumference to the diameter of a circle. @end defvr @noindent -These procedures augment the standard capabilities in @ref{Numerical -operations, , ,r5rs, Revised(5) Scheme}. +These procedures augment the standard capabilities in +@ref{Numerical operations, , ,r5rs, Revised(5) Scheme}. @defun pi* z @code{(* pi @var{z})} @@ -4282,6 +4315,7 @@ an error if the value which should be returned by a call to @code{real-expt} is not real. @end defun + @node Arrays, Records, Numeric, Packages @section Arrays @@ -4400,8 +4434,8 @@ are equivalent to (and can't be distinguished from) strings. @noindent Unshared uniform boolean 0-based arrays of rank 1 (dimension) are -equivalent to (and can't be distinguished from) @ref{Bit Vectors, -bit-vectors}. +equivalent to (and can't be distinguished from) +@ref{Bit Vectors, bit-vectors}. @example (make-array '#1at() 3) @result{} #*000 @equiv{} @@ -4505,6 +4539,7 @@ if the array element is not an exact integer or if @var{val} is not boolean. @end defun + @node Bit Vectors, Array Mapping, Uniform Array, Arrays @subsection Bit Vectors @@ -4573,9 +4608,9 @@ Same as @code{array:copy!} but guaranteed to copy in row-major order. @end defun @defun array-equal? array0 array1 @dots{} -Returns @code{#t} iff all arguments are arrays with the same shape, the -same type, and have corresponding elements which are either -@code{equal?} or @code{array-equal?}. This function differs from +Returns @code{#t} iff all arguments are arrays with the same shape, +the same type, and have corresponding elements which are either +@code{equal?} or @code{array-equal?}. This function differs from @code{equal?} in that a one dimensional shared array may be @var{array-equal?} but not @var{equal?} to a vector or uniform vector. @end defun @@ -4641,6 +4676,7 @@ A @var{printer} value of #f means use the default printer. Only the default printer will be used when printing error messages. @end defun + @node I/O-Extensions, Posix Extensions, Records, Packages @section I/O-Extensions @@ -4688,19 +4724,6 @@ Last file status change time Returns the process ID of the current process. @end defun -@defun file-position port -Returns the current position of the character in @var{port} which will -next be read or written. If @var{port} is not open to a file the result -is unspecified. -@end defun - -@defun file-set-position port integer -Sets the current position in @var{port} which will next be read or -written. If @var{port} is not open to a file the action of -@code{file-set-position} is unspecified. The result of -@code{file-set-position} is unspecified. -@end defun - @defun try-create-file name modes perms If the file with name @var{name} already exists, return @code{#f}, otherwise try to create and open the file like @code{try-open-file}, @@ -4781,8 +4804,9 @@ Applies @var{proc} only to those filenames for which @defun mkdir path mode The @code{mkdir} function creates a new, empty directory whose name is @var{path}. The integer argument @var{mode} specifies the file -permissions for the new directory. @xref{The Mode Bits for Access -Permission, , , libc, Gnu C Library}, for more information about this. +permissions for the new directory. +@xref{The Mode Bits for Access Permission, , , libc, Gnu C Library}, +for more information about this. @code{mkdir} returns if successful, @code{#f} if not. @end defun @@ -4901,10 +4925,11 @@ invariably uppercase. @code{execl}, @code{execlp}, @code{execv}, @code{execvp}, @code{system}, or @code{open-pipe} (@pxref{Posix Extensions, open-pipe}). -To access environment variables, use @code{getenv} (@pxref{System -Interface, getenv, , slib, SLIB}). +To access environment variables, use @code{getenv} +(@pxref{System Interface, getenv, , slib, SLIB}). @end defun + @node Posix Extensions, Unix Extensions, I/O-Extensions, Packages @section Posix Extensions @@ -4963,8 +4988,8 @@ process's @code{fork} returns 0. @end defun @noindent -For a discussion of @dfn{ID}s @xref{Process Persona, , , GNU C Library, -libc}. +For a discussion of @dfn{ID}s +@xref{Process Persona, , , GNU C Library, libc}. @defun getppid Returns the process ID of the parent of the current process. @@ -5219,6 +5244,7 @@ string containing the file name of termainal device; otherwise @code{#f}. @end defun + @node Unix Extensions, Sequence Comparison, Posix Extensions, Packages @section Unix Extensions @@ -5282,7 +5308,6 @@ writing is done. The value returned is unspecified. @end defun - @node Sequence Comparison, Regular Expression Pattern Matching, Unix Extensions, Packages @section Sequence Comparison @@ -5300,8 +5325,8 @@ These functions are defined in @file{rgx.c} using a POSIX or GNU @dfn{regex} library. If your computer does not support regex, a package is available via ftp from @file{ftp.gnu.org:/pub/gnu/regex-0.12.tar.gz}. For a description of -regular expressions, @xref{syntax, , , regex, "regex" regular expression -matching library}. +regular expressions, +@xref{syntax, , , regex, "regex" regular expression matching library}. @defun regcomp @var{pattern} [@var{flags}] Compile a @dfn{regular expression}. Return a compiled regular @@ -5416,6 +5441,7 @@ to perform one substitution. @end table @end defun + @node Line Editing, Curses, Regular Expression Pattern Matching, Packages @section Line Editing @@ -5424,8 +5450,9 @@ These procedures provide input line editing and recall. @noindent These functions are defined in @file{edline.c} and @file{Iedline.scm} -using the @dfn{editline} or GNU @dfn{readline} (@pxref{Top, , Overview -,readline ,GNU Readline Library}) libraries available from: +using the @dfn{editline} or GNU @dfn{readline} +(@pxref{Top, , Overview ,readline ,GNU Readline Library}) libraries +available from: @itemize @bullet @item @@ -5476,6 +5503,7 @@ input and output ports to an edited line port and returns the previous value of @code{(line-editing)}. @end defun + @node Curses, Sockets, Line Editing, Packages @section Curses @@ -5494,8 +5522,7 @@ A program should call @code{endwin} before exiting or escaping from curses mode temporarily, to do a system call, for example. This routine will restore termio modes, move the cursor to the lower left corner of the screen and reset the terminal into the proper non-visual mode. To -resume after a temporary escape, call @ref{Window Manipulation, -refresh}. +resume after a temporary escape, call @ref{Window Manipulation, refresh}. @end defun @menu @@ -5566,6 +5593,7 @@ ready, wgetch will return an eof-object. If disabled, wgetch will hang until a key is pressed. @end defun + @node Terminal Mode Setting, Window Manipulation, Output Options Setting, Curses @subsection Terminal Mode Setting @@ -5635,6 +5663,7 @@ These routines save and restore the state of the terminal modes. @code{savetty}. @end defun + @node Window Manipulation, Output, Terminal Mode Setting, Curses @subsection Window Manipulation @@ -5712,6 +5741,7 @@ specified is relative to the upper left corner of the window @var{win}, which is (0, 0). @end defun + @node Output, Input, Window Manipulation, Curses @subsection Output @@ -5752,10 +5782,10 @@ This routine copies blanks to every position in the window @var{win}. @end defun @defun wclear win -This routine is like @code{werase}, but it also calls @ref{Output -Options Setting, clearok}, arranging that the screen will be cleared -completely on the next call to @code{refresh} or @code{force-output} for -window @var{win}, and repainted from scratch. +This routine is like @code{werase}, but it also calls +@ref{Output Options Setting, clearok}, arranging that the screen will +be cleared completely on the next call to @code{refresh} or +@code{force-output} for window @var{win}, and repainted from scratch. @end defun @defun wclrtobot win @@ -5802,6 +5832,7 @@ is stdscr and the scrolling region is the entire window, the physical screen will be scrolled at the same time. @end defun + @node Input, Curses Miscellany, Output, Curses @subsection Input @@ -5829,6 +5860,7 @@ A list of the y and x coordinates of the cursor position of the window @var{win} is returned @end defun + @node Curses Miscellany, , Input, Curses @subsection Curses Miscellany @@ -5865,6 +5897,7 @@ displayed in the @kbd{C-x} notation. Printing characters are displayed as is. @end defun + @node Sockets, SCMDB, Curses, Packages @section Sockets @@ -5989,6 +6022,7 @@ between calls to getserv. Otherwise, the table stays open. When called without an argument, the service table is closed. @end defun + @node Internet Addresses and Socket Names, Socket, Host and Other Inquiries, Sockets @subsection Internet Addresses and Socket Names @@ -6125,9 +6159,9 @@ port) if successful, @code{#f} if not. @defun char-ready? listen-socket The input port returned by a successful call to @code{socket:listen} can -be polled for connections by @code{char-ready?} (@pxref{Files and Ports, -char-ready?}). This avoids blocking on connections by -@code{socket:accept}. +be polled for connections by @code{char-ready?} +(@pxref{Files and Ports, char-ready?}). This avoids blocking on +connections by @code{socket:accept}. @end defun @defun socket:accept socket @@ -6184,9 +6218,9 @@ sockets for multiple connections without input blocking. (next (cdr con-list))) (else (for-each (lambda (con) - (file-set-position con 0) + (file-position con 0) (write-char c con) - (file-set-position con 0)) + (file-position con 0)) connections) (cons con (next (cdr con-list))))))) (else (cons con (next (cdr con-list))))))))))))) @@ -6217,9 +6251,9 @@ or you can use a client written in scheme: (ct (and actives (memq (current-input-port) actives) (read-char)))) (cond ((or (eof-object? cs) (eof-object? ct)) (close-port con)) (else (cond (cs (display cs))) - (cond (ct (file-set-position con 0) + (cond (ct (file-position con 0) (display ct con) - (file-set-position con 0))) + (file-position con 0))) (go))))) (cond (con (display "Connecting to ") (display (getpeername con)) @@ -6229,6 +6263,7 @@ or you can use a client written in scheme: (newline))) @end example + @node SCMDB, , Sockets, Packages @section SCMDB @@ -6485,6 +6520,7 @@ A @dfn{CAR Immediate} is an Immediate point which can only occur in the @code{CAR}s of evaluated code (as a result of @code{ceval}'s memoization process). + @node Cells, Header Cells, Immediates, Data Types @subsection Cells @@ -6555,6 +6591,7 @@ Returns the a lower bound on the number of required arguments to closure @end deftp + @node Header Cells, Subr Cells, Cells, Data Types @subsection Header Cells @@ -6691,6 +6728,7 @@ Expands to the length of @var{cclo}. @end defmac @end deftp + @node Subr Cells, Ptob Cells, Header Cells, Data Types @subsection Subr Cells @@ -6767,16 +6805,18 @@ C function of 2 arguments and a list of (rest of) @code{SCM} arguments. C function of list of @code{SCM} arguments. @end deftp + @node Ptob Cells, Smob Cells, Subr Cells, Data Types @subsection Ptob Cells @noindent A @dfn{ptob} is a port object, capable of delivering or accepting @tindex ptob -characters. @xref{Ports, , , r5rs, Revised(5) Report on the Algorithmic -Language Scheme}. Unlike the types described so far, new varieties of -ptobs can be defined dynamically (@pxref{Defining Ptobs}). These are -the initial ptobs: +characters. +@xref{Ports, , , r5rs, Revised(5) Report on the Algorithmic Language Scheme}. +Unlike the types described so far, new varieties of ptobs can be +defined dynamically (@pxref{Defining Ptobs}). These are the initial +ptobs: @deftp ptob tc16_inport input port. @@ -6838,6 +6878,7 @@ Returns non-zero if @var{x} is a port, open port, open input-port, or open output-port, respectively. @end defmac + @node Smob Cells, Data Type Representations, Ptob Cells, Data Types @subsection Smob Cells @@ -7027,6 +7068,7 @@ macro 000000000000000mxxxxxxxxG1111111 ...........SCM name............. array ...short rank..cxxxxxxxxG1111111 ............*array..............} @end format + @node Operations, Program Self-Knowledge, Data Types, The Implementation @section Operations @@ -7110,6 +7152,7 @@ used. This has not been a problem in practice and the advantage of using the c-stack far outweighs it. @end deftypefun + @node Sweeping the Heap, , Marking Cells, Garbage Collection @subsubsection Sweeping the Heap @@ -7132,6 +7175,7 @@ object is freed. If the type header of smob is collected, the smob's @code{free} procedure is called to free its storage. @end deftypefun + @node Memory Management for Environments, Signals, Garbage Collection, Operations @subsection Memory Management for Environments @@ -7246,8 +7290,6 @@ into garbage collection techniques about which a considerable amount of literature is available. - - @node Signals, C Macros, Memory Management for Environments, Operations @subsection Signals @cindex signals @@ -7290,6 +7332,7 @@ that this constraint is satisfied @code{#define CAREFUL_INTS} in @file{scmfig.h}. @end defmac + @node C Macros, Changing Scm, Signals, Operations @subsection C Macros @@ -7559,6 +7602,7 @@ void init_gsubr211() @end example @end defun + @node Defining Smobs, Defining Ptobs, Defining Subrs, Operations @subsection Defining Smobs @@ -7633,6 +7677,7 @@ provide examples of SMOBs. There are a maximum of 256 SMOBs. Smobs that must allocate blocks of memory should use, for example, @code{must_malloc} rather than @code{malloc} @xref{Allocating memory}. + @node Defining Ptobs, Allocating memory, Defining Smobs, Operations @subsection Defining Ptobs @@ -7665,6 +7710,7 @@ for examples of how to define ptobs. Ptobs that must allocate blocks of memory should use, for example, @code{must_malloc} rather than @code{malloc} @xref{Allocating memory}. + @node Allocating memory, Embedding SCM, Defining Ptobs, Operations @subsection Allocating memory SCM maintains a count of bytes allocated using malloc, and calls the @@ -7713,7 +7759,6 @@ instead. @end deftypefun - @node Embedding SCM, Callbacks, Allocating memory, Operations @subsection Embedding SCM @cindex Embedding SCM @@ -7944,8 +7989,8 @@ Loads the Scheme source file @code{(in-vicinity (program-vicinity) This function is useful for compiled code init_ functions to load non-compiled Scheme (source) files. @code{program-vicinity} is the -directory from which the calling code was loaded (@pxref{Vicinity, , , -slib, SLIB}). +directory from which the calling code was loaded +(@pxref{Vicinity, , , slib, SLIB}). @end deftypefun @deftypefun SCM scm_evstr (char *@var{str}) @@ -7980,7 +8025,6 @@ can use a wrapper like this for your Scheme procedures: Calls to procedures so wrapped will return even if an error occurs. - @node Type Conversions, Continuations, Callbacks, Operations @subsection Type Conversions @@ -8071,6 +8115,7 @@ Frees the storage allocated to create @var{argv} by a call to @code{makargvfrmstrs}. @end deftypefun + @node Continuations, Evaluation, Type Conversions, Operations @subsection Continuations @cindex continuations @@ -8079,8 +8124,8 @@ Frees the storage allocated to create @var{argv} by a call to The source files @file{continue.h} and @file{continue.c} are designed to function as an independent resource for programs wishing to use continuations, but without all the rest of the SCM machinery. The -concept of continuations is explained in @ref{Control features, -call-with-current-continuation, , r5rs, Revised(5) Scheme}. +concept of continuations is explained in +@ref{Control features, call-with-current-continuation, , r5rs, Revised(5) Scheme}. @noindent The C constructs @code{jmp_buf}, @code{setjmp}, and @code{longjmp} @@ -8184,6 +8229,7 @@ the saved stack is copied back into it's original position. @end itemize @end deftypefun + @node Evaluation, , Continuations, Operations @subsection Evaluation @@ -8294,6 +8340,7 @@ environment. @code{eval} copies @code{expression} so that memoization does not modify @code{expression}. @end deftypefun + @node Program Self-Knowledge, Improvements To Make, Operations, The Implementation @section Program Self-Knowledge @@ -8435,6 +8482,7 @@ executable file. in any of the directories listed in @code{PATH}. @end deftypefun + @node Script Support, , Executable Pathname, Program Self-Knowledge @subsection Script Support diff --git a/scmfig.h b/scmfig.h index 6013800..969f3ca 100644 --- a/scmfig.h +++ b/scmfig.h @@ -1,4 +1,4 @@ -/* Copyright (C) 1990-1999 Free Software Foundation, Inc. +/* Copyright (C) 1990-2006 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 @@ -417,6 +417,16 @@ rgx.c init_rgx(); regcomp and regexec. */ # define WHITE_SPACES ' ':case '\t':case '\r':case '\f' #endif +#ifdef __ia64__ +# define PTR2INT(x) ((long)(x)) +#else +# ifdef __x86_64 +# define PTR2INT(x) ((long)(x)) +# else +# define PTR2INT(x) ((int)(x)) +# endif +#endif + /* Define BIGDIG to an integer type whose size is smaller than long if you want bignums. BIGRAD is one greater than the biggest BIGDIG. */ /* Define DIGSTOOBIG if the digits equivalent to a long won't fit in a long. */ @@ -765,6 +775,14 @@ typedef SCM *SCMPTR; # include #endif +#ifdef __FreeBSD__ +# include +#endif + +#ifdef linux +# include +#endif + /* On VMS, GNU C's errno.h contains a special hack to get link attributes for errno correct for linking with libc. */ @@ -795,7 +813,7 @@ typedef SCM *SCMPTR; #ifdef _WIN32 // Windows doesn't set errno = EINTR -# define SYSCALL(line) do{ line; while(GetLastError() == ERROR_OPERATION_ABORTED){SetLastError(0);Sleep(10);line};}while(0) +# define SYSCALL(line) do{line;while(GetLastError() == ERROR_OPERATION_ABORTED){SetLastError(0);Sleep(10);line};}while(0) #else # define SYSCALL(line) do{errno = 0;line}while(SCM_INTERRUPTED(errno)) #endif diff --git a/scmhob.h b/scmhob.h index b1480c1..1e8e961 100644 --- a/scmhob.h +++ b/scmhob.h @@ -1,5 +1,5 @@ /* scmhob.h is a header file for scheme source compiled with hobbit5x - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997 Tanel Tammet + Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997 Tanel Tammet 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 @@ -76,9 +76,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. #define BOOLEAN_P(x) ((x)==BOOL_T || (x)==BOOL_F) #define CHAR_P ICHRP -#define SYMBOL_P(x) (ISYMP(x) || (!(IMP(x)) && SYMBOLP(x))) -#define VECTOR_P(x) (!(IMP(x)) && VECTORP(x)) -#define PAIR_P(x) (!(IMP(x)) && CONSP(x)) +#define SYMBOL_P(x) (ISYMP(x) || (!(IMP(x)) && SYMBOLP(x))) +#define VECTOR_P(x) (!(IMP(x)) && VECTORP(x)) +#define PAIR_P(x) (!(IMP(x)) && CONSP(x)) #define NUMBER_P INUMP #define INTEGER_P INUMP #define STRING_P(x) (!(IMP(x)) && STRINGP(x)) diff --git a/script.c b/script.c index da30802..7544284 100644 --- a/script.c +++ b/script.c @@ -224,7 +224,7 @@ char *find_impl_file(exec_path, generic_name, initname, sep) /* Look for initname in peer directories "lib" and "src" in subdirectory with the name of the executable (sans any type extension like .EXE). */ - for(peer="lib";!0;peer="src") { + for (peer="lib";!0;peer="src") { path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L); if (path) { strncpy(path + sepind - 4, peer, 3); @@ -239,7 +239,7 @@ char *find_impl_file(exec_path, generic_name, initname, sep) /* Look for initname in peer directories "lib" and "src" in subdirectory with the generic name. */ - for(peer="lib";!0;peer="src") { + for (peer="lib";!0;peer="src") { path = scm_cat_path(0L, exec_path, sepind); if (path) { strncpy(path + sepind - 4, peer, 3); diff --git a/socket.c b/socket.c index c2d1394..fdbcfa2 100644 --- a/socket.c +++ b/socket.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1994, 1995 Free Software Foundation, Inc. +/* Copyright (C) 1994, 1995, 2006 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 @@ -173,7 +173,7 @@ SCM l_hostinfo(name) ve[ 3] = MAKINUM(entry->h_length + 0L); if (sizeof(struct in_addr) != entry->h_length) {ve[ 4] = BOOL_F; return ans;} - for(argv = entry->h_addr_list; argv[i]; i++); + for (argv = entry->h_addr_list; argv[i]; i++); while (i--) { inad = *(struct in_addr *)argv[i]; lst = cons(ulong2num(ntohl(inad.s_addr)), lst); @@ -535,11 +535,11 @@ int sknm_print(exp, port, writing) lputs("inet-addr ", port); lputs(inet_ntoa(((struct sockaddr_in *)CDR(exp))->sin_addr), port); lputc(':', port); - intprint(0L + ntohs(((struct sockaddr_in *)CDR(exp))->sin_port), 10, port); + scm_intprint(0L + ntohs(((struct sockaddr_in *)CDR(exp))->sin_port), 10, port); break; default: lputs(s_unkfam, port); lputc(' ', port); - intprint(0L+((struct sockaddr *)CDR(exp))->sa_family, 10, port); + scm_intprint(0L+((struct sockaddr *)CDR(exp))->sa_family, 10, port); } lputc('>', port); return !0; diff --git a/subr.c b/subr.c index 1399939..6703d7c 100644 --- a/subr.c +++ b/subr.c @@ -186,7 +186,7 @@ SCM append(args) return res; } ASRTER(CONSP(args), args, ARGn, s_append); - for(;NIMP(arg);arg = CDR(arg)) { + for (;NIMP(arg);arg = CDR(arg)) { ASRTER(CONSP(arg), arg, ARGn, s_append); *lloc = cons(CAR(arg), EOL); lloc = &CDR(*lloc); @@ -199,7 +199,7 @@ SCM reverse(lst) { SCM res = EOL; SCM p = lst; - for(;NIMP(p);p = CDR(p)) { + for (;NIMP(p);p = CDR(p)) { ASRTER(CONSP(p), lst, ARG1, s_reverse); res = cons(CAR(p), res); } @@ -224,7 +224,7 @@ erout: ASRTER(NIMP(lst) && CONSP(lst), SCM memq(x, lst) SCM x, lst; { - for(;NIMP(lst);lst = CDR(lst)) { + for (;NIMP(lst);lst = CDR(lst)) { ASRTER(CONSP(lst), lst, ARG2, s_memq); if (CAR(lst)==x) return lst; } @@ -234,7 +234,7 @@ SCM memq(x, lst) SCM member(x, lst) SCM x, lst; { - for(;NIMP(lst);lst = CDR(lst)) { + for (;NIMP(lst);lst = CDR(lst)) { ASRTER(CONSP(lst), lst, ARG2, s_member); if (NFALSEP(equal(CAR(lst), x))) return lst; } @@ -245,7 +245,7 @@ SCM assq(x, alist) SCM x, alist; { SCM tmp; - for(;NIMP(alist);alist = CDR(alist)) { + for (;NIMP(alist);alist = CDR(alist)) { ASRTER(CONSP(alist), alist, ARG2, s_assq); tmp = CAR(alist); ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq); @@ -258,7 +258,7 @@ SCM assoc(x, alist) SCM x, alist; { SCM tmp; - for(;NIMP(alist);alist = CDR(alist)) { + for (;NIMP(alist);alist = CDR(alist)) { ASRTER(CONSP(alist), alist, ARG2, s_assoc); tmp = CAR(alist); ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc); @@ -933,6 +933,7 @@ static char s_logand[] = "logand", s_lognot[] = "lognot", s_copybit[] = "copy-bit", s_copybitfield[] = "copy-bit-field", s_ash[] = "ash", s_logcount[] = "logcount", + s_bitwise_bit_count[] = "bitwise-bit-count", s_intlength[] = "integer-length", s_bitfield[] = "bit-field", s_bitif[] = "bitwise-if"; @@ -1312,7 +1313,7 @@ SCM scm_copybitfield(to, from, rest) } char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; -SCM scm_logcount(n) +SCM scm_bitwise_bit_count(n) SCM n; { register unsigned long c = 0; @@ -1320,18 +1321,42 @@ SCM scm_logcount(n) #ifdef BIGDIG if (NINUMP(n)) { sizet i; BIGDIG *ds, d; - ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_logcount); - if (BIGSIGN(n)) return scm_logcount(difference(MAKINUM(-1L), n)); + ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_bitwise_bit_count); + if (BIGSIGN(n)) + return scm_lognot(scm_bitwise_bit_count(difference(MAKINUM(-1L), n))); ds = BDIGITS(n); - for(i = NUMDIGS(n); i--; ) - for(d = ds[i]; d; d >>= 4) c += logtab[15 & d]; + for (i = NUMDIGS(n); i--; ) + for (d = ds[i]; d; d >>= 4) c += logtab[15 & d]; + if (BIGSIGN(n)) + return MAKINUM(-1 - c); return MAKINUM(c); } +#else + ASRTER(INUMP(n), n, ARG1, s_bitwise_bit_count); +#endif + if ((nn = INUM(n)) < 0) nn = -1 - nn; + for (; nn; nn >>= 4) c += logtab[15 & nn]; + if (n < 0) + return MAKINUM(-1 - c); + return MAKINUM(c); +} + +SCM scm_logcount(n) + SCM n; +{ + register unsigned long c = 0; + register long nn; +#ifdef BIGDIG + if (NINUMP(n)) { + ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_logcount); + if (BIGSIGN(n)) return scm_bitwise_bit_count(difference(MAKINUM(-1L), n)); + return scm_bitwise_bit_count(n); + } #else ASRTER(INUMP(n), n, ARG1, s_logcount); #endif if ((nn = INUM(n)) < 0) nn = -1 - nn; - for(; nn; nn >>= 4) c += logtab[15 & nn]; + for (; nn; nn >>= 4) c += logtab[15 & nn]; return MAKINUM(c); } @@ -1349,14 +1374,14 @@ SCM scm_intlength(n) if (BIGSIGN(n)) return scm_intlength(difference(MAKINUM(-1L), n)); ds = BDIGITS(n); d = ds[c = NUMDIGS(n)-1]; - for(c *= BITSPERDIG; d; d >>= 4) {c += 4; l = ilentab[15 & d];} + for (c *= BITSPERDIG; d; d >>= 4) {c += 4; l = ilentab[15 & d];} return MAKINUM(c - 4 + l); } #else ASRTER(INUMP(n), n, ARG1, s_intlength); #endif if ((nn = INUM(n)) < 0) nn = -1 - nn; - for(;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];} + for (;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];} return MAKINUM(c - 4 + l); } @@ -1500,7 +1525,7 @@ SCM string(chrs) ASRTER(i >= 0, chrs, ARG1, s_string); res = makstr(i); data = UCHARS(res); - for(;NNULLP(chrs);chrs = CDR(chrs)) { + for (;NNULLP(chrs);chrs = CDR(chrs)) { ASRTER(ICHRP(CAR(chrs)), chrs, ARG1, s_string); *data++ = ICHR(CAR(chrs)); } @@ -1518,7 +1543,7 @@ SCM make_string(k, chr) dst = UCHARS(res); if (!UNBNDP(chr)) { ASRTER(ICHRP(chr), chr, ARG2, s_make_string); - for(i--;i >= 0;i--) dst[i] = ICHR(chr); + for (i--;i >= 0;i--) dst[i] = ICHR(chr); } return res; } @@ -1587,7 +1612,7 @@ SCM st_lessp(s1, s2) if (len>i) i = len; c1 = UCHARS(s1); c2 = UCHARS(s2); - for(i = 0;i0) return BOOL_F; if (c<0) return BOOL_T; @@ -1622,7 +1647,7 @@ SCM stci_lessp(s1, s2) if (len>i) i=len; c1 = UCHARS(s1); c2 = UCHARS(s2); - for(i = 0;i0) return BOOL_F; if (c<0) return BOOL_T; @@ -1664,7 +1689,7 @@ SCM st_append(args) register long i = 0; register SCM l, s; register unsigned char *data; - for(l = args;NIMP(l);) { + for (l = args;NIMP(l);) { ASRTER(CONSP(l), l, ARGn, s_st_append); s = CAR(l); ASRTER(NIMP(s) && STRINGP(s), s, ARGn, s_st_append); @@ -1674,9 +1699,9 @@ SCM st_append(args) ASRTER(NULLP(l), args, ARGn, s_st_append); res = makstr(i); data = UCHARS(res); - for(l = args;NIMP(l);l = CDR(l)) { + for (l = args;NIMP(l);l = CDR(l)) { s = CAR(l); - for(i = 0;i= 0, l, ARG1, s_vector); res = make_vector(MAKINUM(i), UNSPECIFIED); data = VELTS(res); - for(;NIMP(l);l = CDR(l)) *data++ = CAR(l); + for (;NIMP(l);l = CDR(l)) *data++ = CAR(l); return res; } SCM vector_ref(v, k) @@ -2073,7 +2098,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes) } while (--j >= ny); switch (modes) { case 3: /* check that remainder==0 */ - for(j = ny;j && !zds[j-1];--j) ; if (j) return 0; + for (j = ny;j && !zds[j-1];--j) ; if (j) return 0; case 2: /* move quotient down in z */ j = (nx==ny ? nx+2 : nx+1) - ny; for (i = 0;i < j;i++) zds[i] = zds[i+ny]; @@ -2091,7 +2116,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes) if (d) divbigdig(zds, ny, d); } doadj: - for(j = ny;j && !zds[j-1];--j) ; + for (j = ny;j && !zds[j-1];--j) ; if (j * BITSPERDIG <= sizeof(SCM)*CHAR_BIT) if (INUMP(z = big2inum(z, j))) return z; return adjbig(z, j); @@ -2126,6 +2151,7 @@ static iproc subr1s[] = { {s_evenp, evenp}, {s_lognot, scm_lognot}, {s_logcount, scm_logcount}, + {s_bitwise_bit_count, scm_bitwise_bit_count}, {s_intlength, scm_intlength}, {"char?", charp}, {s_ch_alphap, char_alphap}, @@ -2226,7 +2252,7 @@ void init_iprocs(subra, type) iproc *subra; int type; { - for(;subra->string; subra++) + for (;subra->string; subra++) make_subr(subra->string, type, subra->cproc); diff --git a/sys.c b/sys.c index d3243c4..8a24c1c 100644 --- a/sys.c +++ b/sys.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002, 2006 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 @@ -51,7 +51,6 @@ #endif void igc P((const char *what, SCM basecont)); -void lfflush P((SCM port)); /* internal SCM call */ SCM *loc_open_file; /* for open-file callback */ SCM *loc_try_create_file; @@ -352,6 +351,7 @@ SCM del_fil(str) void prinport(exp, port, type) SCM exp; SCM port; char *type; { + int filn = fileno(STREAM(exp)); lputs("#<", port); if (CLOSEDP(exp)) lputs("closed-", port); else { @@ -366,8 +366,11 @@ void prinport(exp, port, type) # ifndef AMIGA # ifndef macintosh # ifndef PLAN9 - if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp)))) - lputs(ttyname(fileno(STREAM(exp))), port); + if (OPENP(exp) && tc16_fport==TYP16(exp) && filn >= 0 && isatty(filn)) { + char *ttyn = ttyname(filn); + if (ttyn) lputs(ttyn, port); + else goto punt; + } else # endif # endif @@ -375,19 +378,20 @@ void prinport(exp, port, type) # endif # endif #endif + punt: { SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED; if (NIMP(s) && STRINGP(s)) - iprin1(s, port, 1); + scm_iprin1(s, port, 1); else if (OPFPORTP(exp)) - intprint((long)fileno(STREAM(exp)), 10, port); + scm_intprint((long)filn, 10, port); else - intprint(CDR(exp), -16, port); + scm_intprint(CDR(exp), -16, port); if (TRACKED & SCM_PORTFLAGS(exp)) { - lputs(" L", port); - intprint(scm_port_table[SCM_PORTNUM(exp)].line, 10, port); - lputs(" C", port); - intprint(scm_port_table[SCM_PORTNUM(exp)].col+0L, 10, port); + lputs(" L", port); + scm_intprint(scm_port_table[SCM_PORTNUM(exp)].line, 10, port); + lputs(" C", port); + scm_intprint(scm_port_table[SCM_PORTNUM(exp)].col+0L, 10, port); } } lputc('>', port); @@ -496,7 +500,7 @@ sizet pwrite(ptr, size, nitems, port) { sizet len = size * nitems; sizet i = 0; - for(;i < len;i++) putc(ptr[i], port); + for (;i < len;i++) putc(ptr[i], port); return len; } # define ffwrite pwrite @@ -521,6 +525,7 @@ static ptobfuns fptob = { fflush, fgetc, fclose}; + ptobfuns pipob = { 0, mark0, @@ -537,6 +542,7 @@ ptobfuns pipob = { #endif fflush, fgetc}; + static ptobfuns stptob = { s_string, markcdr, @@ -695,6 +701,7 @@ static int tc16_sysport; #define SYS_ERRP_SIZE 480 static char errbuf[SYS_ERRP_SIZE]; static sizet errbuf_end = 0; + static sizet syswrite(str, siz, num, p) sizet siz, num; char *str; FILE *p; @@ -709,11 +716,11 @@ static sizet syswrite(str, siz, num, p) errbuf_end = dst; } else { - if (NIMP(cur_outp)) lflush(cur_outp); + /* if (NIMP(cur_errp) && OPOUTPORTP(cur_errp)) lfflush(cur_errp); */ if (errbuf_end > 0) { if (errbuf_end > SYS_ERRP_SIZE) { scm_warn("output buffer", " overflowed", UNDEFINED); - intprint((long)errbuf_end, 10, cur_errp); + scm_intprint((long)errbuf_end, 10, cur_errp); lputs(" chars needed\n", cur_errp); errbuf_end = errbuf_end % SYS_ERRP_SIZE; lfwrite(&errbuf[errbuf_end], 1, @@ -723,7 +730,7 @@ static sizet syswrite(str, siz, num, p) errbuf_end = 0; } num = lfwrite(str, siz, num, cur_errp); - lflush(cur_errp); + /* if (NIMP(cur_errp) && OPOUTPORTP(cur_errp)) lfflush(cur_errp); */ } errno = 0; return num; @@ -741,12 +748,6 @@ static int sysputc(c, p) syswrite(&cc, 1, 1, p); return c; } -static int sysflush(p) - FILE *p; -{ - syswrite(0, 0, 0, p); - return 0; -} static ptobfuns sysptob = { 0, mark0, @@ -756,7 +757,7 @@ static ptobfuns sysptob = { sysputc, sysputs, syswrite, - sysflush, + noop0, noop0, noop0}; @@ -828,7 +829,7 @@ static int safeputc(c, p) static int safeflush(p) safeport *p; { - lflush(p->port); + if (p && NIMP(p->port) && OPOUTPORTP(p->port)) lfflush(p->port); return 0; } static SCM marksafep(ptr) @@ -860,7 +861,7 @@ static int freeprint(exp, port, writing) { if (tc_broken_heart==CAR(exp)) { lputs("#", port); - iprin1(CDR(exp), port, writing); + scm_iprin1(CDR(exp), port, writing); } else { if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) { @@ -868,10 +869,10 @@ static int freeprint(exp, port, writing) } else { lputs("#', port); return !0; @@ -1390,7 +1391,7 @@ SCM sym2vcell(sym) SCM lsym, z; sizet hash = strhash(UCHARS(sym), (sizet)LENGTH(sym), (unsigned long)symhash_dim); - for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { + for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); if (CAR(z)==sym) return z; } @@ -1408,12 +1409,12 @@ SCM intern(name, len) sizet hash = strhash(tmp, i, (unsigned long)symhash_dim); /* printf("intern %s len=%d\n",name,len); fflush(stdout); */ DEFER_INTS; - for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { + for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); z = CAR(z); tmp = UCHARS(z); if (LENGTH(z) != len) goto trynext; - for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; + for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; ALLOW_INTS; return CAR(lsym); trynext: ; @@ -1439,12 +1440,12 @@ SCM sysintern(name, val) register sizet i = len; register unsigned char *tmp = (unsigned char *)name; sizet hash = strhash(tmp, i, (unsigned long)symhash_dim); - for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { + for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); z = CAR(z); tmp = UCHARS(z); if (LENGTH(z) != len) goto trynext; - for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; + for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; lsym = CAR(lsym); if (!UNBNDP(val)) CDR(lsym) = val; else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym))) @@ -1593,11 +1594,11 @@ void stack_report() { STACKITEM stack; lputs(";; stack: 0x", cur_errp); - intprint((long)CONT(rootcont)->stkbse, -16, cur_errp); + scm_intprint((long)CONT(rootcont)->stkbse, -16, cur_errp); lputs(" - 0x", cur_errp); - intprint((long)&stack, -16, cur_errp); + scm_intprint((long)&stack, -16, cur_errp); lputs("; ", cur_errp); - intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp); + scm_intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp); lputs(" bytes\n", cur_errp); } @@ -1813,13 +1814,13 @@ void heap_report() { long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]); lputs("\n; 0x", sys_errp); - intprint((long)hplims[i++], -16, sys_errp); + scm_intprint((long)hplims[i++], -16, sys_errp); lputs(" - 0x", sys_errp); - intprint((long)hplims[i++], -16, sys_errp); + scm_intprint((long)hplims[i++], -16, sys_errp); lputs("; ", sys_errp); - intprint(seg_cells, 10, sys_errp); + scm_intprint(seg_cells, 10, sys_errp); lputs(" cells; ", sys_errp); - intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); + scm_intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); lputs(".kiB", sys_errp); }} } @@ -1967,9 +1968,9 @@ void scm_free_gra(gra) void gra_report1(gra) scm_gra *gra; { - intprint((long)gra->len, -10, cur_errp); + scm_intprint((long)gra->len, -10, cur_errp); lputs(" (of ", cur_errp); - intprint((long)gra->alloclen, -10, cur_errp); + scm_intprint((long)gra->alloclen, -10, cur_errp); lputs(") ", cur_errp); lputs(gra->what, cur_errp); lputs("; ", cur_errp); @@ -2049,7 +2050,7 @@ SCM scm_open_ports() { SCM p, res = EOL; int k; - for(k = scm_port_table_len - 1; k > 0; k--) { + for (k = scm_port_table_len - 1; k > 0; k--) { p = scm_port_table[k].port; if (NIMP(p) && OPPORTP(p)) res = cons(p, res); @@ -2462,7 +2463,7 @@ void free_storage() gc_end(); ALLOW_INTS; /* A really bad idea, but printing does it anyway. */ exit_report(); - lflush(sys_errp); + lfflush(sys_errp); scm_free_gra(&ptobs_gra); lmallocated = mallocated = 0; /* Can't do gc_end() here because it uses ptobs which have been freed */ @@ -2655,7 +2656,7 @@ static void gc_sweep(contin_bad) while (i < hplim_ind) { ptr = CELL_UP(hplims[i++]); seg_cells = CELL_DN(hplims[i++]) - ptr; - for(j = seg_cells; j--; ++ptr) { + for (j = seg_cells; j--; ++ptr) { #ifdef POINTERS_MUNGED scmptr = PTR2SCM(ptr); #endif @@ -2814,7 +2815,7 @@ static void gc_sweep(contin_bad) /* must_free((char *)hplims[i-2], sizeof(cell) * (hplims[i-1] - hplims[i-2])); */ hplims[i-2] = 0; - for(j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j]; + for (j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j]; hplim_ind -= 2; i -= 2; /* need to scan segment just moved. */ nfreelist = freelist; @@ -2976,7 +2977,7 @@ static void sweep_port_table() { int k; /* tmp_errp gets entry 0, so we never clear its flags. */ - for(k = scm_port_table_len - 1; k > 0; k--) { + for (k = scm_port_table_len - 1; k > 0; k--) { if (scm_port_table[k].flags & 1) scm_port_table[k].flags &= (~1L); else { diff --git a/time.c b/time.c index 75bf603..3efa19e 100644 --- a/time.c +++ b/time.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, 2006 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 diff --git a/unif.c b/unif.c index b84e9e3..e65ca21 100644 --- a/unif.c +++ b/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002, 2006 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 @@ -1338,12 +1338,12 @@ SCM lcount(item, seq) w <<= LONG_BIT-1-(ubnd%LONG_BIT); w >>= LONG_BIT-1-(ubnd%LONG_BIT); /* There may be only a partial word. */ while (imin < i--) { - for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; + for (;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; w = VELTS(seq)[i]; if (FALSEP(item)) w = ~w; } w >>= (lbnd%LONG_BIT); - for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; + for (;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; return MAKINUM(cnt); case tc7_smob: ASRTGO(ARRAYP(seq) && 1==ARRAY_NDIM(seq) && 0==enclosed++, badarg2); @@ -1526,7 +1526,7 @@ SCM bit_count(v, kv, obj) k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]); k <<= LONG_BIT-1-((LENGTH(v)-1)%LONG_BIT); while (!0) { - for(;k;k >>= 4) count += cnt_tab[k & 0x0f]; + for (;k;k >>= 4) count += cnt_tab[k & 0x0f]; if (0==i--) return MAKINUM(count); k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]); } @@ -1825,11 +1825,11 @@ static void rapr1(ra, j, k, port, writing) case tc7_smob: if (enclosed++) { ARRAY_BASE(ra) = j; - if (n-- > 0) iprin1(ra, port, writing); + if (n-- > 0) scm_iprin1(ra, port, writing); for (j += inc; n-- > 0; j += inc) { lputc(' ', port); ARRAY_BASE(ra) = j; - iprin1(ra, port, writing); + scm_iprin1(ra, port, writing); } break; } @@ -1858,18 +1858,18 @@ static void rapr1(ra, j, k, port, writing) ra = ARRAY_V(ra); goto tail; default: - if (n-- > 0) iprin1(cvref(ra, j, UNDEFINED), port, writing); + if (n-- > 0) scm_iprin1(cvref(ra, j, UNDEFINED), port, writing); for (j += inc; n-- > 0; j += inc) { lputc(' ', port); - iprin1(cvref(ra, j, UNDEFINED), port, writing); + scm_iprin1(cvref(ra, j, UNDEFINED), port, writing); } break; case tc7_string: - if (n-- > 0) iprin1(MAKICHR(CHARS(ra)[j]), port, writing); + if (n-- > 0) scm_iprin1(MAKICHR(CHARS(ra)[j]), port, writing); if (writing) for (j += inc; n-- > 0; j += inc) { lputc(' ', port); - iprin1(MAKICHR(CHARS(ra)[j]), port, writing); + scm_iprin1(MAKICHR(CHARS(ra)[j]), port, writing); } else for (j += inc; n-- > 0; j += inc) @@ -1877,20 +1877,20 @@ static void rapr1(ra, j, k, port, writing) break; case tc7_VfixN32: if (errjmp_bad) { - ipruk("VfixN32", ra, port); + scm_ipruk("VfixN32", ra, port); break; } - if (n-- > 0) intprint(VELTS(ra)[j], -10, port); + if (n-- > 0) scm_intprint(VELTS(ra)[j], -10, port); for (j += inc; n-- > 0; j += inc) { lputc(' ', port); - intprint(VELTS(ra)[j], -10, port); + scm_intprint(VELTS(ra)[j], -10, port); } break; case tc7_VfixZ32: - if (n-- > 0) intprint(VELTS(ra)[j], 10, port); + if (n-- > 0) scm_intprint(VELTS(ra)[j], 10, port); for (j += inc; n-- > 0; j += inc) { lputc(' ', port); - intprint(VELTS(ra)[j], 10, port); + scm_intprint(VELTS(ra)[j], 10, port); } break; # ifdef FLOATS @@ -1932,7 +1932,7 @@ int raprin1(exp, port, writing) return 1; } else { - intprint(ndim, 10, port); + scm_intprint(ndim, 10, port); goto tail; } } @@ -1940,9 +1940,9 @@ int raprin1(exp, port, writing) if (exp==v) { /* a uve, not an array */ register long i, j, w; lputc('*', port); - for(i = 0;i<(LENGTH(exp))/LONG_BIT;i++) { + for (i = 0;i<(LENGTH(exp))/LONG_BIT;i++) { w = VELTS(exp)[i]; - for(j = LONG_BIT;j;j--) { + for (j = LONG_BIT;j;j--) { lputc(w&1?'1':'0', port); w >>= 1; } @@ -1950,7 +1950,7 @@ int raprin1(exp, port, writing) j = LENGTH(exp)%LONG_BIT; if (j) { w = VELTS(exp)[LENGTH(exp)/LONG_BIT]; - for(;j;j--) { + for (;j;j--) { lputc(w&1?'1':'0', port); w >>= 1; } @@ -1992,7 +1992,7 @@ int raprin1(exp, port, writing) } if ((v != exp) && 0==ARRAY_NDIM(exp)) { lputc(' ', port); - iprin1(aref(exp, EOL), port, writing); + scm_iprin1(aref(exp, EOL), port, writing); } else { lputc('(', port); diff --git a/version.txi b/version.txi index 4f3847d..16a9b55 100644 --- a/version.txi +++ b/version.txi @@ -1,2 +1,2 @@ -@set SCMVERSION 5e3 -@set SCMDATE October 2006 +@set SCMVERSION 5e4 +@set SCMDATE November 2007 diff --git a/x.c b/x.c index e062ba9..0c13a52 100644 --- a/x.c +++ b/x.c @@ -2317,7 +2317,7 @@ static int print_xwindow(exp, f, writing) { lputs(CLOSEDP(exp) ? "#', f); return 1; } @@ -2327,7 +2327,7 @@ static int print_xcursor(exp, f, writing) int writing; { lputs("#', f); return 1; } @@ -2347,7 +2347,7 @@ static int print_xcolormap(exp, f, writing) int writing; { lputs("#', f); return 1; } @@ -2357,8 +2357,8 @@ static int print_xgcontext(exp, f, writing) int writing; { lputs("#gid, 16, f); skimu */ - intprint((long) XGContextFromGC(XGCONTEXT(exp)), 16, f); + /* scm_intprint((long) GCONTEXT(exp)->gid, 16, f); skimu */ + scm_intprint((long) XGContextFromGC(XGCONTEXT(exp)), 16, f); lputc('>', f); return 1; } @@ -2384,13 +2384,13 @@ static int print_xvisual(exp, f, writing) { XVisualInfo *xvi = XVISUALINFO(exp); lputs("#visualid, 16, f); + scm_intprint((long) xvi->visualid, 16, f); lputs(" ", f); lputs(xvisualclass2name(xvi->class), f); lputc(' ', f); - intprint((long) xvi->depth, 10, f); + scm_intprint((long) xvi->depth, 10, f); lputc('x', f); - intprint((long) xvi->colormap_size, 10, f); + scm_intprint((long) xvi->colormap_size, 10, f); lputc('>', f); return 1; } -- cgit v1.2.3