summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorDavid N. Welton <davidw@efn.org>1998-12-11 20:21:49 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commita47af30d2f0e96afcd1f14b1984575c359faa3d6 (patch)
tree2ed08ce2d757f917de7c3c7c04fd7e309f454c83
parentf64b2806c1d66a1341bb8b1491f384169ab1d65f (diff)
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-debian/5c3-5.tar.gz
scm-debian/5c3-5.zip
Import Debian changes 5c3-5debian/5c3-5
scm (5c3-5) frozen unstable; urgency=low * debian/rules chmod +x's bld.scm. Fixes #30521. scm (5c3-4) frozen unstable; urgency=low * Made bld.scm executable. Fixes #29578. scm (5c3-3) frozen unstable; urgency=low * -nw * Fixes #16762. * Fixes #18163. * Fixes #18164. * Fixes #23743. * Fixes #24098. * Fixes #24099. * Fixes #24547. scm (5c3-2) frozen unstable; urgency=low * Re-uploading for slink freeze. scm (5c3-1) unstable; urgency=low * New upstream version.
Diffstat
-rw-r--r--.gdbinit16
-rw-r--r--ANNOUNCE240
-rw-r--r--ChangeLog905
-rw-r--r--Init5c3.scm (renamed from Init.scm)258
-rw-r--r--Link.scm13
-rw-r--r--Macro.scm60
-rw-r--r--Makefile111
-rw-r--r--README23
-rw-r--r--bld.scm59
-rwxr-xr-xbuild59
-rwxr-xr-xbuild.bat2
-rw-r--r--[-rwxr-xr-x]build.scm1551
-rw-r--r--continue.c4
-rw-r--r--continue.h16
-rw-r--r--debian/changelog37
-rw-r--r--debian/control4
-rw-r--r--debian/postrm2
-rw-r--r--debian/require.scm.debian2
-rwxr-xr-xdebian/rules15
-rw-r--r--disarm.scm159
-rw-r--r--dynl.c241
-rw-r--r--eval.c1681
-rw-r--r--gmalloc.c168
-rw-r--r--ioext.c68
-rw-r--r--mkimpcat.scm13
-rw-r--r--patchlvl.h22
-rw-r--r--posix.c43
-rw-r--r--r4rstest.scm68
-rw-r--r--ramap.c33
-rw-r--r--record.c10
-rw-r--r--repl.c498
-rw-r--r--rgx.c16
-rw-r--r--rope.c3
-rw-r--r--scl.c93
-rw-r--r--scm.132
-rw-r--r--scm.c437
-rw-r--r--scm.doc70
-rw-r--r--scm.h198
-rw-r--r--scm.texi482
-rw-r--r--scmfig.h326
-rw-r--r--setjump.h35
-rw-r--r--socket.c30
-rw-r--r--subr.c168
-rw-r--r--sys.c1095
-rw-r--r--time.c329
-rw-r--r--unif.c114
46 files changed, 6968 insertions, 2841 deletions
diff --git a/.gdbinit b/.gdbinit
index 6d39779..343b7f1 100644
--- a/.gdbinit
+++ b/.gdbinit
@@ -64,7 +64,7 @@ define scm
call newline(sys_protects[2]),(void)0
end
-define load
+define lload
if (errjmp_bad)
echo sorry, errjmp_bad\n
else
@@ -94,3 +94,17 @@ end
document cdr
CDR of $
end
+
+define disp
+ call iprin1($arg0, sys_protects[2], 0)
+ echo \n
+end
+
+define writ
+ call iprin1($arg0, sys_protects[2], 1)
+ echo \n
+end
+
+
+
+
diff --git a/ANNOUNCE b/ANNOUNCE
index 770a9cc..102b42c 100644
--- a/ANNOUNCE
+++ b/ANNOUNCE
@@ -1,45 +1,142 @@
-This message announces the availability of Scheme release scm5b3.
-
-New in scm5b3 are:
-
- * mkimpcat.scm: 'hobbit, 'scmhob, and 'build added.
- * Link.scm (compile-file link-named-scm): Fixed. Require of
- strings removed. Tested with Hobbit 5x.
- (scm:object-suffix): changed to ".o"; only used by link-named-scm.
- * patchlvl.h (SCMVERSION): Bumped from 5b2 to 5b3.
- * mkimpcat.scm: modified for new SLIB catalog arrangement.
- * sys.c (gc_sweep): added `contin_bad' argument. When set,
- gc_sweep will warn of any uncollected continuations of non-zero
- length. This should make unexec problems less mysterious.
- * Init.scm (home-vicinity): added. Used to find "ScmInit.scm".
- * unexsunos4.c: added from emacs.
- * unexhp9k800.c: added from emacs. Broken -- doesn't change the
- segment sizes.
- * unexalpha.c: added from emacs.
- * build.scm (build C-libraries): changed horrible `supress-files'
- field to `lib-support'.
- (rebuild-catalog): added. Called by dll and dlls methods.
- * scm.texi (Compiling and Linking Custom Files): Added to describe
- how to use "build.scm" with custom files.
- * Makefile (myscm4 myscm5): now delete slibcat and implcat to keep
- them from getting stale.
- * gmalloc.c: HP-UX B.10.10 A doesn't have getpagesize.h.
- * sys.c (mark_syms): No longer mark the value cell because value
- cells get returned by calls to intern(). This caused a rare GC
- leak which showed up in large programs.
- * scm.h (const): defined to comment for hpux native cc.
-
-Fri Oct 10 00:18:40 1997 Peter E. Davis <pete@media.mit.edu>
-
- * unexhp9k800.c: added HP-UX unexec support.
-
-Sun Sep 28 14:48:10 1997 Radey Shouman <shouman@zianet.com>
-
- * ramap.c (array_imap): Fixed for zero-rank arrays arguments.
+This message announces the availability of Scheme release scm5c3.
+
+New in scm5c3:
+
+ * patchlvl.h (SCMVERSION): Bumped from 5c2 to 5c3.
+ * gmalloc.c: Imported gmalloc.c from emacs 20.2.1.
+ (check_block): (check_frag_blocks): Debugging functions added.
+ * sys.c (scm_protect_temp): Added, is currently, and probably will
+ remain, a noop to force allocation of a SCM temporary on the
+ stack.
+ * scl.c (big2str): Added call to scm_protect_temp.
+ * eval.c (map): (for_each): Added calls to scm_protect_temp.
+ * rgx.c (lregcomp): Added call to scm_protect_temp.
+ * scl.c (big2str): Take address of SCM temporary as gc protection.
+ * dynl.c (l_dyn_link):
+ conditionalized message on verbose. Cleaned up message.
+ * Link.scm (link:link):
+ prepend ./ to non-absolute sun-dl library paths.
+ * scm.texi, scm.doc, scm.1, r4rstest.scm, README, Init5c2.scm, ANNOUNCE:
+ ...-swiss => swissnet
+ * scm.h (verbose): read only macro for scm_verbose.
+ * repl.c (scm_verbose): renamed from verbose.
+ * scmfig.h (VERIFY_INTS): Added macro to print warnings if
+ interrupts are improperly allowed and CAREFUL_INTS is #defined.
+ (VOLATILE): Expands to `volatile' keyword if __STDC__ is #defined.
+ * sys.c (sys_errp): Interrupt safe system output port added.
+ (scm_estk_reset): (must_malloc): (must_realloc): (scm_make_cont):
+ Now should be run with ints deferred, no longer ever allow ints.
+ scm-estk_reset builds a new stack if scm_estk is BOOL_F.
+ * scm.c (process_signals): Modified to print deferred output to
+ sys_errp.
+ * eval.c (SCM_ENV_SAVE): (SCM_ENV_RESTORE): now ENV_SAVE,
+ ENV_RESTORE, local to eval.c
+ (apply): (ceval_1): Ints deferred before call to scm_make_cont,
+ which no longer allows ints.
+ (closure): Now takes the number of required closure arguments as a
+ second argument.
+ (m_lambda): Computes and memoizes the number of required arguments.
+ * repl.c (iprlist): Uses GCCDR so that fatal error messages during
+ gc may print better.
+ (handle_it): Call to scm_egc made conditional on NO_ENV_CACHE.
+ (growth_mon): (gc_start): (gc_end): (heap_report): Now use
+ sys_errp.
+ (ints_warn): Added for interrupt warnings using VERIFY_INTS.
+ (scm_stack_trace): Now completely prints stacks up to 20 deep,
+ rather than 10.
+ (def_err_response): Prints errobj if error is fatal.
+ (lroom): Made subr_1o for easier calling from C.
+ * Init5c2.scm (array-shape): No longer signals an error when
+ passed a non-array -- now returns whatever ARRAY-DIMENSIONS
+ returned (currently #f).
+ * scm.c (scm_proftimer): Also conditional on SIGALRM.
+ * sys.c (init_storage): Fixed initialization of tmp_errp so that
+ it is always correctly aligned.
+ * scm.c (process_signals): Fixed braino in code to search for
+ deferred signals.
+ (scmable_signal): Added POSIX signal unblocking call, conditional
+ on SIG_UNBLOCK, so Scheme signal handlers may be interrupted
+ before they exit.
+ * scm.c (scmable_signal): (err_signal): (init_signals):
+ (ignore_signals):
+ (unignore_signals): (restore_signals): Abstracted signal handling.
+ (fpe_signal): (bus_signal): (segv_signal): (alrm_signal):
+ (prof_signal): Removed.
+ * repl.c (process_signals): Moved to scm.c
+ * sys.c (must_realloc_cell): Now returns void.
+ * scm.c (prof_signal): (scm_proftimer): (ignore_signals):
+ (unignore_signals): Added handler for SIGPROF, raised via call to
+ setitimer (Scheme function PROFILE-TIMER).
+ * repl.c (handle_it): No longer saves scm_env, scm_env_tmp to
+ estk, they are protected by doing ecache gc.
+ (process_signals): Handles SIGPROF.
+ * sys.c (scm_fill_freelist): No longer always does gc.
+ (gc_mark): No longer bashes cdr of `free' cells, handle_it now
+ bashes more selectively.
+ (scm_egc): DEFER/ALLOW_INTS moved to minimize debugging ints_viol
+ messages -- some will still occur.
+ (scm_egc): No longer saves scm_env and scm_env_ptr to estk, they
+ are protected separately. To improve interrupt safety.
+ * unif.c (resizuve): eliminated unused variable `ptr'.
+ * sys.c (freeprint): Now prints cdr of new cell.
+ * repl.c (input_waiting): Now checks return value of select and
+ restarts if interrupted. This was causing CHAR-READY? to return
+ #T when no input was actually readable.
+ * sys.c (scm_egc): (scm_egc_copy_roots): Eliminated extra root
+ argument, made safe because EGC_ROOT is always called with ints
+ deferred.
+ (gc_mark): Check for ecache broken heart during mark -- fatal error.
+ (gc_sweep): Now uses HUGE_LENGTH instead of LENGTH for string
+ termination check.
+ (must_malloc_cell): (must_realloc_cell): Added.
+ (gc_for_alloc): Static function abstracts gc calls for malloc/realloc.
+ * unif.c (make_uve): Removed call to makestr in order to support
+ huge strings.
+ (resizuve): Now uses must_realloc_cell.
+ * subr.c (make_vector): (mkbig): (adjbig): Now use
+ must_malloc_cell, must_realloc_cell.
+ * socket.c (maksknm): Now uses must_malloc_cell.
+ * scm.h (ISYMNUM): Use only 8 bits for number, freeing some bits
+ for other uses.
+ * scl.c (makdbl): Now uses must_malloc_cell.
+ * rgx.c (lrgecomp): Now uses must_malloc_cell.
+ * repl.c (handle_it): Keep pointers to discarded new cells.
+ * record.c (rec_constr1): (init_record): Now use must_malloc_cell.
+ * posix.c (scm_getgroups): Now uses must_malloc_cell.
+ * dynl.c (l_dyn_link): (l_dyn_call): Moved NEWCELL out of deferred
+ ints sections. For dlopen versions, print more error messages.
+ * eval.c (macroexp1): now prints name of unbound variable.
+ (s_unbnd s_wtap): abstracted error message strings.
+ * eval.c (ceval_1): No longer make extra environment frame for
+ LETREC, since internal DEFINE is now rewritten.
+ * sys.c (scm_fill_freelist): added. Assures that at least
+ MIN_GC_YIELD cells are in freelis. This is used before returning
+ from interrupts.
+ * repl.c (handle_it): Discard 2 cells (because of CDR in NEWCELL).
+ Call scm_fill_freelist();
+ * Init5c2.scm: removed DEFINED? conditionals for old SCMs.
+ * sys.c (scm_estk_grow): Now pushes estk ptr, with ints deferred.
+ * eval.c (ENV_PUSH): (ENV_POP): Now done with DEFER_INTS_EGC to
+ prevent problems with interrupt handlers that run Scheme code.
+ * sys.c (scm_estk_grow): Protected critical section with
+ DEFER/ALLOW_INTS
+ (must_malloc): (must_realloc): Protected igc call with
+ DEFER/ALLOW_INTS.
+ (scm_egc): Added DEFER/ALLOW_INTS around call to igc -- prevents
+ interrupts violation message in debug mode.
+ (igc): Now SCM_ENV_SAVE before any gc marking to fix gc bug
+ tickled by running Scheme code from interrupts.
+ (scm_egc): (scm_egc_copy_roots): Now take a single argument, a gc
+ root. Simplifies handling of the case where scm_egc calls igc,
+ and possibly itself.
+ * repl.c (growth_mon): Now prints "shrank" instead of "grew" if
+ the relevant limit decreased.
+ (handle_it): Do env cache gc before applying interrupt
+ handler, to protect data on the estk, which might move.
-=-=-
-Scm conforms to Revised^4 Report on the Algorithmic Language Scheme
+Scm conforms to Revised^5 Report on the Algorithmic Language Scheme
and the IEEE P1178 specification. Scm is written in C and runs under
Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and
similar systems. ASCII and EBCDIC are supported.
@@ -48,84 +145,79 @@ Documentation is included explaining the many Scheme Language
extensions in scm, the internal representations, and how to extend or
include SCM in other programs. Documentation is online at:
- http://www-swiss.ai.mit.edu/~jaffer/SCM.html
+ http://swissnet.ai.mit.edu/~jaffer/SCM.html
SCM can be obtained via FTP (detailed instructions follow) from:
- ftp-swiss.ai.mit.edu:pub/scm/scm5b3.tar.gz
- prep.ai.mit.edu:pub/gnu/jacal/scm5b3.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/imp/scm5b3.tar.gz
+ swissnet.ai.mit.edu:pub/scm/scm5c3.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/scm5c3.tar.gz
SLIB is a portable Scheme library which SCM uses:
- ftp-swiss.ai.mit.edu:pub/scm/slib2c0.tar.gz
- prep.ai.mit.edu:pub/gnu/jacal/slib2c0.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2c0.tar.gz
+ swissnet.ai.mit.edu:pub/scm/slib2c3.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/slib2c3.tar.gz
JACAL is a symbolic math system written in Scheme:
- ftp-swiss.ai.mit.edu:pub/scm/jacal1a7.tar.gz
+ swissnet.ai.mit.edu:pub/scm/jacal1a7.tar.gz
prep.ai.mit.edu:pub/gnu/jacal/jacal1a7.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/code/num/jacal1a7.tar.gz
HOBBIT is a compiler for SCM code:
- ftp-swiss.ai.mit.edu:pub/scm/hobbit4d.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/imp/hobbit4d.tar.gz
+ swissnet.ai.mit.edu:pub/scm/hobbit4d.tar.gz
SLIB-PSD is a portable debugger for Scheme (requires emacs editor):
- ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz
+ swissnet.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz
prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz
SMG-SCM is an SMG interface package which works with SCM on VMS.
- ftp-swiss.ai.mit.edu:pub/scm/smg-scm2a1.zip
+ swissnet.ai.mit.edu:pub/scm/smg-scm2a1.zip
prep.ai.mit.edu:pub/gnu/jacal/smg-scm2a1.zip
- ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/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:
- ftp-swiss.ai.mit.edu:pub/scm/turtlegr.tar.gz
+ swissnet.ai.mit.edu:pub/scm/turtlegr.tar.gz
prep.ai.mit.edu:pub/gnu/jacal/turtlegr.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/turtlegr.tar.gz
XSCM is a X windows interface package which works with SCM:
- ftp-swiss.ai.mit.edu:pub/scm/xscm-2.01.tar.gz
+ swissnet.ai.mit.edu:pub/scm/xscm-2.01.tar.gz
prep.ai.mit.edu:pub/gnu/jacal/xscm-2.01.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/xscm-2.01.tar.gz
MacSCM is a Macintosh applications building package which works with
SCM (similar to XSCM).
- ftp-swiss.ai.mit.edu:pub/scm/macscm.tar.Z
- ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/macscm.tar.gz
+ swissnet.ai.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.
- ftp-swiss.ai.mit.edu:pub/scm/wb1a2.tar.gz
- ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/wb1a2.tar.gz
+ swissnet.ai.mit.edu:pub/scm/wb1a2.tar.gz
+
+SIMSYNCH is a digital logic simulation system written in SCM.
+ swissnet.ai.mit.edu:pub/scm/synch1a2.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/synch1a3.tar.gz
DLD is a C library package allowing SCM to dynamically load object
-files on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation
-(SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST.
+files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation
+(SunOS 4.0), Sequent Symmetry (Dynix), Atari ST, and a.out Linux
+systems.
prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz
#! implements "#!" (POSIX) shell-scripts for MS-DOS batch files.
- ftp-swiss.ai.mit.edu:pub/scm/#!.zip
+ swissnet.ai.mit.edu:pub/scm/#!.zip
-=-=-
- ftp ftp-swiss.ai.mit.edu (anonymous)
+ ftp swissnet.ai.mit.edu (anonymous)
bin
cd pub/scm
- get scm5b3.tar.gz
- get slib2c0.tar.gz
+ get scm5c3.tar.gz
+ get slib2c3.tar.gz
or
ftp prep.ai.mit.edu (anonymous)
bin
cd pub/gnu/jacal
- get scm5b3.tar.gz
- get slib2c0.tar.gz
+ get scm5c3.tar.gz
+ get slib2c3.tar.gz
- `scm5b3.tar.gz' is a gzipped tar file of the C code distribution.
- `slib2c0.tar.gz' is a gzipped tar file of a Scheme Library.
+ `scm5c3.tar.gz' is a gzipped tar file of the C code distribution.
+ `slib2c3.tar.gz' is a gzipped tar file of a Scheme Library.
Files in these directories with the ".gz" suffix are compressed with
patent-free gzip (no relation to zip). The program to uncompress them
@@ -136,8 +228,8 @@ is available from
Remember to use binary mode when transferring the files.
Be sure to get and read the GNU General Public License (COPYING).
-It is included in scm5b3.tar.gz.
+It is included in scm5c3.tar.gz.
I sell IBM PC floppy disk sets with the source files, documentation,
and MS-DOS and i386 MS-DOS executables for $99.00. To order, send
-e-mail to jaffer@ai.mit.edu.
+e-mail to jaffer @ rice-chex.ai.mit.edu.
diff --git a/ChangeLog b/ChangeLog
index 6f847a3..e9e3e19 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,9 +1,908 @@
+Fri Sep 11 17:25:14 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5c2 to 5c3.
+
+1998-09-11 Radey Shouman <Radey_Shouman@splashtech.com>
+
+ * gmalloc.c: Imported gmalloc.c from emacs 20.2.1.
+
+ (check_block): (check_frag_blocks): Debugging functions added.
+
+ * sys.c (scm_protect_temp): Added, is currently, and probably will
+ remain, a noop to force allocation of a SCM temporary on the
+ stack.
+
+ * scl.c (big2str): Added call to scm_protect_temp.
+
+ * eval.c (map): (for_each): Added calls to scm_protect_temp.
+
+ * rgx.c (lregcomp): Added call to scm_protect_temp.
+
+1998-09-04 Radey Shouman <radey@colorage.com>
+
+ * scl.c (big2str): Take address of SCM temporary as gc protection.
+
+1998-09-02 Aubrey Jaffer <jaffer@colorage.com>
+
+ * dynl.c (l_dyn_link):
+ conditionalized message on verbose. Cleaned up message.
+
+ * Link.scm (link:link):
+ prepend ./ to non-absolute sun-dl library paths.
+
+ * scm.texi, scm.doc, scm.1, r4rstest.scm, README, Init5c2.scm, ANNOUNCE:
+ ...-swiss => swissnet
+
+ * scm.h (verbose): read only macro for scm_verbose.
+
+ * repl.c (scm_verbose): renamed from verbose.
+
+1998-08-31 Radey Shouman <Radey_Shouman@splashtech.com>
+
+ * scmfig.h (VERIFY_INTS): Added macro to print warnings if
+ interrupts are improperly allowed and CAREFUL_INTS is #defined.
+
+ (VOLATILE): Expands to `volatile' keyword if __STDC__ is #defined.
+
+ * sys.c (sys_errp): Interrupt safe system output port added.
+ (scm_estk_reset): (must_malloc): (must_realloc): (scm_make_cont):
+ Now should be run with ints deferred, no longer ever allow ints.
+ scm-estk_reset builds a new stack if scm_estk is BOOL_F.
+
+ * scm.c (process_signals): Modified to print deferred output to
+ sys_errp.
+
+ * eval.c (SCM_ENV_SAVE): (SCM_ENV_RESTORE): now ENV_SAVE,
+ ENV_RESTORE, local to eval.c
+ (apply): (ceval_1): Ints deferred before call to scm_make_cont,
+ which no longer allows ints.
+ (closure): Now takes the number of required closure arguments as a
+ second argument.
+ (m_lambda): Computes and memoizes the number of required arguments.
+
+ * repl.c (iprlist): Uses GCCDR so that fatal error messages during
+ gc may print better.
+ (handle_it): Call to scm_egc made conditional on NO_ENV_CACHE.
+ (growth_mon): (gc_start): (gc_end): (heap_report): Now use
+ sys_errp.
+ (ints_warn): Added for interrupt warnings using VERIFY_INTS.
+ (scm_stack_trace): Now completely prints stacks up to 20 deep,
+ rather than 10.
+ (def_err_response): Prints errobj if error is fatal.
+ (lroom): Made subr_1o for easier calling from C.
+
+1998-08-27 Radey Shouman <radey@colorage.com>
+
+ * Init5c2.scm (array-shape): No longer signals an error when
+ passed a non-array -- now returns whatever ARRAY-DIMENSIONS
+ returned (currently #f).
+
+1998-08-26 Aubrey Jaffer <jaffer@colorage.com>
+
+ * scm.c (scm_proftimer): Also conditional on SIGALRM.
+
+1998-08-25 Radey Shouman <radey@colorage.com>
+
+ * sys.c (init_storage): Fixed initialization of tmp_errp so that
+ it is always correctly aligned.
+
+ * scm.c (process_signals): Fixed braino in code to search for
+ deferred signals.
+ (scmable_signal): Added POSIX signal unblocking call, conditional
+ on SIG_UNBLOCK, so Scheme signal handlers may be interrupted
+ before they exit.
+
+1998-08-24 Radey Shouman <radey@colorage.com>
+
+ * scm.c (scmable_signal): (err_signal): (init_signals):
+ (ignore_signals):
+ (unignore_signals): (restore_signals): Abstracted signal handling.
+
+ (fpe_signal): (bus_signal): (segv_signal): (alrm_signal):
+ (prof_signal): Removed.
+
+ * repl.c (process_signals): Moved to scm.c
+
+ * sys.c (must_realloc_cell): Now returns void.
+
+1998-08-20 Radey Shouman <radey@colorage.com>
+
+ * scm.c (prof_signal): (scm_proftimer): (ignore_signals):
+ (unignore_signals): Added handler for SIGPROF, raised via call to
+ setitimer (Scheme function PROFILE-TIMER).
+
+ * repl.c (handle_it): No longer saves scm_env, scm_env_tmp to
+ estk, they are protected by doing ecache gc.
+ (process_signals): Handles SIGPROF.
+
+ * sys.c (scm_fill_freelist): No longer always does gc.
+ (gc_mark): No longer bashes cdr of `free' cells, handle_it now
+ bashes more selectively.
+ (scm_egc): DEFER/ALLOW_INTS moved to minimize debugging ints_viol
+ messages -- some will still occur.
+ (scm_egc): No longer saves scm_env and scm_env_ptr to estk, they
+ are protected separately. To improve interrupt safety.
+
+1998-08-19 Radey Shouman <radey@colorage.com>
+
+ * unif.c (resizuve): eliminated unused variable `ptr'.
+
+ * sys.c (freeprint): Now prints cdr of new cell.
+
+1998-08-18 Radey Shouman <radey@colorage.com>
+
+ * repl.c (input_waiting): Now checks return value of select and
+ restarts if interrupted. This was causing CHAR-READY? to return
+ #T when no input was actually readable.
+
+1998-08-17 Radey Shouman <radey@colorage.com>
+
+ * sys.c (scm_egc): (scm_egc_copy_roots): Eliminated extra root
+ argument, made safe because EGC_ROOT is always called with ints
+ deferred.
+
+ (gc_mark): Check for ecache broken heart during mark -- fatal error.
+
+ (gc_sweep): Now uses HUGE_LENGTH instead of LENGTH for string
+ termination check.
+
+ (must_malloc_cell): (must_realloc_cell): Added.
+
+ (gc_for_alloc): Static function abstracts gc calls for malloc/realloc.
+
+ * unif.c (make_uve): Removed call to makestr in order to support
+ huge strings.
+ (resizuve): Now uses must_realloc_cell.
+
+ * subr.c (make_vector): (mkbig): (adjbig): Now use
+ must_malloc_cell, must_realloc_cell.
+
+ * socket.c (maksknm): Now uses must_malloc_cell.
+
+ * scm.h (ISYMNUM): Use only 8 bits for number, freeing some bits
+ for other uses.
+
+ * scl.c (makdbl): Now uses must_malloc_cell.
+
+ * rgx.c (lrgecomp): Now uses must_malloc_cell.
+
+ * repl.c (handle_it): Keep pointers to discarded new cells.
+
+ * record.c (rec_constr1): (init_record): Now use must_malloc_cell.
+
+ * posix.c (scm_getgroups): Now uses must_malloc_cell.
+
+ * dynl.c (l_dyn_link): (l_dyn_call): Moved NEWCELL out of deferred
+ ints sections. For dlopen versions, print more error messages.
+
+1998-08-17 Aubrey Jaffer <jaffer@colorage.com>
+
+ * eval.c (macroexp1): now prints name of unbound variable.
+ (s_unbnd s_wtap): abstracted error message strings.
+
+1998-08-11 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ceval_1): No longer make extra environment frame for
+ LETREC, since internal DEFINE is now rewritten.
+
+1998-08-10 Aubrey Jaffer <jaffer@colorage.com>
+
+ * sys.c (scm_fill_freelist): added. Assures that at least
+ MIN_GC_YIELD cells are in freelis. This is used before returning
+ from interrupts.
+
+ * repl.c (handle_it): Discard 2 cells (because of CDR in NEWCELL).
+ Call scm_fill_freelist();
+
+1998-08-08 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * Init5c2.scm: removed DEFINED? conditionals for old SCMs.
+
+1998-07-28 Radey Shouman <radey@colorage.com>
+
+ * sys.c (scm_estk_grow): Now pushes estk ptr, with ints deferred.
+
+ * eval.c (ENV_PUSH): (ENV_POP): Now done with DEFER_INTS_EGC to
+ prevent problems with interrupt handlers that run Scheme code.
+
+1998-07-27 Radey Shouman <radey@colorage.com>
+
+ * sys.c (scm_estk_grow): Protected critical section with
+ DEFER/ALLOW_INTS
+
+ (must_malloc): (must_realloc): Protected igc call with
+ DEFER/ALLOW_INTS.
+
+ (scm_egc): Added DEFER/ALLOW_INTS around call to igc -- prevents
+ interrupts violation message in debug mode.
+
+ (igc): Now SCM_ENV_SAVE before any gc marking to fix gc bug
+ tickled by running Scheme code from interrupts.
+
+ (scm_egc): (scm_egc_copy_roots): Now take a single argument, a gc
+ root. Simplifies handling of the case where scm_egc calls igc,
+ and possibly itself.
+
+ * repl.c (growth_mon): Now prints "shrank" instead of "grew" if
+ the relevant limit decreased.
+ (handle_it): Do env cache gc before applying interrupt
+ handler, to protect data on the estk, which might move.
+
+Wed Jul 22 16:36:48 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5c1 to 5c2.
+
+1998-07-22 Radey Shouman <radey@colorage.com>
+
+ * sys.c: Added include of unistd.h for linux.
+ (freeprint): Distinguishes between free cells (on freelist)
+ and new cells.
+ (scm_egc): Check for scm_estk, scm_estk_ptr not consistent.
+
+ *repl.c (ints_viol): Added sense argument again, since there are
+ several meaningful values for ints_disabled.
+ (handle_it): More careful about interrupts when saving estk. *
+
+ *scmfig.h (DEFER_INTS): (ALLOW_INTS): (DEFER_INTS_EGC):
+ (ALLOW_INTS_EGC): ints_viol calls changed.
+
+ * ramap.c (array_for_each): (array_map): Always act as if CCLO is
+ defined, this does no harm, and allows CCLO optimizations for the
+ dynamicly loaded case.
+
+ * posix.c: Added include of unistd.h for linux.
+
+ * eval.c (ident2sym): Now available in Scheme as
+ IDENTIFIER->SYMBOL.
+ (closure): Removed env argument, now uses scm_env and is more careful
+ about interrupts.
+ (env2tree): Now uses DEFER_INTS_EGC.
+
+1998-07-22 Aubrey Jaffer <jaffer@colorage.com>
+
+ * build.scm (read-version): added to read version number from
+ "patchlvl.h".
+ (batch:rebuild-catalog): rebuilds the catalog in implvic (executable's
+ implementation vicinity).
+ (build-params): implinit renamed to implvic.
+ (make-dll-archive): deposits dll-archives in implvic.
+
+ * scm.c (INIT_FILE_NAME): definitions moved to "patchlvl.h".
+
+ * patchlvl.h (INIT_FILE_NAME): moved from "scm.c" so it will be
+ updated automatically.
+
+ * Init.scm: renamed Init5c1.scm. The init file-name will
+ henceforth include the version number.
+
+ * Makefile (new): Added support for Init file renaming (including
+ CVS).
+
+1998-07-17 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ceval_1): Changed IM_SET to make High C happy.
+
+ * scmfig.h: ioext.c: Added STDC_HEADERS #define and #include
+ <unistd.h> for linux. Allows use of the rename() system call,
+ which works for some filesystems that do not allow multiple links
+ (smbfs).
+
+1998-07-16 Aubrey Jaffer <jaffer@colorage.com>
+
+ * repl.c (repl): changed __TURBOC__ flag to __MSDOS__. This
+ enables the cr/lf fix for DJGPP also.
+ (repl): Enabled cr/lf fix for __HIGHC__ also.
+
+1998-07-16 Radey Shouman <radey@colorage.com>
+
+ * eval.c (lookupcar): Second argument now specifies what to check:
+ LOOKUP_UNDEFP for error on undefined, LOOKUP_MACROP for error on
+ keyword. LOOKUP_UNDEFP and LOOKUP_MACROP are #defined only in
+ eval.c. Error is again signalled for undefined symbols at top
+ level.
+
+1998-07-14 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ENV_PUSH): (ENV_POP): Modified for interrupt safety.
+
+ (ceval_1): (apply): (procedurep): (macroexp1): (make_specfun):
+ cclo is now a subtype of tc7_specfun, which also includes
+ tc16_apply and tc16_call_cc, smobs are now never procedures.
+
+ (apply): Added call/cc support, error checking for subr_2o and
+ subr_3 types.
+
+ * sys.c (gc_mark): (gc_sweep): Modified for new specfun, cclo
+ representation.
+
+ (gc): Now does ecache gc if given optional argument.
+
+ * repl.c (iprin1): Modified for new specfun, cclo representation.
+
+ (handle_it): Now saves and restores estk for interrupt safety.
+
+ * ramap.c (array_map): Changed for new cclo representation.
+
+1998-07-10 Radey Shouman <radey@colorage.com>
+
+ * eval.c (macroexp1): Made sure to call unmemocar before
+ throwing error.
+ (ceval_1): ALLOW_INTS_EGC before returning value.
+
+1998-07-09 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ceval_1): Modifications to allow rewriting of interal
+ DEFINE to LETREC: If an ISYM is evaluated in non-tail position the
+ body of which it is the CAR is macro expanded by m_expand_body,
+ which rewrites internal DEFINE.
+
+ (m_expand_body): Added.
+
+ (m_macroexp1): Added argument to control error checking:
+ m_expand_body may speculatively expand forms in the wrong
+ environments. Made argument number checks conditional on
+ RECKLESS.
+
+ (m_body): Added, error checks bodies and inserts the ISYM tokens.
+
+ (m_lambda): (m_letstar): (m_letrec1): (m_letrec): (m_let): Now
+ call m_body.
+
+ (m_cond): (m_case): (m_quote): Modified to avoid destructively changing
+ their argument forms. Since m_expand_body speculatively macro
+ expands forms the process must be reversible.
+
+ (m_ident_eqp): Fixed to use proper environment.
+
+ (renamed_ident): Added DEFER_INTS_EGC.
+
+ Added prototypes for static functions.
+
+1998-07-07 Radey Shouman <radey@colorage.com>
+
+ * eval.c (SPECFUN): Removed -- now the only case.
+ (ceval_1): (m_cont): IM_CONT case removed.
+ (scm_evalatomcar): Added check for tc16_specfun. Made unquoted vector
+ message conditional on RECKLESS.
+
+ * scm.h:
+ * repl.c: IM_CONT removed.
+
+ * sys.c (gc_sweep): Fixed bug in float gc introduced with NUM_HP.
+ (freeprint): Added for debugging.
+
+1998-07-06 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ceval_1): envpp now -1 after estk has been popped,
+ allows better stack tracing.
+
+ * eval.c (ceval_1): Fixed argument number check for closures and
+ made conditional on CAUTIOUS.
+
+ (ceval_1): (evalatomcar): (lookupcar): Moved check for
+ using macro as variable from ceval_1 and evalatomcar to lookupcar.
+
+1998-07-02 Radey Shouman <radey@colorage.com>
+
+ * Init.scm (call-with-current-continuation): Now subr.
+
+ * eval.c (ceval_1): Made CALL-WITH-CURRENT-CONTINUATION an inlined
+ smob, like APPLY. Flushed @CALL-WITH-CURRENT-CONTINUATION.
+
+ ecache allocated lists now no longer passed to apply of asubrs and
+ rpsubrs -- this is not interrupt safe.
+
+ (macroexp1): Added argument number checks for subrs, this gives error
+ messages with unmemoized code.
+
+ * eval.c (ceval_1): Fixed error reporting -- "wrong number of
+ args" was sometimes reported as "wrong type to apply".
+
+ Now pass arglist allocated in ecache for asubrs and rpsubrs with
+ 3+ args.
+
+1998-07-01 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ceval): (ceval_1): (ilookup): (lookupcar): (farlookup):
+ New model of interrupt control for protecting ecache references
+ using DEFER_INTS_EGC, ALLOW_INTS_EGC. These need not be strictly
+ nested, ints are always allowed by ceval_1 before tail-calling a
+ subr.
+ (ceval_1): @apply flushed in favor of a smob denoting apply and
+ understood by the evaluator -- allows ecache allocation of
+ argument lists.
+ (scm_macroexp1): Now checks arity for closures, checking had been
+ broken for non-CAUTIOUS SCM.
+
+ * scmfig.h (DEFER_INTS_EGC): (ALLOW_INTS_EGC): Defined.
+
+ * sys.c (scm_env_cons): (scm_env_cons): (scm_env_cons2):
+ (scm_extend_env): DEFER_INTS replaced with DEFER_INTS_EGC.
+
+ * repl.c (repl_report): At verbose level 3 now reports number of
+ ecache cells migrated and why, also number of ecache garbage
+ collections.
+ (ints_viol): Reports filename and line number of violation, and
+ filename and number of last previous DEFER/ALLOW_INTS.
+
+
+1998-06-23 Radey Shouman <radey@colorage.com>
+
+ * scm.c (int_signal): Now signals error if there is no Scheme
+ handler.
+ (ignore_signals): Changed SIG_IGN to SIG_DFL for SIGINT.
+
+1998-06-22 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ENV_PUSH): Fixed problem introduced during last change:
+ estk was overstepping its bounds.
+
+1998-06-19 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ilookup): (farlookup): (unmemocar): (ceval_1):
+ (id_denote): Wrapped all pointer-chasing of possible ecache cells
+ in DEFER/ALLOW_INTS for safety when interrupt handlers may
+ evaluate Scheme code asynchronously.
+
+ (scm_macroexp1): (m_define): (m_atlet_syntax): Environments now
+ always wrapped when passed to macro expanders.
+
+ (ecache_p): (debug_env_car): (debug_env_cdr): Added for CAREFUL_INTS
+ checking.
+
+ (test_ints): Added when CAREFUL_INTS is defined for checking interrupt
+ safety.
+
+ * repl.c (ints_viol): Now prints file and line number.
+
+1998-06-15 Radey Shouman <radey@colorage.com>
+
+ * scm.h (SCM_ENV_SAVE): (SCM_ENV_RESTORE): Added, to prevent
+ oversights in sys.c.
+
+ * sys.c (scm_env_cons): (scm_env_cons2): Made interrupt safe;
+ return results in global scm_env_tmp, use DEFER/ALLOW_INTS.
+ (scm_extend_env): (scm_env_cons_tmp): Added.
+ (scm_env_acons): Deleted, superseded by scm_extend_env.
+
+ *eval.c (ceval_1): (apply): Replaced and rewrote scm_env_ routines
+ to use new interrupt safe versions. ENV_TMP replaced by
+ scm_env_tmp, it was hard to remember that ENV_TMP might move.
+ CLEAR_ENV_TMP removed since scm_env_tmp will be overwritten almost
+ every time estk is pushed.
+
+1998-06-15 Aubrey Jaffer <jaffer@colorage.com>
+
+ * build.scm (compile-c-files *unknown*): Now uses
+ BATCH:APPLY-CHOP-TO-FIT BATCH:TRY-SYSTEM rather than BATCH-SYSTEM.
+
+1998-06-12 Aubrey Jaffer <jaffer@colorage.com>
+
+ * eval.c (evalatomcar): #ifdef MACRO added around M_IDENTP.
+
+ * Makefile (dist): Added cvs flag command to dist target.
+
+1998-06-12 Radey Shouman <radey@colorage.com>
+
+ * repl.c (scm_execpath): Added ASSERTion to signal error in case
+ malloc fails.
+
+ * subr.c (scm_copybitfield): corrected unsigned declaration of len
+ variable, will now signal errors if END < START.
+ (bigcomp): Changed type of xlen from sizet to long, since
+ it is compared with -1.
+
+1998-06-07 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * Init.scm (string-ci->symbol): added (new in "slib/strcase.scm")
+
+Fri Jun 5 16:01:02 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5c0 to 5c1.
+
+1998-06-05 Aubrey Jaffer <jaffer@colorage.com>
+
+ * ANNOUNCE: Removed ftp.cs.indiana.edu:/pub/scheme-repository/
+ entries because they are no longer being maintained or updated.
+
+1998-06-03 Aubrey Jaffer <jaffer@colorage.com>
+
+ * Makefile (Install): target updated to include more recent *.scm
+ as well as *.sl and *.so files.
+
+ * continue.h (setjump): Using (include <signal.h> and) SIG_UNBLOCK
+ for setjump #defines.
+
+ * scm.c (ignore_signals): SIG_UNBLOCK is a better indicator for
+ sigprocmask() than __USE_POSIX.
+
+1998-06-03 Radey Shouman <radey@colorage.com>
+
+ * unif.c (array_inbp): Deleted unused label badarg:
+
+1998-06-02 Aubrey Jaffer <jaffer@colorage.com>
+
+ * repl.c: SIGHUP_deferred added.
+
+1998-06-02 Radey Shouman <radey@colorage.com>
+
+ * scm.c (ignore_signals): now unblocks signals (mask).
+
+ * ioext.c (i_execv): Now brackets execv[p] with un/ignore_signals().
+
+1998-06-01 Radey Shouman <radey@colorage.com>
+
+ * scm.c (unblock_signals): Deleted. Signal mask problem fixed by
+ of #defining setjump as sigsetjmp, longjump as siglongjmp.
+
+1998-05-30 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * build.scm (batch:rebuild-catalog): rewritten from
+ rebuild-catalog.
+ (default-for-platform): new batch-dialect added.
+ (guess-how): removed. Guessing delayed using
+ default-for-platform.
+
+1998-05-28 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ceval_1): setjmp changed to setjump.
+
+ * continue.h:
+ Changed setjump, longjump to use sigsetjmp, siglongjmp if it
+ looks as though we're POSIX
+
+1998-05-28 Aubrey Jaffer <jaffer@colorage.com>
+
+ * repl.c (handle_it): absorbed wta() call always used with it.
+ (SIGALRM_deferred): renamed from alrm_deferred.
+ (SIGINT_deferred): renamed from sig_deferred.
+ (han_sig han_alarm): collapsed into (new) process_signals().
+
+ * scm.c (alrm_signal int_signal): now call handle_it() directly,
+ instead of through han_sig() and han_alarm().
+
+ * scmfig.h (CHECK_INTS): simplified; deferred_proc when non-zero
+ is address of procedure to call for signal processing (always
+ process_signals()).
+
+ * sys.c (sysintern mksubr): "const" added to declaration of first
+ arguments.
+
+1998-05-27 Aubrey Jaffer <jaffer@colorage.com>
+
+ * repl.c (everr): fixed really broken default vs. dowinds stuff.
+
+ * socket.c (l_accept): moved DEFER_INTS so accept() call won't
+ block.
+
+1998-05-27 Radey Shouman <radey@colorage.com>
+
+ * repl.c: Fixed bug in scm_stack_trace: could have a negative
+ number of stack frames if interrupted at top level.
+
+1998-05-26 Aubrey Jaffer <jaffer@colorage.com>
+
+ * scmfig.h: Metaware __HIGHC__ lacks sbrk (LACK_SBRK).
+
+1998-05-21 Radey Shouman <radey@colorage.com>
+
+ * sys.c (must_realloc): Fixed sense of check on realloc return
+ value in must_realloc.
+
+ * repl.c (scm_ecache_report): Fixed ecache stack report in ROOM.
+
+1998-05-21 Aubrey Jaffer <jaffer@colorage.com>
+
+ * sys.c, scm.h, repl.c: Fixed long vs. int bugs for 16-bit compilers.
+
+ * Init.scm: Made renamed logical operations safe for old executables.
+
+ * scmfig.h: Borland sbrk() is a noop.
+
+ * sys.c: Fixed ECACHEP for Borland C.
+
+ * Init.scm: Removed check for duplicate key values for CASEV (now
+ done by CASE).
+
+ * Init.scm (casev): Removed check for duplicate key values for
+ CASEV (now done by CASE).
+
+1998-05-21 radey <radey@scm.colorage.net>
+
+ * scm.texi: Documented changes to closure format.
+
+ * sys.c: cosmetic changes.
+
+Wed May 20 17:53:52 EDT 1998 Aubrey Jaffer <jaffer@aubrey.jaffer>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5b5 to 5c0.
+
+1998-05-20 Radey Shouman <radey@colorage.com>
+
+ * eval.c: Added check for duplicate key values for CASE.
+
+ * sys.c (scm_egc): Modified scm_egc to prevent a major gc from
+ happening inside an ecache gc -- which was causing environment lossage.
+
+1998-05-20 Aubrey Jaffer <jaffer@colorage.com>
+
+ * Makefile: made check or checklit part of normal build.
+
+ * scm.texi (Evaluation): Added description of FARLOC.
+ (Memory Management for Environments): Added Tom Lord's
+ documentation of ecache.
+
+ * build.scm (build): compile-c-files linux: don't use -O2 when -g
+ is specified.
+
+1998-05-14 Radey Shouman <radey@colorage.com>
+
+ * Init.scm (bit-extract): (logical:bit-field):
+ (logical:bitwise-if): (logical:copy-bit):
+ (logical:copy-bit-field): definitions added for SLIB compatibility.
+
+ * subr.c (scm_bitfield): renamed BIT-EXTRACT to BIT-FIELD,
+ added range check on END.
+ (scm_bitif): (scm_copybitfield): (scm_copybit): added.
+
+1998-05-12 Aubrey Jaffer <jaffer@colorage.com>
+
+ * eval.c (m_case): Added checks for ELSE clause.
+
+ * Init.scm (defconst): added.
+ (casev): added.
+ (print-args): fixed (environment-cache broke).
+
+ * eval.c (env2tree): exported to Scheme as environment->tree.
+
+1998-05-11 Aubrey Jaffer <jaffer@colorage.com>
+
+ * continue.c (dynthrow): Giving up on HPUX stack growth.
+ "growth[] being optimized out" message disabled for HPUX.
+
+ * sys.c (try_open_file): Renamed from open_file.
+ (open_file): Now calls back to Scheme; applies `open-file'.
+
+Fri May 8 17:40:44 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5b4 to 5b5.
+
+1998-05-08 Radey Shouman <radey@colorage.com>
+
+ * eval.c (m_letrec1): added to support tagged environment frames.
+ (m_let, m_letrec, m_lambda, m_do): Now put an ISPCSYM in the last
+ cdr of the names they add to the environment, this is intended for
+ debugging.
+
+1998-05-07 Radey Shouman <radey@colorage.com>
+
+ * repl.c (scm_brk_report): Added.
+ * scm.c (main): set global variables remembering initial brk.
+
+ * eval.c (ceval_1): LETREC now adds extra (empty) environment
+ frame so internal define does not upset memoization.
+ * r4rstest.scm: tests for LETREC/internal DEFINE bug added.
+
+1998-04-22 <radey@colorage.com>
+
+ * repl.c (repl_driver): Added sbrk call just before dumping --
+ fixes problems with linux dumped executables.
+
+1998-04-16 <radey@colorage.com>
+
+ * unif.c (scm_logaref): (scm_logaset): Added.
+
+Thu Apr 9 11:31:20 EDT 1998 Aubrey Jaffer <jaffer@scm.colorage.net>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5b3 to 5b4.
+
+1998-04-08 Aubrey Jaffer <jaffer@colorage.com>
+
+ * sys.c (gc_mark): first column #endif was within comment.
+ (sweep_symhash): was being called by igc -- even with NO_SYM_GC flag.
+
+1998-04-07 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * build.scm (link-c-program highc.31): added -stack 65000.
+
+ * sys.c (gc_mark): added CHECK_STACK;
+
+1998-04-06 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * sys.c (gc_mark): Checks strings and symbols for extra 0 byte.
+ (mark_syms): Added check for extra 0 byte; check strhash() of
+ symbol matches bucket index.
+
+1998-04-06 Aubrey Jaffer <jaffer@colorage.com>
+
+ * unif.c (make_uve): Changed to call makstr for strings. This is
+ so extra byte will be 0.
+
+ * time.c (your_time): PharLap.51 ftime() is non-monotonic. Fix
+ added to assure ftime() never decreases.
+
+1998-04-03 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * Init.scm (apply:nconc-to-last): Changed value to nconc2copy;
+ this allows apply's definition to remain unchanged.
+
+1998-04-03 <radey@colorage.com>
+
+ * rope.c: scm_cell_p now returns true for env cache cells, so they
+ may be printed during debugging.
+
+1998-04-03 Ben Caradoc-Davies <bmcd@physics.otago.ac.nz>
+
+ * sys.c (gc_sweep): If a segment is freed during garbage
+ collection, the heap size counter is adjusted, but the cells
+ collected counter is not. Then when calculating cells allocated,
+ cells in a freed segment are counted twice (negatively).
+
+1998-04-03 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * scm.texi (Low Level Syntactic Hooks): Documented behavior of
+ @apply; turning a former bug into a feature.
+
+1998-04-01 Aubrey Jaffer <jaffer@colorage.com>
+
+ * scl.c (ex2in): changed tc7_cxr floident() to tc7_subr_1 ex2in()
+ so it will handle complex numbers.
+
+1998-04-01 <radey@colorage.com>
+
+ * eval.c (nconc2copy): Added to fix bug in apply that
+ allowed local SET! to mutate lists passed to APPLY.
+ * Init.scm (apply): now uses apply:nconc-to-copy.
+
+1998-03-26 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ilookup): (lookupcar): (farlookup): (ceval): (evalatomcar):
+ (ceval_1): (iqq): (wrapenv): Substantial changes to use
+ copy-collected stack cache intended to reduce time in gc.
+
+ * sys.c (egc_mark): (egc_sweep): (egc_copy): (egc_copy_stack):
+ (egc_copy_roots): (scm_egc): The cache garbage collector.
+ (scm_env_cons): (scm_env_cons2): (scm_env_acons): Functions to
+ allocate storage in the environment cache.
+
+ * repl.c (scm_egc_start): (scm_egc_end): (scm_ecache_report):
+ (scm_stack_trace): Added to support environment cache.
+ stack-trace now does not print all of stacktraces deeper than
+ 10 levels.
+
+1998-03-20 Patrick Lecoanet <lecoanet@cena.dgac.fr>
+
+ * sys.c (igc): Use of NO_SYM_GC flag fixed.
+
+1998-03-20 Aubrey Jaffer <jaffer@colorage.com>
+
+ * eval.c (m_define): "redefining built-in " message now
+ conditional on verbose >= 2.
+ (evalatomcar): unquoted vectors give warning when verbose >= 2.
+ (EVALCELLCAR): Now always uses ATOMP, which catches all non-pair cells.
+
+1998-03-20 Radey Shouman <radey@colorage.com>
+
+ * Macro.scm (macro:compile-syntax-rules): Allows vectors to
+ be used as patterns and templates, per R5RS.
+ * eval.c (unpaint): Unpaints identifiers in quoted vectors.
+
+1998-03-09 Aubrey Jaffer <jaffer@colorage.com>
+
+ * repl.c (dump): made compatible with change to boot-tail
+ * time.c:
+ * scmfig.h: Removed support for HAVE_CONFIG_H.
+
+1998-03-09 Radey Shouman <radey@colorage.com>
+
+ * time.c: I found that SCM on Linux uses ftime(), but that ftime()
+ is implemented in glibc as a call to time(). Linux does support
+ gettimeofday(), which does allow 10 msec resolution. I tried
+ using the definition of ftime() using gettimeofday() at the end of
+ time.c (#ifdef freebsd). It worked like a charm.
+
+1998-03-05 Radey Shouman <radey@colorage.com>
+
+ * Init.scm (boot-tail): added `dumped?' argument.
+ * Init.scm (set-vicinities!): added.
+ * time.c (reset_time): Added to fix user time report for dumped
+ executables -- now reports the time since invocation, rather than
+ the time since dumping.
+ * scm.c (init_scm): Calls reset_time if dumped.
+ * scm.c (scm_find_impl): Wrapper for scm_find_impl_file.
+ * scm.c (find-init-file): added Scheme interface for scm_find_impl.
+
+1998-02-27 Bob Schumaker <cobblers@netcom.com>
+
+ * dynl.c: added Macintosh support.
+
+1998-02-23 Drew Csillag <drew_csillag@geocities.com>
+
+ * scm.c: Port for __CYGWIN32__
+
+1998-02-17 Radey Shouman <radey@colorage.com>
+
+ * Macro.scm (macro:compile-syntax-rules): Fixed to recognize
+ non-identifier literals in patterns.
+
+1998-02-09 <amu@mit.edu>
+
+ * scm.h (CGETUN):
+ * sys.c (noop0): I found two places where SCM uses a possibly
+ signed type for characters in a stream and risks confusing '\377'
+ (a legitimate character) with EOF (-1). This patch addresses this
+ problem, and should make SCM's streams completely 8-bit clean.
+
+1998-02-11 Aubrey Jaffer <jaffer@colorage.com>
+
+ * scm.texi (Index): combined indexes into one node. Added use of
+ @url command.
+
+Mon Jan 12 10:12:20 1998 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * disarm.scm: (require 'disarm) disables opening and modifications
+ of files.
+
+Sun Jan 11 22:52:59 1998 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * posix.c: replaced C definitions of open-input-pipe and
+ open-output-pipe with call to scm_ldstr().
+
+Sat Jan 10 11:54:03 1998 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * Init.scm (read:eval-feature): moved into read:sharp (only use).
+ (read:sharp): now handles `#\.'; moved from lreadr in "repl.c".
+
+Sun Dec 21 19:40:31 1997 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * repl.c (exit_report exit_report): improved.
+ * sys.c (stack_report): improved.
+
+ * scl.c (iint2str): split into two routines. Negative radix
+ argument now forces unsigned conversion.
+
+ * sys.c (alloc_some_heap): heap size variables were confused.
+ heap_cells is now used instead of heap_size.
+
+ * setjump.h (MIN_GC_YIELD NUM_HASH_BUCKETS): moved from scmfig.h.
+
+ * scm.h (THRASH): added.
+
+Mon, 01 Dec 1997 17:56:43 Andreas Menke <asmenke@bln.de>
+
+ * sys.c (must_malloc must_realloc): Bumps up mtrigger if less than
+ 1/8 of malloc space was reclaimed by GC.
+
+Wed Dec 17 22:40:45 1997 Aaron Ucko <amu@mit.edu>
+
+ * rgx.c (lregcomp): There is a small bug in rgx.c; a few things
+ should be set before sending the pattern buffer to
+ re_compile_pattern(). These fields should be set to zero, which
+ means the bug only appers after memory is reused. This only
+ affects use of GNU regex (i.e., only happens with _GNU_SOURCE
+ defined). cf. regex.info for more information.
+
+Wed Dec 17 22:40:45 1997 Aubrey Jaffer <jaffer@ai.mit.edu>
+
+ * sys.c (free_storage): added fflush for stdout and stderr
+ (because those ports don't get closed).
+
+Sun Nov 30 23:21:05 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu>
+
+ * build (build-from-argv): split from "build.scm" so that cgi
+ scripts don't carry getopt baggage.
+
+Thu Nov 20 09:45:28 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu>
+
+ * build.scm (build): suppress-files field restored to C-libraries
+ table. It really is the correct way to deal with "findexec.c".
+
Sun Nov 16 13:43:21 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu>
* mkimpcat.scm: 'hobbit, 'scmhob, and 'build added.
* Link.scm (compile-file link-named-scm): Fixed. Require of
- strings removed. Tested with Hobbit 5x.
+ strings removed. Tested with Hobbit 5x.
(scm:object-suffix): changed to ".o"; only used by link-named-scm.
Sun Nov 2 23:15:57 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu>
@@ -227,8 +1126,8 @@ Fri Mar 7 21:12:17 EST 1997 Aubrey Jaffer <jaffer@scm.bertronics.com>
* patchlvl.h (SCMVERSION): Bumped from 5a0 to 5a1.
Mon Mar 3 20:09:43 1997 Radey Shouman <shouman@zianet.com>
-
- * eval.c (renamed_ident): Renamed RENAME-IDENTIFIER to
+
+ * eval.c (renamed_ident): Renamed RENAME-IDENTIFIER to
RENAMED-IDENTIFIER.
* eval.c (m_case): Avoid renaming data at the head of each
diff --git a/Init.scm b/Init5c3.scm
index 35575e9..4f691ac 100644
--- a/Init.scm
+++ b/Init5c3.scm
@@ -1,15 +1,15 @@
;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
-;;
+;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
-;;
+;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
-;;
+;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
@@ -36,25 +36,15 @@
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
-;; If you do not wish that, delete this exception notice.
+;; If you do not wish that, delete this exception notice.
;;;; "Init.scm", Scheme initialization code for SCM.
;;; Author: Aubrey Jaffer.
(define (scheme-implementation-type) 'SCM)
-(define (scheme-implementation-version) "5b3")
-
-;;; Temporary hack for compatability with older versions.
-(define software-type
- (cond ((eq? 'msdos (software-type))
- (lambda () 'ms-dos))
- (else software-type)))
+(define (scheme-implementation-version) "5c3")
-;;; This definition of PROGRAM-VICINITY is a copy of the definition in
-;;; SLIB/require.scm. It is used here to bootstrap
-;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY.
-
-(define program-vicinity
+(define pathname->vicinity
(let ((*vicinity-suffix*
(case (software-type)
((AMIGA) '(#\: #\/))
@@ -63,19 +53,27 @@
((NOSVE) '(#\: #\.))
((UNIX COHERENT) '(#\/))
((VMS) '(#\: #\])))))
- (lambda ()
- (let loop ((i (- (string-length *load-pathname*) 1)))
+ (lambda (pathname)
+ ;;Go up one level if PATHNAME ends in a vicinity suffix.
+ (let loop ((i (- (string-length pathname) 2)))
(cond ((negative? i) "")
- ((memv (string-ref *load-pathname* i) *vicinity-suffix*)
- (substring *load-pathname* 0 (+ i 1)))
+ ((memv (string-ref pathname i) *vicinity-suffix*)
+ (substring pathname 0 (+ i 1)))
(else (loop (- i 1))))))))
+;;; This definition of PROGRAM-VICINITY is equivalent to the one defined
+;;; SLIB/require.scm. It is used here to bootstrap
+;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY.
+
+(define (program-vicinity)
+ (if *load-pathname*
+ (pathname->vicinity *load-pathname*)
+ (error "not loading but called" 'program-vicinity)))
+
(define in-vicinity string-append)
;;; This is the vicinity where this file resides.
-(define implementation-vicinity
- (let ((vic (program-vicinity)))
- (lambda () vic)))
+(define implementation-vicinity #f)
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
@@ -84,19 +82,48 @@
;;; (implementation-vicinity) as (library-vicinity). "require.scm",
;;; the first file loaded from (library-vicinity), can redirect it.
-(define library-vicinity
- (let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
- (if library-path (lambda () library-path)
- implementation-vicinity)))
-
-(define home-vicinity
- (let ((home (getenv "HOME")))
- (and home
- (case (software-type)
- ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
- (if (not (char=? #\/ (string-ref home (+ -1 (string-length home)))))
- (set! home (string-append home "/"))))))
- (lambda () home)))
+(define library-vicinity #f)
+(define home-vicinity #f)
+(define (set-vicinities!)
+ (set! implementation-vicinity
+ (let ((vic (if *load-pathname* ;Happens when not dumped.
+ (program-vicinity)
+ (let ((path
+ (or (getenv "SCM_INIT_PATH")
+ (find-init-file (execpath #t)))))
+ (if path
+ (pathname->vicinity path)
+ (or (and (procedure? implementation-vicinity)
+ (implementation-vicinity))
+ (error "Can't find SCM_INIT_PATH")))))))
+ (lambda () vic)))
+ (set! library-vicinity
+ (let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
+ (if library-path
+ (lambda () library-path)
+ (lambda ()
+ (let ((olv library-vicinity)
+ (oload load))
+ (dynamic-wind
+ (lambda () (set! load identity))
+ (lambda ()
+ (try-load (in-vicinity (implementation-vicinity)
+ "require.scm")))
+ (lambda () (set! load oload)))
+ (if (eq? olv library-vicinity)
+ (error "Can't find library-vicinity"))
+ (library-vicinity))))))
+ (set! home-vicinity
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (not
+ (char=? #\/
+ (string-ref home (+ -1 (string-length home)))))
+ (set! home (string-append home "/"))))))
+ (lambda () home))))
+(set-vicinities!)
;;; Here for backward compatability
(define scheme-file-suffix
@@ -107,7 +134,7 @@
(set! *features*
(append '(getenv tmpnam abort transcript with-file
ieee-p1178 rev4-report rev4-optional-procedures
- hash object-hash delay eval dynamic-wind
+ hash object-hash delay dynamic-wind
multiarg-apply multiarg/and- logical defmacro
string-port source current-time)
*features*))
@@ -126,20 +153,6 @@
((eof-object? c))
(write-char c)))))
-(define (read:eval-feature exp)
- (cond ((symbol? exp)
- (or (memq exp *features*) (eq? exp (software-type))))
- ((and (pair? exp) (list? exp))
- (case (car exp)
- ((not) (not (read:eval-feature (cadr exp))))
- ((or) (if (null? (cdr exp)) #f
- (or (read:eval-feature (cadr exp))
- (read:eval-feature (cons 'or (cddr exp))))))
- ((and) (if (null? (cdr exp)) #t
- (and (read:eval-feature (cadr exp))
- (read:eval-feature (cons 'and (cddr exp))))))
- (else (error "read:sharp+ invalid expression " exp))))))
-
(define (read:array digit port)
(define chr0 (char->integer #\0))
(let ((rank (let readnum ((val (- (char->integer digit) chr0)))
@@ -168,13 +181,26 @@
(error "read:uniform-vector list not found")))
(define (read:sharp c port)
- (define (barf)
- (error "unknown # object" c))
+ (define (barf) (error "unknown # object" c))
+ (define (feature? exp)
+ (cond ((symbol? exp)
+ (or (memq exp *features*) (eq? exp (software-type))))
+ ((and (pair? exp) (list? exp))
+ (case (car exp)
+ ((not) (not (feature? (cadr exp))))
+ ((or) (if (null? (cdr exp)) #f
+ (or (feature? (cadr exp))
+ (feature? (cons 'or (cddr exp))))))
+ ((and) (if (null? (cdr exp)) #t
+ (and (feature? (cadr exp))
+ (feature? (cons 'and (cddr exp))))))
+ (else (error "read:sharp+ invalid expression " exp))))))
(case c ((#\') (read port))
- ((#\+) (if (read:eval-feature (read port))
+ ((#\.) (eval (read port)))
+ ((#\+) (if (feature? (read port))
(read port)
(begin (read port) (if #f #f))))
- ((#\-) (if (not (read:eval-feature (read port)))
+ ((#\-) (if (not (feature? (read port)))
(read port)
(begin (read port) (if #f #f))))
((#\b) (read:uniform-vector #t port))
@@ -217,36 +243,19 @@
(define >=? >=)
(define t #t)
(define nil #f)
-(cond ((defined? the-macro)
- (define sequence (the-macro begin))
- (set! apply
- (let ((apply:nconc-to-last apply:nconc-to-last)
- (@apply (the-macro @apply)))
- (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
- (define call-with-current-continuation
- (let ((@call-with-current-continuation
- (the-macro @call-with-current-continuation)))
- (lambda (proc) (@call-with-current-continuation proc)))))
- (else
- (define sequence begin)
- (set! apply
- (let ((apply:nconc-to-last apply:nconc-to-last)
- (@apply @apply))
- (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
- (define call-with-current-continuation
- (let ((@call-with-current-continuation
- @call-with-current-continuation))
- (lambda (proc) (@call-with-current-continuation proc))))))
-(if (defined? copy-tree)
- (define @copy-tree copy-tree)
- (define copy-tree @copy-tree))
+(define (identity x) x)
+
+(if (not (defined? the-macro))
+ (define the-macro identity))
+(define sequence (the-macro begin))
+(define copy-tree @copy-tree)
;;; VMS does something strange when output is sent to both
;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
(case (software-type) ((VMS) (set-current-error-port (current-output-port))))
;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
-;;; mode to open files in. MS-DOS does carraige return - newline
+;;; mode to open files in. MS-DOS does carriage return - newline
;;; translation if not opened in `b' mode.
(define OPEN_READ (case (software-type)
@@ -318,9 +327,6 @@
(close-port nport)
ans))
-(if (not (defined? force-output))
- (define (force-output . a) #f))
-
(define (warn . args)
(define cep (current-error-port))
(perror "WARN")
@@ -377,7 +383,7 @@
(begin
(define (ed . args)
(system (apply string-append
- (or (getenv "EDITOR") "ed")
+ (or (getenv "EDITOR") "editor")
(map (lambda (s) (string-append " " s)) args))))
(set! *features* (cons 'ed *features*))))
@@ -396,7 +402,6 @@
(and (> sl sufl)
(string=? (substring str (- sl sufl) sl) suffix))))
-(define (identity x) x)
(define slib:error error)
(define slib:warn warn)
(define slib:tab #\tab)
@@ -466,7 +471,7 @@
(load (in-vicinity (library-vicinity) "require"))
-;;; DO NOT MOVE! This has to be done after "require.scm" is loaded.
+;;; DO NOT MOVE! This must be done after "require.scm" is loaded.
(define slib:load-source scm:load-source)
(define slib:load scm:load)
@@ -484,6 +489,10 @@
(define (string-upcase str) (string-upcase! (string-copy str)))
(define (string-downcase str) (string-downcase! (string-copy str)))
(define (string-capitalize str) (string-capitalize! (string-copy str)))
+(define string-ci->symbol
+ (if (equal? "a" (symbol->string 'a))
+ (lambda (str) (string->symbol (string-downcase str)))
+ (lambda (str) (string->symbol (string-upcase str)))))
(define logical:logand logand)
(define logical:logior logior)
@@ -492,9 +501,14 @@
(define logical:ash ash)
(define logical:logcount logcount)
(define logical:integer-length integer-length)
-(define logical:bit-extract bit-extract)
(define logical:integer-expt integer-expt)
+(define logical:bit-field bit-field)
+(define bit-extract bit-field)
+(define logical:bitwise-if bitwise-if)
+(define logical:copy-bit copy-bit)
+(define logical:copy-bit-field copy-bit-field)
+
(define (logical:ipow-by-squaring x k acc proc)
(cond ((zero? k) acc)
((= 1 k) (proc acc x))
@@ -580,10 +594,36 @@
(defmacro defvar (var val)
`(if (not (defined? ,var)) (define ,var ,val)))
+(defmacro defconst (name value)
+ (cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value)))
+ (else (cond ((not (slib:eval `(defined? ,name))))
+ ((and (symbol? name) (eqv? (slib:eval value)
+ (slib:eval name))))
+ (else (slib:error 'trying-to-defconst name
+ 'to-different-value value)))
+ `(define ,name ,value))))
+(defmacro casev (key . clauses)
+ (let ((clauses
+ (map (lambda (clause)
+ (if (list? (car clause))
+ (cons (apply
+ append
+ (map (lambda (elt)
+ (case elt
+ ((unquote) '(unquote))
+ ((unquote-splicing) '(unquote-splicing))
+ (else
+ (eval (list 'quasiquote (list elt))))))
+ (car clause)))
+ (cdr clause))
+ clause))
+ clauses)))
+ `(case ,key ,@clauses)))
(define print-args
(procedure->syntax
(lambda (sexp env)
+ (set! env (environment->tree env))
(let ((frame (and (not (null? env)) (car env))))
(cond ((not (null? (cdr sexp)))
(display "In")
@@ -660,8 +700,11 @@
(define (list->uniform-vector prot lst)
(list->uniform-array 1 prot lst))
(define (array-shape a)
- (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
- (array-dimensions a)))))
+ (let ((dims (array-dimensions a)))
+ (if (pair? dims)
+ (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+ dims)
+ dims)))))
;;;; Initialize statically linked add-ons
(cond ((defined? scm_init_extensions)
@@ -674,25 +717,33 @@
;;; if it wants to alter the arguments which BOOT-TAIL processes.
(define *argv* #f)
-;;; This loads the user's initialization file, or files named in
-;;; program arguments.
-
-(or (eq? (software-type) 'THINKC)
- (member "-no-init-file" (program-arguments))
- (member "--no-init-file" (program-arguments))
- (try-load (in-vicinity (or (home-vicinity) (user-vicinity))
- (string-append "ScmInit") (scheme-file-suffix)))
- (errno 0))
-
(if (not (defined? *R4RS-macro*))
(define *R4RS-macro* #f))
(if (not (defined? *interactive*))
(define *interactive* #f))
-(define (boot-tail)
- (cond ((not *argv*) (set! *argv* (program-arguments))
- (cond ((provided? 'getopt) (set! *optind* 1)
- (set! *optarg* #f)))))
+(define (boot-tail dumped?)
+ (cond ((not *argv*)
+ (set! *argv* (program-arguments))
+ (cond (dumped?
+ (set-vicinities!)
+ (verbose (if (and (isatty? (current-input-port))
+ (isatty? (current-output-port)))
+ (if (<= (length *argv*) 1) 2 1)
+ 0))))
+ (cond ((provided? 'getopt)
+ (set! *optind* 1)
+ (set! *optarg* #f)))))
+
+;;; This loads the user's initialization file, or files named in
+;;; program arguments.
+ (or (eq? (software-type) 'THINKC)
+ (member "-no-init-file" (program-arguments))
+ (member "--no-init-file" (program-arguments))
+ (try-load (in-vicinity (or (home-vicinity) (user-vicinity))
+ (string-append "ScmInit") (scheme-file-suffix)))
+ (errno 0))
+
(cond
((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
(require 'getopt)
@@ -817,6 +868,7 @@
((#\5) (require 'dynamic-wind)
(require 'values)
(require 'macro)
+ (require 'eval)
(set! *R4RS-macro* #t))
(else (require (string->symbol *optarg*))))
(require (string->symbol *optarg*))))))
@@ -871,7 +923,7 @@ There is no warranty, to the extent permitted by law.
", a Scheme interpreter."
(string-append
"Latest info: "
- "http://www-swiss.ai.mit.edu/~jaffer/"
+ "http://swissnet.ai.mit.edu/~jaffer/"
up-name ".html
"
))
diff --git a/Link.scm b/Link.scm
index a141e54..a60fd02 100644
--- a/Link.scm
+++ b/Link.scm
@@ -68,18 +68,18 @@
(define (compile-file file . args)
(apply hobbit file args)
- (require 'build)
+ (load (in-vicinity (implementation-vicinity) "build"))
(build-from-whole-argv
(list "build" "-tdll"
(string-append "--compiler-options=-I" (implementation-vicinity))
"-c"
- (string-append (descmify file) ".c")
- ;; or (replace-suffix file (scheme-file-suffix) ".c")
+ (begin (require 'glob)
+ (replace-suffix file (scheme-file-suffix) ".c"))
"-hsystem"
)))
(define (link-named-scm name . modules)
- (require 'build)
+ (load (in-vicinity (implementation-vicinity) "build"))
(let* ((iv (implementation-vicinity))
(oss (string-append scm:object-suffix " "))
(command
@@ -107,6 +107,7 @@
(define link:able-suffix
(cond ((provided? 'shl) ".sl")
((provided? 'sun-dl) ".so")
+ ((provided? 'mac-dl) ".shlb")
(else ".o")))
(define link:link
(lambda (file . libs)
@@ -136,6 +137,10 @@
(set! *load-pathname* file)
(set! linkobj (assoc name link:modules))
(cond (linkobj (dyn:unlink (cdr linkobj))))
+ (if (and (provided? 'sun-dl)
+ (> 3 (string-length file))
+ (not (eqv? (string-ref file 0) '#\/)))
+ (set! file (string-append "./" file)))
(set! linkobj (dyn:link file))
(for-each (lambda (lib)
(cond ((dyn:link lib))
diff --git a/Macro.scm b/Macro.scm
index f053b9c..76fc495 100644
--- a/Macro.scm
+++ b/Macro.scm
@@ -1,4 +1,45 @@
-;; Support for R4RS macros.
+;; Copyright (C) 1997, 1998 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Macro.scm", Support for syntax-rules macros.
+;;; Author: Radey Shouman
;;
;; As in SYNTAX-CASE, the identifier ... may be quoted in a
;; SYNTAX-RULES pattern or template as (... ...).
@@ -98,7 +139,13 @@
(recur (cdr pat) vars rank
(lambda (comp2 vars2)
(k (cons comp1 comp2)
- (append2 vars1 vars2)))))))))))
+ (append2 vars1 vars2))))))))
+ ((vector? pat)
+ (recur (vector->list pat) vars rank
+ (lambda (comp vars)
+ (k (list->vector comp) vars))))
+ (else
+ (k pat vars)))))
(define (rewrite-template template vars env-def)
(let recur ((tmpl template)
@@ -146,6 +193,10 @@
(k (cons comp1 comp2)
(append2 ins1 ins2)
(append2 op1 op2))))))))
+ ((vector? tmpl)
+ (recur (vector->list tmpl) rank inserted
+ (lambda (compiled inserted opened)
+ (k (list->vector compiled) inserted opened))))
(else
(k tmpl '() '())))))
@@ -187,6 +238,9 @@
'()))
((pattern-variable? r)
(list (cons r x)))
+ ((vector? r)
+ (and (vector? x)
+ (recur (vector->list r) (vector->list x))))
(else
(and (equal? r x) '())))))
@@ -221,6 +275,8 @@
(if a (cdr a) tmpl)))
((pattern-variable? tmpl)
(@copy-tree (cdr (assq tmpl vars))))
+ ((vector? tmpl)
+ (list->vector (recur (vector->list tmpl) vars)))
(else
tmpl)))))
diff --git a/Makefile b/Makefile
index 8f391f2..46c0ed1 100644
--- a/Makefile
+++ b/Makefile
@@ -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, 1998 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -38,7 +38,7 @@
# whether to permit this exception to apply to your modifications.
# If you do not wish that, delete this exception notice.
-# "Makefile" for scm5b3 Scheme Interpreter
+# "Makefile" for scm5c3 Scheme Interpreter
# Author: Aubrey Jaffer
SHELL = /bin/sh
@@ -47,17 +47,17 @@ CFLAGS = -g
#LIBS =
LD = $(CC) -g
-# directory where COPYING and Init.scm reside.
+# directory where COPYING and Init5c3.scm reside.
#IMPLPATH = /usr/local/src/scm/
#this one is good for bootstrapping
IMPLPATH = `pwd`/
-# Pathname where Init.scm resides.
-IMPLINIT = $(IMPLPATH)Init.scm
+# Pathname where Init5c3.scm resides.
+IMPLINIT = $(IMPLPATH)Init5c3.scm
DFLAG = -DIMPLINIT=\"$(IMPLINIT)\"
-# If pathname where Init.scm resides is not known in advance then
+# If pathname where Init5c3.scm resides is not known in advance then
# SCM_INIT_PATH is the environment variable whose value is the
-# pathname where Init.scm resides.
+# pathname where Init5c3.scm resides.
intro:
@echo
@@ -81,7 +81,7 @@ intro:
@echo
@echo " Once you have built scmlit successfully, test it:"
@echo " make checklit"
- @echo " If this reports no errors, use scmlit to build.scm"
+ @echo " If this reports no errors, use scmlit to build"
@echo " fancier versions of scm, with optional features."
cfiles = scm.c time.c repl.c ioext.c scl.c sys.c eval.c subr.c sc2.c \
@@ -91,11 +91,14 @@ cfiles = scm.c time.c repl.c ioext.c scl.c sys.c eval.c subr.c sc2.c \
ofiles = time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \
continue.o findexec.o script.o
# ramap.o
-ifiles = Init.scm Transcen.scm Link.scm Macro.scm
+ifiles = Init5c3.scm Transcen.scm Link.scm Macro.scm
-all: scmlit
+all:
+ make mydlls
+ make myscm
scmlit: $(ofiles) scm.o
$(LD) -o scmlit $(ofiles) scm.o $(LIBS)
+ make checklit
scm.o: scm.c scm.h scmfig.h patchlvl.h scmflags.h
$(CC) $(CFLAGS) -c $(DFLAG) scm.c
scmflags.h: scmflags
@@ -122,49 +125,51 @@ continue.o: continue.c continue.h setjump.h scmflags.h
srcdir=$(HOME)/scm/
-udscm4: $(cfiles) build.scm
- $(srcdir)build.scm -hsystem -o udscm4 -Fcautious \
+udscm4: $(cfiles) $(hfiles) build.scm build
+ $(srcdir)build -hsystem -o udscm4 -Fcautious \
bignums arrays inexact engineering-notation dump dynamic-linking
-udscm5: $(cfiles) build.scm
- $(srcdir)build.scm -hsystem -o udscm5 -Fcautious \
+udscm5: $(cfiles) $(hfiles) build.scm build
+ $(srcdir)build -hsystem -o udscm5 -Fcautious \
bignums arrays inexact engineering-notation dump dynamic-linking \
- macro
+ macro #-DNO_SYM_GC
myscm4: udscm4 $(ifiles)
-rm slibcat implcat
-mv scm scm~
- ./udscm4 -o scm
+ echo "(quit)" | ./udscm4 -no-init-file -o scm
myscm: udscm5 $(ifiles)
-rm slibcat implcat
-mv scm scm~
- ./udscm5 -r5 -o scm
+ echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm
+ make check
mylib:
- $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \
+ $(srcdir)build -hsystem -Fcautious bignums arrays inexact \
engineering-notation dump dynamic-linking -tlib
pgscm:
- $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \
+ $(srcdir)build -hsystem -Fcautious bignums arrays inexact \
engineering-notation dump dynamic-linking -o udscm \
--compiler-options=-pg --linker-options=-pg
- ./udscm -o pgscm
+ echo "(quit)" | ./udscm -no-init-file -o pgscm
mydebug:
- $(srcdir)build.scm -hsystem -ogdbscm -F cautious \
+ $(srcdir)build -hsystem -oudgdbscm -F cautious \
bignums arrays inexact engineering-notation dump dynamic-linking \
macro \
debug --compiler-options=-Wall --linker-options=-Wall #-DTEST_FARLOC
+ echo "(quit)" | ./udgdbscm -no-init-file -r5 -o gdbscm
mydlls:
- $(srcdir)build.scm -h system -t dll -c sc2.c rgx.c crs.c edline.c \
+ $(srcdir)build -h system -t dll -c sc2.c rgx.c crs.c edline.c \
record.c gsubr.c ioext.c posix.c unix.c socket.c \
ramap.c
myturtle:
- $(srcdir)build.scm -h system -F turtlegr -t dll
+ $(srcdir)build -h system -F turtlegr -t dll
implcat: *.so mkimpcat.scm
./scmlit -lmkimpcat.scm
-checklit: r4rstest.scm
+checklit:
./scmlit -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)'
check: r4rstest.scm
./scm -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)'
@@ -199,11 +204,11 @@ report:
dvidir=../dvi/
dvi: $(dvidir)scm.dvi
$(dvidir)scm.dvi: $(srcdir)scm.texi $(dvidir)scm.fn Makefile
-# cd $(dvidir);texi2dvi $(srcdir)scm.texi
- -(cd $(dvidir);export set TEXINPUTS=$(srcdir):$$TEXINPUTS;texindex scm.??)
- cd $(dvidir);export set TEXINPUTS=$(srcdir):$$TEXINPUTS;tex $(srcdir)scm.texi
+# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)scm.texi
+ -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex scm.??)
+ cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi
$(dvidir)scm.fn:
- cd $(dvidir);tex $(srcdir)scm.texi
+ cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi
xdvi: $(dvidir)scm.dvi
xdvi -s 6 $(dvidir)scm.dvi
htmldir=../public_html/
@@ -226,6 +231,7 @@ includedir = $(prefix)include/
info: $(infodir)/scm.info
$(infodir)/scm.info: scm.texi
makeinfo scm.texi -o $(infodir)/scm.info
+ install-info $(infodir)/scm.info $(infodir)/dir
-rm $(infodir)/scm.info*.gz
infoz: $(infodir)/scm.info.gz
@@ -236,13 +242,11 @@ install: scm.1
test -d $(bindir) || mkdir $(bindir)
test -d $(man1dir) || mkdir $(man1dir)
-cp scm $(bindir)
- -strip $(bindir)scm
+# -strip $(bindir)scm
-cp scm.1 $(man1dir)
test -d $(IMPLPATH) || mkdir $(IMPLPATH)
- -cp Init.scm $(IMPLPATH)
- -cp Link.scm $(IMPLPATH)
- -cp Transcen.scm $(IMPLPATH)
- -cp COPYING $(IMPLPATH)
+ -cp Init5c3.scm Link.scm Transcen.scm Macro.scm COPYING $(IMPLPATH)
+ -cp mkimpcat.scm Iedline.scm *.sl *.so $(IMPLPATH)
installlib:
test -d $(includedir) || mkdir $(includedir)
@@ -257,7 +261,7 @@ uninstall:
-rm $(includedir)scm.h
-rm $(includedir)scmfig.h
-rm $(libdir)libscm.a
-# -rm $(IMPLPATH)Init.scm
+# -rm $(IMPLPATH)Init5c3.scm
# -rm $(IMPLPATH)Link.scm
# -rm $(IMPLPATH)Transcen.scm
# -rm $(IMPLPATH)COPYING
@@ -267,7 +271,7 @@ scm.doc: scm.1
#### Stuff for maintaining SCM below ####
-VERSION = 5b3
+include patchlvl.h
ver = $(VERSION)
RM_R = rm -rf
ufiles = pre-crt0.c ecrt0.c gmalloc.c unexec.c unexelf.c unexhp9k800.c \
@@ -285,7 +289,7 @@ hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h
tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm
dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \
scm.texi ChangeLog
-mfiles = Makefile build.scm build.bat .gdbinit mkimpcat.scm
+mfiles = Makefile build.scm build build.bat .gdbinit mkimpcat.scm disarm.scm
vfiles = setjump.mar setjump.s
afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \
$(vfiles) $(ufiles)
@@ -299,9 +303,17 @@ temp/scm: $(afiles)
mkdir temp/scm
ln $(afiles) temp/scm
+release: dist
+ rsync -v $(htmldir)SCM.html martigny.ai.mit.edu:public_html/
+ rsync -v $(dest)README $(dest)scm$(VERSION).tar.gz martigny.ai.mit.edu:dist/
+ upload $(dest)README $(dest)scm$(VERSION).tar.gz prep.ai.mit.edu:gnu/jacal/
+upzip: $(HOME)/pub/scm.zip
+ rsync -v $(HOME)/pub/scm.zip martigny.ai.mit.edu:pub/
+
dist: $(dest)scm$(VERSION).tar.gz
$(dest)scm$(VERSION).tar.gz: temp/scm
$(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) tar.gz
+ cvs tag -F scm$(VERSION)
shar: scm.shar
scm.shar: temp/scm
$(makedev) PROD=scm shar
@@ -318,7 +330,8 @@ scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm require.scm
cd ..; zip -9ur $(dest)scm$(VERSION).zip \
scm/turtle scm/turtlegr.c scm/grtest.scm scm/require.scm
mv $(dest)scm$(VERSION).zip /c/scm/dist/
-pubzip: temp/scm
+pubzip: $(HOME)/pub/scm.zip
+$(HOME)/pub/scm.zip: temp/scm
$(makedev) DEST=$(HOME)/pub/ PROD=scm zip
diffs: pubdiffs
@@ -330,6 +343,7 @@ distdiffs: temp/scm
HOBBITVERSION = 4d
hobfiles = README.hob hobbit.doc hobbit.tms hobbit.scm scmhob.h
+#hobfiles = hobbit.doc COPYING Makefile.hob hobbit.scm scmhob.h scmhob.scm
hobtemp/scm: $(hobfiles)
-$(RM_R) hobtemp
@@ -355,13 +369,24 @@ new:
mv -f change ChangeLog
$(CHPAT) scm$(VERSION) scm$(ver) ANNOUNCE ../jacal/ANNOUNCE \
../wb/README ../wb/ANNOUNCE \
- ../public_html/README.html ../dist/README \
- ../public_html/SLIB.html ../public_html/JACAL.html \
- ../public_html/SCM.html ../public_html/Hobbit.html \
+ $(htmldir)README.html ../dist/README \
+ $(htmldir)SLIB.html $(htmldir)JACAL.html \
+ $(htmldir)SCM.html $(htmldir)Hobbit.html \
+ $(htmldir)SIMSYNCH.html \
/c/scm/dist/install.bat /c/scm/dist/makefile \
/c/scm/dist/mkdisk.bat README
+ mv -f Init$(VERSION).scm Init$(ver).scm
$(CHPAT) $(VERSION) $(ver) scm.texi patchlvl.h \
- Init.scm ../public_html/SCM.html Makefile
+ Init$(ver).scm $(htmldir)SCM.html Makefile
+ cvs remove Init$(VERSION).scm
+ cvs add Init$(ver).scm
+ cvs commit -m 'Init$(VERSION).scm changed to Init$(ver).scm' \
+ Init$(VERSION).scm Init$(ver).scm
+ cvs commit -m '(SCMVERSION): Bumped from $(VERSION) to $(ver).'
+ cvs tag -F scm$(ver)
+ if [ -L Init.scm ]; then rm -f Init.scm; else \
+ mv -f Init.scm Init.scm~; fi
+ ln -s Init$(ver).scm Init.scm
configtemp/scm: $(confiles)
-$(RM_R) configtemp/scm
@@ -405,9 +430,9 @@ ctags: $(hfiles) $(cfiles)
etags $(hfiles) $(cfiles)
TAGS:
tags: $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\
- hobbit.scm scm.texi README build.scm # $(mfiles) ChangeLog
+ scm.texi README build.scm # $(mfiles) ChangeLog hobbit.scm
etags $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\
- hobbit.scm scm.texi README build.scm # $(mfiles) ChangeLog
+ scm.texi README build.scm # $(mfiles) ChangeLog hobbit.scm
mostlyclean:
clean:
-rm -f core a.out ramap.o ramap.obj $(ofiles) scm.o lints
diff --git a/README b/README
index bcd7d8b..45697b4 100644
--- a/README
+++ b/README
@@ -1,5 +1,5 @@
-This directory contains the distribution of scm5b3. Scm conforms to
-Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178
+This directory contains the distribution of scm5c3. Scm conforms to
+Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178
specification. Scm runs under VMS, MS-DOS, OS2, MacOS, Amiga,
Atari-ST, NOS/VE, Unix and similar systems.
@@ -39,13 +39,14 @@ The author can be reached at <jaffer@ai.mit.edu>
new SCM executables, libraries, and dlls.
`build.bat' invokes build.scm on MS-DOS platforms.
`mkimpcat.scm' build SCM-specific catalog for SLIB.
+ `disarm.scm' disables file opening and modifications.
`.gdbinit' provides commands for debugging SCM with GDB.
`setjump.mar' provides setjump and longjump which do not use $unwind
utility on VMS.
`ugsetjump.s' provides setjump and longjump which work on Ultrix VAX.
`setjump.s' provides setjump and longjump for the Cray YMP.
- `Init.scm' is Scheme initialization code.
+ `Init5c2.scm' is Scheme initialization code.
`Transcen.scm' has Scheme code for inexact builtin procedures.
`Link.scm' has Scheme code for compiling and dynamic linking.
`scmfig.h' is a C include file containing system dependent definitions.
@@ -94,12 +95,12 @@ 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:
- * ftp-swiss.ai.mit.edu:pub/scm/slib2c0.tar.gz
- * prep.ai.mit.edu:pub/gnu/jacal/slib2c0.tar.gz
- * ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c0.tar.gz
- * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c0.tar.gz
+ * swissnet.ai.mit.edu:pub/scm/slib2c3.tar.gz
+ * prep.ai.mit.edu:pub/gnu/jacal/slib2c3.tar.gz
+ * ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c3.tar.gz
+ * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c3.tar.gz
-Unpack SLIB (`tar xzf slib2c0.tar.gz' or `unzip -ao slib2c0.zip') in an
+Unpack SLIB (`tar xzf slib2c3.tar.gz' or `unzip -ao slib2c3.zip') in an
appropriate directory for your system; both `tar' and `unzip' will
create the directory `slib'.
@@ -129,12 +130,12 @@ overrides `require.scm'. Again, absolute pathnames are recommended.
MAKING SCM
- The SCM distribution has "Makefile" which contains rules for making
+The SCM distribution has "Makefile" which contains rules for making
"scmlit", a "bare-bones" version of SCM sufficient for running
`build.scm'. `build.scm' is used to compile (or create scripts to
compile) full featured versions.
- Makefiles are not portable to the majority of platforms. If
+Makefiles are not portable to the majority of platforms. If
`Makefile' works for you, good; If not, I don't want to hear about it.
If you need to compile SCM without build.scm, there are several ways to
proceed:
@@ -162,7 +163,7 @@ proceed:
Making SCM with Think C 4.0 or 4.1
-Note: These instructions need to be uptdated for scm5b3. If Think C
+Note: These instructions need to be uptdated for scm5c3. If Think C
can be called using system(), then SCM can be built using build.scm.
Edit Scmfig.H to set desired options and IMPLINIT.
diff --git a/bld.scm b/bld.scm
new file mode 100644
index 0000000..b12ecb9
--- /dev/null
+++ b/bld.scm
@@ -0,0 +1,59 @@
+#!/bin/sh
+:;exec ./scmlit -f $0 -e"(bi)" build $*
+
+(require 'build)
+(require 'getopt)
+(require 'getopt-parameters)
+
+(define (build-from-argv argv)
+ (cond ((string? argv)
+ (require 'read-command)
+ (set! argv (call-with-input-string argv read-command))))
+ (let ()
+ (define command (string->symbol (list-ref argv *optind*)))
+ (define argc (length argv))
+ (cond
+ ((pair? argv)
+ (set! *optind* (+ 1 *optind*))
+ ((make-command-server build '*commands*)
+ command
+ (lambda (comname comval options positions arities types
+ defaulters checks aliases)
+ (let* ((params (getopt->parameter-list
+ argc argv options arities types aliases))
+ (fparams (fill-empty-parameters defaulters params)))
+ (cond ((not (list? params)) #f)
+ ((not (check-parameters checks fparams)) #f)
+ ((not (check-arities (map arity->arity-spec arities) fparams))
+ (slib:error 'build-from-argv "arity error" fparams) #f)
+ (else (comval fparams))))))))))
+
+(define (build-from-whole-argv argv)
+ (set! *optind* 0)
+ (set! *optarg* #f)
+ (build-from-argv argv))
+
+(define b build-from-whole-argv)
+
+(define (b*)
+ (require 'read-command)
+ (do ((e (read-command) (read-command)))
+ ((eof-object? e))
+ (cond ((null? e))
+ (else
+ (cond ((not (string-ci=? (car e) "build"))
+ (set! e (cons "build" e))))
+ (write (build-from-whole-argv e))
+ (newline)))
+ (display "build> ")
+ (force-output)))
+
+(define (bi) (build-from-argv *argv*))
+
+(cond (*interactive*
+ (display "type (b \"build <command-line>\") to build") (newline)
+ (display "type (b*) to enter build command loop") (newline)))
+
+;;; Local Variables:
+;;; mode:scheme
+;;; End:
diff --git a/build b/build
new file mode 100755
index 0000000..6392f65
--- /dev/null
+++ b/build
@@ -0,0 +1,59 @@
+#!/bin/sh
+:;exec scmlit -f $0 -e"(bi)" build $*
+
+(require 'build)
+(require 'getopt)
+(require 'getopt-parameters)
+
+(define (build-from-argv argv)
+ (cond ((string? argv)
+ (require 'read-command)
+ (set! argv (call-with-input-string argv read-command))))
+ (let ()
+ (define command (string->symbol (list-ref argv *optind*)))
+ (define argc (length argv))
+ (cond
+ ((pair? argv)
+ (set! *optind* (+ 1 *optind*))
+ ((make-command-server build '*commands*)
+ command
+ (lambda (comname comval options positions arities types
+ defaulters checks aliases)
+ (let* ((params (getopt->parameter-list
+ argc argv options arities types aliases))
+ (fparams (fill-empty-parameters defaulters params)))
+ (cond ((not (list? params)) #f)
+ ((not (check-parameters checks fparams)) #f)
+ ((not (check-arities (map arity->arity-spec arities) fparams))
+ (slib:error 'build-from-argv "arity error" fparams) #f)
+ (else (comval fparams))))))))))
+
+(define (build-from-whole-argv argv)
+ (set! *optind* 0)
+ (set! *optarg* #f)
+ (build-from-argv argv))
+
+(define b build-from-whole-argv)
+
+(define (b*)
+ (require 'read-command)
+ (do ((e (read-command) (read-command)))
+ ((eof-object? e))
+ (cond ((null? e))
+ (else
+ (cond ((not (string-ci=? (car e) "build"))
+ (set! e (cons "build" e))))
+ (write (build-from-whole-argv e))
+ (newline)))
+ (display "build> ")
+ (force-output)))
+
+(define (bi) (build-from-argv *argv*))
+
+(cond (*interactive*
+ (display "type (b \"build <command-line>\") to build") (newline)
+ (display "type (b*) to enter build command loop") (newline)))
+
+;;; Local Variables:
+;;; mode:scheme
+;;; End:
diff --git a/build.bat b/build.bat
index 7144165..0a4292f 100755
--- a/build.bat
+++ b/build.bat
@@ -1 +1 @@
-scmlit -f build.scm -e(bi) build %1 %2 %3 %4 %5 %6 %7 %8 %9
+scmlit -f build -e(bi) build %1 %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/build.scm b/build.scm
index bf40fc2..3c45f09 100755..100644
--- a/build.scm
+++ b/build.scm
@@ -1,18 +1,18 @@
-#!/bin/sh
-:;exec ./scmlit -f $0 -e"(bi)" build $*
-;;; "build.scm" Build database and program
+;;; "build.scm" Build database and program -*-scheme-*-
;;; Copyright (C) 1994, 1995, 1996, 1997 Aubrey Jaffer.
;;; See the file `COPYING' for terms applying to this program.
-(require 'getopt)
(require 'parameters)
(require 'database-utilities)
;;;(define build (create-database "buildscm.scm" 'alist-table))
(define build (create-database #f 'alist-table))
+(require 'glob)
(require 'batch)
(batch:initialize! build)
+((((build 'open-table) 'batch-dialect #t) 'row:insert) '(default-for-platform))
+
(set! OPEN_WRITE "w") ; Because MS-DOS scripts need ^M
(define-tables build
@@ -88,7 +88,7 @@
("Init.scm" Scheme required "Scheme initialization.")
("Transcen.scm" Scheme required "inexact builtin procedures.")
("Link.scm" Scheme required "compiles and dynamically links.")
- ("Macro.scm" Scheme required "Supports R4RS Macros.")
+ ("Macro.scm" Scheme required "Supports Syntax-Rules Macros.")
("scmfig.h" c-header required "contains system dependent definitions.")
("patchlvl.h" c-header required "patchlevel of this release.")
("setjump.h" c-header required "continuations, stacks, and memory allocation.")
@@ -133,7 +133,7 @@
(for-each (build 'add-domain)
'((optstring #f (lambda (x) (or (not x) (string? x))) string #f)
(filename #f #f string #f)
- (build-whats #f #f symbol #f)))
+ (build-whats build-whats #f symbol #f)))
(define-tables build
@@ -180,6 +180,7 @@
(atari-st-gcc m68000 atari.st gcc)
(atari-st-turbo-c m68000 atari.st turbo-c)
(borland-c-3.1 8086 ms-dos borland-c)
+ (cygwin32 i386 unix gcc)
(djgpp i386 ms-dos gcc)
(freebsd i386 unix cc)
(gcc *unknown* unix gcc)
@@ -210,110 +211,111 @@
((compiler-flags string)
(link-lib-flag string)
(lib-path optstring)
- (lib-support expression))
+ (lib-support expression)
+ (suppress-files expression))
- ((m *unknown* "" "-lm" "/usr/lib/libm.a" ())
- (c *unknown* "" "-lc" "/usr/lib/libc.a" ())
- (regex *unknown* "" "-lregex" "/usr/lib/libregex.a" ())
- (curses *unknown* "" "-lcurses" "/usr/lib/libcurses.a" ())
+ ((m *unknown* "" "-lm" "/usr/lib/libm.a" () ())
+ (c *unknown* "" "-lc" "/usr/lib/libc.a" () ())
+ (regex *unknown* "" "-lregex" "/usr/lib/libregex.a" () ())
+ (curses *unknown* "" "-lcurses" "/usr/lib/libcurses.a" () ())
(graphics *unknown* "-I/usr/X11/include -DX11" "-lX11"
- "/usr/X11/lib/libX11.sa" ())
- (editline *unknown* "" "-lreadline" "/usr/lib/libreadline.a" ())
- (termcap *unknown* "" "-ltermcap" "/usr/lib/libtermcap.a" ())
- (debug *unknown* "-g" "-g" #f ())
- (socket *unknown* "" "" #f ())
-
- (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"))
- (dump linux-aout "" "/usr/lib/crt0.o" #f ("unexec.c" "gmalloc.c"))
-
- (m linux "" "-lm" "/lib/libm.so" ())
- (c linux "" "-lc" "/lib/libc.so" ())
- (dlll linux "-DSUN_DL" "-ldl" #f ())
+ "/usr/X11/lib/libX11.sa" () ())
+ (editline *unknown* "" "-lreadline" "/usr/lib/libreadline.a" () ())
+ (terminfo *unknown* "" "-lncurses" "/usr/lib/libncurses.a" () ())
+ (debug *unknown* "-g" "-g" #f () ())
+ (socket *unknown* "" "" #f () ())
+
+ (c cygwin32 "" "" "" () ())
+ (m linux-aout "" "-lm" "/usr/lib/libm.sa" () ())
+ (c linux-aout "" "-lc" "/usr/lib/libc.sa" () ())
+ ;; (dlll linux "-DDLD" "-ldld" #f () ("findexec.c"))
+ (regex linux "" "" "" () ())
+ ;; (curses linux "-I/usr/include/ncurses" "-lncurses" "/usr/lib/libncurses.a" () ())
+;; (nostart linux "" "-nostartfiles" #f ("pre-crt0.c") ())
+ (dump linux-aout "" "/usr/lib/crt0.o" #f ("unexec.c" "gmalloc.c") ())
+
+ (m linux "" "-lm" "/lib/libm.so" () ())
+ (c linux "" "-lc" "/lib/libc.so" () ())
+ (dlll linux "-DSUN_DL" "-ldl" #f () ())
(graphics linux "-I/usr/include/X11 -DX11" "-L/usr/X11R6/lib -lX11"
- "/usr/X11R6/lib/libX11.so" ())
- (curses linux "" "-lcurses" "/lib/libncurses.so" ())
- (nostart linux "" "" #f ())
- (dump linux "" "" #f ("unexelf.c" "gmalloc.c"))
+ "/usr/X11R6/lib/libX11.so" () ())
+ (curses linux "" "-lcurses" "/lib/libncurses.so" () ())
+ (nostart linux "" "" #f () ())
+ (dump linux "" "" #f ("unexelf.c" "gmalloc.c") ())
- (m acorn-unixlib "" "" #f ())
+ (m acorn-unixlib "" "" #f () ())
- (nostart alpha "" "-non_shared" #f ("pre-crt0.c"))
- (dump alpha "" "" #f ("unexalpha.c"))
+ (nostart alpha "" "-non_shared" #f ("pre-crt0.c") ())
+ (dump alpha "" "" #f ("unexalpha.c") ())
- (m amiga-dice-c "" "-lm" #f ())
- (m amiga-SAS/C-5.10 "" "lcmieee.lib" #f ())
- (c amiga-SAS/C-5.10 "" "lc.lib" #f ())
+ (m amiga-dice-c "" "-lm" #f () ())
+ (m amiga-SAS/C-5.10 "" "lcmieee.lib" #f () ())
+ (c amiga-SAS/C-5.10 "" "lc.lib" #f () ())
- (m vms-gcc "" "" #f ())
- (m vms "" "" #f ())
+ (m vms-gcc "" "" #f () ())
+ (m vms "" "" #f () ())
- (m atari-st-gcc "" "-lpml" #f ())
- (m atari-st-turbo-c "" "" #f ())
+ (m atari-st-gcc "" "-lpml" #f () ())
+ (m atari-st-turbo-c "" "" #f () ())
- (m sunos "" "-lm" #f ())
- (dlll sunos "-DSUN_DL" "-ldl" #f ())
- (nostart sunos "" "-e __start -nostartfiles -static" #f ("ecrt0.c"))
- (dump sunos "" "" #f ("unexelf.c" "gmalloc.c"))
+ (m sunos "" "-lm" #f () ())
+ (dlll sunos "-DSUN_DL" "-ldl" #f () ())
+ (nostart sunos "" "-e __start -nostartfiles -static" #f ("ecrt0.c") ())
+ (dump sunos "" "" #f ("unexelf.c" "gmalloc.c") ())
- (m sun-svr4-gcc-sunld "" "-lm" #f ())
- (dlll sun-svr4-gcc-sunld "-DSUN_DL" "-Wl,-ldl" #f ())
- (nostart sun-svr4-gcc-sunld "" "-e __start -nostartfiles" #f ("ecrt0.c"))
- (dump sun-svr4-gcc-sunld "" "" #f ("unexelf.c" "gmalloc.c"))
- (socket sun-svr4-gcc-sunld "" "-lsocket -lnsl" #f ())
- (regex sun-svr4-gcc-sunld "" "" #f ())
+ (m sun-svr4-gcc-sunld "" "-lm" #f () ())
+ (dlll sun-svr4-gcc-sunld "-DSUN_DL" "-Wl,-ldl" #f () ())
+ (nostart sun-svr4-gcc-sunld "" "-e __start -nostartfiles" #f ("ecrt0.c") ())
+ (dump sun-svr4-gcc-sunld "" "" #f ("unexelf.c" "gmalloc.c") ())
+ (socket sun-svr4-gcc-sunld "" "-lsocket -lnsl" #f () ())
+ (regex sun-svr4-gcc-sunld "" "" #f () ())
- (nostart gcc "" "-e __start -nostartfiles" #f ("ecrt0.c"))
- (dump gcc "" "" #f ("unexelf.c" "gmalloc.c"))
+ (nostart gcc "" "-e __start -nostartfiles" #f ("ecrt0.c") ())
+ (dump gcc "" "" #f ("unexelf.c" "gmalloc.c") ())
- (m hp-ux "" "-lm" #f ())
- (dlll hp-ux "-DHAVE_DYNL" "-Wl,-E -ldld" #f ())
- (graphics hp-ux "-DX11" "-lX" "/usr/lib/X11R5/libX11.sl" ())
- (nostart hp-ux "" "" #f ("ecrt0.c"))
- (dump hp-ux "" "" #f ("unexhp9k800.c" "gmalloc.c"))
+ (m hp-ux "" "-lm" #f () ())
+ (dlll hp-ux "-DHAVE_DYNL" "-Wl,-E -ldld" #f () ())
+ (graphics hp-ux "-DX11" "-lX" "/usr/lib/X11R5/libX11.sl" () ())
+ (nostart hp-ux "" "" #f ("ecrt0.c") ())
+ (dump hp-ux "" "" #f ("unexhp9k800.c" "gmalloc.c") ())
- (c djgpp "" "-lc" #f ("findexec.c"))
+ (c djgpp "" "-lc" #f () ("findexec.c"))
(curses djgpp "-I/djgpp/contrib/pdcurses/include/"
"-L/djgpp/contrib/pdcurses/lib/ -lcurses"
- "\\djgpp\\contrib\\pdcurses\\lib\\libcurse.a" ())
- (nostart djgpp "" "-nostartfiles" #f ("pre-crt0.c"))
- (dump djgpp "" "c:/djgpp/lib/crt0.o" #f ("unexec.c" "gmalloc.c"))
-;;; (nostart djgpp "" "" #f ("ecrt0.c"))
-;;; (dump djgpp "" "" #f ("unexelf.c" "gmalloc.c"))
-;;; (nostart djgpp "" "-e __start -nostartfiles -static" #f ("ecrt0.c"))
-;;; (dump djgpp "" "" #f ("unexelf.c" "gmalloc.c"))
-
- (c Microsoft-C "" "" #f ("findexec.c"))
- (m Microsoft-C "" "" #f ())
- (c Microsoft-C-nt "" "" #f ("findexec.c"))
- (m Microsoft-C-nt "" "" #f ())
- (c Microsoft-Quick-C "" "" #f ("findexec.c"))
- (m Microsoft-Quick-C "" "" #f ())
-
- (c Turbo-C-2 "" "" #f ("findexec.c"))
- (m Turbo-C-2 "" "" #f ())
- (graphics Turbo-C-2 "" "graphics.lib" #f ())
-
- (c Borland-C-3.1 "" "" #f ("findexec.c"))
- (m Borland-C-3.1 "" "" #f ())
- (graphics Borland-C-3.1 "" "graphics.lib" #f ())
- (windows Borland-C-3.1 "-N -W" "-W" #f ())
-
- (c highc.31 "" "" #f ("findexec.c"))
- (m highc.31 "" "" #f ())
- (windows highc.31 "-Hwin" "-Hwin" #f ())
-
- (m freebsd "" "-lm" #f ())
- (regex freebsd "" "-lgnuregex" "" ())
- (editline freebsd "" "-lreadline" "" ())
- (dlll freebsd "-DSUN_DL" "" "" ())
- (nostart freebsd "" "-e start -dc -dp -Bstatic -lgnumalloc" #f ("pre-crt0.c"))
- (dump freebsd "" "/usr/lib/crt0.o" "" ("unexsunos4.c"))
+ "\\djgpp\\contrib\\pdcurses\\lib\\libcurse.a" () ())
+ (nostart djgpp "" "-nostartfiles" #f ("pre-crt0.c") ())
+ (dump djgpp "" "c:/djgpp/lib/crt0.o" #f ("unexec.c" "gmalloc.c") ())
+;;; (nostart djgpp "" "" #f ("ecrt0.c") ())
+;;; (dump djgpp "" "" #f ("unexelf.c" "gmalloc.c") ())
+;;; (nostart djgpp "" "-e __start -nostartfiles -static" #f ("ecrt0.c") ())
+;;; (dump djgpp "" "" #f ("unexelf.c" "gmalloc.c") ())
+
+ (c Microsoft-C "" "" #f () ("findexec.c"))
+ (m Microsoft-C "" "" #f () ())
+ (c Microsoft-C-nt "" "" #f () ("findexec.c"))
+ (m Microsoft-C-nt "" "" #f () ())
+ (c Microsoft-Quick-C "" "" #f () ("findexec.c"))
+ (m Microsoft-Quick-C "" "" #f () ())
+
+ (c Turbo-C-2 "" "" #f () ("findexec.c"))
+ (m Turbo-C-2 "" "" #f () ())
+ (graphics Turbo-C-2 "" "graphics.lib" #f () ())
+
+ (c Borland-C-3.1 "" "" #f () ("findexec.c"))
+ (m Borland-C-3.1 "" "" #f () ())
+ (graphics Borland-C-3.1 "" "graphics.lib" #f () ())
+ (windows Borland-C-3.1 "-N -W" "-W" #f () ())
+
+ (c highc.31 "" "" #f () ("findexec.c"))
+ (m highc.31 "" "" #f () ())
+ (windows highc.31 "-Hwin" "-Hwin" #f () ())
+
+ (m freebsd "" "-lm" #f () ())
+ (regex freebsd "" "-lgnuregex" "" () ())
+ (editline freebsd "" "-lreadline" "" () ())
+ (dlll freebsd "-DSUN_DL" "" "" () ())
+ (nostart freebsd "" "-e start -dc -dp -Bstatic -lgnumalloc" #f ("pre-crt0.c") ())
+ (dump freebsd "" "/usr/lib/crt0.o" "" ("unexsunos4.c") ())
))
'(compile-commands
@@ -325,125 +327,124 @@
(lambda (files parms)
(define rsp-name "temp.rsp")
(apply batch:lines->file parms rsp-name files)
- (batch:system parms
- "bcc" "-d" "-O" "-Z" "-G" "-w-pro" "-ml" "-c"
- (if (member '(define "FLOATS" #t)
- (c-defines parms))
- "" "-f-")
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- (string-append "@" rsp-name))
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:try-system
+ parms
+ "bcc" "-d" "-O" "-Z" "-G" "-w-pro" "-ml" "-c"
+ (if (member '(define "FLOATS" #t)
+ (c-defines parms))
+ "" "-f-")
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ (string-append "@" rsp-name))
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program Borland-C-3.1
(lambda (oname objects libs parms)
(define lnk-name (string-append oname ".lnk"))
(apply batch:lines->file parms
lnk-name
(append libs objects))
- (batch:system parms "bcc"
- (string-append "-e" oname)
- "-ml"
- (string-append "@" lnk-name))
- (string-append oname ".exe")))
+ (and (batch:try-system
+ parms "bcc" (string-append "-e" oname)
+ "-ml" (string-append "@" lnk-name))
+ (string-append oname ".exe"))))
(compile-c-files Turbo-C-2
(lambda (files parms)
- (batch:system parms
- "tcc" "-c" "-d" "-O" "-Z" "-G" "-ml" "-c"
- "-Ic:\\turboc\\include"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:chop-to-fit-system
+ parms
+ "tcc" "-c" "-d" "-O" "-Z" "-G" "-ml" "-c"
+ "-Ic:\\turboc\\include"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program Turbo-C-2
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to
(replace-suffix (car objects) ".obj" ".exe")
#\\))
(oexe (string-append oname ".exe")))
- (if (not (string-ci=? exe oexe))
- (batch:delete-file parms oexe))
- (batch:system parms
- "tcc" "-Lc:\\turboc\\lib" libs objects)
- (if (not (string-ci=? exe oexe))
- (batch:rename-file parms exe oexe))
- oexe)))
+ (and (or (string-ci=? exe oexe)
+ (batch:delete-file parms oexe))
+ (batch:try-system
+ parms "tcc" "-Lc:\\turboc\\lib" libs objects)
+ (or (string-ci=? exe oexe)
+ (batch:rename-file parms exe oexe))
+ oexe))))
(compile-c-files Microsoft-C
(lambda (files parms)
- (batch:system parms
- "cl" "-c" "Oxp" "-AH"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:chop-to-fit-system
+ parms "cl" "-c" "Oxp" "-AH"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program Microsoft-C
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to
(replace-suffix (car objects) ".obj" ".exe")
#\\))
(oexe (string-append oname ".exe")))
- (if (not (string-ci=? exe oexe))
- (batch:delete-file parms oexe))
- (batch:system parms
- "link" "/noe" "/ST:40000"
- (apply string-join "+"
- (map (lambda (o)
- (replace-suffix o ".obj" ""))
- objects))
- libs)
- (if (not (string-ci=? exe oexe))
- (batch:rename-file parms exe oexe))
- oexe)))
+ (and (or (string-ci=? exe oexe)
+ (batch:delete-file parms oexe))
+ (batch:try-system
+ parms "link" "/noe" "/ST:40000"
+ (apply string-join "+"
+ (map (lambda (o)
+ (replace-suffix o ".obj" ""))
+ objects))
+ libs)
+ (or (string-ci=? exe oexe)
+ (batch:rename-file parms exe oexe))
+ oexe))))
(compile-c-files Microsoft-C-nt
(lambda (files parms)
- (batch:system parms
- "cl" "-c" "-nologo" "-O2"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:chop-to-fit-system parms
+ "cl" "-c" "-nologo" "-O2"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program Microsoft-C-nt
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to
(replace-suffix (car objects) ".obj" ".exe")
#\\))
(oexe (string-append oname ".exe")))
-; (if (not (string-ci=? exe oexe))
-; (batch:delete-file parms oexe))
- (batch:system parms
- "link" "/nologo" (string-append "/out:" oexe)
- (apply string-join " "
- (map (lambda (o)
- (replace-suffix o ".obj" ""))
- objects))
- libs)
-; (if (not (string-ci=? exe oexe))
-; (batch:rename-file parms exe oexe))
- oexe)))
+ (and (batch:try-system
+ parms "link" "/nologo"
+ (string-append "/out:" oexe)
+ (apply string-join " "
+ (map (lambda (o)
+ (replace-suffix o ".obj" ""))
+ objects))
+ libs)
+ oexe))))
(compile-c-files Microsoft-Quick-C
(lambda (files parms)
- (batch:system parms
- "qcl" "/AH" "/W1" "/Ze" "/O" "/Ot" "/DNDEBUG"
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:chop-to-fit-system
+ parms
+ "qcl" "/AH" "/W1" "/Ze" "/O" "/Ot" "/DNDEBUG"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program Microsoft-Quick-C
(lambda (oname objects libs parms)
(define crf-name (string-append oname ".crf"))
@@ -455,400 +456,445 @@
,(string-append oname ".exe")
,(apply string-join " " libs)
";"))
- (batch:system parms
- "qlink"
- "/CP:0xffff" "/NOI" "/SE:0x80" "/ST:0x9c40"
- crf-name)
- (string-append oname ".exe")))
+ (and (batch:try-system
+ parms "qlink"
+ "/CP:0xffff" "/NOI" "/SE:0x80" "/ST:0x9c40"
+ crf-name)
+ (string-append oname ".exe"))))
(compile-c-files Watcom-9.0
(lambda (files parms)
- (batch:system parms
- "wcc386p" "/mf" "/d2" "/ze" "/oxt" "/3s"
- "/zq" "/w3"
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:chop-to-fit-system
+ parms
+ "wcc386p" "/mf" "/d2" "/ze" "/oxt" "/3s"
+ "/zq" "/w3"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program Watcom-9.0
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to
(replace-suffix (car objects)
- ".obj" ".exe")
+ ".obj" ".exe")
#\\))
(oexe (string-append oname ".exe")))
- (if (not (string-ci=? exe oexe))
- (batch:delete-file parms oexe))
- (batch:system parms
- "wlinkp" "option" "quiet" "option"
- "stack=40000" "FILE"
- (apply string-join ","
- (map (lambda (o)
- (replace-suffix o ".obj" ""))
- objects))
- libs)
- (if (not (string-ci=? exe oexe))
- (batch:rename-file parms exe oexe))
- oexe)))
+ (and (or (string-ci=? exe oexe)
+ (batch:delete-file parms oexe))
+ (batch:try-system
+ parms
+ "wlinkp" "option" "quiet" "option"
+ "stack=40000" "FILE"
+ (apply string-join ","
+ (map (lambda (o)
+ (replace-suffix o ".obj" ""))
+ objects))
+ libs)
+ (if (not (string-ci=? exe oexe))
+ (batch:rename-file parms exe oexe))
+ oexe))))
(compile-c-files highc.31
(lambda (files parms)
(define hcc-name "temp.hcc")
(apply batch:lines->file parms hcc-name files)
- (batch:system parms
- "d:\\hi_c\\hc386.31\\bin\\hc386"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- "-c" (string-append "@" hcc-name))
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:try-system
+ parms
+ "d:\\hi_c\\hc386.31\\bin\\hc386"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ "-c" (string-append "@" hcc-name))
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program highc.31
(lambda (oname objects libs parms)
(let ((oexe (string-append oname ".exe")))
(define lnk-name (string-append oname ".lnk"))
(apply batch:lines->file parms
lnk-name (append libs objects))
- (batch:system parms
- "d:\\hi_c\\hc386.31\\bin\\hc386" "-o" oname
- (string-append "@" lnk-name))
- (batch:system parms
- "bind386" "d:/hi_c/pharlap.51/run386b.exe" oname
- "-exe" oexe)
- oexe)))
+ (and (batch:try-system
+ parms
+ "d:\\hi_c\\hc386.31\\bin\\hc386" "-o" oname
+ "-stack 65000"
+ (string-append "@" lnk-name))
+ (batch:try-system
+ parms
+ "bind386" "d:/hi_c/pharlap.51/run386b.exe" oname
+ "-exe" oexe)
+ oexe))))
(compile-c-files djgpp
(lambda (files parms)
- (batch:apply-chop-to-fit
- batch:try-system parms
- "gcc" "-Wall" "-O2" "-c"
- (include-spec "-I" parms)
- (c-includes parms) (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- "\\/")))
+ (and (batch:chop-to-fit-system
+ parms
+ "gcc" "-Wall" "-O2" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms) (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ "\\/"))))
(link-c-program djgpp
(lambda (oname objects libs parms)
(let ((exe (string-append oname ".exe")))
- (or
- (batch:try-system parms
- "gcc" "-o" oname
- (must-be-first
- '("-nostartfiles"
- "pre-crt0.o" "ecrt0.o"
- "c:/djgpp/lib/crt0.o")
- (append objects libs)))
- (let ((arname (string-append oname ".a")))
- (batch:delete-file parms arname)
- (batch:apply-chop-to-fit
- batch:try-system parms
- "ar" "r" arname objects)
- (and
- (batch:system
- parms "gcc" "-o" oname
- (must-be-first
- '("-nostartfiles"
- "pre-crt0.o" "ecrt0.o" "c:/djgpp/lib/crt0.o")
- (cons arname libs)))
- (batch:delete-file parms arname)))
- (slib:error 'build "couldn't build archive"))
- (batch:system parms "strip" exe)
- (batch:delete-file parms oname)
- ;;(batch:delete-file parms exe)
- ;;(batch:system parms "coff2exe" "-s" "c:\\djgpp\\bin\\go32.exe" oname)
- exe)))
+ (and (or (batch:try-system parms
+ "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "c:/djgpp/lib/crt0.o")
+ (append objects libs)))
+ (let ((arname (string-append oname ".a")))
+ (batch:delete-file parms arname)
+ (and (batch:chop-to-fit-system
+ parms
+ "ar" "r" arname objects)
+ (batch:try-system
+ parms "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "c:/djgpp/lib/crt0.o")
+ (cons arname libs)))
+ (batch:delete-file parms arname)))
+ ;;(build:error 'build "couldn't build archive")
+ )
+ (batch:try-system parms "strip" exe)
+ (batch:delete-file parms oname)
+ ;;(batch:delete-file parms exe)
+ ;;(batch:try-system parms "coff2exe" "-s" "c:\\djgpp\\bin\\go32.exe" oname)
+ exe))))
(compile-c-files os/2-emx
(lambda (files parms)
- (batch:system parms
- "gcc" "-O" "-m386" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\\)))
+ (and (batch:chop-to-fit-system parms
+ "gcc" "-O" "-m386" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ #\\))))
(link-c-program os/2-emx
(lambda (oname objects libs parms)
- (batch:system parms
- "gcc" "-o" (string-append oname ".exe")
- objects libs)
- (string-append oname ".exe")))
+ (and (batch:try-system
+ parms "gcc" "-o" (string-append oname ".exe")
+ objects libs)
+ (string-append oname ".exe"))))
(compile-c-files os/2-cset
(lambda (files parms)
- (batch:system parms
- "icc.exe" "/Gd-" "/Ge+" "/Gm+" "/Q" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- #\\)))
+ (and (batch:chop-to-fit-system
+ parms "icc.exe" "/Gd-" "/Ge+" "/Gm+" "/Q" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".obj")
+ #\\))))
(link-c-program os/2-cset
(lambda (oname objects libs parms)
- (batch:system parms
- "link386.exe" objects libs
- (string-append "," oname ".exe,,,;"))
- (string-append oname ".exe")))
+ (and (batch:try-system
+ parms "link386.exe" objects libs
+ (string-append "," oname ".exe,,,;"))
+ (string-append oname ".exe"))))
(compile-c-files HP-UX
(lambda (files parms)
- (batch:system parms
- "cc" "+O1" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "cc" "+O1" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(compile-dll-c-files HP-UX
(lambda (files parms)
- (batch:system parms
- "cc" "+O1" "-Wl,-E" "+z" "-c"
- (c-includes parms)
- (c-flags parms)
- files)
- (map
- (lambda (fname)
- (batch:rename-file parms
- (string-append fname ".sl")
- (string-append fname ".sl~"))
- (batch:system parms
- "ld" "-b" "-o"
- (string-append fname ".sl")
- (string-append fname ".o"))
- (string-append fname ".sl"))
- (truncate-up-to
- (replace-suffix files ".c" "")
- #\/))))
-; (make-dll-archive HP-UX
+ (and (batch:chop-to-fit-system
+ parms "cc" "+O1" "-Wl,-E" "+z" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (let ((results
+ (map
+ (lambda (fname)
+ (batch:rename-file
+ parms
+ (string-append fname ".sl")
+ (string-append fname ".sl~"))
+ (and (batch:try-system
+ parms "ld" "-b" "-o"
+ (string-append fname ".sl")
+ (string-append fname ".o"))
+ (string-append fname ".sl")))
+ (truncate-up-to
+ (replace-suffix files ".c" "")
+ #\/))))
+ (and (apply and? results) results)))))
+; (make-dll-archive HP-UX
; (lambda (oname objects libs parms)
-; (batch:system parms
-; "ld" "-b" "-o" (string-append oname ".sl")
-; objects)
-; (rebuild-catalog)
-; (string-append oname ".sl")))
-
+; (and (batch:try-system
+; parms "ld" "-b" "-o" (string-append oname ".sl")
+; objects)
+; (batch:rebuild-catalog parms)
+; (string-append oname ".sl"))))
(make-dll-archive sunos
(lambda (oname objects libs parms)
- (batch:system parms
- "ld" "-assert" "pure-text" "-o"
- (string-append oname ".so.1.0")
- objects)
- (rebuild-catalog)
- (string-append oname ".so.1.0")))
+ (and (batch:try-system
+ parms
+ "ld" "-assert" "pure-text" "-o"
+ (string-append
+ (car (parameter-list-ref parms 'implvic))
+ oname ".so.1.0")
+ objects)
+ (batch:rebuild-catalog parms)
+ (string-append
+ (car (parameter-list-ref parms 'implvic))
+ oname ".so.1.0"))))
(compile-c-files linux-aout
(lambda (files parms)
- (batch:system parms
- "gcc" "-Wall" "-O2" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(compile-dll-c-files linux-aout
(lambda (files parms)
- (batch:system parms
- "gcc" "-Wall" "-O2" "-c"
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system
+ parms
+ "gcc" "-Wall" "-O2" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ #\/))))
;;; (make-dll-archive linux-aout
;;; (lambda (oname objects libs parms) #t
-;;; (rebuild-catalog)
+;;; (batch:rebuild-catalog parms)
;;; oname))
(compile-c-files linux
(lambda (files parms)
- (batch:system parms
- "gcc" "-O2" "-c" (c-includes parms)
- (include-spec "-I" parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system
+ parms
+ "gcc"
+ (if (member "-g" (c-includes parms)) "" "-O2")
+ "-c" (c-includes parms)
+ (include-spec "-I" parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(compile-dll-c-files linux
(lambda (files parms)
- (batch:system parms
- "gcc" "-O2" "-fpic" "-c" (c-includes parms)
- (c-flags parms)
- files)
- (let* ((platform (car (parameter-list-ref
- parms 'platform)))
- (ld-opts
- (map (lambda (l)
- (build:lib-ld-flag l platform))
- (parameter-list-ref parms 'c-lib))))
- (map
- (lambda (fname)
- (batch:system parms
- "gcc" "-shared" "-o"
- (string-append fname ".so")
- (string-append fname ".o")
- ld-opts)
- (string-append fname ".so"))
- (truncate-up-to
- (replace-suffix files ".c" "")
- #\/)))))
+ (and
+ (batch:chop-to-fit-system
+ parms
+ "gcc" "-O2" "-fpic" "-c" (c-includes parms)
+ (c-flags parms)
+ files)
+ (let* ((platform (car (parameter-list-ref
+ parms 'platform)))
+ (ld-opts
+ (map (lambda (l)
+ (build:lib-ld-flag l platform))
+ (parameter-list-ref parms 'c-lib)))
+ (results
+ (map
+ (lambda (fname)
+ (and (batch:try-system
+ parms
+ "gcc" "-shared" "-o"
+ (string-append fname ".so")
+ (string-append fname ".o")
+ ld-opts)
+ (string-append fname ".so")))
+ (truncate-up-to
+ (replace-suffix files ".c" "")
+ #\/))))
+ (and (apply and? results) results)))))
(make-dll-archive linux
(lambda (oname objects libs parms)
(let ((platform (car (parameter-list-ref
parms 'platform))))
- (batch:system
- parms
- "gcc" "-shared" "-o"
- (string-append oname ".so")
- objects
- (map (lambda (l) (build:lib-ld-flag l platform))
- (parameter-list-ref parms 'c-lib))))
- (rebuild-catalog)
- (string-append oname ".so")))
+ (and (batch:try-system
+ parms
+ "gcc" "-shared" "-o"
+ (string-append
+ (car (parameter-list-ref parms 'implvic))
+ oname ".so")
+ objects
+ (map (lambda (l)
+ (build:lib-ld-flag l platform))
+ (parameter-list-ref parms 'c-lib)))
+ (batch:rebuild-catalog parms)
+ (string-append
+ (car (parameter-list-ref parms 'implvic))
+ oname ".so")))))
(link-c-program linux
(lambda (oname objects libs parms)
- (batch:system parms
- "gcc" "-rdynamic" "-o" oname
- (must-be-first
- '("pre-crt0.o" "ecrt0.o" "/usr/lib/crt0.o")
- (append objects libs)))
- oname))
+ (and (batch:try-system
+ parms "gcc" "-rdynamic" "-o" oname
+ (must-be-first
+ '("pre-crt0.o" "ecrt0.o" "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname)))
(compile-c-files Unicos
(lambda (files parms)
- (batch:system parms
- "cc" "-hvector2" "-hscalar2" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
- (link-c-program Unicos
+ (and (batch:chop-to-fit-system
+ parms
+ "cc" "-hvector2" "-hscalar2" "-c"
+ (include-spec "-i" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
+ (link-c-program unicos
(lambda (oname objects libs parms)
- (batch:system parms
- "cc" "setjump.o" "-o" oname objects libs)
- oname))
+ (and (batch:try-system
+ parms "cc" "setjump.o" "-o" oname objects libs)
+ oname)))
(compile-c-files gcc
(lambda (files parms)
- (batch:system parms
- "gcc" "-Wall" "-O2" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program gcc
(lambda (oname objects libs parms)
(batch:rename-file parms
oname (string-append oname "~"))
- (batch:system parms
- "gcc" "-o" oname
- (must-be-first
- '("-nostartfiles"
- "pre-crt0.o" "ecrt0.o"
- "/usr/lib/crt0.o")
- (append objects libs)))
- oname))
+ (and (batch:try-system parms
+ "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname)))
+
+ (compile-c-files cygwin32
+ (lambda (files parms)
+ (and (batch:chop-to-fit-system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ #\/))))
+ (link-c-program cygwin32
+ (lambda (oname objects libs parms)
+ (batch:rename-file parms
+ (string-append oname ".exe")
+ (string-append oname "~"))
+ (and (batch:try-system parms
+ "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname)))
(compile-c-files sun-svr4-gcc-sunld
(lambda (files parms)
- (batch:system parms
- "gcc" "-Wall" "-O2" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program sun-svr4-gcc-sunld
(lambda (oname objects libs parms)
(batch:rename-file parms
oname (string-append oname "~"))
- (batch:system parms
- "gcc" "-o" oname
- (must-be-first
- '("-nostartfiles"
- "pre-crt0.o" "ecrt0.o"
- "/usr/lib/crt0.o")
- (append objects libs)))
- oname))
+ (and (batch:try-system parms
+ "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname)))
(compile-c-files svr4
(lambda (files parms)
- (batch:system parms
- "cc" "-O" "-DSVR4" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "cc" "-O" "-DSVR4" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(compile-c-files aix
(lambda (files parms)
- (batch:system parms
- "cc" "-O" "-Dunix" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "cc" "-O" "-Dunix" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program aix
(lambda (oname objects libs parms)
- (batch:system parms
- "cc" "-lansi" "-o" oname objects libs)
- oname))
+ (and (batch:try-system
+ parms "cc" "-lansi" "-o" oname objects libs)
+ oname)))
(compile-c-files amiga-aztec
(lambda (files parms)
- (batch:system parms
- "cc" "-dAMIGA"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "cc" "-dAMIGA"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program amiga-aztec
(lambda (oname objects libs parms)
- (batch:system parms
- "cc" "-o" oname objects libs "-lma")
- oname))
+ (and (batch:try-system
+ parms "cc" "-o" oname objects libs "-lma")
+ oname)))
(compile-c-files amiga-SAS/C-5.10
(lambda (files parms)
- (batch:system parms
- "lc" "-d3" "-M" "-fi" "-O"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (batch:system parms "blink with link.amiga NODEBUG")
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system
+ parms
+ "lc" "-d3" "-M" "-fi" "-O"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (batch:try-system
+ parms "blink with link.amiga NODEBUG")
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program amiga-SAS/C-5.10
(lambda (oname objects libs parms)
(define lnk-name "link.amiga")
@@ -871,156 +917,158 @@
(compile-c-files amiga-dice-c
(lambda (files parms)
- (batch:system parms
- "dcc" "-r" "-gs" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files "-o" (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/))
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:try-system
+ parms
+ "dcc" "-r" "-gs" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files "-o" (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ #\/))
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program amiga-dice-c
(lambda (oname objects libs parms)
- (batch:system parms
- "dcc" "-r" "-gs" "-o" oname objects libs)
- oname))
+ (and (batch:try-system
+ parms "dcc" "-r" "-gs" "-o" oname objects libs)
+ oname)))
(compile-c-files atari-st-gcc
(lambda (files parms)
- (batch:system parms
- "gcc" "-v" "-O" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system parms
+ "gcc" "-v" "-O" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program atari-st-gcc
(lambda (oname objects libs parms)
- (batch:system parms
- "gcc" "-v" "-o" (string-append oname ".ttp")
- objects libs)
- (string-append oname ".ttp")))
+ (and (batch:try-system
+ parms "gcc" "-v" "-o" (string-append oname ".ttp")
+ objects libs)
+ (string-append oname ".ttp"))))
(compile-c-files atari-st-turbo-c
(lambda (files parms)
- (batch:system parms
- "tcc" "-P" "-W-" "-Datarist"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system
+ parms
+ "tcc" "-P" "-W-" "-Datarist"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program atari-st-turbo-c
(lambda (oname objects libs parms)
- (batch:system parms
- "tlink" "-o" (string-append oname ".ttp")
- objects libs "mintlib.lib" "osbind.lib"
- "pcstdlib.lib" "pcfltlib.lib")
- (string-append oname ".ttp")))
+ (and (batch:try-system
+ parms "tlink" "-o" (string-append oname ".ttp")
+ objects libs "mintlib.lib" "osbind.lib"
+ "pcstdlib.lib" "pcfltlib.lib")
+ (string-append oname ".ttp"))))
(compile-c-files acorn-unixlib
(lambda (files parms)
- (batch:system parms
- "cc" "-c" "-depend" "!Depend" "-IUnixLib:"
- "-pcc" "-Dunix" "-DSVR3" "-DARM_ULIB"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- #\/)))
+ (and (batch:chop-to-fit-system
+ parms
+ "cc" "-c" "-depend" "!Depend" "-IUnixLib:"
+ "-pcc" "-Dunix" "-DSVR3" "-DARM_ULIB"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ #\/))))
(link-c-program acorn-unixlib
(lambda (oname objects libs parms)
- (batch:system parms
- "link" "-o" oname objects libs
- ":5.$.dev.gcc.unixlib36d.clib.o.unixlib")
- (batch:system parms
- "squeeze" oname)
- oname))
+ (and (batch:try-system
+ parms "link" "-o" oname objects libs
+ ":5.$.dev.gcc.unixlib36d.clib.o.unixlib")
+ (batch:try-system parms "squeeze" oname)
+ oname)))
(compile-c-files vms
(lambda (files parms)
- (batch:system parms
- "cc"
- (c-includes parms)
- (c-flags parms)
- (replace-suffix files ".c" ""))
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- "/]")))
+ (and (batch:chop-to-fit-system
+ parms
+ "cc"
+ (c-includes parms)
+ (c-flags parms)
+ (replace-suffix files ".c" ""))
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ "/]"))))
(link-c-program vms
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to
(replace-suffix (car objects)
- ".obj" ".exe")
+ ".obj" ".exe")
"/]"))
(oexe (string-append oname ".exe")))
- (batch:system parms
- "macro" "setjump")
- (batch:system parms
- "link"
- (apply string-join ","
- (append (map (lambda (f)
- (replace-suffix f ".obj" ""))
- objects)
- '("setjump" "sys$input/opt\n ")))
- (apply string-join
- "," (append (remove "" libs)
- '("sys$share:vaxcrtl/share"))))
- (if (not (string-ci=? exe oexe))
- (batch:rename-file parms exe oexe))
- oexe)))
+ (and (batch:try-system parms "macro" "setjump")
+ (batch:try-system
+ parms
+ "link"
+ (apply string-join ","
+ (append (map (lambda (f)
+ (replace-suffix f ".obj" ""))
+ objects)
+ '("setjump" "sys$input/opt\n ")))
+ (apply string-join
+ "," (append (remove "" libs)
+ '("sys$share:vaxcrtl/share"))))
+ (or (string-ci=? exe oexe)
+ (batch:rename-file parms exe oexe))
+ oexe))))
(compile-c-files vms-gcc
(lambda (files parms)
- (batch:system parms
- "gcc"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- (replace-suffix files ".c" ""))
- (truncate-up-to
- (replace-suffix files ".c" ".obj")
- "/]")))
+ (and (batch:chop-to-fit-system
+ parms
+ "gcc"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ (replace-suffix files ".c" ""))
+ (truncate-up-to
+ (replace-suffix files ".c" ".obj")
+ "/]"))))
(link-c-program vms-gcc
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to
- (replace-suffix (car objects)
- ".obj" ".exe")
+ (replace-suffix (car objects) ".obj" ".exe")
"/]"))
(oexe (string-append oname ".exe")))
- (batch:system parms
- "macro" "setjump")
- (batch:system parms
- "link"
- (apply string-join ","
- (append objects
- '("setjump.obj"
- "sys$input/opt\n ")))
- (apply string-join
- "," (append (remove "" libs)
- '("gnu_cc:[000000]gcclib/lib"
- "sys$share:vaxcrtl/share"))))
- (if (not (string-ci=? exe oexe))
- (batch:rename-file parms exe oexe))
- oexe)))
+ (and (batch:try-system parms "macro" "setjump")
+ (batch:try-system
+ parms
+ "link"
+ (apply string-join ","
+ (append objects
+ '("setjump.obj"
+ "sys$input/opt\n ")))
+ (apply string-join
+ "," (append (remove "" libs)
+ '("gnu_cc:[000000]gcclib/lib"
+ "sys$share:vaxcrtl/share"))))
+ (or (string-ci=? exe oexe)
+ (batch:rename-file parms exe oexe))
+ oexe))))
(compile-c-files *unknown*
(lambda (files parms)
- (batch:system parms
- "cc" "-O" "-c"
- (include-spec "-I" parms)
- (c-includes parms)
- (c-flags parms)
- files)
+ (batch:chop-to-fit-system
+ parms
+ "cc" "-O" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ files)
(truncate-up-to
(replace-suffix files ".c" ".o")
"\\/]")))
@@ -1028,89 +1076,101 @@
(lambda (oname objects libs parms)
(batch:rename-file parms
oname (string-append oname "~"))
- (batch:system parms
- "cc" "-o" oname
- (must-be-first
- '("-nostartfiles"
- "pre-crt0.o" "ecrt0.o"
- "/usr/lib/crt0.o")
- (append objects libs)))
- oname))
+ (and (batch:try-system parms
+ "cc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname)))
(make-archive *unknown*
(lambda (oname objects libs parms)
(let ((aname (string-append oname ".a")))
- (batch:system parms "ar rc" aname objects)
- (batch:system parms "ranlib" aname)
- aname)))
+ (and (batch:try-system parms "ar rc" aname objects)
+ (batch:try-system parms "ranlib" aname)
+ aname))))
(compile-dll-c-files *unknown*
(lambda (files parms)
- (batch:system parms
- "cc" "-O" "-c"
- (c-includes parms)
- (c-flags parms)
- files)
- (truncate-up-to
- (replace-suffix files ".c" ".o")
- "\\/]")))
+ (and (batch:chop-to-fit-system parms
+ "cc" "-O" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to
+ (replace-suffix files ".c" ".o")
+ "\\/]"))))
(make-dll-archive *unknown*
(lambda (oname objects libs parms)
- (let ((aname (string-append oname ".a")))
- (batch:system parms
- "ar rc" aname objects)
- (batch:system parms
- "ranlib" aname)
- (rebuild-catalog)
- aname)))
+ (let ((aname
+ (string-append
+ (car (parameter-list-ref parms 'implvic))
+ oname ".a")))
+ (and (batch:try-system parms "ar rc" aname objects)
+ (batch:try-system parms "ranlib" aname)
+ (batch:rebuild-catalog parms)
+ aname))))
(update-catalog *unknown*
(lambda (oname objects libs parms)
- (rebuild-catalog)
+ (batch:rebuild-catalog parms)
(if (= 1 (length objects)) (car objects)
objects)))
(compile-c-files freebsd
(lambda (files parms)
- (batch:system parms
- "cc" "-O" "-Dfreebsd" "-c"
- (c-includes parms)
- (c-flags parms)
- files)
- (replace-suffix files ".c" ".o")))
+ (and (batch:chop-to-fit-system
+ parms
+ "cc" "-O" "-Dfreebsd" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o"))))
(link-c-program freebsd
(lambda (oname objects libs parms)
(batch:rename-file parms
oname (string-append oname "~"))
- (batch:system parms
- "cc" "-o" oname
- (must-be-first
- '("-nostartfiles"
- "pre-crt0.o" "crt0.o"
- "/usr/lib/crt0.o")
- (append objects libs)))
- oname))
+ (and (batch:try-system parms
+ "cc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "crt0.o"
+ "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname)))
(compile-dll-c-files freebsd
(lambda (files parms)
- (batch:system parms
- "cc" "-O" "-fpic" "-c"
- "-Dfreebsd"
- (string-append "-I" (implementation-vicinity))
- (c-includes parms)
- (c-flags parms)
- files)
- (let ((objs (replace-suffix files ".c" ".o")))
- (map (lambda (f)
- (batch:system parms "ld" "-Bshareable" f)
- (batch:system parms "mv" "a.out" f))
- objs)
- objs)))
+ (and (batch:chop-to-fit-system
+ parms
+ "cc" "-O" "-fpic" "-c"
+ "-Dfreebsd"
+ (string-append
+ "-I" (parameter-list-ref parms 'scm-srcdir))
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (let ((objs (replace-suffix files ".c" ".o")))
+ (every
+ (lambda (f)
+ (and (batch:try-system
+ parms "ld" "-Bshareable" f)
+ (batch:try-system
+ parms "mv" "a.out" f)))
+ objs)
+ objs))))
(make-dll-archive freebsd
(lambda (oname objects libs parms)
- (batch:system parms
- "ld" "-Bshareable" "-o"
- (string-append oname ".so")
- objects)
- (rebuild-catalog)
- (string-append oname ".so")))
+ (and (batch:try-system
+ parms
+ "ld" "-Bshareable" "-o"
+ (string-append
+ (car (parameter-list-ref parms 'implvic))
+ oname ".so")
+ objects)
+ (batch:rebuild-catalog parms)
+ (string-append
+ (car (parameter-list-ref parms 'implvic))
+ oname ".so"))))
))
@@ -1230,7 +1290,7 @@ file delete and rename, and directory functions.")
`Curses' screen management package.")
(edit-line
- ((c-file "edline.c") (c-lib termcap editline) (compiled-init "init_edline"))
+ ((c-file "edline.c") (c-lib terminfo editline) (compiled-init "init_edline"))
"\
interface to the editline or GNU readline library")
@@ -1270,7 +1330,7 @@ Convert a running scheme program into an executable file.")
;;; (short-aligned-stack ((define "SHORT_ALIGN")))
;;; (initial-malloc-limit ((define "INIT_MALLOC_LIMIT" 100000)))
;;; (number-of-hash-buckets ((define "NUM_HASH_BUCKETS" 137)))
-;;; (minimum-gc-yield ((define "MIN_GC_YIELD" "(heap_size/4)")))
+;;; (minimum-gc-yield ((define "MIN_GC_YIELD" "(heap_cells/4)")))
(heap-can-shrink ((define "DONT_GC_FREE_SEGMENTS"))
"\
@@ -1286,7 +1346,14 @@ unusual stacks need this. Also, if you incorporate new C code into
scm which uses VMS system services or library routines (which need to
unwind the stack in an ordrly manner) you may need to define
CHEAP_CONTINUATIONS.")
- ))
+ )))
+
+(for-each (build 'add-domain)
+ '((features features #f symbol #f)
+ (C-libraries C-libraries #f symbol #f)))
+
+(define-tables build
+
'(build-params
*parameter-columns*
*parameter-columns*
@@ -1296,18 +1363,16 @@ CHEAP_CONTINUATIONS.")
"what to build it for")
(2 target-name single string (lambda (pl) '("scm")) #f
"base name of target")
- (3 c-lib nary symbol (lambda (pl) '(c)) #f
+ (3 c-lib nary C-libraries (lambda (pl) '(c)) #f
"C library (and include files)")
(4 define nary string #f #f "#define FLAG")
- (5 implinit single string
- (lambda (pl) (list (object->string
- (in-vicinity (implementation-vicinity) "Init.scm"))))
+ (5 implvic single string (lambda (pl) (list ""))
#f "implementation vicinity")
(6 c-file nary filename #f #f "C source files")
(7 o-file nary filename #f #f "other object files")
(8 init nary string #f #f "initialization calls")
(9 compiled-init nary string #f #f "later initialization calls")
- (10 features nary symbol
+ (10 features nary features
(lambda (pl) '(arrays inexact bignums))
(lambda (rdb) (((rdb 'open-table) 'features #f) 'get 'spec))
"features to include")
@@ -1323,28 +1388,27 @@ CHEAP_CONTINUATIONS.")
,@(or (getspec what) '())))))
"what to build")
(12 batch-dialect single batch-dialect
- guess-how
+ (lambda (pl) '(default-for-platform)) ;;guess-how
#f
- "How to build")
- (13 who single expression (lambda (pl) (list (current-output-port))) #f
- "name of buildfile or port")
+ "scripting language")
+ (13 who optional expression #f #f "name of buildfile")
(14 compiler-options nary string #f #f "command-line compiler options")
(15 linker-options nary string #f #f "command-line linker options")
- (17 batch-port nary expression #f #f
- "port batch file will be written to.")
- (18 c-defines nary expression #f #f "#defines for C")
- (19 c-includes nary expression #f #f "library induced defines for C")
- (20 scm-srcdir single filename
+ (16 scm-srcdir single filename
(lambda (pl) (list (user-vicinity))) #f
"directory path for files in the manifest")
- (21 scm-libdir single filename
+ (17 scm-libdir single filename
(lambda (pl) (list (implementation-vicinity))) #f
"directory path for files in the manifest")
+ (18 c-defines nary expression #f #f "#defines for C")
+ (19 c-includes nary expression #f #f "library induced defines for C")
+ (20 batch-port nary expression #f #f
+ "port batch file will be written to.")
))
'(build-pnames
((name string))
- ((parameter-index uint))
+ ((parameter-index uint)) ;should be build-params
(
("p" 1) ("platform" 1)
("o" 2) ("outname" 2)
@@ -1360,8 +1424,8 @@ CHEAP_CONTINUATIONS.")
("w" 13) ("script name" 13)
("compiler options" 14)
("linker options" 15)
- ("scm srcdir" 20)
- ("scm libdir" 21)
+ ("scm srcdir" 16)
+ ("scm libdir" 17)
))
'(*commands*
@@ -1374,11 +1438,11 @@ CHEAP_CONTINUATIONS.")
build-params
build-pnames
build:build
- "build program.")
+ "compile and link SCM programs.")
(*initialize*
no-parameters
no-parameters
- build:init
+ #f
"SCM Build Database"))))
;;;((build 'close-database))
@@ -1389,6 +1453,7 @@ CHEAP_CONTINUATIONS.")
(define build:lib-cc-flag #f)
(define build:lib-ld-flag #f)
(define build:c-lib-support #f)
+(define build:c-suppress #f)
(define plan-command #f)
;;; Look up command on a platform, but default to '*unknown* if not
@@ -1400,7 +1465,8 @@ CHEAP_CONTINUATIONS.")
(let ((ans (getter thing platform)))
(cond (ans ans)
((eq? '*unknown* platform)
- (build:error "Couldn't find: " plat thing))
+ ;;(slib:warn "Couldn't find: " plat thing)
+ '())
(else (look '*unknown*)))))
(look plat)))
@@ -1433,9 +1499,16 @@ CHEAP_CONTINUATIONS.")
(map (lambda (c)
(string-append c "();"))
(parameter-list-ref parms 'compiled-init))))
+ (implvic (let ((impl (car (parameter-list-ref parms 'implvic))))
+ (if (equal? "" impl)
+ (car (parameter-list-ref parms 'scm-srcdir))
+ impl)))
(c-defines
`((define "IMPLINIT"
- ,(car (parameter-list-ref parms 'implinit)))
+ ,(object->string
+ (string-append
+ implvic "Init" (read-version parms) ".scm")))
+ ;;,@`(if (equal? "" implvic) '() (...))
,@(if (string=? "" init=) '()
`((define "INITS" ,init=)))
,@(if (string=? "" compiled-init=) '()
@@ -1447,19 +1520,28 @@ CHEAP_CONTINUATIONS.")
(c-includes
(map (lambda (l) (build:lib-cc-flag l platform))
(parameter-list-ref parms 'c-lib)))
- (batch-dialect (car (parameter-list-ref parms 'batch-dialect)))
(what (car (parameter-list-ref parms 'what)))
(c-proc (plan-command ((((rdb 'open-table) 'build-whats #f)
'get 'c-proc)
what)
platform)))
+
+ (case (car (parameter-list-ref parms 'batch-dialect))
+ ((default-for-platform)
+ (let ((os ((((build 'open-table) 'platform #f)
+ 'get 'operating-system) platform)))
+ (if (not os)
+ (build:error "OS corresponding to " platform " unknown"))
+ (adjoin-parameters!
+ parms (cons 'batch-dialect (list (os->batch-dialect os)))))))
+
(adjoin-parameters!
parms
(cons 'c-defines c-defines)
- (cons 'c-includes c-includes)
- )
+ (cons 'c-includes c-includes))
- (let ((name (car (parameter-list-ref parms 'who))))
+ (let ((name (parameter-list-ref parms 'who)))
+ (set! name (if (null? name) (current-output-port) (car name)))
(batch:call-with-output-script
parms
name
@@ -1476,17 +1558,21 @@ CHEAP_CONTINUATIONS.")
;; ================ Compile C source files
(set! o-files
- (c-proc
- (map (lambda (file)
- (in-vicinity
- (car (parameter-list-ref parms 'scm-srcdir))
- file))
- (apply append
- (parameter-list-ref parms 'c-file)
- (map
- (lambda (l) (build:c-lib-support l platform))
- (parameter-list-ref parms 'c-lib))))
- parms))
+ (let ((suppressors
+ (apply append
+ (map (lambda (l) (build:c-suppress l platform))
+ (parameter-list-ref parms 'c-lib))))
+ (ssdir (car (parameter-list-ref parms 'scm-srcdir))))
+ (c-proc
+ (map (lambda (file) (in-vicinity ssdir file))
+ (apply
+ append
+ (remove-if (lambda (file) (member file suppressors))
+ (parameter-list-ref parms 'c-file))
+ (map
+ (lambda (l) (build:c-lib-support l platform))
+ (parameter-list-ref parms 'c-lib))))
+ parms)))
;; ================ Link C object files
((plan-command
@@ -1528,13 +1614,23 @@ CHEAP_CONTINUATIONS.")
(else (string-append "-D" (cadr d) "=" (object->string (caddr d))))))
defines))
-(define (guess-how pl)
- (let* ((plat (parameter-list-ref pl 'platform))
- (platform (if (pair? plat) (car plat) batch:platform)))
- (let ((os (or ((((build 'open-table) 'platform #f)
- 'get 'operating-system) platform) batch:platform)))
- (cond ((not os) (slib:error "OS corresponding to " platform " unknown"))
- (else (list (os->batch-dialect os)))))))
+(define (batch:chop-to-fit-system . args)
+ (apply batch:apply-chop-to-fit
+ batch:try-system
+ args))
+
+(define (read-version parms)
+ (call-with-input-file
+ (string-append (car (parameter-list-ref parms 'scm-srcdir)) "patchlvl.h")
+ (lambda (port)
+ (do ((c (read-char port) (read-char port)))
+ ((or (eof-object? c) (eqv? #\= c))
+ (symbol->string (read port)))))))
+
+(define (batch:rebuild-catalog parms)
+ (batch:delete-file parms
+ (in-vicinity (car (parameter-list-ref parms 'implvic))
+ "slibcat")))
(define build:initializer
(lambda (rdb)
@@ -1548,6 +1644,9 @@ CHEAP_CONTINUATIONS.")
(set! build:c-lib-support
(make-defaulting-platform-lookup
(build:c-libraries 'get 'lib-support)))
+ (set! build:c-suppress
+ (make-defaulting-platform-lookup
+ (build:c-libraries 'get 'suppress-files)))
(set! plan-command
(let ((lookup (make-defaulting-platform-lookup
(((rdb 'open-table) 'compile-commands #f)
@@ -1555,61 +1654,3 @@ CHEAP_CONTINUATIONS.")
(lambda (thing plat)
(slib:eval (lookup thing plat)))))))
(build:initializer build)
-
-(define (rebuild-catalog)
- (delete-file (in-vicinity (implementation-vicinity) "slibcat"))
- ;;(load (in-vicinity (implementation-vicinity) "mkimpcat"))
- )
-
-(define (build-from-argv argv)
- (cond ((string? argv)
- (require 'read-command)
- (set! argv (call-with-input-string argv read-command))))
- (let ()
- (define command (string->symbol (list-ref argv *optind*)))
- (define argc (length argv))
- (cond
- ((pair? argv)
- (set! *optind* (+ 1 *optind*))
- ((make-command-server build '*commands*)
- command
- (lambda (comname comval options positions arities types
- defaulters checks aliases)
- (let* ((params (getopt->parameter-list
- argc argv options arities types aliases))
- (fparams (fill-empty-parameters defaulters params)))
- (cond ((not (list? params)) #f)
- ((not (check-parameters checks fparams)) #f)
- ((not (check-arities (map arity->arity-spec arities) fparams))
- (slib:error 'build-from-argv "arity error" fparams) #f)
- (else (comval fparams))))))))))
-
-(define (build-from-whole-argv argv)
- (set! *optind* 0)
- (set! *optarg* #f)
- (build-from-argv argv))
-
-(define b build-from-whole-argv)
-
-(define (b*)
- (require 'read-command)
- (do ((e (read-command) (read-command)))
- ((eof-object? e))
- (cond ((null? e))
- (else
- (cond ((not (string-ci=? (car e) "build"))
- (set! e (cons "build" e))))
- (write (build-from-whole-argv e))
- (newline)))
- (display "build> ")
- (force-output)))
-
-(define (bi) (build-from-argv *argv*))
-
-(cond (*interactive*
- (display "type (b \"build <command-line>\") to build") (newline)
- (display "type (b*) to enter build command loop") (newline)))
-
-;;; Local Variables:
-;;; mode:scheme
-;;; End:
diff --git a/continue.c b/continue.c
index 2f0f225..a41931e 100644
--- a/continue.c
+++ b/continue.c
@@ -186,13 +186,17 @@ void dynthrow(a)
register long j;
register STACKITEM *src, *dst = cont->stkbse;
# ifdef STACK_GROWS_UP
+# ifndef hpux
if (a[2] && (a - ((long *)a[3]) < SCM_GROWTH))
puts("grow_throw: check if long growth[]; being optimized out");
+# endif
/* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
if PTR_GE(dst + (cont->length), (STACKITEM *)&a) grow_throw(a);
# else
+# ifndef hpux
if (a[2] && (((long *)a[3]) - a < SCM_GROWTH))
puts("grow_throw: check if long growth[]; being optimized out");
+# endif
/* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
dst -= cont->length;
if PTR_LE(dst, (STACKITEM *)&a) grow_throw(a);
diff --git a/continue.h b/continue.h
index 3c213e0..e917314 100644
--- a/continue.h
+++ b/continue.h
@@ -64,9 +64,16 @@
# else /* ndef _CRAY1 */
# include <setjmp.h>
-# define jump_buf jmp_buf
-# define setjump setjmp
-# define longjump longjmp
+# include <signal.h>
+# ifdef SIG_UNBLOCK
+# define jump_buf sigjmp_buf
+# define setjump(buf) sigsetjmp((buf), !0)
+# define longjump siglongjmp
+# else
+# define jump_buf jmp_buf
+# define setjump setjmp
+# define longjump longjmp
+# endif /* ndef HAVE_SIGSETJMP */
# endif /* ndef _CRAY1 */
#endif /* ndef vax */
@@ -83,6 +90,9 @@
#ifdef THINK_C
# define SHORT_ALIGN
#endif
+#ifdef __MWERKS__
+# define SHORT_ALIGN
+#endif
#ifdef MSDOS
# define SHORT_ALIGN
#endif
diff --git a/debian/changelog b/debian/changelog
index ed01d96..c94c8fb 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,40 @@
+scm (5c3-5) frozen unstable; urgency=low
+
+ * debian/rules chmod +x's bld.scm. Fixes #30521.
+
+ -- David N. Welton <davidw@efn.org> Fri, 11 Dec 1998 20:21:49 -0800
+
+scm (5c3-4) frozen unstable; urgency=low
+
+ * Made bld.scm executable. Fixes #29578.
+
+ -- David N. Welton <davidw@efn.org> Mon, 30 Nov 1998 20:57:12 -0800
+
+scm (5c3-3) frozen unstable; urgency=low
+
+ * -nw
+ * Fixes #16762.
+ * Fixes #18163.
+ * Fixes #18164.
+ * Fixes #23743.
+ * Fixes #24098.
+ * Fixes #24099.
+ * Fixes #24547.
+
+ -- David N. Welton <davidw@efn.org> Mon, 9 Nov 1998 21:41:29 -0800
+
+scm (5c3-2) frozen unstable; urgency=low
+
+ * Re-uploading for slink freeze.
+
+ -- David N. Welton <davidw@efn.org> Mon, 2 Nov 1998 21:06:01 -0800
+
+scm (5c3-1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- David N. Welton <davidw@efn.org> Thu, 29 Oct 1998 21:37:49 -0800
+
scm (5b3-1) unstable; urgency=low
* New maintainer
diff --git a/debian/control b/debian/control
index ef0a30b..9660bb5 100644
--- a/debian/control
+++ b/debian/control
@@ -1,8 +1,8 @@
Source: scm
Section: devel
Priority: optional
-Maintainer: Rob Browning <rlb@cs.utexas.edu>
-Standards-Version: 2.1.1.2
+Maintainer: David N. Welton <davidw@efn.org>
+Standards-Version: 2.5.0.0
Package: scm
Architecture: any
diff --git a/debian/postrm b/debian/postrm
index 03e39ad..e7f4756 100644
--- a/debian/postrm
+++ b/debian/postrm
@@ -1,4 +1,4 @@
#!/bin/sh
set -e
-install-info --quiet --remove slib
+install-info --quiet --remove scm
diff --git a/debian/require.scm.debian b/debian/require.scm.debian
index d876879..06e43e6 100644
--- a/debian/require.scm.debian
+++ b/debian/require.scm.debian
@@ -1,2 +1,2 @@
-(define (library-vicinity) "/usr/lib/slib/")
+(define (library-vicinity) "/usr/share/slib/")
(load (in-vicinity (library-vicinity) "require"))
diff --git a/debian/rules b/debian/rules
index c3b6b26..07e44fa 100755
--- a/debian/rules
+++ b/debian/rules
@@ -21,21 +21,20 @@ SCM_OPTIONS = -p linux --compiler-options=-O2 --compiler-options=-g \
-F array-for-each \
-F inexact \
-F record \
- -F compiled-closure \
+ -F compiled-closure \
-F generalized-c-arguments \
-F tick-interrupts \
-F i/o-extensions \
-# -F turtlegr \
-F curses \
-F edit-line \
-F regex \
-F socket \
- -F posix \
+ -F posix \
-F unix \
-F dynamic-linking \
-F dump \
-F heap-can-shrink \
- -F macro
+ -F macro
NON_LIB_FILES = 'bench.scm|build.scm|example.scm|r4rstest.scm|pi.scm'
@@ -44,12 +43,14 @@ NON_LIB_FILES = 'bench.scm|build.scm|example.scm|r4rstest.scm|pi.scm'
# make checklit
build:
+ chmod +x bld.scm
$(checkdir)
+ cp debian/require.scm.debian require.scm
${MAKE} scmlit
- test -e /usr/lib/slib || \
+ test -e /usr/share/slib || \
(echo "Must have slib installed for compile" && exit 1)
- cp debian/require.scm.debian require.scm
- SCHEME_LIBRARY_PATH=/usr/lib/slib/ ./build.scm ${SCM_OPTIONS} > debian/bld
+# SCHEME_LIBRARY_PATH=/usr/share/slib/ ./build.scm ${SCM_OPTIONS} > debian/bld
+ ./bld.scm ${SCM_OPTIONS} > debian/bld
chmod ug+x debian/bld
debian/bld
-rm -f debian/bld
diff --git a/disarm.scm b/disarm.scm
new file mode 100644
index 0000000..d77ac2b
--- /dev/null
+++ b/disarm.scm
@@ -0,0 +1,159 @@
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "disarm.scm", Make SCM safe for client-server applications.
+;;; Author: Aubrey Jaffer.
+
+(define (disarm name)
+ (lambda args
+ ;;(if (memq? name *features*) (set! *features* (remove name *features)))
+ (error name 'disabled)))
+
+(define abort quit)
+(define restart (disarm 'restart))
+(define ed (disarm 'ed))
+#+vms
+(define vms-debug (disarm 'vms-debug))
+
+;; opening files
+(define open-file (disarm 'open-file))
+(define transcript-on (disarm 'transcript-on))
+
+#+i/o-extensions
+(begin
+ (define system (disarm 'system))
+ (define execvp (disarm 'exec))
+ (define execv execvp)
+ (define execlp execvp)
+ (define execl execvp)
+ (define putenv (disarm 'putenv))
+ (define stat (disarm 'stat))
+ (define reopen-file (disarm 'reopen-file))
+ (define duplicate-port (disarm 'duplicate-port))
+ (define redirect-port! (disarm 'redirect-port!))
+ (define opendir (disarm 'opendir))
+ (define mkdir (disarm 'mkdir))
+ (define rmdir (disarm 'rmdir))
+ (define chdir (disarm 'chdir))
+ (define rename-file (disarm 'rename-file))
+ (define chmod (disarm 'chmod))
+ (define utime (disarm 'utime))
+ (define umask (disarm 'umask))
+ (define fileno (disarm 'fileno))
+ (define access (disarm 'access))
+ )
+#+posix
+(begin
+ (define open-pipe (disarm 'open-pipe))
+ (define fork (disarm 'fork))
+ (define setuid (disarm 'setuid))
+ (define setgid (disarm 'setgid))
+ (define seteuid (disarm 'seteuid))
+ (define setegid (disarm 'setegid))
+ (define kill (disarm 'kill))
+ (define waitpid (disarm 'waitpid))
+ (define uname (disarm 'uname))
+ (define getpw (disarm 'getpw))
+ (define getgr (disarm 'getgr))
+ (define getgroups (disarm 'getgroups))
+ (define link (disarm 'link))
+ (define chown (disarm 'chown))
+ )
+;;#+unix
+;;(begin
+;; (define symlink (disarm 'symlink))
+;; (define readlink (disarm 'readlink))
+;; (define lstat (disarm 'lstat))
+;; (define nice (disarm 'nice))
+;; (define acct (disarm 'acct))
+;; (define mknod (disarm 'mknod))
+;; )
+
+#+edit-line
+(error 'edit-line 'inappropriate-for-server)
+#+curses
+(error 'curses 'inappropriate-for-server)
+#+turtle-graphics
+(error 'turtle-graphics 'inappropriate-for-server)
+
+;;#+socket
+;;(begin
+;; (define make-stream-socket (disarm 'make-stream-socket))
+;; (define make-stream-socketpair (disarm 'make-stream-socketpair))
+;; (define socket:connect (disarm 'socket:connect))
+;; (define socket:bind (disarm 'socket:bind))
+;; (define socket:listen (disarm 'socket:listen))
+;; (define socket:accept (disarm 'socket:accept))
+;; )
+
+;; load
+(define load (disarm 'load))
+(define try-load load)
+(define scm:load load)
+(define scm:load-source load)
+(define link:link (disarm 'link:link))
+
+;; SLIB loads
+(define base:load load)
+(define slib:load load)
+(define slib:load-compiled load)
+(define slib:load-source load)
+(define defmacro:load load)
+(define macro:load load)
+;;(define macwork:load load)
+;;(define syncase:load load)
+;;(define synclo:load load)
+
+;;;; eval
+;;(define eval (disarm 'eval))
+;;(define eval-string eval)
+;;(define interaction-environment (disarm 'interaction-environment))
+;;(define scheme-report-environment (disarm 'scheme-report-environment))
+
+;;;; SLIB evals
+;;(define base:eval eval)
+;;(define slib:eval eval)
+;;(define defmacro:eval eval)
+;;(define macro:eval eval)
+;;(define macwork:eval eval)
+;;(define repl:eval eval)
+;;(define syncase:eval eval)
+;;(define syncase:eval-hook eval)
+;;(define synclo:eval eval)
diff --git a/dynl.c b/dynl.c
index 7e90a8a..8fcf7aa 100644
--- a/dynl.c
+++ b/dynl.c
@@ -121,7 +121,7 @@ SCM l_dyn_main_call(symb, shl, args)
else dld_perror("DLDP");
if (!i) listundefs();
if (!func) {
- must_free_argv(argv);
+ must_free_argv(argv, 0);
ALLOW_INTS;
dld_perror("DLD");
return BOOL_F;
@@ -131,7 +131,7 @@ SCM l_dyn_main_call(symb, shl, args)
i = (*func) ((int)ilength(args), argv);
/* *loc_loadpath = oloadpath; */
DEFER_INTS;
- must_free_argv(argv);
+ must_free_argv(argv, 0);
ALLOW_INTS;
return MAKINUM(0L+i);
}
@@ -156,19 +156,22 @@ static iproc subr1s[] = {
void init_dynl()
{
# ifndef RTL
+ if (!execpath) execpath = scm_find_executable();
if ((!execpath) || dld_init(execpath)) {
dld_perror("DLD:");
/* wta(CAR(progargs), "couldn't init", "dld"); */
return;
}
# endif
- init_iprocs(subr1s, tc7_subr_1);
- make_subr(s_call, tc7_subr_2, l_dyn_call);
- make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
- add_feature("dld");
+ if (!dumped) {
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_call, tc7_subr_2, l_dyn_call);
+ make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+ add_feature("dld");
# ifdef DLD_DYNCM
- add_feature("dld:dyncm");
+ add_feature("dld:dyncm");
# endif
+ }
}
#else
@@ -180,7 +183,7 @@ int prinshl(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#<shl ", port);
- intprint(CDR(exp), 16, port);
+ intprint(CDR(exp), -16, port);
lputc('>', port);
return 1;
}
@@ -194,13 +197,13 @@ SCM l_dyn_link(fname)
SCM z;
shl_t shl;
ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ NEWCELL(z);
DEFER_INTS;
shl = shl_load(CHARS(fname), BIND_DEFERRED , 0L);
if (NULL==shl) {
ALLOW_INTS;
return BOOL_F;
}
- NEWCELL(z);
SETCHARS(z, shl);
CAR(z) = tc16_shl;
ALLOW_INTS;
@@ -252,7 +255,7 @@ SCM l_dyn_main_call(symb, shl, args)
i = (*func) ((int)ilength(args), argv);
/* *loc_loadpath = oloadpath; */
DEFER_INTS;
- must_free_argv(argv);
+ must_free_argv(argv, 0);
ALLOW_INTS;
return MAKINUM(0L+i);
}
@@ -275,11 +278,13 @@ static iproc subr1s[] = {
{0, 0}};
void init_dynl()
{
- tc16_shl = newsmob(&shlsmob);
- init_iprocs(subr1s, tc7_subr_1);
- make_subr(s_call, tc7_subr_2, l_dyn_call);
- make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
- add_feature("shl");
+ if (!dumped) {
+ tc16_shl = newsmob(&shlsmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_call, tc7_subr_2, l_dyn_call);
+ make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+ add_feature("shl");
+ }
}
# endif
#endif
@@ -337,7 +342,9 @@ SCM dynl(dir, symbol, fname)
void init_dynl()
{
+ if (!dumped) {
make_subr(s_dynl, tc7_subr_3, dynl);
+ }
}
#endif
@@ -369,7 +376,7 @@ int prinshl(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#<shl ", port);
- intprint(CDR(exp), 16, port);
+ intprint(CDR(exp), -16, port);
lputc('>', port);
return 1;
}
@@ -384,13 +391,21 @@ SCM l_dyn_link(fname)
void *handle;
if FALSEP(fname) return fname;
ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ NEWCELL(z);
DEFER_INTS;
handle = dlopen(CHARS(fname), DLOPEN_MODE);
if (NULL==handle) {
- ALLOW_INTS;
+ if (verbose > 2) {
+ char *dlr = dlerror();
+ ALLOW_INTS;
+ if (dlr) {
+ lputs(s_link, cur_errp);
+ lputs(": ", cur_errp);
+ lputs(dlr, cur_errp);
+ newline(cur_errp);
+ }}
return BOOL_F;
}
- NEWCELL(z);
SETCHARS(z, handle);
CAR(z) = tc16_shl;
ALLOW_INTS;
@@ -408,9 +423,14 @@ SCM l_dyn_call(symb, shl)
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
- const char *dlr = dlerror();
+ char *dlr = dlerror();
ALLOW_INTS;
- if (dlr) puts(dlr);
+ if (dlr) {
+ lputs(s_call, cur_errp);
+ lputs(": ", cur_errp);
+ lputs(dlr, cur_errp);
+ newline(cur_errp);
+ }
return BOOL_F;
}
ALLOW_INTS;
@@ -432,9 +452,14 @@ SCM l_dyn_main_call(symb, shl, args)
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
- const char *dlr = dlerror();
+ char *dlr = dlerror();
ALLOW_INTS;
- if (dlr) puts(dlr);
+ if (dlr) {
+ lputs(s_main_call, cur_errp);
+ lputs(": ", cur_errp);
+ lputs(dlr, cur_errp);
+ newline(cur_errp);
+ }
return BOOL_F;
}
argv = makargvfrmstrs(args, s_main_call);
@@ -468,10 +493,172 @@ static iproc subr1s[] = {
void init_dynl()
{
- tc16_shl = newsmob(&shlsmob);
- init_iprocs(subr1s, tc7_subr_1);
- make_subr(s_call, tc7_subr_2, l_dyn_call);
- make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
- add_feature("sun-dl");
+ if (!dumped) {
+ tc16_shl = newsmob(&shlsmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_call, tc7_subr_2, l_dyn_call);
+ make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+ add_feature("sun-dl");
+ }
}
#endif /* SUN_DL */
+
+#ifdef macintosh
+
+# include <CodeFragments.h>
+# include <Errors.h>
+
+# define SHL(obj) ((void*)CDR(obj))
+
+sizet frshl(ptr)
+ CELLPTR ptr;
+{
+# if 0
+ /* Should freeing a shl close and possibly unmap the object file it */
+ /* refers to? */
+ if(SHL(ptr))
+ dlclose(SHL(ptr));
+# endif
+ return 0;
+}
+
+int prinshl(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ lputs("#<shl ", port);
+ intprint(CDR(exp), 16, port);
+ lputc('>', port);
+ return 1;
+}
+int tc16_shl;
+static smobfuns shlsmob = {mark0, frshl, prinshl};
+
+static char s_link[] = "dyn:link", s_call[] = "dyn:call";
+SCM l_dyn_link(fname)
+ SCM fname;
+{
+ OSErr err;
+ SCM z;
+ void *handle;
+ Str63 libName;
+ CFragConnectionID connID;
+ Ptr mainAddr;
+ Str255 errMessage;
+
+ if FALSEP(fname) return fname;
+ ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ NEWCELL(z);
+ DEFER_INTS;
+ strcpy((char *)libName, CHARS(fname));
+ c2pstr((char *)libName);
+ err = GetSharedLibrary (libName, kCompiledCFragArch, kReferenceCFrag,
+ &connID, &mainAddr, errMessage);
+
+ if (err!=noErr) {
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ SETCHARS(z, (void *)connID);
+ CAR(z) = tc16_shl;
+ ALLOW_INTS;
+ /* linkpath = fname; */
+ return z;
+}
+
+SCM l_dyn_call(symb, shl)
+ SCM symb, shl;
+{
+ void (*func)() = 0;
+ OSErr err;
+ CFragSymbolClass symClass;
+ Str255 symName;
+
+ /* SCM oloadpath = *loc_loadpath; */
+ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ DEFER_INTS;
+
+ strcpy((char *)symName, CHARS(symb));
+ c2pstr((char *)symName);
+ err = FindSymbol((CFragConnectionID)SHL(shl), symName,
+ (Ptr *)&func, &symClass);
+ if (err!=noErr /* || symClass != kCodeCFragSymbol */) {
+ ALLOW_INTS;
+ if (err == cfragConnectionIDErr) puts("Invalid library connection.");
+ if (err == cfragNoSymbolErr) puts("Symbol not found.");
+ return BOOL_F;
+ }
+ ALLOW_INTS;
+ /* *loc_loadpath = linkpath; */
+ (*func) ();
+ /* *loc_loadpath = oloadpath; */
+ return BOOL_T;
+}
+static char s_main_call[] = "dyn:main-call";
+SCM l_dyn_main_call(symb, shl, args)
+ SCM symb, shl, args;
+{
+ int i;
+ int (*func)P((int argc, char **argv)) = 0;
+ char **argv;
+ OSErr err;
+ CFragSymbolClass symClass;
+ Str255 symName;
+
+ /* SCM oloadpath = *loc_loadpath; */
+ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+ DEFER_INTS;
+ strcpy((char *)symName, CHARS(symb));
+ c2pstr((char *)symName);
+ err = FindSymbol((CFragConnectionID)SHL(shl), symName,
+ (Ptr *)&func, &symClass);
+ if (err!=noErr || symClass != kCodeCFragSymbol) {
+ ALLOW_INTS;
+ if (err == cfragConnectionIDErr) puts("Invalid library connection.");
+ if (err == cfragNoSymbolErr) puts("Symbol not found.");
+ return BOOL_F;
+ }
+ argv = makargvfrmstrs(args, s_main_call);
+ ALLOW_INTS;
+ /* *loc_loadpath = linkpath; */
+ i = (*func) ((int)ilength(args), argv);
+ /* *loc_loadpath = oloadpath; */
+ DEFER_INTS;
+ must_free_argv(argv, 0);
+ ALLOW_INTS;
+ return MAKINUM(0L+i);
+}
+
+static char s_unlink[] = "dyn:unlink";
+SCM l_dyn_unlink(shl)
+ SCM shl;
+{
+ OSErr status;
+ CFragConnectionID connID;
+
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ DEFER_INTS;
+ connID = (CFragConnectionID)SHL(shl);
+ status = CloseConnection(&connID);
+ SETCHARS(shl, NULL);
+ ALLOW_INTS;
+ if (status!=noErr) return BOOL_T;
+ return BOOL_F;
+}
+static iproc subr1s[] = {
+ {s_link, l_dyn_link},
+ {s_unlink, l_dyn_unlink},
+ {0, 0}};
+
+void init_dynl()
+{
+ if (!dumped) {
+ tc16_shl = newsmob(&shlsmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_call, tc7_subr_2, l_dyn_call);
+ make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+ add_feature("mac-dl");
+ }
+}
+#endif /* MACOS */
diff --git a/eval.c b/eval.c
index 8620edc..335be3b 100644
--- a/eval.c
+++ b/eval.c
@@ -47,18 +47,130 @@
#define I_SYM(x) (CAR((x)-1L))
#define I_VAL(x) (CDR((x)-1L))
-#ifdef MACRO
-# define ATOMP(x) (5==(5 & (int)CAR(x)))
-# define EVALCELLCAR(x,env) (ATOMP(CAR(x))?evalatomcar(x,env):ceval(CAR(x),env))
+#define ATOMP(x) (5==(5 & (int)CAR(x)))
+#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x):ceval_1(CAR(x)))
+
+/* Environment frames are initially allocated in a small cache ("ecache").
+ This cache is subject to copying gc, cells in it may be moved to the
+ general purpose Scheme heap by a call to any routine that allocates cells
+ in the cache.
+
+ Global variables scm_env and scm_env_tmp are used as software
+ registers: scm_env is the current lexical environment, scm_env_tmp
+ is used for protecting environment frames under construction and not
+ yet linked into the environment.
+
+ In order to protect environments from garbage collection, a stack of
+ environments (scm_estk) is maintained. scm_env and scm_env_tmp may
+ be pushed on or popped off the stack using the macros ENV_PUSH and
+ ENV_POP.
+
+ It is not safe to pass objects that may allocated in the ecache as
+ arguments to C functions, or to return them from C functions, since
+ such objects may be moved by the ecache gc. Ecache gc may happen
+ anywhere interrupts are not deferred, because some interrupt
+ handlers may evaluate Scheme code and then return.
+
+ Interrupts may be deferred with DEFER_INTS_EGC: This will prevent
+ interrupts until an ALLOW_INTS or ALLOW_INTS_EGC, which may happen
+ any time Scheme code is evaluated. It is not necessary to strictly
+ nest DEFER_INTS_EGC and ALLOW_INTS_EGC since ALLOW_INTS_EGC is
+ called in ceval_1 before any subrs are called.
+
+ Instead of using the C stack and deferring interrupts, objects which
+ might have been allocated in the ecache may be passed using the
+ global variables scm_env_tmp and scm_env.
+
+ If the CDR of a cell that might be allocated in the regular heap is
+ made to point to a cell allocated in the cache, then the first cell
+ must be recorded as a gc root, using the macro EGC_ROOT. There is
+ no provision for allowing the CAR of a regular cell to point to a
+ cache cell. */
+
+#ifdef NO_ENV_CACHE
+# define scm_env_cons(a,b) {scm_env_tmp=cons((a),(b));}
+# define scm_env_cons2(a,b,c) {scm_env_tmp=cons2((a),(b),(c));}
+# define scm_env_cons_tmp(a) {scm_env_tmp=cons((a),scm_env_tmp);}
+# define EXTEND_ENV(names) {scm_env=acons((names),scm_env_tmp,scm_env);}
#else
-# define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env)
+# define EXTEND_ENV scm_extend_env
+#endif
+
+SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED;
+long tc16_env; /* Type code for environments passed to macro
+ transformers. */
+SCM nconc2copy P((SCM x));
+SCM copy_list P((SCM x));
+SCM rename_ident P((SCM id, SCM env));
+SCM eqv P((SCM x, SCM y));
+void scm_dynthrow P((CONTINUATION *cont, SCM val));
+void scm_egc P((void));
+void scm_estk_grow P((sizet inc));
+void scm_estk_shrink P((void));
+int badargsp P((SCM proc, SCM args));
+
+static SCM ceval_1 P((SCM x));
+static SCM evalatomcar P((SCM x));
+static SCM evalcar P((SCM x));
+static SCM id2sym P((SCM id));
+static SCM iqq P((SCM form));
+static SCM m_body P((SCM op, SCM xorig, char *what));
+static SCM m_iqq P((SCM form, int depth, SCM env));
+static SCM m_letrec1 P((SCM op, SCM imm, SCM xorig, SCM env));
+static SCM macroexp1 P((SCM x, int check));
+static SCM unmemocar P((SCM x));
+static SCM wrapenv P((void));
+static SCM *id_denote P((SCM var));
+static int prinenv P((SCM exp, SCM port, int writing));
+static int prinid P((SCM exp, SCM port, int writing));
+static int prinmacro P((SCM exp, SCM port, int writing));
+static int prinprom P((SCM exp, SCM port, int writing));
+static void bodycheck P((SCM xorig, SCM *bodyloc, char *what));
+static void unpaint P((SCM *p));
+#ifdef CAREFUL_INTS
+static void debug_env_warn P((char *fnam, long line, char *what));
+#endif
+
+/* Flush global variable state to estk. */
+#define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;}
+
+/* Make global variable state consistent with estk. */
+#define ENV_RESTORE {scm_env=scm_estk_ptr[0]; scm_env_tmp=scm_estk_ptr[1];}
+
+#define ENV_PUSH {DEFER_INTS_EGC; ENV_SAVE;\
+ if (INUM0==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow(20);\
+ else scm_estk_ptr += SCM_ESTK_FRLEN;}
+
+#define ENV_POP {DEFER_INTS_EGC;\
+ if (INUM0==scm_estk_ptr[-SCM_ESTK_FRLEN]) scm_estk_shrink();\
+ else scm_estk_ptr -= SCM_ESTK_FRLEN; ENV_RESTORE;}
+
+#ifdef NO_ENV_CACHE
+# define EGC_ROOT(x) /**/
+#else
+# ifdef CAREFUL_INTS
+# define EGC_ROOT(x) {if (!ints_disabled) \
+ debug_env_warn(__FILE__,__LINE__,"EGC_ROOT"); \
+ scm_egc_roots[--scm_egc_root_index] = (x); \
+ if (0==scm_egc_root_index) scm_egc();}
+# else
+# define EGC_ROOT(x) {scm_egc_roots[--scm_egc_root_index] = (x);\
+ if (0==scm_egc_root_index) scm_egc();}
+# endif
#endif
-#define EVALIMP(x, env) (ILOCP(x)?*ilookup((x), env):x)
-#define EVALCAR(x, env) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x), env):\
- I_VAL(CAR(x))):EVALCELLCAR(x, env))
-#define EXTEND_ENV acons
+#define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;}
+#define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;}
+#define SIDEVAL_1(x) if NIMP(x) ceval_1(x)
+#ifdef CAUTIOUS
+# define TRACE(x) scm_estk_ptr[2]=(x)
+#else
+# define TRACE(x) /**/
+#endif
+#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
+#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\
+ I_VAL(CAR(x))):EVALCELLCAR(x))
long tc16_macro; /* Type code for macros */
#define MACROP(x) (tc16_macro==TYP16(x))
@@ -75,26 +187,148 @@ static char s_escaped[] = "escaped synthetic identifier";
# define ENV_MARK BOOL_T
#else
# define IDENTP SYMBOLP
+# define M_IDENTP(x) (0)
#endif
-SCM *ilookup(iloc, env)
- SCM iloc, env;
+/* #define SCM_PROFILE */
+#ifdef SCM_PROFILE
+long eval_cases[128];
+long eval_cases_other[NUM_ISYMS];
+long ilookup_cases[10][10][2]; /* frame, dist, icdrp */
+long eval_clo_cases[5][4]; /* actual args, required args */
+SCM scm_profile(resetp)
+ SCM resetp;
+{
+ SCM ev = make_uve(sizeof(eval_cases)/sizeof(long), MAKINUM(-1));
+ SCM evo = make_uve(sizeof(eval_cases_other)/sizeof(long), MAKINUM(-1));
+ SCM il = dims2ura(cons2(MAKINUM(10), MAKINUM(10), cons(MAKINUM(2), EOL)),
+ MAKINUM(-1), EOL);
+ SCM evc = dims2ura(cons2(MAKINUM(5), MAKINUM(4), EOL), MAKINUM(-1), EOL);
+ long *v = (long *)VELTS(ev);
+ int i;
+ for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++)
+ v[i] = eval_cases[i];
+ v = (long *)VELTS(evo);
+ for (i = 0; i < sizeof(eval_cases_other)/sizeof(long); i++)
+ v[i] = eval_cases_other[i];
+ v = (long *)VELTS(ARRAY_V(il));
+ for (i = 0; i < sizeof(ilookup_cases)/sizeof(long); i++)
+ v[i] = ((long *)ilookup_cases)[i];
+ v = (long *)VELTS(ARRAY_V(evc));
+ for (i = 0; i < sizeof(eval_clo_cases)/sizeof(long); i++)
+ v[i] = ((long *)eval_clo_cases)[i];
+ if (! UNBNDP(resetp)) {
+ for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++)
+ eval_cases[i] = 0;
+ for (i = 0; i < sizeof(eval_cases_other)/sizeof(long); i++)
+ eval_cases_other[i] = 0;
+ for (i = 0; i < sizeof(ilookup_cases)/sizeof(long); i++)
+ ((long *)ilookup_cases)[i] = 0;
+ for (i = 0; i < sizeof(eval_clo_cases)/sizeof(long); i++)
+ ((long *)eval_clo_cases)[i] = 0;
+ }
+ return cons2(ev, evo, cons2(il, evc, EOL));
+}
+#endif
+
+#ifdef CAREFUL_INTS
+# undef CAR
+# define CAR(x) (*debug_env_car((x), __FILE__, __LINE__))
+# undef CDR
+# define CDR(x) (*debug_env_cdr((x), __FILE__, __LINE__))
+/* Inhibit warnings for ARGC, is not changed by egc. */
+# undef ARGC
+# define ARGC(x) ((6L & (((cell *)(SCM2PTR(x)))->cdr))>>1)
+#include <signal.h>
+SCM test_ints(x)
+ SCM x;
+{
+ static int cnt = 100;
+ if (0==--cnt) {
+ cnt = 100;
+ DEFER_INTS;
+ scm_egc();
+ ALLOW_INTS;
+ /* l_raise(MAKINUM(SIGALRM)); */
+ }
+ return x;
+}
+int ecache_p(x)
+ SCM x;
+{
+ register CELLPTR ptr;
+ if NCELLP(x) return 0;
+ ptr = (CELLPTR)SCM2PTR(x);
+ if (PTR_LE(scm_ecache, ptr)
+ && PTR_GT(scm_ecache+scm_ecache_len, ptr))
+ return !0;
+ return 0;
+}
+static void debug_env_warn(fnam, line, what)
+ char *fnam;
+ long line;
+ char *what;
+{
+ lputs(fnam, cur_errp);
+ lputc(':', cur_errp);
+ intprint(line, 10, cur_errp);
+ lputs(": unprotected ", cur_errp);
+ lputs(what, cur_errp);
+ lputs(" of ecache value\n", cur_errp);
+}
+SCM *debug_env_car(x, fnam, line)
+ SCM x;
+ char *fnam;
+ long line;
+{
+ SCM *ret;
+ if (!ints_disabled && ecache_p(x))
+ debug_env_warn(fnam, line, "CAR");
+ ret = &(((cell *)(SCM2PTR(x)))->car);
+ if (!ints_disabled && NIMP(*ret) && ecache_p(*ret))
+ debug_env_warn(fnam, line, "CAR");
+ return ret;
+}
+SCM *debug_env_cdr(x, fnam, line)
+ SCM x;
+ char *fnam;
+ long line;
+{
+ SCM *ret;
+ if (!ints_disabled && ecache_p(x))
+ debug_env_warn(fnam, line, "CDR");
+ ret = &(((cell *)(SCM2PTR(x)))->cdr);
+ if (!ints_disabled && NIMP(*ret) && ecache_p(*ret))
+ debug_env_warn(fnam, line, "CAR");
+ return ret;
+}
+#endif /* CAREFUL_INTS */
+
+SCM *ilookup(iloc)
+ SCM iloc;
{
register int ir = IFRAME(iloc);
- register SCM er = env;
+ register SCM er;
+#ifdef SCM_PROFILE
+ ilookup_cases[ir<10 ? ir : 9]
+ [IDIST(iloc)<10 ? IDIST(iloc) : 9][ICDRP(iloc)?1:0]++;
+#endif
+ DEFER_INTS_EGC;
+ er = scm_env;
for(;0 != ir;--ir) er = CDR(er);
er = CAR(er);
for(ir = IDIST(iloc);0 != ir;--ir) er = CDR(er);
if ICDRP(iloc) return &CDR(er);
return &CAR(CDR(er));
}
-
-SCM *farlookup(farloc, env)
- SCM farloc, env;
+SCM *farlookup(farloc)
+ SCM farloc;
{
register int ir;
- register SCM er = env;
+ register SCM er;
SCM x = CDR(farloc);
+ DEFER_INTS_EGC;
+ er = scm_env;
for (ir = INUM(CAR(x)); 0 != ir; --ir) er = CDR(er);
er = CAR(er);
for (ir = INUM(CDR(x)); 0 != ir; --ir) er = CDR(er);
@@ -102,15 +336,23 @@ SCM *farlookup(farloc, env)
return &CAR(CDR(er));
}
-SCM *lookupcar(vloc, genv)
- SCM vloc, genv;
+static char s_badkey[] = "Use of keyword as variable",
+ s_unbnd[] = "unbound variable: ", s_wtap[] = "Wrong type to apply: ";
+/* check is logical OR of LOOKUP_UNDEFP and LOOKUP_MACROP */
+#define LOOKUP_UNDEFP 1
+#define LOOKUP_MACROP 2
+SCM *lookupcar(vloc, check)
+ SCM vloc;
+ int check;
{
- SCM env = genv;
+ SCM env;
register SCM *al, fl, var = CAR(vloc);
register unsigned int idist, iframe = 0;
#ifdef MACRO
SCM mark = IDENT_MARK(var);
#endif
+ DEFER_INTS_EGC;
+ env = scm_env;
for(; NIMP(env); env = CDR(env)) {
idist = 0;
al = &CAR(env);
@@ -123,6 +365,14 @@ SCM *lookupcar(vloc, genv)
#endif
if NCONSP(fl)
if (fl==var) {
+#ifndef RECKLESS
+ if ((check & LOOKUP_UNDEFP)
+ && UNBNDP(CDR(*al))) { env = EOL; goto errout; }
+# ifdef MACRO
+ if ((check & LOOKUP_MACROP)
+ && (NIMP(CDR(*al)) && MACROP(CDR(*al)))) goto badkey;
+# endif
+#endif
#ifndef TEST_FARLOC
if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
CAR(vloc) = MAKILOC(iframe, idist) + ICDR;
@@ -135,7 +385,12 @@ SCM *lookupcar(vloc, genv)
al = &CDR(*al);
if (CAR(fl)==var) {
#ifndef RECKLESS /* letrec inits to UNDEFINED */
- if UNBNDP(CAR(*al)) {env = EOL; goto errout;}
+ if ((check & LOOKUP_UNDEFP)
+ && UNBNDP(CAR(*al))) {env = EOL; goto errout;}
+# ifdef MACRO
+ if ((check & LOOKUP_MACROP)
+ && NIMP(CAR(*al)) && MACROP(CAR(*al))) goto badkey;
+# endif
#endif
#ifndef TEST_FARLOC
if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
@@ -157,24 +412,33 @@ SCM *lookupcar(vloc, genv)
#endif
var = sym2vcell(var);
#ifndef RECKLESS
- if (NNULLP(env) || UNBNDP(CDR(var))) {
+ if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) {
var = CAR(var);
errout:
- everr(vloc, genv, var,
+ everr(vloc, wrapenv() /*scm_env*/, var,
# ifdef MACRO
M_IDENTP(var) ? s_escaped :
# endif
- (NULLP(env) ? "unbound variable: " : "damaged environment"), "");
+ (NULLP(env) ? s_unbnd : "damaged environment"), "");
+ }
+# ifdef MACRO
+ if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) {
+ var = CAR(var);
+ badkey: everr(vloc, wrapenv()/*scm_env*/, var, s_badkey, "");
}
+# endif
#endif
CAR(vloc) = var + 1;
return &CDR(var);
}
-static SCM unmemocar(form, env)
- SCM form, env;
+static SCM unmemocar(form)
+ SCM form;
{
+ SCM env;
register int ir;
+ DEFER_INTS_EGC;
+ env = scm_env;
if IMP(form) return form;
if (1==TYP3(form))
CAR(form) = I_SYM(CAR(form));
@@ -187,47 +451,44 @@ static SCM unmemocar(form, env)
return form;
}
-#ifdef MACRO
/* CAR(x) is known to be a cell but not a cons */
-static char s_badkey[] = "Use of keyword as variable";
-static SCM evalatomcar(x, env)
- SCM x, env;
+static SCM evalatomcar(x)
+ SCM x;
{
SCM r;
switch TYP7(CAR(x)) {
default:
- everr(x, env, CAR(x), "Cannot evaluate: ", "");
+ everr(x, wrapenv() /*scm_env*/, CAR(x), "Cannot evaluate: ", "");
case tcs_symbols:
lookup:
- r = *lookupcar(x, env);
-# ifndef RECKLESS
- if (NIMP(r) && MACROP(r)) {
- x = cons(CAR(x), CDR(x));
- unmemocar(x, env);
- everr(x, env, CAR(x), s_badkey, "");
- }
-# endif
- return r;
+ return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP);
case tc7_vector:
+#ifndef RECKLESS
+ if (2 <= verbose) warn("unquoted ", s_vector);
+#endif
+ r = cons2(IM_QUOTE, CAR(x), EOL);
+ CAR(x) = r;
+ return CAR(CDR(r));
+ case tc7_smob:
+#ifdef MACRO
+ if M_IDENTP(CAR(x)) goto lookup;
+#endif
+ /* fall through */
case tc7_string:
case tc7_bvect: case tc7_ivect: case tc7_uvect:
case tc7_fvect: case tc7_dvect: case tc7_cvect:
return CAR(x);
- case tc7_smob:
- if M_IDENTP(CAR(x)) goto lookup;
- return CAR(x);
}
}
-#endif /* def MACRO */
-SCM eval_args(l, env)
- SCM l, env;
+SCM eval_args(l)
+ SCM l;
{
SCM res = EOL, *lloc = &res;
while NIMP(l) {
- *lloc = cons(EVALCAR(l, env), EOL);
- lloc = &CDR(*lloc);
- l = CDR(l);
+ *lloc = cons(EVALCAR(l), EOL);
+ lloc = &CDR(*lloc);
+ l = CDR(l);
}
return res;
}
@@ -240,21 +501,21 @@ static char s_test[] = "bad test";
static char s_body[] = "bad body";
static char s_bindings[] = "bad bindings";
static char s_variable[] = "bad variable";
+static char s_bad_else_clause[] = "bad ELSE clause";
static char s_clauses[] = "bad or missing clauses";
static char s_formals[] = "bad formals";
#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)_pos, _subr);
-SCM i_dot, i_quote, i_quasiquote, i_lambda,
- i_let, i_arrow, i_else, i_unquote, i_uq_splicing, i_apply;
+SCM i_dot, i_quote, i_quasiquote, i_lambda, i_define,
+ i_let, i_arrow, i_else, i_unquote, i_uq_splicing;
#define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what);
#ifdef MACRO
-SCM rename_ident P((SCM id, SCM env));
-# define TOPDENOTE_EQ(sym, x, env) ((sym)==ident2sym(x) && TOPLEVELP(x,env))
-# define TOPLEVELP(x,env) (0==id_denote(x,env))
+# define TOPDENOTE_EQ(sym, x, env) ((sym)==id2sym(x) && TOPLEVELP(x,env))
+# define TOPLEVELP(x,env) (0==id_denote(x))
# define TOPRENAME(v) (renamed_ident(v, BOOL_F))
-static SCM ident2sym(id)
+static SCM id2sym(id)
SCM id;
{
if NIMP(id)
@@ -263,11 +524,13 @@ static SCM ident2sym(id)
return id;
}
-static SCM *id_denote(var, env)
- SCM var, env;
+static SCM *id_denote(var)
+ SCM var;
{
register SCM *al, fl;
- SCM mark = IDENT_MARK(var);
+ SCM env, mark = IDENT_MARK(var);
+ DEFER_INTS_EGC;
+ env = scm_env;
for(;NIMP(env); env = CDR(env)) {
al = &CAR(env);
for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
@@ -294,6 +557,12 @@ static void unpaint(p)
if NIMP(CAR(x)) unpaint(&CAR(x));
p = &CDR(*p);
}
+ else if VECTORP(x) {
+ sizet i = LENGTH(x);
+ if (0==i) return;
+ while (i-- > 1) unpaint(&(VELTS(x)[i]));
+ p = VELTS(x);
+ }
else {
while M_IDENTP(x) *p = x = IDENT_PARENT(x);
return;
@@ -313,16 +582,33 @@ static void bodycheck(xorig, bodyloc, what)
ASRTSYNTAX(ilength(*bodyloc) >= 1, s_expression);
}
+static SCM m_body(op, xorig, what)
+ SCM op, xorig;
+ char *what;
+{
+ ASRTSYNTAX(ilength(xorig) >= 1, s_expression);
+ /* Don't add another ISYM if one is present already. */
+ if ISYMP(CAR(xorig)) return xorig;
+ /* Retain possible doc string. */
+ if (IMP(CAR(xorig)) || NCONSP(CAR(xorig))) {
+ if NNULLP(CDR(xorig))
+ return cons(CAR(xorig), m_body(op, CDR(xorig), what));
+ return xorig;
+ }
+ return cons2(op, CAR(xorig), CDR(xorig));
+}
+
SCM m_quote(xorig, env)
SCM xorig, env;
{
+ SCM x = copytree(CDR(xorig));
ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
#ifdef MACRO
DEFER_INTS;
- unpaint(&CAR(CDR(xorig)));
+ unpaint(&CAR(x));
ALLOW_INTS;
#endif
- return cons(IM_QUOTE, CDR(xorig));
+ return cons(IM_QUOTE, x);
}
SCM m_begin(xorig, env)
@@ -368,32 +654,47 @@ SCM m_or(xorig, env)
else return BOOL_F;
}
+#ifdef INUMS_ONLY
+# define memv memq
+#endif
SCM m_case(xorig, env)
SCM xorig, env;
{
- SCM proc, x = CDR(xorig);
+ SCM clause, cdrx = copy_list(CDR(xorig)), x = cdrx;
+#ifndef RECKLESS
+ SCM s, keys = EOL;
+#endif
ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
while(NIMP(x = CDR(x))) {
- proc = CAR(x);
- ASSYNT(ilength(proc) >= 2, xorig, s_clauses, s_case);
- if TOPDENOTE_EQ(i_else, CAR(proc), env)
- CAR(proc) = IM_ELSE;
+ clause = CAR(x);
+ ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case);
+ if TOPDENOTE_EQ(i_else, CAR(clause), env) {
+ ASSYNT(NULLP(CDR(x)), xorig, s_bad_else_clause, s_case);
+ CAR(x) = cons(IM_ELSE, CDR(clause));
+ }
else {
- ASSYNT(ilength(CAR(proc)) >= 0, xorig, s_clauses, s_case);
+ ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case);
#ifdef MACRO
+ clause = cons(copy_list(CAR(clause)), CDR(clause));
DEFER_INTS;
- unpaint(&CAR(proc));
+ unpaint(&CAR(clause));
ALLOW_INTS;
+ CAR(x) = clause;
#endif
+#ifndef RECKLESS
+ for (s = CAR(clause); NIMP(s); s = CDR(s))
+ ASSYNT(FALSEP(memv(CAR(s),keys)), xorig, "duplicate key value", s_case);
+ keys = append(cons2(CAR(clause), keys, EOL));
+#endif
}
}
- return cons(IM_CASE, CDR(xorig));
+ return cons(IM_CASE, cdrx);
}
SCM m_cond(xorig, env)
SCM xorig, env;
{
- SCM arg1, x = CDR(xorig);
+ SCM arg1, cdrx = copy_list(CDR(xorig)), x = cdrx;
int len = ilength(x);
ASSYNT(len >= 1, xorig, s_clauses, s_cond);
while(NIMP(x)) {
@@ -401,26 +702,30 @@ SCM m_cond(xorig, env)
len = ilength(arg1);
ASSYNT(len >= 1, xorig, s_clauses, s_cond);
if TOPDENOTE_EQ(i_else, CAR(arg1), env) {
- ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, "bad ELSE clause", s_cond);
- CAR(arg1) = BOOL_T;
+ ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, s_bad_else_clause, s_cond);
+ CAR(x) = cons(BOOL_T, CDR(arg1));
}
- arg1 = CDR(arg1);
- if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(arg1), env)) {
- ASSYNT(3==len && NIMP(CAR(CDR(arg1))), xorig, "bad recipient", s_cond);
- CAR(arg1) = IM_ARROW;
+ else {
+ arg1 = CDR(arg1);
+ if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(arg1), env)) {
+ ASSYNT(3==len && NIMP(CAR(CDR(arg1))), xorig, "bad recipient", s_cond);
+ CAR(x) = cons2(CAR(CAR(x)), IM_ARROW, CDR(arg1));
+ }
}
x = CDR(x);
}
- return cons(IM_COND, CDR(xorig));
+ return cons(IM_COND, cdrx);
}
SCM m_lambda(xorig, env)
SCM xorig, env;
{
SCM proc, x = CDR(xorig);
+ int argc = 0; /* Number of required args */
if (ilength(x) < 2) goto badforms;
proc = CAR(x);
if NULLP(proc) goto memlambda;
+ if (IM_LET==proc) goto memlambda; /* named let */
if IMP(proc) goto badforms;
if IDENTP(proc) goto memlambda;
if NCONSP(proc) goto badforms;
@@ -430,12 +735,13 @@ SCM m_lambda(xorig, env)
else goto memlambda;
if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms;
proc = CDR(proc);
+ argc++;
}
- if NNULLP(proc)
+ if (NNULLP(proc) && (IM_LET != proc)) /* IM_LET inserted by named let. */
badforms: wta(xorig, s_formals, s_lambda);
memlambda:
- bodycheck(xorig, &CDR(x), s_lambda);
- return cons(IM_LAMBDA, CDR(xorig));
+ return cons2(ISYMSETVAL(IM_LAMBDA, argc), CAR(x),
+ m_body(IM_LAMBDA, CDR(x), s_lambda));
}
SCM m_letstar(xorig, env)
SCM xorig, env;
@@ -454,8 +760,7 @@ SCM m_letstar(xorig, env)
proc = CDR(proc);
}
x = cons(vars, CDR(x));
- bodycheck(xorig, &CDR(x), s_letstar);
- return cons(IM_LETSTAR, x);
+ return cons2(IM_LETSTAR, CAR(x), m_body(IM_LETSTAR, CDR(x), s_letstar));
}
/* DO gets the most radically altered syntax
@@ -475,7 +780,7 @@ SCM m_do(xorig, env)
SCM xorig, env;
{
SCM x = CDR(xorig), arg1, proc;
- SCM vars = EOL, inits = EOL, steps = EOL;
+ SCM vars = IM_DO, inits = EOL, steps = EOL;
SCM *initloc = &inits, *steploc = &steps;
int len = ilength(x);
ASSYNT(len >= 2, xorig, s_test, s_do);
@@ -505,16 +810,16 @@ SCM m_do(xorig, env)
}
/* evalcar is small version of inline EVALCAR when we don't care about speed */
-static SCM evalcar(x, env)
- SCM x, env;
+static SCM evalcar(x)
+ SCM x;
{
- return EVALCAR(x, env);
+ return EVALCAR(x);
}
/* Here are acros which return values rather than code. */
-static SCM iqq(form, env)
- SCM form, env;
+static SCM iqq(form)
+ SCM form;
{
SCM tmp;
if IMP(form) return form;
@@ -523,15 +828,15 @@ static SCM iqq(form, env)
SCM *data = VELTS(form);
tmp = EOL;
for(;--i >= 0;) tmp = cons(data[i], tmp);
- return vector(iqq(tmp, env));
+ return vector(iqq(tmp));
}
if NCONSP(form) return form;
tmp = CAR(form);
if (IM_UNQUOTE==tmp)
- return evalcar(CDR(form), env);
+ return evalcar(CDR(form));
if (NIMP(tmp) && IM_UQ_SPLICING==CAR(tmp))
- return append(cons2(evalcar(CDR(tmp),env), iqq(CDR(form),env), EOL));
- return cons(iqq(CAR(form),env), iqq(CDR(form),env));
+ return append(cons2(evalcar(CDR(tmp)), iqq(CDR(form)), EOL));
+ return cons(iqq(CAR(form)), iqq(CDR(form)));
}
static SCM m_iqq(form, depth, env)
@@ -545,9 +850,7 @@ static SCM m_iqq(form, depth, env)
long i = LENGTH(form);
SCM *data = VELTS(form);
tmp = EOL;
- ALLOW_INTS;
for(;--i >= 0;) tmp = cons(data[i], tmp);
- DEFER_INTS;
tmp = m_iqq(tmp, depth, env);
for(i = 0; i < LENGTH(form); i++) {
data[i] = CAR(tmp);
@@ -603,9 +906,7 @@ SCM m_quasiquote(xorig, env)
{
SCM x = CDR(xorig);
ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote);
- DEFER_INTS;
- x = m_iqq(x, 1, env);
- ALLOW_INTS;
+ x = m_iqq(copytree(x), 1, env);
return cons(IM_QUASIQUOTE, x);
}
@@ -616,7 +917,6 @@ SCM m_delay(xorig, env)
return cons2(IM_DELAY, EOL, CDR(xorig));
}
-extern int verbose;
SCM m_define(x, env)
SCM x, env;
{
@@ -630,8 +930,12 @@ SCM m_define(x, env)
}
ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define);
ASSYNT(1==ilength(x), arg1, s_expression, s_define);
+ if (NIMP(env) && tc16_env==CAR(env)) {
+ DEFER_INTS_EGC;
+ env = CDR(env);
+ }
if NULLP(env) {
- x = evalcar(x,env);
+ x = evalcar(x);
#ifdef MACRO
while M_IDENTP(proc) {
ASSYNT(IMP(IDENT_MARK(proc)), proc, s_escaped, s_define);
@@ -640,7 +944,8 @@ SCM m_define(x, env)
#endif
arg1 = sym2vcell(proc);
#ifndef RECKLESS
- if (NIMP(CDR(arg1)) &&
+ if (2 <= verbose &&
+ NIMP(CDR(arg1)) &&
(proc ==
((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1))))
&& (CDR(arg1) != x))
@@ -656,21 +961,25 @@ SCM m_define(x, env)
return UNSPECIFIED;
#endif
}
- return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x);
+ return cons2(IM_DEFINE, proc, x);
+ /* return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x); */
}
/* end of acros */
-SCM m_letrec(xorig, env)
- SCM xorig, env;
+static SCM m_letrec1(op, imm, xorig, env)
+ SCM op, imm, xorig, env;
{
SCM cdrx = CDR(xorig); /* locally mutable version of form */
char *what = CHARS(CAR(xorig));
SCM x = cdrx, proc, arg1; /* structure traversers */
- SCM vars = EOL, inits = EOL, *initloc = &inits;
+ SCM vars = imm, inits = EOL, *initloc = &inits;
- ASRTSYNTAX(ilength(x) >= 2, s_body);
+ /* ASRTSYNTAX(ilength(x) >= 2, s_body); */
proc = CAR(x);
- if NULLP(proc) return m_letstar(xorig, env); /* null binding, let* faster */
+#if 0
+ if NULLP(proc) /* null binding, let* faster */
+ return m_letstar(cons2(CAR(xorig), EOL, m_body(imm, CDR(x), what)), env);
+#endif
ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
do {
/* vars list reversed here, inits reversed at evaluation */
@@ -681,9 +990,19 @@ SCM m_letrec(xorig, env)
*initloc = cons(CAR(CDR(arg1)), EOL);
initloc = &CDR(*initloc);
} while NIMP(proc = CDR(proc));
- cdrx = cons2(vars, inits, CDR(x));
- bodycheck(xorig, &CDR(CDR(cdrx)), what);
- return cons(IM_LETREC, cdrx);
+ return cons2(op, vars, cons(inits, m_body(imm, CDR(x), what)));
+}
+
+SCM m_letrec(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig);
+ ASSYNT(ilength(x) >= 2, xorig, s_body, s_letrec);
+ if NULLP(CAR(x)) /* null binding, let* faster */
+ return m_letstar(cons2(CAR(xorig), EOL,
+ m_body(IM_LETREC, CDR(x), s_letrec)),
+ env);
+ return m_letrec1(IM_LETREC, IM_LETREC, xorig, env);
}
SCM m_let(xorig, env)
@@ -691,17 +1010,18 @@ SCM m_let(xorig, env)
{
SCM cdrx = CDR(xorig); /* locally mutable version of form */
SCM x = cdrx, proc, arg1, name; /* structure traversers */
- SCM vars = EOL, inits = EOL, *varloc = &vars, *initloc = &inits;
+ SCM vars = IM_LET, inits = EOL, *varloc = &vars, *initloc = &inits;
ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
proc = CAR(x);
- if (NULLP(proc)
+ if (NULLP(proc) /* null or single binding, let* is faster */
|| (NIMP(proc) && CONSP(proc)
&& NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc))))
- return m_letstar(xorig, env); /* null or single binding, let* is faster */
+ return m_letstar(cons2(CAR(xorig), proc, m_body(IM_LET, CDR(x), s_let)),
+ env);
ASSYNT(NIMP(proc), xorig, s_bindings, s_let);
if CONSP(proc) /* plain let, proc is <bindings> */
- return cons(IM_LET, CDR(m_letrec(xorig, env)));
+ return m_letrec1(IM_LET, IM_LET, xorig, env);
if (!IDENTP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
name = proc; /* named let, build equiv letrec */
x = CDR(x);
@@ -712,19 +1032,16 @@ SCM m_let(xorig, env)
arg1 = CAR(proc);
ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let);
- *varloc = cons(CAR(arg1), EOL);
+ *varloc = cons(CAR(arg1), IM_LET);
varloc = &CDR(*varloc);
*initloc = cons(CAR(CDR(arg1)), EOL);
initloc = &CDR(*initloc);
proc = CDR(proc);
}
- return
- m_letrec(cons2(i_let,
- cons(cons2(name,
- cons2(TOPRENAME(i_lambda), vars, CDR(x)), EOL),
- EOL),
- acons(name, inits, EOL)), /* body */
- env);
+ proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let));
+ proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL),
+ acons(name, inits, EOL));
+ return m_letrec1(IM_LETREC, IM_LET, proc, env);
}
#define s_atapply (ISYMCHARS(IM_APPLY)+1)
@@ -736,19 +1053,154 @@ SCM m_apply(xorig, env)
return cons(IM_APPLY, CDR(xorig));
}
-#define s_atcall_cc (ISYMCHARS(IM_CONT)+1)
+SCM m_expand_body(xorig)
+ SCM xorig;
+{
+ SCM form, x = CDR(xorig), defs = EOL;
+ char *what = ISYMCHARS(CAR(xorig)) + 2;
+ while NIMP(x) {
+ form = CAR(x);
+ if (IMP(form) || NCONSP(form)) break;
+ if IMP(CAR(form)) break;
+ if (! IDENTP(CAR(form))) break;
+ form = macroexp1(cons(CAR(form), CDR(form)), 0);
+ if (IM_DEFINE==CAR(form)) {
+ defs = cons(CDR(form), defs);
+ x = CDR(x);
+ }
+ else if NIMP(defs) {
+ break;
+ }
+ else if (IM_BEGIN==CAR(form)) {
+ x = append(cons2(CDR(form), CDR(x), EOL));
+ }
+ else {
+ x = cons(form, CDR(x));
+ break;
+ }
+ }
+ ASSYNT(NIMP(x), CDR(xorig), s_body, what);
+ if NIMP(defs)
+ x = cons(m_letrec1(IM_LETREC, IM_DEFINE, cons2(i_define, defs, x),
+ wrapenv())
+ , EOL);
+ DEFER_INTS;
+ CAR(xorig) = CAR(x);
+ CDR(xorig) = CDR(x);
+ ALLOW_INTS;
+ return xorig;
+}
-SCM m_cont(xorig, env)
- SCM xorig, env;
+static SCM macroexp1(x, check)
+ SCM x;
+ int check;
{
- ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_atcall_cc);
- return cons(IM_CONT, CDR(xorig));
+ SCM res, proc;
+ int argc;
+ ASRTGO(IDENTP(CAR(x)), badfun);
+ macro_tail:
+ proc = *lookupcar(x, 0);
+ if (NIMP(proc) && MACROP(proc)) {
+ unmemocar(x);
+ res = apply(CDR(proc), cons2(x, wrapenv(), EOL), EOL);
+ switch ((int)(CAR(proc)>>16) & 0x7f) {
+ case 2: /* mmacro */
+ if (ilength(res) <= 0)
+ res = cons2(IM_BEGIN, res, EOL);
+ DEFER_INTS;
+ CAR(x) = CAR(res);
+ CDR(x) = CDR(res);
+ ALLOW_INTS;
+ break;
+ case 1: /* macro */
+ x = NIMP(res) ? res : cons2(IM_BEGIN, res, EOL);
+ break;
+ case 0: /* acro */
+ return cons2(IM_QUOTE, res, EOL);
+ }
+ if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail;
+#ifndef RECKLESS
+ if (check && IM_DEFINE==CAR(x))
+ everr(x, wrapenv() /*scm_env*/, i_define, "Bad placement", "");
+#endif
+ return x;
+ }
+ else if (!check) {
+ unmemocar(x);
+ return x;
+ }
+#ifdef RECKLESS
+ return x;
+#else
+ ASRTGO(NIMP(proc), badfun);
+ argc = ilength(CDR(x));
+# ifdef CCLO
+ cclo_tail:
+# endif
+ switch TYP7(proc) {
+ default:
+ badfun:
+ unmemocar(x);
+ everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc,
+ UNBNDP(proc) ? s_unbnd : s_wtap, "");
+ case tc7_lsubr:
+ case tc7_rpsubr:
+ case tc7_asubr:
+ return x;
+ case tc7_subr_0:
+ ASRTGO(0==argc, wrongnumargs);
+ return x;
+ case tc7_contin:
+ case tc7_subr_1:
+ case tc7_cxr:
+ ASRTGO(1==argc, wrongnumargs);
+ return x;
+ case tc7_subr_2:
+ ASRTGO(2==argc, wrongnumargs);
+ return x;
+ case tc7_subr_3:
+ ASRTGO(3==argc, wrongnumargs);
+ return x;
+ case tc7_subr_1o:
+ ASRTGO(0==argc || 1==argc, wrongnumargs);
+ return x;
+ case tc7_subr_2o:
+ ASRTGO(1==argc || 2==argc, wrongnumargs);
+ return x;
+ case tc7_lsubr_2:
+ ASRTGO(2<=argc, wrongnumargs);
+ return x;
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ ASRTGO(2<=argc, wrongnumargs);
+ return x;
+ case tc16_call_cc:
+ ASRTGO(1==argc, wrongnumargs);
+ return x;
+# ifdef CCLO
+ case tc16_cclo:
+ proc = CCLO_SUBR(proc);
+ argc++;
+ goto cclo_tail;
+# endif
+ }
+ case tcs_closures:
+ if (badargsp(proc, CDR(x))) {
+ wrongnumargs:
+ unmemocar(x);
+ everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
+ }
+ return x;
+ }
+#endif /* ndef RECKLESS */
}
#ifndef RECKLESS
-int badargsp(formals, args)
- SCM formals, args;
+int badargsp(proc, args)
+ SCM proc, args;
{
+ SCM formals = CAR(CODE(proc));
while NIMP(formals) {
if NCONSP(formals) return 0;
if IMP(args) return 1;
@@ -760,59 +1212,93 @@ int badargsp(formals, args)
#endif
char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
-SCM eqv P((SCM x, SCM y));
-#ifdef CAUTIOUS
-static char s_bottom[] = "stacktrace bottommed out";
-#endif
+char s_call_cc[] = "call-with-current-continuation"; /* s_apply[] = "apply"; */
+
+static SCM wrapenv()
+{
+ register SCM z;
+ NEWCELL(z);
+ DEFER_INTS_EGC;
+ CDR(z) = scm_env;
+ CAR(z) = tc16_env;
+ EGC_ROOT(z);
+ return z;
+}
SCM ceval(x, env)
SCM x, env;
{
+ DEFER_INTS_EGC;
+ ENV_PUSH;
+ scm_env = env;
+ TRACE(x);
+ x = ceval_1(x);
+ ENV_POP;
+ ALLOW_INTS_EGC;
+ return x;
+}
+
+static SCM ceval_1(x)
+ SCM x;
+{
union {SCM *lloc; SCM arg1;} t;
- SCM proc, arg2;
+ SCM proc, arg2, arg3;
+ int envpp = 0; /* 1 means an environment has been pushed in this
+ invocation of ceval_1, -1 means pushed and then popped. */
CHECK_STACK;
loop: POLL;
+ TRACE(x);
+#ifdef SCM_PROFILE
+ eval_cases[TYP7(x)]++;
+#endif
switch TYP7(x) {
case tcs_symbols:
/* only happens when called at top level */
- x = cons(x, UNDEFINED);
- goto retval;
+ x = *lookupcar(cons(x, UNDEFINED), LOOKUP_UNDEFP);
+ goto retx;
case (127 & IM_AND):
x = CDR(x);
t.arg1 = x;
while(NNULLP(t.arg1 = CDR(t.arg1)))
- if FALSEP(EVALCAR(x, env)) return BOOL_F;
+ if (FALSEP(EVALCAR(x))) {x = BOOL_F; goto retx;}
else x = t.arg1;
goto carloop;
- cdrtcdrxbegin:
-#ifdef CAUTIOUS
- ASSERT(NIMP(stacktrace), EOL, s_bottom, s_eval);
- stacktrace = CDR(stacktrace);
-#endif
cdrxbegin:
case (127 & IM_BEGIN):
x = CDR(x);
begin:
t.arg1 = x;
while(NNULLP(t.arg1 = CDR(t.arg1))) {
- SIDEVAL(CAR(x), env);
+ if IMP(CAR(x)) {
+ if ISYMP(CAR(x)) {
+ x = m_expand_body(x);
+ goto begin;
+ }
+ }
+ else
+ ceval_1(CAR(x));
x = t.arg1;
}
carloop: /* eval car of last form in list */
if NCELLP(CAR(x)) {
x = CAR(x);
- return IMP(x)?EVALIMP(x, env):I_VAL(x);
+ x = IMP(x) ? EVALIMP(x) : I_VAL(x);
+ goto retx;
}
- if IDENTP(CAR(x)) {
- retval:
- return *lookupcar(x, env);
+
+ if ATOMP(CAR(x)) {
+ x = evalatomcar(x);
+ retx:
+ ENV_MAY_POP(envpp, 0);
+ ALLOW_INTS_EGC;
+ return x;
}
x = CAR(x);
goto loop; /* tail recurse */
case (127 & IM_CASE):
x = CDR(x);
- t.arg1 = EVALCAR(x, env);
+ t.arg1 = EVALCAR(x);
#ifndef INUMS_ONLY
arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1));
#endif
@@ -835,331 +1321,312 @@ SCM ceval(x, env)
proc = CDR(proc);
}
}
+ retunspec:
+ ENV_MAY_POP(envpp, 0);
+ ALLOW_INTS_EGC;
return UNSPECIFIED;
case (127 & IM_COND):
while(NIMP(x = CDR(x))) {
proc = CAR(x);
- t.arg1 = EVALCAR(proc, env);
+ t.arg1 = EVALCAR(proc);
if NFALSEP(t.arg1) {
x = CDR(proc);
- if NULLP(x) return t.arg1;
+ if NULLP(x) {
+ x = t.arg1;
+ goto retx;
+ }
if (IM_ARROW != CAR(x)) goto begin;
proc = CDR(x);
- proc = EVALCAR(proc, env);
+ proc = EVALCAR(proc);
ASRTGO(NIMP(proc), badfun);
-#ifdef CAUTIOUS
- if CLOSUREP(proc) goto checkargs1;
-#endif
goto evap1;
}
}
- return UNSPECIFIED;
+ goto retunspec;
case (127 & IM_DO):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
proc = CAR(CDR(x)); /* inits */
- t.arg1 = EOL; /* values */
+ scm_env_tmp = EOL; /* values */
while NIMP(proc) {
- t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ scm_env_cons_tmp(EVALCAR(proc));
proc = CDR(proc);
}
- env = EXTEND_ENV(CAR(x), t.arg1, env);
+ EXTEND_ENV(CAR(x));
x = CDR(CDR(x));
- while (proc = CAR(x), FALSEP(EVALCAR(proc, env))) {
+ while (proc = CAR(x), FALSEP(EVALCAR(proc))) {
for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
t.arg1 = CAR(proc); /* body */
- SIDEVAL(t.arg1, env);
+ SIDEVAL_1(t.arg1);
}
- for(t.arg1 = EOL, proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc))
- t.arg1 = cons(EVALCAR(proc, env), t.arg1); /* steps */
- env = EXTEND_ENV(CAR(CAR(env)), t.arg1, CDR(env));
+ scm_env_tmp = EOL;
+ for(proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc)) {
+ scm_env_cons_tmp(EVALCAR(proc)); /* steps */
+ }
+ DEFER_INTS_EGC;
+ t.arg1 = CAR(CAR(scm_env));
+ scm_env = CDR(scm_env);
+ EXTEND_ENV(t.arg1);
}
x = CDR(proc);
- if NULLP(x) return UNSPECIFIED;
+ if NULLP(x) goto retunspec;
goto begin;
case (127 & IM_IF):
x = CDR(x);
- if NFALSEP(EVALCAR(x, env)) x = CDR(x);
- else if IMP(x = CDR(CDR(x))) return UNSPECIFIED;
+ if NFALSEP(EVALCAR(x)) x = CDR(x);
+ else if IMP(x = CDR(CDR(x))) goto retunspec;
goto carloop;
case (127 & IM_LET):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
proc = CAR(CDR(x));
- t.arg1 = EOL;
+ scm_env_tmp = EOL;
do {
- t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ scm_env_cons_tmp(EVALCAR(proc));
} while NIMP(proc = CDR(proc));
- env = EXTEND_ENV(CAR(x), t.arg1, env);
+ EXTEND_ENV(CAR(x));
x = CDR(x);
goto cdrxbegin;
case (127 & IM_LETREC):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
- env = EXTEND_ENV(CAR(x), undefineds, env);
+ scm_env_tmp = undefineds;
+ EXTEND_ENV(CAR(x));
x = CDR(x);
proc = CAR(x);
- t.arg1 = EOL;
+ scm_env_tmp = EOL;
do {
- t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ scm_env_cons_tmp(EVALCAR(proc));
} while NIMP(proc = CDR(proc));
- CDR(CAR(env)) = t.arg1;
+ EGC_ROOT(CAR(scm_env));
+ CDR(CAR(scm_env)) = scm_env_tmp;
+ scm_env_tmp = EOL;
goto cdrxbegin;
case (127 & IM_LETSTAR):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
proc = CAR(x);
if IMP(proc) {
- env = EXTEND_ENV(EOL, EOL, env);
+ scm_env_tmp = EOL;
+ EXTEND_ENV(EOL);
goto cdrxbegin;
}
do {
t.arg1 = CAR(proc);
proc = CDR(proc);
- env = EXTEND_ENV(t.arg1, EVALCAR(proc, env), env);
+ scm_env_tmp = EVALCAR(proc);
+ EXTEND_ENV(t.arg1);
} while NIMP(proc = CDR(proc));
goto cdrxbegin;
case (127 & IM_OR):
x = CDR(x);
t.arg1 = x;
while(NNULLP(t.arg1 = CDR(t.arg1))) {
- x = EVALCAR(x, env);
- if NFALSEP(x) return x;
+ x = EVALCAR(x);
+ if NFALSEP(x) goto retx;
x = t.arg1;
}
goto carloop;
case (127 & IM_LAMBDA):
- return closure(CDR(x), env);
+ x = closure(CDR(x), ISYMVAL(CAR(x)));
+ goto retx;
case (127 & IM_QUOTE):
- return CAR(CDR(x));
+ x = CAR(CDR(x));
+ goto retx;
case (127 & IM_SET):
x = CDR(x);
+ arg2 = EVALCAR(CDR(x));
proc = CAR(x);
switch (7 & (int)proc) {
case 0:
if CONSP(proc)
- t.lloc = farlookup(proc,env);
- else {
- t.lloc = lookupcar(x,env);
-#ifdef MACRO
-# ifndef RECKLESS
- if (NIMP(*t.lloc) && MACROP(*t.lloc)) {
- unmemocar(x,env);
- everr(x, env, CAR(x), s_badkey, s_set);
- }
-# endif
-#endif
- }
+ *farlookup(proc) = arg2;
+ else
+ *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2;
break;
case 1:
- t.lloc = &I_VAL(proc);
+ I_VAL(proc) = arg2;
break;
case 4:
- t.lloc = ilookup(proc, env);
+ *ilookup(proc) = arg2;
break;
}
- x = CDR(x);
- *t.lloc = EVALCAR(x, env);
#ifdef SICP
- return *t.lloc;
-#else
- return UNSPECIFIED;
+ x = arg2;
+ goto retx;
#endif
+ goto retunspec;
case (127 & IM_DEFINE): /* only for internal defines */
+ goto badfun;
+#if 0
x = CDR(x);
proc = CAR(x);
x = CDR(x);
- x = evalcar(x, env);
- env = CAR(env);
- DEFER_INTS;
- CAR(env) = proc;
- CDR(env) = cons(x, CDR(env));
- ALLOW_INTS;
- return UNSPECIFIED;
+ x = evalcar(x);
+ DEFER_INTS_EGC;
+ scm_env_tmp = CDR(CAR(scm_env));
+ scm_env_cons_tmp(x);
+ EGC_ROOT(CAR(scm_env));
+ /* DEFER_INTS; */
+ CAR(CAR(scm_env)) = proc;
+ CDR(CAR(scm_env)) = scm_env_tmp;
+ /* ALLOW_INTS; */
+ goto retunspec;
+#endif
/* new syntactic forms go here. */
case (127 & MAKISYM(0)):
proc = CAR(x);
ASRTGO(ISYMP(proc), badfun);
+#ifdef SCM_PROFILE
+ eval_cases_other[ISYMNUM(proc)]++;
+#endif
switch ISYMNUM(proc) {
case (ISYMNUM(IM_APPLY)):
proc = CDR(x);
- proc = EVALCAR(proc, env);
+ proc = EVALCAR(proc);
ASRTGO(NIMP(proc), badfun);
+ t.arg1 = CDR(CDR(x));
+ t.arg1 = EVALCAR(t.arg1);
if (CLOSUREP(proc)) {
- t.arg1 = CDR(CDR(x));
- t.arg1 = EVALCAR(t.arg1, env);
+ ENV_MAY_PUSH(envpp);
+ scm_env_tmp = t.arg1;
#ifndef RECKLESS
- if (badargsp(CAR(CODE(proc)), t.arg1)) goto wrongnumargs;
-#endif
- env = EXTEND_ENV(CAR(CODE(proc)), t.arg1, ENV(proc));
- x = CODE(proc);
- goto cdrxbegin;
- }
- proc = i_apply;
- goto evapply;
- case (ISYMNUM(IM_CONT)):
- t.arg1 = scm_make_cont();
- if ((proc = setjump(CONT(t.arg1)->jmpbuf)))
-#ifdef SHORT_INT
- return (SCM)thrown_value;
+ goto clo_checked;
#else
- return (SCM)proc;
+ goto clo_unchecked;
#endif
- proc = CDR(x);
- proc = evalcar(proc, env);
- ASRTGO(NIMP(proc), badfun);
-#ifdef CAUTIOUS
- if CLOSUREP(proc) {
- checkargs1:
- stacktrace = cons(x, stacktrace);
- /* Check that argument list of proc can match 1 arg. */
- arg2 = CAR(CODE(proc));
- ASRTGO(NIMP(arg2), wrongnumargs);
- if NCONSP(arg2) goto evap1;
- arg2 = CDR(arg2);
- ASRTGO(NULLP(arg2) || NCONSP(arg2), wrongnumargs);
}
-#endif
- goto evap1;
+ x = apply(proc, t.arg1, EOL);
+ goto retx;
case (ISYMNUM(IM_DELAY)):
- return makprom(closure(CDR(x), env));
+ x = makprom(closure(CDR(x), 0));
+ goto retx;
case (ISYMNUM(IM_QUASIQUOTE)):
- return iqq(CAR(CDR(x)), env);
+ ALLOW_INTS_EGC;
+ x = iqq(CAR(CDR(x)));
+ goto retx;
case (ISYMNUM(IM_FARLOC_CAR)):
case (ISYMNUM(IM_FARLOC_CDR)):
- return *farlookup(x, env);
+ x = *farlookup(x);
+ goto retx;
default:
goto badfun;
}
default:
proc = x;
badfun:
- everr(x, env, proc, "Wrong type to apply: ", "");
+ everr(x, wrapenv() /*scm_env*/, proc, s_wtap, "");
case tc7_vector:
case tc7_bvect: case tc7_ivect: case tc7_uvect:
case tc7_fvect: case tc7_dvect: case tc7_cvect:
case tc7_string:
case tc7_smob:
-#ifdef MACRO
- if M_IDENTP(x) {
- x = cons(x, UNDEFINED);
- goto retval;
- }
-#endif
- return x;
+ goto retx;
case (127 & ILOC00):
- proc = *ilookup(CAR(x), env);
- ASRTGO(NIMP(proc), badfun);
-#ifndef RECKLESS
-# ifdef CAUTIOUS
- goto checkargs;
-# endif
-#endif
+ proc = *ilookup(CAR(x));
break;
case tcs_cons_gloc:
proc = I_VAL(CAR(x));
- ASRTGO(NIMP(proc), badfun);
-#ifndef RECKLESS
-# ifdef CAUTIOUS
- goto checkargs;
-# endif
-#endif
break;
case tcs_cons_nimcar:
- if IDENTP(CAR(x)) {
- proc = *lookupcar(x, env);
- if IMP(proc) {unmemocar(x, env); goto badfun;}
- if MACROP(proc) {
- unmemocar(x, env);
- t.arg1 = apply(CDR(proc), x, cons(env, listofnull));
- switch ((int)(CAR(proc)>>16)) {
- case 2: /* mmacro */
- if (ilength(t.arg1) <= 0)
- t.arg1 = cons2(IM_BEGIN, t.arg1, EOL);
- DEFER_INTS;
- CAR(x) = CAR(t.arg1);
- CDR(x) = CDR(t.arg1);
- ALLOW_INTS;
- goto loop;
- case 1: /* macro */
- if NIMP(x = t.arg1) goto loop;
- case 0: /* acro */
- return t.arg1;
- }
- }
+ if ATOMP(CAR(x)) {
+ x = macroexp1(x, !0);
+ goto loop;
}
- else proc = ceval(CAR(x), env);
- ASRTGO(NIMP(proc), badfun);
-#ifndef RECKLESS
-# ifdef CAUTIOUS
- checkargs:
-# endif
+ proc = ceval_1(CAR(x));
/* At this point proc is the evaluated procedure from the function
position and x has the form which is being evaluated. */
- if CLOSUREP(proc) {
-# ifdef CAUTIOUS
- stacktrace = cons(x, stacktrace);
-# endif
- arg2 = CAR(CODE(proc));
- t.arg1 = CDR(x);
- while NIMP(arg2) {
- if NCONSP(arg2) {
- goto evapply;
+ }
+ ASRTGO(NIMP(proc), badfun);
+ *scm_estk_ptr = scm_env; /* For error reporting at wrongnumargs. */
+ if NULLP(CDR(x)) {
+ evap0:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) { /* no arguments given */
+ case tc7_subr_0:
+ return SUBRF(proc)();
+ case tc7_subr_1o:
+ return SUBRF(proc) (UNDEFINED);
+ case tc7_lsubr:
+ return SUBRF(proc)(EOL);
+ case tc7_rpsubr:
+ return BOOL_T;
+ case tc7_asubr:
+ return SUBRF(proc)(UNDEFINED, UNDEFINED);
+ case tcs_closures:
+ DEFER_INTS_EGC;
+ ENV_MAY_PUSH(envpp);
+ scm_env_tmp = EOL;
+#ifdef SCM_PROFILE
+ eval_clo_cases[0][0]++;
+#endif
+#ifdef CAUTIOUS
+ if (0!=ARGC(proc)) {
+ clo_checked:
+ DEFER_INTS_EGC;
+ t.arg1 = CAR(CODE(proc));
+ arg2 = scm_env_tmp;
+ while NIMP(t.arg1) {
+ if NCONSP(t.arg1) goto clo_unchecked;
+ if IMP(arg2) goto umwrongnumargs;
+ t.arg1 = CDR(t.arg1);
+ arg2 = CDR(arg2);
}
- if IMP(t.arg1) goto umwrongnumargs;
- arg2 = CDR(arg2);
- t.arg1 = CDR(t.arg1);
+ if NNULLP(arg2) goto umwrongnumargs;
}
- if NNULLP(t.arg1) goto umwrongnumargs;
- }
+#else /* def CAUTIOUS */
+ clo_checked:
#endif
- }
- evapply:
- if NULLP(CDR(x)) switch TYP7(proc) { /* no arguments given */
- case tc7_subr_0:
- return SUBRF(proc)();
- case tc7_subr_1o:
- return SUBRF(proc) (UNDEFINED);
- case tc7_lsubr:
- return SUBRF(proc)(EOL);
- case tc7_rpsubr:
- return BOOL_T;
- case tc7_asubr:
- return SUBRF(proc)(UNDEFINED, UNDEFINED);
+ clo_unchecked:
+ x = CODE(proc);
+ scm_env = ENV(proc);
+ EXTEND_ENV(CAR(x));
+ goto cdrxbegin;
+ case tc7_specfun:
#ifdef CCLO
- case tc7_cclo:
- t.arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto evap1;
+ if (tc16_cclo==TYP16(proc)) {
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap1;
+ }
#endif
- case tcs_closures:
- x = CODE(proc);
- env = EXTEND_ENV(CAR(x), EOL, ENV(proc));
- goto cdrtcdrxbegin;
- case tc7_contin:
- case tc7_subr_1:
- case tc7_subr_2:
- case tc7_subr_2o:
- case tc7_cxr:
- case tc7_subr_3:
- case tc7_lsubr_2:
- umwrongnumargs:
- unmemocar(x, env);
- wrongnumargs:
- everr(x, env, proc, (char *)WNA, "");
- default:
- goto badfun;
+ case tc7_contin:
+ case tc7_subr_1:
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ case tc7_cxr:
+ case tc7_subr_3:
+ case tc7_lsubr_2:
+ umwrongnumargs:
+ unmemocar(x);
+ wrongnumargs:
+ if (envpp < 0) {
+ scm_estk_ptr += SCM_ESTK_FRLEN;
+ scm_env = *scm_estk_ptr;
+ }
+ everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
+ default:
+ goto badfun;
+ }
}
x = CDR(x);
#ifdef CAUTIOUS
if (IMP(x)) goto wrongnumargs;
#endif
- t.arg1 = EVALCAR(x, env);
+ t.arg1 = EVALCAR(x);
x = CDR(x);
- if NULLP(x)
-evap1: switch TYP7(proc) { /* have one argument in t.arg1 */
- case tc7_subr_2o:
- return SUBRF(proc)(t.arg1, UNDEFINED);
- case tc7_subr_1:
- case tc7_subr_1o:
- return SUBRF(proc)(t.arg1);
- case tc7_cxr:
+ if NULLP(x) {
+evap1:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) { /* have one argument in t.arg1 */
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, UNDEFINED);
+ case tc7_subr_1:
+ case tc7_subr_1o:
+ return SUBRF(proc)(t.arg1);
+ case tc7_cxr:
#ifdef FLOATS
if SUBRF(proc) {
if INUMP(t.arg1)
@@ -1191,109 +1658,214 @@ evap1: switch TYP7(proc) { /* have one argument in t.arg1 */
return SUBRF(proc)(t.arg1, UNDEFINED);
case tc7_lsubr:
return SUBRF(proc)(cons(t.arg1, EOL));
-#ifdef CCLO
- case tc7_cclo:
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto evap2;
+ case tcs_closures:
+ ENV_MAY_PUSH(envpp);
+#ifdef SCM_PROFILE
+ eval_clo_cases[1][ARGC(proc)]++;
#endif
- case tcs_closures:
- x = CODE(proc);
- env = EXTEND_ENV(CAR(x), cons(t.arg1, EOL), ENV(proc));
- goto cdrtcdrxbegin;
- case tc7_contin:
- scm_dynthrow(CONT(proc), t.arg1);
- case tc7_subr_2:
- case tc7_subr_0:
- case tc7_subr_3:
- case tc7_lsubr_2:
- goto wrongnumargs;
- default:
- goto badfun;
- }
-#ifdef CAUTIOUS
- if (IMP(x)) goto wrongnumargs;
+ if (1==ARGC(proc)) {
+ scm_env_cons(t.arg1, EOL);
+ goto clo_unchecked;
+ }
+ else {
+ scm_env_tmp = cons(t.arg1, EOL);
+ goto clo_checked;
+ }
+ case tc7_contin:
+ scm_dynthrow(CONT(proc), t.arg1);
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_call_cc:
+ proc = t.arg1;
+ DEFER_INTS_EGC;
+ t.arg1 = scm_make_cont();
+ EGC_ROOT(t.arg1);
+ if ((x = setjump(CONT(t.arg1)->jmpbuf))) {
+#ifdef SHORT_INT
+ x = (SCM)thrown_value;
#endif
- { /* have two or more arguments */
- arg2 = EVALCAR(x, env);
- x = CDR(x);
- if NULLP(x)
+ goto retx;
+ }
+ ASRTGO(NIMP(proc), badfun);
+ goto evap1;
#ifdef CCLO
- evap2:
+ case tc16_cclo:
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap2;
#endif
- switch TYP7(proc) { /* have two arguments */
+ }
case tc7_subr_2:
- case tc7_subr_2o:
- return SUBRF(proc)(t.arg1, arg2);
- case tc7_lsubr:
- return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
- case tc7_lsubr_2:
- return SUBRF(proc)(t.arg1, arg2, EOL);
- case tc7_rpsubr:
- case tc7_asubr:
- return SUBRF(proc)(t.arg1, arg2);
-#ifdef CCLO
- cclon: case tc7_cclo:
- return apply(CCLO_SUBR(proc), proc,
- cons2(t.arg1, arg2, cons(eval_args(x, env), EOL)));
-/* case tc7_cclo:
- x = cons(arg2, eval_args(x, env));
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto evap3; */
-#endif
case tc7_subr_0:
- case tc7_cxr:
- case tc7_subr_1o:
- case tc7_subr_1:
case tc7_subr_3:
- case tc7_contin:
+ case tc7_lsubr_2:
goto wrongnumargs;
default:
goto badfun;
- case tcs_closures:
- env = EXTEND_ENV(CAR(CODE(proc)), cons2(t.arg1, arg2, EOL), ENV(proc));
- x = CODE(proc);
- goto cdrtcdrxbegin;
}
- switch TYP7(proc) { /* have 3 or more arguments */
- case tc7_subr_3:
- ASRTGO(NULLP(CDR(x)), wrongnumargs);
- return SUBRF(proc)(t.arg1, arg2, EVALCAR(x, env));
- case tc7_asubr:
-/* t.arg1 = SUBRF(proc)(t.arg1, arg2);
- while NIMP(x) {
- t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = CDR(x);
+ }
+#ifdef CAUTIOUS
+ if (IMP(x)) goto wrongnumargs;
+#endif
+ { /* have two or more arguments */
+ arg2 = EVALCAR(x);
+ x = CDR(x);
+ if NULLP(x) { /* have two arguments */
+ evap2:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) {
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, arg2);
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, EOL);
+ case tc7_rpsubr:
+ case tc7_asubr:
+ return SUBRF(proc)(t.arg1, arg2);
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ proc = t.arg1;
+ if NULLP(arg2) goto evap0;
+ if (IMP(arg2) || NCONSP(arg2)) {
+ x = arg2;
+ badlst: wta(x, (char *)ARGn, s_apply);
+ }
+ t.arg1 = CAR(arg2);
+ x = CDR(arg2);
+ apply3:
+ if NULLP(x) goto evap1;
+ ASRTGO(NIMP(x) && CONSP(x), badlst);
+ arg2 = CAR(x);
+ x = CDR(x);
+ apply4:
+ if NULLP(x) goto evap2;
+ ASRTGO(NIMP(x) && CONSP(x), badlst);
+ arg3 = CAR(x);
+ ASRTGO(0 <= ilength(x), badlst);
+ x = copy_list(CDR(x));
+ goto evap3;
+#ifdef CCLO
+ case tc16_cclo: cclon:
+ return apply(CCLO_SUBR(proc),
+ cons2(proc, t.arg1, cons(arg2, x)), EOL);
+ /* arg3 = arg2;
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap3; */
+#endif
+ }
+ case tc7_subr_0:
+ case tc7_cxr:
+ case tc7_subr_1o:
+ case tc7_subr_1:
+ case tc7_subr_3:
+ case tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ case tcs_closures:
+ ENV_MAY_PUSH(envpp);
+#ifdef SCM_PROFILE
+ eval_clo_cases[2][ARGC(proc)]++;
+#endif
+ switch ARGC(proc) {
+ case 2:
+ scm_env_cons2(t.arg1, arg2, EOL);
+ goto clo_unchecked;
+ case 1:
+ scm_env_cons(t.arg1, cons(arg2, EOL));
+ goto clo_checked;
+ case 0:
+ case 3: /* Error, will be caught at clo_checked: */
+ scm_env_tmp = cons2(t.arg1, arg2, EOL);
+ goto clo_checked;
+ }
}
- return t.arg1; */
- case tc7_rpsubr:
- return apply(proc, t.arg1, acons(arg2, eval_args(x, env), EOL));
- case tc7_lsubr_2:
- return SUBRF(proc)(t.arg1, arg2, eval_args(x, env));
- case tc7_lsubr:
- return SUBRF(proc)(cons2(t.arg1, arg2, eval_args(x, env)));
+ }
+ { /* have 3 or more arguments */
+ arg3 = EVALCAR(x);
+ x = CDR(x);
+ if NIMP(x) x = eval_args(x);
+ evap3:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) {
+ case tc7_subr_3:
+ ASRTGO(NULLP(x), wrongnumargs);
+ return SUBRF(proc)(t.arg1, arg2, arg3);
+ case tc7_asubr:
+ /* t.arg1 = SUBRF(proc)(t.arg1, arg2);
+ while NIMP(x) {
+ t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
+ x = CDR(x);
+ }
+ return t.arg1; */
+ case tc7_rpsubr:
+ return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL);
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, cons(arg3, x));
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, cons(arg3, x)));
+ case tcs_closures:
+ ENV_MAY_PUSH(envpp);
+#ifdef SCM_PROFILE
+ eval_clo_cases[IMP(x)?3:4][ARGC(proc)]++;
+#endif
+ switch ARGC(proc) {
+ case 3:
+ scm_env_cons2(arg2, arg3, x);
+ scm_env_cons_tmp(t.arg1);
+ goto clo_checked;
+ case 2:
+ scm_env_cons2(t.arg1, arg2, cons(arg3, x));
+ goto clo_checked;
+ case 1:
+ scm_env_cons(t.arg1, cons2(arg2, arg3, x));
+ goto clo_checked;
+ case 0:
+ scm_env_tmp = cons2(t.arg1, arg2, cons(arg3, x));
+ goto clo_checked;
+ }
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ proc = t.arg1;
+ t.arg1 = arg2;
+ if IMP(x) {
+ x = arg3;
+ goto apply3;
+ }
+ arg2 = arg3;
+ if IMP(CDR(x)) {
+ x = CAR(x);
+ goto apply4;
+ }
+ arg3 = CAR(x);
+ x = nconc2copy(CDR(x));
+ goto evap3;
#ifdef CCLO
- case tc7_cclo: goto cclon;
+ case tc16_cclo:
+ x = cons(arg3, x);
+ goto cclon;
#endif
- case tcs_closures:
- env = EXTEND_ENV(CAR(CODE(proc)),
- cons2(t.arg1, arg2, eval_args(x, env)),
- ENV(proc));
- x = CODE(proc);
- goto cdrtcdrxbegin;
- case tc7_subr_2:
- case tc7_subr_1o:
- case tc7_subr_2o:
- case tc7_subr_0:
- case tc7_cxr:
- case tc7_subr_1:
- case tc7_contin:
- goto wrongnumargs;
- default:
- goto badfun;
+ }
+ case tc7_subr_2:
+ case tc7_subr_1o:
+ case tc7_subr_2o:
+ case tc7_subr_0:
+ case tc7_cxr:
+ case tc7_subr_1:
+ case tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
}
}
}
@@ -1305,9 +1877,7 @@ SCM procedurep(obj)
case tcs_closures:
case tc7_contin:
case tcs_subrs:
-#ifdef CCLO
- case tc7_cclo:
-#endif
+ case tc7_specfun:
return BOOL_T;
}
return BOOL_F;
@@ -1331,19 +1901,18 @@ SCM l_proc_doc(proc)
return BOOL_F;
/*
case tcs_subrs:
-#ifdef CCLO
- case tc7_cclo:
-#endif
+ case tc7_specfun:
*/
}
}
/* This code is for apply. it is destructive on multiple args.
This will only screw you if you do (apply apply '( ... )) */
-SCM nconc2last(lst)
+/* Copy last (list) argument, so SET! in a closure can't mutate it. */
+SCM nconc2copy(lst)
SCM lst;
{
- SCM *lloc = &lst;
+ SCM last, *lloc = &lst;
#ifdef CAUTIOUS
ASSERT(ilength(lst) >= 1, lst, WNA, s_apply);
#endif
@@ -1351,14 +1920,30 @@ SCM nconc2last(lst)
#ifdef CAUTIOUS
ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply);
#endif
- *lloc = CAR(*lloc);
+ last = CAR(*lloc);
+ *lloc = EOL;
+ for(; NIMP(last); last=CDR(last)) {
+ *lloc = cons(CAR(last), EOL);
+ lloc = &CDR(*lloc);
+ }
return lst;
}
-
-
+/* Shallow copy */
+SCM copy_list(lst)
+ SCM lst;
+{
+ SCM res, *lloc = &res;
+ res = EOL;
+ for(; NIMP(lst); lst = CDR(lst)) {
+ *lloc = cons(CAR(lst), EOL);
+ lloc = &CDR(*lloc);
+ }
+ return res;
+}
SCM apply(proc, arg1, args)
SCM proc, arg1, args;
{
+ apply_tail:
ASRTGO(NIMP(proc), badproc);
if NULLP(args)
if NULLP(arg1) arg1 = UNDEFINED;
@@ -1368,15 +1953,17 @@ SCM apply(proc, arg1, args)
}
else {
/* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
- args = nconc2last(args);
+ args = nconc2copy(args);
}
-#ifdef CCLO
- tail:
-#endif
+ cc_tail:
+ ALLOW_INTS_EGC;
switch TYP7(proc) {
case tc7_subr_2o:
- args = NULLP(args)?UNDEFINED:CAR(args);
- return SUBRF(proc)(arg1, args);
+ if NULLP(args) {
+ args = UNDEFINED;
+ return SUBRF(proc)(arg1, args);
+ }
+ /* Fall through */
case tc7_subr_2:
ASRTGO(NIMP(args) && NULLP(CDR(args)), wrongnumargs);
args = CAR(args);
@@ -1416,6 +2003,8 @@ SCM apply(proc, arg1, args)
return arg1;
}
case tc7_subr_3:
+ ASRTGO(NIMP(args) && NIMP(CDR(args)) && NULLP(CDR(CDR(args))),
+ wrongnumargs);
return SUBRF(proc)(arg1, CAR(args), CAR(CDR(args)));
case tc7_lsubr:
return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1, args));
@@ -1442,22 +2031,54 @@ SCM apply(proc, arg1, args)
case tcs_closures:
arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args));
#ifndef RECKLESS
- if (badargsp(CAR(CODE(proc)), arg1)) goto wrongnumargs;
+ if (badargsp(proc, arg1)) goto wrongnumargs;
#endif
- args = EXTEND_ENV(CAR(CODE(proc)), arg1, ENV(proc));
+ DEFER_INTS_EGC;
+ ENV_PUSH;
+ TRACE(proc);
+ scm_env_tmp = arg1;
+ scm_env = ENV(proc);
+ EXTEND_ENV(CAR(CODE(proc)));
proc = CODE(proc);
- while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc, args);
+ arg1 = ceval_1(cons(IM_BEGIN, CDR(proc)));
+ /* while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc); */
+ ENV_POP;
return arg1;
case tc7_contin:
ASRTGO(NULLP(args), wrongnumargs);
scm_dynthrow(CONT(proc), arg1);
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ ASRTGO(!UNBNDP(arg1), wrongnumargs);
+ proc = arg1;
+ arg1 = args;
+ args = EOL;
+ goto apply_tail;
+ case tc16_call_cc:
+ ASRTGO(NULLP(args), wrongnumargs);
+ proc = arg1;
+ ASRTGO(NIMP(proc), badproc);
+ DEFER_INTS_EGC;
+ arg1 = scm_make_cont();
+ EGC_ROOT(arg1);
+ if ((args = setjump(CONT(arg1)->jmpbuf))) {
+#ifdef SHORT_INT
+ args = (SCM)thrown_value;
+#endif
+ return args;
+ }
+ args = EOL;
+ goto cc_tail;
#ifdef CCLO
- case tc7_cclo:
- args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
- arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto tail;
+ case tc16_cclo:
+ args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+ arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto cc_tail;
#endif
+ }
+ goto badproc;
wrongnumargs:
wta(proc, (char *)WNA, s_apply);
default:
@@ -1472,7 +2093,8 @@ SCM map(proc, arg1, args)
{
long i;
SCM res = EOL, *pres = &res;
- SCM *ve = &args; /* Keep args from being optimized away. */
+ SCM *ve;
+ scm_protect_temp(&args); /* Keep args from being optimized away. */
if NULLP(arg1) return res;
ASSERT(NIMP(arg1), arg1, ARG2, s_map);
if NULLP(args) {
@@ -1504,8 +2126,9 @@ SCM map(proc, arg1, args)
SCM for_each(proc, arg1, args)
SCM proc, arg1, args;
{
- SCM *ve = &args; /* Keep args from being optimized away. */
+ SCM *ve;
long i;
+ scm_protect_temp(&args); /* Keep args from being optimized away. */
if NULLP(arg1) return UNSPECIFIED;
ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
if NULLP(args) {
@@ -1529,13 +2152,24 @@ SCM for_each(proc, arg1, args)
}
}
-SCM closure(code, env)
- SCM code, env;
+/* The number of required arguments up to 3 is encoded in the cdr of the
+ closure. This information is used to make sure that rest args are not
+ allocated in the environment cache. */
+SCM closure(code, argc)
+ SCM code;
+ int argc;
{
register SCM z;
+ if (argc > 3) argc = 3;
NEWCELL(z);
SETCODE(z, code);
- ENV(z) = env;
+ DEFER_INTS_EGC;
+ if (IMP(scm_env))
+ CDR(z) = argc<<1;
+ else {
+ CDR(z) = scm_env | (argc<<1);
+ EGC_ROOT(z);
+ }
return z;
}
@@ -1600,6 +2234,17 @@ static int prinmacro(exp, port, writing)
lputc('>', port);
return !0;
}
+static int prinenv(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ lputs("#<environment ", port);
+ intprint((long)exp, -16, port);
+ /* iprin1(CDR(exp), port, writing); */
+ lputc('>', port);
+ return !0;
+}
#ifdef MACRO
static int prinid(exp, port, writing)
SCM exp;
@@ -1611,7 +2256,7 @@ static int prinid(exp, port, writing)
lputs("#<identifier ", port);
iprin1(s, port, writing);
lputc(':', port);
- intprint((long)exp, 16, port);
+ intprint((long)exp, -16, port);
lputc('>', port);
return !0;
}
@@ -1664,7 +2309,7 @@ SCM definedp(x, env)
{
SCM proc = CAR(x = CDR(x));
#ifdef MACRO
- proc = ident2sym(proc);
+ proc = id2sym(proc);
#endif
return (ISYMP(proc)
|| (NIMP(proc) && IDENTP(proc)
@@ -1684,7 +2329,8 @@ static char s_ident_eqp[] = "identifier-equal?";
SCM ident_eqp(id1, id2, env)
SCM id1, id2, env;
{
- SCM s1 = id1, s2 = id2;
+ SCM s1 = id1, s2 = id2, ret;
+
# ifndef RECKLESS
if IMP(id1)
badarg1: wta(id1, (char *)ARG1, s_ident_eqp);
@@ -1697,8 +2343,21 @@ SCM ident_eqp(id1, id2, env)
ASRTGO(SYMBOLP(s1), badarg1);
ASRTGO(SYMBOLP(s2), badarg2);
if (s1 != s2) return BOOL_F;
- if (id_denote(id1, env)==id_denote(id2, env)) return BOOL_T;
- return BOOL_F;
+ DEFER_INTS_EGC;
+ ENV_PUSH;
+ scm_env = (NIMP(env) && tc16_env==CAR(env)) ? CDR(env) : env;
+ ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F;
+ ENV_POP;
+ return ret;
+}
+
+static char s_ident2sym[] = "identifier->symbol";
+SCM ident2sym(id)
+ SCM id;
+{
+ id = id2sym(id);
+ ASSERT(NIMP(id) && SYMBOLP(id), id, ARG1, s_ident2sym);
+ return id;
}
static char s_renamed_ident[] = "renamed-identifier";
@@ -1707,6 +2366,11 @@ SCM renamed_ident(id, env)
{
SCM z;
ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
+ if NIMP(env) {
+ ASSERT(tc16_env==CAR(env), env, ARG2, s_renamed_ident);
+ DEFER_INTS_EGC;
+ env = CDR(env);
+ }
NEWCELL(z);
if IMP(env) {
CAR(z) = tc16_ident;
@@ -1736,15 +2400,18 @@ SCM m_syn_quote(xorig, env)
SCM m_atlet_syntax(xorig, env)
SCM xorig, env;
{
- if (IMP(env) || CONSP(CAR(CAR(env))))
- return m_let(xorig, env);
- else {
- SCM mark = renamed_ident(i_mark, BOOL_F);
- return m_letstar(cons2(i_let,
- cons(cons2(mark, BOOL_F, EOL), EOL),
- acons(TOPRENAME(i_let), CDR(xorig), EOL)),
- env);
- }
+ SCM mark;
+ DEFER_INTS_EGC;
+ if (tc16_env==CAR(env))
+ env = CDR(env);
+ if NULLP(env) return m_let(xorig, env);
+ mark = CAR(CAR(env));
+ if (NIMP(mark) && CONSP(mark)) return m_let(xorig, env);
+ mark = renamed_ident(i_mark, BOOL_F);
+ return m_letstar(cons2(i_let,
+ cons(cons2(mark, BOOL_F, EOL), EOL),
+ acons(TOPRENAME(i_let), CDR(xorig), EOL)),
+ env);
}
static char s_the_macro[] = "the-macro";
@@ -1754,14 +2421,46 @@ SCM m_the_macro(xorig, env)
SCM x = CDR(xorig);
ASSYNT(1==ilength(x), xorig, s_expression, s_the_macro);
if (NIMP(CAR(x)) && IDENTP(CAR(x)))
- x = *lookupcar(x, env);
+ x = *lookupcar(x, LOOKUP_UNDEFP);
else
- x = evalcar(x, env);
+ x = evalcar(x);
ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro);
return cons2(IM_QUOTE, x, EOL);
}
#endif
+static char s_env2tree[] = "environment->tree";
+SCM env2tree(env)
+ SCM env;
+{
+ SCM ans, a, *lloc;
+ if NULLP(env) return env;
+ ASSERT(NIMP(env) && tc16_env==CAR(env), env, ARG1, s_env2tree);
+ DEFER_INTS_EGC;
+ if IMP(CDR(env)) return env;
+ ENV_PUSH;
+ scm_env = CDR(env);
+ ans = a = cons(UNSPECIFIED, UNSPECIFIED);
+ while (!0) {
+ scm_env_tmp = CAR(scm_env);
+ lloc = &CAR(a);
+ while (NIMP(scm_env_tmp) && CONSP(scm_env_tmp)) {
+ *lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp));
+ lloc = &CDR(*lloc);
+ DEFER_INTS_EGC;
+ scm_env_tmp = CDR(scm_env_tmp);
+ }
+ scm_env = CDR(scm_env);
+ if IMP(scm_env) {
+ CDR(a) = scm_env;
+ break;
+ }
+ a = (CDR(a) = cons(UNSPECIFIED, UNSPECIFIED));
+ }
+ ENV_POP;
+ ALLOW_INTS_EGC;
+ return ans;
+}
static iproc subr1s[] = {
{"@copy-tree", copytree},
@@ -1771,9 +2470,11 @@ static iproc subr1s[] = {
{"procedure->syntax", makacro},
{"procedure->macro", makmacro},
{"procedure->memoizing-macro", makmmacro},
- {"apply:nconc-to-last", nconc2last},
+ {"apply:nconc-to-last", nconc2copy},
+ {s_env2tree, env2tree},
#ifdef MACRO
{s_identp, identp},
+ {s_ident2sym, ident2sym},
#endif
{0, 0}};
@@ -1785,6 +2486,7 @@ static iproc lsubr2s[] = {
static smobfuns promsmob = {markcdr, free0, prinprom};
static smobfuns macrosmob = {markcdr, free0, prinmacro};
+static smobfuns envsmob = {markcdr, free0, prinenv};
#ifdef MACRO
static smobfuns idsmob = {markcdr, free0, prinid};
#endif
@@ -1805,14 +2507,31 @@ SCM make_synt(name, macroizer, fcn)
CDR(symcell) = macroizer(z);
return CAR(symcell);
}
-
+SCM make_specfun(name, typ)
+ char *name;
+ int typ;
+{
+ SCM symcell = sysintern(name, UNDEFINED);
+ register SCM z;
+ NEWCELL(z);
+ CAR(z) = (long)typ;
+ CDR(z) = CAR(symcell);
+ CDR(symcell) = z;
+ return z;
+}
void init_eval()
{
tc16_promise = newsmob(&promsmob);
tc16_macro = newsmob(&macrosmob);
+ tc16_env = newsmob(&envsmob);
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(lsubr2s, tc7_lsubr_2);
- i_apply = make_subr(s_apply, tc7_lsubr_2, apply);
+#ifdef SCM_PROFILE
+ make_subr("scm:profile", tc7_subr_1o, scm_profile);
+#endif
+ make_specfun(s_apply, tc16_apply);
+ make_specfun(s_call_cc, tc16_call_cc);
+
i_dot = CAR(sysintern(".", UNDEFINED));
i_arrow = CAR(sysintern("=>", UNDEFINED));
i_else = CAR(sysintern("else", UNDEFINED));
@@ -1821,7 +2540,7 @@ void init_eval()
/* acros */
i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote);
- make_synt(s_define, makmmacro, m_define);
+ i_define = make_synt(s_define, makmmacro, m_define);
make_synt(s_delay, makmmacro, m_delay);
make_synt("defined?", makacro, definedp);
/* end of acros */
@@ -1840,7 +2559,7 @@ void init_eval()
i_quote = make_synt(s_quote, makmmacro, m_quote);
make_synt(s_set, makmmacro, m_set);
make_synt(s_atapply, makmmacro, m_apply);
- make_synt(s_atcall_cc, makmmacro, m_cont);
+ /* make_synt(s_atcall_cc, makmmacro, m_cont); */
#ifdef MACRO
tc16_ident = newsmob(&idsmob);
diff --git a/gmalloc.c b/gmalloc.c
index d9eaf1b..cf0fad2 100644
--- a/gmalloc.c
+++ b/gmalloc.c
@@ -1,4 +1,4 @@
-/* DO NOT EDIT THIS FILE -- it is automagically generated. -*- C -*- */
+/* This file is no longer automatically generated from libc. */
#define _MALLOC_INTERNAL
@@ -37,13 +37,13 @@ Cambridge, MA 02139, USA.
#endif
#if defined (__cplusplus) || (defined (__STDC__) && __STDC__)
-#undef __P
-#define __P(args) args
+#undef PP
+#define PP(args) args
#undef __ptr_t
#define __ptr_t void *
#else /* Not C++ or ANSI C. */
-#undef __P
-#define __P(args) ()
+#undef PP
+#define PP(args) ()
#undef const
#define const
#undef __ptr_t
@@ -96,24 +96,24 @@ extern "C"
/* Allocate SIZE bytes of memory. */
-extern __ptr_t malloc __P ((__malloc_size_t __size));
+extern __ptr_t malloc PP ((__malloc_size_t __size));
/* Re-allocate the previously allocated block
in __ptr_t, making the new block SIZE bytes long. */
-extern __ptr_t realloc __P ((__ptr_t __ptr, __malloc_size_t __size));
+extern __ptr_t realloc PP ((__ptr_t __ptr, __malloc_size_t __size));
/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */
-extern __ptr_t calloc __P ((__malloc_size_t __nmemb, __malloc_size_t __size));
+extern __ptr_t calloc PP ((__malloc_size_t __nmemb, __malloc_size_t __size));
/* Free a block allocated by `malloc', `realloc' or `calloc'. */
-extern void free __P ((__ptr_t __ptr));
+extern void free PP ((__ptr_t __ptr));
/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */
#if ! (defined (_MALLOC_INTERNAL) && __DJGPP__ - 0 == 1) /* Avoid conflict. */
-extern __ptr_t memalign __P ((__malloc_size_t __alignment,
- __malloc_size_t __size));
+extern __ptr_t memalign PP ((__malloc_size_t __alignment,
+ __malloc_size_t __size));
#endif
/* Allocate SIZE bytes on a page boundary. */
#if ! (defined (_MALLOC_INTERNAL) && defined (GMALLOC_INHIBIT_VALLOC))
-extern __ptr_t valloc __P ((__malloc_size_t __size));
+extern __ptr_t valloc PP ((__malloc_size_t __size));
#endif
@@ -213,26 +213,26 @@ extern __malloc_size_t _bytes_free;
/* Internal versions of `malloc', `realloc', and `free'
used when these functions need to call each other.
They are the same but don't call the hooks. */
-extern __ptr_t _malloc_internal __P ((__malloc_size_t __size));
-extern __ptr_t _realloc_internal __P ((__ptr_t __ptr, __malloc_size_t __size));
-extern void _free_internal __P ((__ptr_t __ptr));
+extern __ptr_t _malloc_internal PP ((__malloc_size_t __size));
+extern __ptr_t _realloc_internal PP ((__ptr_t __ptr, __malloc_size_t __size));
+extern void _free_internal PP ((__ptr_t __ptr));
#endif /* _MALLOC_INTERNAL. */
/* Given an address in the middle of a malloc'd object,
return the address of the beginning of the object. */
-extern __ptr_t malloc_find_object_address __P ((__ptr_t __ptr));
+extern __ptr_t malloc_find_object_address PP ((__ptr_t __ptr));
/* Underlying allocation function; successive calls should
return contiguous pieces of memory. */
-extern __ptr_t (*__morecore) __P ((__malloc_ptrdiff_t __size));
+extern __ptr_t (*__morecore) PP ((__malloc_ptrdiff_t __size));
/* Default value of `__morecore'. */
-extern __ptr_t __default_morecore __P ((__malloc_ptrdiff_t __size));
+extern __ptr_t __default_morecore PP ((__malloc_ptrdiff_t __size));
/* If not NULL, this function is called after each time
`__morecore' is called to increase the data size. */
-extern void (*__after_morecore_hook) __P ((void));
+extern void (*__after_morecore_hook) PP ((void));
/* Number of extra blocks to get each time we ask for more core.
This reduces the frequency of calling `(*__morecore)'. */
@@ -241,15 +241,19 @@ extern __malloc_size_t __malloc_extra_blocks;
/* Nonzero if `malloc' has been called and done its initialization. */
extern int __malloc_initialized;
/* Function called to initialize malloc data structures. */
-extern int __malloc_initialize __P ((void));
+extern int __malloc_initialize PP ((void));
/* Hooks for debugging versions. */
-extern void (*__malloc_initialize_hook) __P ((void));
-extern void (*__free_hook) __P ((__ptr_t __ptr));
-extern __ptr_t (*__malloc_hook) __P ((__malloc_size_t __size));
-extern __ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size));
-extern __ptr_t (*__memalign_hook) __P ((__malloc_size_t __size,
- __malloc_size_t __alignment));
+extern void (*__malloc_initialize_hook) PP ((void));
+extern void (*__free_hook) PP ((__ptr_t __ptr));
+extern __ptr_t (*__malloc_hook) PP ((__malloc_size_t __size));
+extern __ptr_t (*__realloc_hook) PP ((__ptr_t __ptr, __malloc_size_t __size));
+extern __ptr_t (*__memalign_hook) PP ((__malloc_size_t __size,
+ __malloc_size_t __alignment));
+
+ /* Debugging functions, added by Radey Shouman */
+int check_block __P((__malloc_size_t block, int cont));
+int check_frag_blocks __P((void));
/* Return values for `mprobe': these are the kinds of inconsistencies that
`mcheck' enables detection of. */
@@ -266,16 +270,16 @@ enum mcheck_status
before `malloc' is ever called. ABORTFUNC is called with an error code
(see enum above) when an inconsistency is detected. If ABORTFUNC is
null, the standard function prints on stderr and then calls `abort'. */
-extern int mcheck __P ((void (*__abortfunc) __P ((enum mcheck_status))));
+extern int mcheck PP ((void (*__abortfunc) PP ((enum mcheck_status))));
/* Check for aberrations in a particular malloc'd block. You must have
called `mcheck' already. These are the same checks that `mcheck' does
when you free or reallocate a block. */
-extern enum mcheck_status mprobe __P ((__ptr_t __ptr));
+extern enum mcheck_status mprobe PP ((__ptr_t __ptr));
/* Activate a standard collection of tracing hooks. */
-extern void mtrace __P ((void));
-extern void muntrace __P ((void));
+extern void mtrace PP ((void));
+extern void muntrace PP ((void));
/* Statistics available to the user. */
struct mstats
@@ -288,23 +292,23 @@ struct mstats
};
/* Pick up the current statistics. */
-extern struct mstats mstats __P ((void));
+extern struct mstats mstats PP ((void));
/* Call WARNFUN with a warning message when memory usage is high. */
-extern void memory_warnings __P ((__ptr_t __start,
- void (*__warnfun) __P ((const char *))));
+extern void memory_warnings PP ((__ptr_t __start,
+ void (*__warnfun) PP ((const char *))));
/* Relocating allocator. */
/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */
-extern __ptr_t r_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size));
+extern __ptr_t r_alloc PP ((__ptr_t *__handleptr, __malloc_size_t __size));
/* Free the storage allocated in HANDLEPTR. */
-extern void r_alloc_free __P ((__ptr_t *__handleptr));
+extern void r_alloc_free PP ((__ptr_t *__handleptr));
/* Adjust the block at HANDLEPTR to be SIZE bytes long. */
-extern __ptr_t r_re_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size));
+extern __ptr_t r_re_alloc PP ((__ptr_t *__handleptr, __malloc_size_t __size));
#ifdef __cplusplus
@@ -341,10 +345,10 @@ Cambridge, MA 02139, USA.
#include <errno.h>
/* How to really get more memory. */
-__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __default_morecore;
+__ptr_t (*__morecore) PP ((ptrdiff_t __size)) = __default_morecore;
/* Debugging hook for `malloc'. */
-__ptr_t (*__malloc_hook) __P ((__malloc_size_t __size));
+__ptr_t (*__malloc_hook) PP ((__malloc_size_t __size));
/* Pointer to the base of the first block. */
char *_heapbase;
@@ -375,12 +379,12 @@ int __malloc_initialized;
__malloc_size_t __malloc_extra_blocks;
-void (*__malloc_initialize_hook) __P ((void));
-void (*__after_morecore_hook) __P ((void));
+void (*__malloc_initialize_hook) PP ((void));
+void (*__after_morecore_hook) PP ((void));
/* Aligned allocation. */
-static __ptr_t align __P ((__malloc_size_t));
+static __ptr_t align PP ((__malloc_size_t));
static __ptr_t
align (size)
__malloc_size_t size;
@@ -408,7 +412,7 @@ align (size)
/* Get SIZE bytes, if we can get them starting at END.
Return the address of the space we got.
If we cannot get space at END, fail and return 0. */
-static __ptr_t get_contiguous_space __P ((__malloc_ptrdiff_t, __ptr_t));
+static __ptr_t get_contiguous_space PP ((__malloc_ptrdiff_t, __ptr_t));
static __ptr_t
get_contiguous_space (size, position)
__malloc_ptrdiff_t size;
@@ -442,7 +446,7 @@ get_contiguous_space (size, position)
/* This is called when `_heapinfo' and `heapsize' have just
been set to describe a new info table. Set up the table
to describe itself and account for it in the statistics. */
-static void register_heapinfo __P ((void));
+static void register_heapinfo PP ((void));
#ifdef __GNUC__
__inline__
#endif
@@ -497,7 +501,7 @@ static int morecore_recursing;
/* Get neatly aligned memory, initializing or
growing the heap info table as necessary. */
-static __ptr_t morecore __P ((__malloc_size_t));
+static __ptr_t morecore PP ((__malloc_size_t));
static __ptr_t
morecore (size)
__malloc_size_t size;
@@ -875,14 +879,14 @@ Cambridge, MA 02139, USA.
#define __malloc_safe_bcopy safe_bcopy
#endif
/* This function is defined in realloc.c. */
-extern void __malloc_safe_bcopy __P ((__ptr_t, __ptr_t, __malloc_size_t));
+extern void __malloc_safe_bcopy PP ((__ptr_t, __ptr_t, __malloc_size_t));
#define memmove(to, from, size) __malloc_safe_bcopy ((from), (to), (size))
#endif
#endif
/* Debugging hook for free. */
-void (*__free_hook) __P ((__ptr_t __ptr));
+void (*__free_hook) PP ((__ptr_t __ptr));
/* List of blocks allocated by memalign. */
struct alignlist *_aligned_blocks = NULL;
@@ -1248,7 +1252,7 @@ __malloc_safe_bcopy (afrom, ato, size)
#endif /* emacs */
#ifndef memmove
-extern void __malloc_safe_bcopy __P ((__ptr_t, __ptr_t, __malloc_size_t));
+extern void __malloc_safe_bcopy PP ((__ptr_t, __ptr_t, __malloc_size_t));
#define memmove(to, from, size) __malloc_safe_bcopy ((from), (to), (size))
#endif
@@ -1258,7 +1262,7 @@ extern void __malloc_safe_bcopy __P ((__ptr_t, __ptr_t, __malloc_size_t));
#define min(A, B) ((A) < (B) ? (A) : (B))
/* Debugging hook for realloc. */
-__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size));
+__ptr_t (*__realloc_hook) PP ((__ptr_t __ptr, __malloc_size_t __size));
/* Resize the given region to the new size, returning a pointer
to the (possibly moved) region. This is optimized for speed;
@@ -1460,7 +1464,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
systems with potentially hostile include files. */
#include <stddef.h>
-extern __ptr_t __sbrk __P ((ptrdiff_t increment));
+extern __ptr_t __sbrk PP ((ptrdiff_t increment));
#endif
#ifndef NULL
@@ -1508,7 +1512,7 @@ Cambridge, MA 02139, USA. */
#else
-__ptr_t (*__memalign_hook) __P ((size_t __size, size_t __alignment));
+__ptr_t (*__memalign_hook) PP ((size_t __size, size_t __alignment));
__ptr_t
memalign (alignment, size)
@@ -1612,19 +1616,13 @@ Cambridge, MA 02139, USA.
#if defined (__GNU_LIBRARY__) || defined (_LIBC)
#include <stddef.h>
#include <sys/cdefs.h>
-extern size_t __getpagesize __P ((void));
+#if defined (__GLIBC__) && __GLIBC__ >= 2
+/* __getpagesize is already declared in <unistd.h> with return type int */
#else
-/* added by Denys Duchier: handle missing getpagesize.h
- on solaris: getpagesize is in the c library, but there
- is no include file that declares it.
- */
-#if defined(sun) && defined(__svr4__) && !defined(__GNUG__)
-extern int getpagesize(void);
+extern size_t __getpagesize PP ((void));
+#endif
#else
-#ifndef hpux
#include "getpagesize.h"
-#endif
-#endif
#define __getpagesize() getpagesize()
#endif
@@ -1646,3 +1644,53 @@ valloc (size)
}
#endif /* Not ELIDE_VALLOC. */
+
+/* Debugging functions added by Radey Shouman */
+struct list *check_block_prev;
+int check_block(block, cont)
+ __malloc_size_t block;
+ int cont;
+{
+ char *minptr, *maxptr;
+ struct list *ptr, *prev;
+ int nfree, type = _heapinfo[block].busy.type;
+ tail:
+ nfree = _heapinfo[block].busy.info.frag.nfree;
+ minptr = ((char *)ADDRESS(block));
+ maxptr = ((char *)ADDRESS(block) + BLOCKSIZE);
+ if (0==type) return 0;
+ prev = ptr = (struct list *) ((char *) ADDRESS (block) +
+ (_heapinfo[block].busy.info.frag.first << type));
+ if ((BLOCKSIZE >> type) <= nfree)
+ return 1;
+ if (nfree < 0)
+ return 2;
+ while (nfree--) {
+ if (! (((char *)ptr >= minptr) && ((char *)ptr < maxptr)))
+ return 3;
+ prev = ptr;
+ ptr = prev->next;
+ }
+ check_block_prev = prev;
+ if (cont && ptr) {
+ block = BLOCK(ptr);
+ if (type != _heapinfo[block].busy.type) return 4;
+ goto tail;
+ }
+ return 0;
+}
+
+int check_frag_blocks()
+{
+ __malloc_size_t block;
+ int err;
+ __malloc_size_t log;
+ for (log = 1; log < BLOCKLOG; log++)
+ if (_fraghead[log].next) {
+ block = BLOCK(_fraghead[log].next);
+ err = check_block(block, !0);
+ if (err) return err;
+ }
+ return 0;
+}
+
diff --git a/ioext.c b/ioext.c
index c653970..4e0002d 100644
--- a/ioext.c
+++ b/ioext.c
@@ -48,12 +48,13 @@
# include <sys/types.h>
#endif
-#ifndef THINK_C
+#ifndef macintosh
# ifdef vms
# include <stat.h>
# else
# include <sys/stat.h>
-# endif
+#endif
+
# ifdef __TURBOC__
# include <io.h>
# endif
@@ -74,6 +75,9 @@ SCM stat2scm P((struct stat *stat_temp));
# include <sys/types.h>
# include <unistd.h>
#endif
+#ifdef linux
+# include <unistd.h>
+#endif
#ifndef STDC_HEADERS
int chdir P((const char *path));
@@ -124,6 +128,7 @@ SCM read_line(port)
switch (c) {
case LINE_INCREMENTORS:
case EOF:
+ if (j>0 && '\r'==p[j-1]) j--;
if (len==j) return tok_buf;
return resizuve(tok_buf, (SCM)MAKINUM(j));
default:
@@ -222,7 +227,7 @@ SCM reopen_file(filename, modes, port)
}
#ifndef MCH_AMIGA
-
+# ifndef macintosh
static char s_dup[]="duplicate-port";
SCM l_dup(oldpt, modes)
SCM oldpt, modes;
@@ -262,6 +267,7 @@ SCM l_dup2(into_pt, from_pt)
ALLOW_INTS;
return into_pt;
}
+# endif
# ifndef vms
# ifndef _WIN32
@@ -293,7 +299,7 @@ SCM l_readdir(port)
if (!rdent) {ALLOW_INTS; return BOOL_F;}
ALLOW_INTS;
/* rdent could be overwritten by another readdir to the same handle */
- return makfrom0str(rdent->d_name);
+ return makfrom0str((char *)rdent->d_name);
}
static char s_rewinddir[]="rewinddir";
SCM l_rewinddir(port)
@@ -396,6 +402,7 @@ SCM l_getcwd()
# endif
}
+# ifndef __MWERKS__
static char s_chmod[] = "chmod";
SCM l_chmod(pathname, mode)
SCM pathname, mode;
@@ -406,6 +413,7 @@ SCM l_chmod(pathname, mode)
SYSCALL(val = chmod(CHARS(pathname), INUM(mode)););
return val ? BOOL_F : BOOL_T;
}
+# endif
# ifndef vms
# ifdef __EMX__
@@ -431,6 +439,7 @@ SCM l_utime(pathname, acctime, modtime)
}
# endif /* vms */
+# ifndef __MWERKS__
static char s_umask[] = "umask";
SCM l_umask(mode)
SCM mode;
@@ -438,6 +447,7 @@ SCM l_umask(mode)
ASSERT(INUMP(mode), mode, ARG1, s_umask);
return MAKINUM(umask(INUM(mode)));
}
+# endif
# endif /* MCH_AMIGA */
#endif /* THINK_C */
@@ -448,7 +458,7 @@ SCM ren_fil(oldname, newname)
SCM ans;
ASSERT(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil);
ASSERT(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil);
-#ifdef STDC_HEADERS
+#if 1 /* def STDC_HEADERS */
SYSCALL(ans = (rename(CHARS(oldname), CHARS(newname))) ? BOOL_F: BOOL_T;);
return ans;
#else
@@ -471,20 +481,14 @@ SCM l_fileno(port)
if (tc16_fport != TYP16(port)) return BOOL_F;
return MAKINUM(fileno(STREAM(port)));
}
-static char s_isatty[] = "isatty?";
-SCM l_isatty(port)
- SCM port;
-{
- ASSERT(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;
-}
-#ifndef F_OK
-# define F_OK 00
-# define X_OK 01
-# define W_OK 02
-# define R_OK 04
-#endif
+#ifndef THINK_C
+# ifndef __MWERKS__
+# ifndef F_OK
+# define F_OK 00
+# define X_OK 01
+# define W_OK 02
+# define R_OK 04
+# endif
static char s_access[] = "access";
SCM l_access(pathname, mode)
SCM pathname, mode;
@@ -502,8 +506,9 @@ SCM l_access(pathname, mode)
SYSCALL(val = access(CHARS(pathname), imodes););
return val ? BOOL_F : BOOL_T;
}
+# endif /* __MWERKS__ */
-#ifndef THINK_C
+SCM stat2scm P((struct stat *stat_temp));
char s_stat[] = "stat";
SCM l_stat(str)
@@ -563,10 +568,10 @@ SCM l_getpid()
return MAKINUM((unsigned long)getpid());
}
# endif /* MCH_AMIGA */
-#endif /* THINK_C */
+#endif /* THINK_C */
#ifndef __IBMC__
-# ifndef THINK_C
+# ifndef macintosh
# ifndef __WATCOMC__
# ifndef GO32
# ifndef _Windows
@@ -587,8 +592,10 @@ SCM i_execv(modes, path, args)
args = cons(path, args);
DEFER_INTS;
execargv = makargvfrmstrs(args, s_execv);
- ALLOW_INTS;
+ ignore_signals();
(strchr(modes, 'p') ? execvp : execv)(execargv[0], &execargv[1]);
+ unignore_signals();
+ ALLOW_INTS;
perror(execargv[0]);
return MAKINUM(errno);
}
@@ -628,7 +635,6 @@ SCM l_putenv(str)
static iproc subr1s[] = {
{s_file_position, file_position},
{s_fileno, l_fileno},
- {s_isatty, l_isatty},
#ifndef MCH_AMIGA
# ifndef vms
# ifndef _WIN32
@@ -642,10 +648,12 @@ static iproc subr1s[] = {
#endif
#ifndef THINK_C
# ifndef MCH_AMIGA
+# ifndef __MWERKS__
{s_umask, l_umask},
+# endif
# endif
- {s_chdir, lchdir},
{s_stat, l_stat},
+ {s_chdir, lchdir},
#endif
{0, 0}};
@@ -655,12 +663,14 @@ static iproc subr1os[] = {
static iproc subr2s[] = {
{s_ren_fil, ren_fil},
+#ifndef macintosh
{s_access, l_access},
+#endif
#ifndef MCH_AMIGA
+ {s_mkdir, l_mkdir},
+# ifndef macintosh
{s_dup, l_dup},
{s_dup2, l_dup2},
- {s_mkdir, l_mkdir},
-# ifndef THINK_C
{s_chmod, l_chmod},
# endif
#endif
@@ -681,7 +691,9 @@ void init_ioext()
make_subr(s_reopen_file, tc7_subr_3, reopen_file);
#ifndef THINK_C
# ifndef MCH_AMIGA
+# ifndef __MWERKS__
make_subr("getpid", tc7_subr_0, l_getpid);
+# endif
make_subr("getcwd", tc7_subr_0, l_getcwd);
# ifndef vms
# ifndef _WIN32
@@ -692,7 +704,7 @@ void init_ioext()
# endif
#endif
#ifndef __IBMC__
-# ifndef THINK_C
+# ifndef macintosh
# ifndef __WATCOMC__
# ifndef GO32
# ifndef _Windows
diff --git a/mkimpcat.scm b/mkimpcat.scm
index 4c69937..890d521 100644
--- a/mkimpcat.scm
+++ b/mkimpcat.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -176,7 +176,16 @@
(display* "(")
(add-alias 'hobbit (in-vicinity (implementation-vicinity) "hobbit"))
(add-alias 'scmhob (in-vicinity (implementation-vicinity) "scmhob"))
- (add-alias 'build (in-vicinity (implementation-vicinity) "build"))
+ (add-alias 'regex-case
+ (in-vicinity (implementation-vicinity) "rgxcase"))
+ (add-alias 'url-filename
+ (in-vicinity (implementation-vicinity) "urlfile"))
+ (add-source 'disarm (in-vicinity
+ (implementation-vicinity)
+ (string-append "disarm" (scheme-file-suffix))))
+ (add-source 'build (in-vicinity
+ (implementation-vicinity)
+ (string-append "build" (scheme-file-suffix))))
;; (add-alias 'impl:callback '(identity))
diff --git a/patchlvl.h b/patchlvl.h
index 3564060..1313eb4 100644
--- a/patchlvl.h
+++ b/patchlvl.h
@@ -1,8 +1,20 @@
-/* SCMVERSION is a string for the version specifier. The leading
- number is the major version number, the letter is the revision ("a"
- for alpha release, "b" for beta release, "c", and so on), and the
- trailing number is the patchlevel. */
+
+#if 0 /* SCMVERSION is a string for the version specifier. The leading
+ # number is the major version number, the letter is the revision ("a"
+ # 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=5c3
+#endif
#ifndef SCMVERSION
-# define SCMVERSION "5b3"
+# define SCMVERSION "5c3"
+#endif
+#ifndef RTL
+# ifdef nosve
+# define INIT_FILE_NAME "Init5c3_scm";
+# endif
+# ifndef INIT_FILE_NAME
+# define INIT_FILE_NAME "Init5c3.scm"
+# endif
#endif
diff --git a/posix.c b/posix.c
index 77cfaf4..1ed5f1c 100644
--- a/posix.c
+++ b/posix.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1994, 1995, 1998 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -57,6 +57,10 @@
#else /* added by Denys Duchier */
# ifdef SVR4
# include <unistd.h>
+# else
+# ifdef linux
+# include <unistd.h>
+# endif
# endif
#endif
@@ -134,16 +138,6 @@ SCM open_pipe(pipestr, modes)
ALLOW_INTS;
return z;
}
-SCM l_open_input_pipe(pipestr)
- SCM pipestr;
-{
- return open_pipe(pipestr, makfromstr("r", (sizeof "r")-1));
-}
-SCM l_open_output_pipe(pipestr)
- SCM pipestr;
-{
- return open_pipe(pipestr, makfromstr("w", (sizeof "w")-1));
-}
static int prinpipe(exp, port, writing)
SCM exp; SCM port; int writing;
{
@@ -155,25 +149,22 @@ static char scm_s_getgroups[] = "getgroups";
SCM scm_getgroups()
{
SCM grps, ans;
- int ngroups = getgroups(NULL, 0);
+ int ngroups = getgroups(0, 0);
if (!ngroups) return BOOL_F;
NEWCELL(grps);
DEFER_INTS;
+ /* grps is used as a gc protect, its type used to be tc7_string, but
+ strings are now checked for null termination during gc. */
+ grps = must_malloc_cell(ngroups * sizeof(gid_t), scm_s_getgroups);
+ /* length need not be exactly right */
+ SETLENGTH(grps, (0L + ngroups * sizeof(gid_t))/sizeof(long), tc7_uvect);
+ ALLOW_INTS;
{
- gid_t *groups = (gid_t *)must_malloc(ngroups * sizeof(gid_t),
- scm_s_getgroups);
+ gid_t *groups = (gid_t *)CHARS(grps);
int val = getgroups(ngroups, groups);
- if (val < 0) {
- must_free((char *)groups);
- ALLOW_INTS;
- return BOOL_F;
- }
- SETCHARS(grps, groups); /* set up grps as a GC protect */
- SETLENGTH(grps, 0L + ngroups * sizeof(gid_t), tc7_string);
- ALLOW_INTS;
+ if (val < 0) return BOOL_F;
ans = make_vector(MAKINUM(ngroups), UNDEFINED);
while (--ngroups >= 0) VELTS(ans)[ngroups] = MAKINUM(groups[ngroups]);
- SETCHARS(grps, groups); /* to make sure grps stays around. */
return ans;
}
}
@@ -383,8 +374,6 @@ static iproc subr1s[] = {
{"setegid", l_setegid},
{"seteuid", l_seteuid},
#endif
- {"open-input-pipe", l_open_input_pipe},
- {"open-output-pipe", l_open_output_pipe},
{s_ttyname, l_ttyname},
{0, 0}};
@@ -411,4 +400,8 @@ void init_posix()
ptobs[0x0ff & (tc16_pipe>>8)].free = pclose;
ptobs[0x0ff & (tc16_pipe>>8)].print = prinpipe;
add_feature(s_pipe);
+ scm_ldstr("\n\
+(define (open-input-pipe cmd) (open-pipe cmd \"r\"))\n\
+(define (open-output-pipe cmd) (open-pipe cmd \"w\"))\n\
+");
}
diff --git a/r4rstest.scm b/r4rstest.scm
index 6573e20..35da2f4 100644
--- a/r4rstest.scm
+++ b/r4rstest.scm
@@ -13,7 +13,7 @@
;; To receive a copy of the GNU General Public License, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA; or view
-;; http://www-swiss.ai.mit.edu/~jaffer/GPL.html
+;; http://swissnet.ai.mit.edu/~jaffer/GPL.html
;;;; "r4rstest.scm" Test correctness of scheme implementations.
;;; Author: Aubrey Jaffer
@@ -105,10 +105,10 @@
(for-each (lambda (f)
(set! i (+ 1 i))
(cond ((and (= i j))
- (cond ((not (f x))) (test #t f x)))
+ (cond ((not (f x)) (test #t f x))))
((f x) (test #f f x)))
(cond ((and (= i j))
- (cond ((not (f y))) (test #t f y)))
+ (cond ((not (f y)) (test #t f y))))
((f y) (test #f f y))))
disjoint-type-functions))
(list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c))
@@ -259,6 +259,16 @@
(test 88 foo 88)
(test 4 foo 4)
(test 34 'define x)
+(test 99 'internal-define (letrec ((foo (lambda (arg)
+ (or arg (and (procedure? foo)
+ (foo 99))))))
+ (define bar (foo #f))
+ (foo #f)))
+(test 77 'internal-define (letrec ((foo 77)
+ (bar #f)
+ (retfoo (lambda () foo)))
+ (define baz (retfoo))
+ (retfoo)))
(SECTION 6 1)
(test #f not #t)
(test #f not 3)
@@ -560,37 +570,37 @@
(display ";testing bignums; ")
(newline)
(SECTION 6 5 5)
- (test 0 modulo 3333333333 3)
- (test 0 modulo 3333333333 -3)
- (test 0 remainder 3333333333 3)
- (test 0 remainder 3333333333 -3)
- (test 2 modulo 3333333332 3)
- (test -1 modulo 3333333332 -3)
- (test 2 remainder 3333333332 3)
- (test 2 remainder 3333333332 -3)
- (test 1 modulo -3333333332 3)
- (test -2 modulo -3333333332 -3)
- (test -2 remainder -3333333332 3)
- (test -2 remainder -3333333332 -3)
-
- (test 3 modulo 3 3333333333)
- (test 3333333330 modulo -3 3333333333)
- (test 3 remainder 3 3333333333)
- (test -3 remainder -3 3333333333)
- (test -3333333330 modulo 3 -3333333333)
- (test -3 modulo -3 -3333333333)
- (test 3 remainder 3 -3333333333)
- (test -3 remainder -3 -3333333333)
+ (test 0 modulo 33333333333333333333 3)
+ (test 0 modulo 33333333333333333333 -3)
+ (test 0 remainder 33333333333333333333 3)
+ (test 0 remainder 33333333333333333333 -3)
+ (test 2 modulo 33333333333333333332 3)
+ (test -1 modulo 33333333333333333332 -3)
+ (test 2 remainder 33333333333333333332 3)
+ (test 2 remainder 33333333333333333332 -3)
+ (test 1 modulo -33333333333333333332 3)
+ (test -2 modulo -33333333333333333332 -3)
+ (test -2 remainder -33333333333333333332 3)
+ (test -2 remainder -33333333333333333332 -3)
+
+ (test 3 modulo 3 33333333333333333333)
+ (test 33333333333333333330 modulo -3 33333333333333333333)
+ (test 3 remainder 3 33333333333333333333)
+ (test -3 remainder -3 33333333333333333333)
+ (test -33333333333333333330 modulo 3 -33333333333333333333)
+ (test -3 modulo -3 -33333333333333333333)
+ (test 3 remainder 3 -33333333333333333333)
+ (test -3 remainder -3 -33333333333333333333)
(test 0 modulo -2177452800 86400)
(test 0 modulo 2177452800 -86400)
(test 0 modulo 2177452800 86400)
(test 0 modulo -2177452800 -86400)
- (test #t 'remainder (tb 281474976710655 65535))
- (test #t 'remainder (tb 281474976710654 65535))
+ (test #t 'remainder (tb 281474976710655325431 65535))
+ (test #t 'remainder (tb 281474976710655325430 65535))
(SECTION 6 5 6)
- (test 281474976710655 string->number "281474976710655")
- (test "281474976710655" number->string 281474976710655)
+ (test 281474976710655325431 string->number "281474976710655325431")
+ (test "281474976710655325431" number->string 281474976710655325431)
(report-errs))
(SECTION 6 5 6)
@@ -1027,7 +1037,7 @@
(if (and (string->number "0.0") (inexact? (string->number "0.0")))
(test-inexact))
-(let ((n (string->number "281474976710655")))
+(let ((n (string->number "281474976710655325431")))
(if (and n (exact? n))
(test-bignum)))
(newline)
diff --git a/ramap.c b/ramap.c
index 25a1df9..d00e400 100644
--- a/ramap.c
+++ b/ramap.c
@@ -538,6 +538,9 @@ SCM sc2array(s, ra, prot)
switch TYP7(ARRAY_V(res)) {
case tc7_vector:
break;
+ case tc7_bvect:
+ if (BOOL_T==s || BOOL_F==s) break;
+ goto mismatch;
case tc7_string:
if ICHRP(s) break;
goto mismatch;
@@ -1375,11 +1378,14 @@ SCM array_map(ra0, proc, lra)
ramapc(ramap_a, proc, ra0, lra, s_array_map);
}
return UNSPECIFIED;
-#ifdef CCLO
- case tc7_cclo:
- lra = cons(sc2array(proc,ra0,EOL), lra);
- proc = CCLO_SUBR(proc);
- goto tail;
+#if 1 /* def CCLO */
+ case tc7_specfun:
+ if (tc16_cclo==TYP16(proc)) {
+ lra = cons(sc2array(proc,ra0,EOL), lra);
+ proc = CCLO_SUBR(proc);
+ goto tail;
+ }
+ goto gencase;
#endif
}
}
@@ -1425,15 +1431,18 @@ SCM array_for_each(proc, ra0, lra)
ASSERT(BOOL_T==procedurep(proc), proc, ARG1, s_array_for_each);
tail:
switch TYP7(proc) {
- default:
+ default: gencase:
ramapc(rafe, proc, ra0, lra, s_array_for_each);
return UNSPECIFIED;
-#ifdef CCLO
- case tc7_cclo:
- lra = cons(ra0, lra);
- ra0 = sc2array(proc, ra0, EOL);
- proc = CCLO_SUBR(proc);
- goto tail;
+#if 1 /* def CCLO */
+ case tc7_specfun:
+ if (tc16_cclo==TYP16(proc)) {
+ lra = cons(ra0, lra);
+ ra0 = sc2array(proc, ra0, EOL);
+ proc = CCLO_SUBR(proc);
+ goto tail;
+ }
+ goto gencase;
#endif
}
}
diff --git a/record.c b/record.c
index 126a1fc..7724889 100644
--- a/record.c
+++ b/record.c
@@ -174,9 +174,8 @@ SCM rec_constr1(args)
SCM rec, inds = (((rec_cclo *)CDR(cclo))->constr.indices);
sizet i = INUM(((rec_cclo *)CDR(cclo))->constr.recsize);
args = CDR(args);
- NEWCELL(rec);
DEFER_INTS;
- SETCHARS(rec, must_malloc((i+1L)*sizeof(SCM), s_record));
+ rec = must_malloc_cell((i+1L)*sizeof(SCM), s_record);
SETNUMDIGS(rec, i+1L, tc16_record);
ALLOW_INTS;
while (i--)
@@ -272,7 +271,7 @@ static SCM markrec(ptr)
static sizet freerec(ptr)
CELLPTR ptr;
{
- must_free(CHARS(ptr));
+ must_free(CHARS(ptr), sizeof(SCM)*NUMDIGS(ptr));
return sizeof(SCM)*NUMDIGS(ptr);
}
static int recprin1(exp, port, writing)
@@ -332,9 +331,10 @@ void init_record()
SCM i_name = CAR(intern(s_name, (sizeof s_name)-1));
SCM i_fields = CAR(intern(s_fields, (sizeof s_fields)-1));
tc16_record = newsmob(&recsmob);
- NEWCELL(the_rtd_rtd);
- SETCHARS(the_rtd_rtd, must_malloc((long)sizeof(rtd_type), s_record));
+ DEFER_INTS;
+ the_rtd_rtd = must_malloc_cell((long)sizeof(rtd_type), s_record);
SETNUMDIGS(the_rtd_rtd, (long)sizeof(rtd_type)/sizeof(SCM), tc16_record);
+ ALLOW_INTS;
REC_RTD(the_rtd_rtd) = the_rtd_rtd;
RTD_NAME(the_rtd_rtd) = makfromstr(s_record, (sizeof s_record)-1);
RTD_FIELDS(the_rtd_rtd) = cons2(i_name, i_fields, EOL);
diff --git a/repl.c b/repl.c
index 1593909..a60d7e8 100644
--- a/repl.c
+++ b/repl.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, 1998 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -66,7 +66,6 @@ unsigned char upcase[CHAR_CODE_LIMIT];
unsigned char downcase[CHAR_CODE_LIMIT];
unsigned char lowers[] = "abcdefghijklmnopqrstuvwxyz";
unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-extern int verbose;
void init_tables()
{
int i;
@@ -75,7 +74,7 @@ void init_tables()
upcase[lowers[i]] = uppers[i];
downcase[uppers[i]] = lowers[i];
}
- verbose = 1; /* Here so that monitor info won't be */
+ scm_verbose = 1; /* Here so that monitor info won't be */
/* printed while in init_storage. (BOOM) */
}
@@ -120,9 +119,8 @@ char *isymnames[] = {
/* NUM_ISPCSYMS ISPCSYMS here */
"#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda",
"#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!",
- "#@define", "#@apply", "#@call-with-current-continuation",
- "#@farloc-car", "#@farloc-cdr", "#@delay", "#@quasiquote",
- "#@unquote", "#@unquote-splicing", "#@else", "#@=>",
+ "#@define", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay",
+ "#@quasiquote", "#@unquote", "#@unquote-splicing", "#@else", "#@=>",
/* user visible ISYMS */
/* other keywords */
/* Flags */
@@ -158,13 +156,13 @@ void ipruk(hdr, ptr, port)
lputs(hdr, port);
if (scm_cell_p(ptr)) {
lputs(" (0x", port);
- intprint(CAR(ptr), 16, port);
+ intprint(CAR(ptr), -16, port);
lputs(" . 0x", port);
- intprint(CDR(ptr), 16, port);
+ intprint(CDR(ptr), -16, port);
lputs(") @", port);
}
lputs(" 0x", port);
- intprint(ptr, 16, port);
+ intprint(ptr, -16, port);
lputc('>', port);
}
@@ -177,8 +175,8 @@ void iprlist(hdr, exp, tlr, port, writing)
lputs(hdr, port);
/* CHECK_INTS; */
iprin1(CAR(exp), port, writing);
- exp = CDR(exp);
- for(;NIMP(exp);exp = CDR(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);
@@ -214,16 +212,16 @@ taloop:
lputs(charnames[(sizeof charnames/sizeof(char *))-1], port);
#endif /* ndef EBCDIC */
else if (i > '\177')
- intprint(i, 8, port);
+ intprint(i, -8, port);
else lputc((int)i, 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);
+ intprint((long)IFRAME(exp), -10, port);
lputc(ICDRP(exp)?'-':'+', port);
- intprint((long)IDIST(exp), 10, port);
+ intprint((long)IDIST(exp), -10, port);
}
else goto idef;
break;
@@ -296,18 +294,24 @@ taloop:
lputs(CHARS(SNAME(exp)), port);
lputc('>', port);
break;
+ case tc7_specfun:
#ifdef CCLO
- case tc7_cclo:
- lputs("#<compiled-closure ", port);
- iprin1(CCLO_SUBR(exp), port, writing);
+ if (tc16_cclo==TYP16(exp)) {
+ lputs("#<compiled-closure ", port);
+ iprin1(CCLO_SUBR(exp), port, writing);
+ lputc('>', port);
+ break;
+ }
+#endif
+ lputs("#<primitive-procedure ", port);
+ lputs(CHARS(CDR(exp)), port);
lputc('>', port);
break;
-#endif
case tc7_contin:
lputs("#<continuation ", port);
- intprint(LENGTH(exp), 10, port);
+ intprint(LENGTH(exp), -10, port);
lputs(" @ ", port);
- intprint((long)CHARS(exp), 16, port);
+ intprint((long)CHARS(exp), -16, port);
lputc('>', port);
break;
case tc7_port:
@@ -325,6 +329,10 @@ taloop:
}
}
+#ifndef GO32
+static char s_char_readyp[]="char-ready?";
+#endif
+
#ifdef __IBMC__
# define MSDOS
#endif
@@ -349,7 +357,7 @@ static int input_waiting(f)
# ifdef MWC
# include <sys/io.h>
# else
-# ifndef THINK_C
+# ifndef macintosh
# ifndef ARM_ULIB
# include <sys/ioctl.h>
# endif
@@ -371,12 +379,15 @@ static int input_waiting(f)
# ifdef HAVE_SELECT
fd_set ifds;
struct timeval tv;
+ int ret;
FD_ZERO(&ifds);
FD_SET(fileno(f), &ifds);
tv.tv_sec = 0;
tv.tv_usec = 0;
- select((fileno(f) + 1), &ifds, (fd_set *) NULL, (fd_set *) NULL, &tv);
+ SYSCALL(ret = select((fileno(f) + 1), &ifds, (fd_set *) NULL,
+ (fd_set *) NULL, &tv););
+ ASSERT(ret>=0, MAKINUM(ret), "select error", s_char_readyp);
return FD_ISSET(fileno(f), &ifds);
# else
# ifdef FIONREAD
@@ -392,7 +403,6 @@ static int input_waiting(f)
#endif
/* perhaps should undefine MSDOS from __IBMC__ here */
#ifndef GO32
-static char s_char_readyp[]="char-ready?";
SCM char_readyp(port)
SCM port;
{
@@ -488,7 +498,7 @@ FILE *trans = 0;
SCM trans_on(fil)
SCM fil;
{
- transcript = open_file(fil, makfromstr("w", (sizet)sizeof(char)));
+ transcript = try_open_file(fil, makfromstr("w", (sizet)sizeof(char)));
if FALSEP(transcript) trans = 0;
else trans = STREAM(transcript);
return UNSPECIFIED;
@@ -515,6 +525,7 @@ void lputs(s, port)
SCM port;
{
sizet i = PTOBNUM(port);
+ ASSERT(s, INUM0, ARG1, "lputs");
SYSCALL((ptobs[i].fputs)(s, STREAM(port)););
if (trans && (port==def_outp || port==cur_errp))
SYSCALL(fputs(s, trans););
@@ -711,13 +722,11 @@ lpc: switch (c) {
++j; goto lp;
}
goto tryagain;
- case '.':
- p = lreadr(tok_buf, port);
- return EVAL(p, (SCM)EOL);
default: callshrp:
p = CDR(intern("read:sharp", (sizeof "read:sharp")-1));
if NIMP(p) {
- p = apply(p, MAKICHR(c), acons(port, EOL, EOL));
+ p = apply(p, cons2(MAKICHR(c), port, EOL), EOL);
+ /* p = apply(p, MAKICHR(c), acons(port, EOL, EOL)); */
if (UNSPECIFIED==p) goto tryagain;
return p;
}
@@ -897,16 +906,20 @@ struct errdesc errmsgs[] = {
{"numerical overflow", 0, FPE_SIGNAL},
{"Argument out of range", 0, FPE_SIGNAL},
{"Could not allocate", "out-of-storage", 0},
+ {"Thrashing", "thrashing", 0},
{"EXIT", "end-of-program", -1},
{"hang up", "hang-up", EXIT},
{"user interrupt", "user-interrupt", 0},
{"arithmetic error", "arithmetic-error", 0},
{"bus error", 0, 0},
{"segment violation", 0, 0},
- {"alarm", "alarm-interrupt", 0}
+ {"alarm", "alarm-interrupt", 0},
+ {"profile interrupt", "profile-interrupt", 0},
};
-int errjmp_bad = 1, ints_disabled = 1, sig_deferred = 0, alrm_deferred;
+void (* deferred_proc) P((void)) = 0;
+int errjmp_bad = 1, ints_disabled = 1;
+unsigned long SIG_deferred = 0;
SCM err_exp, err_env;
char *err_pos, *err_s_subr;
cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL};
@@ -915,12 +928,14 @@ SCM *loc_errobj = (SCM *)&tmp_errobj;
SCM *loc_loadpath = (SCM *)&tmp_loadpath;
SCM loadport = UNDEFINED;
long linum = 1;
-int verbose = 1;
+int scm_verbose = 1;
long cells_allocated = 0, lcells_allocated = 0,
mallocated = 0, lmallocated = 0,
rt = 0, gc_rt, gc_time_taken;
long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
long gc_syms_collected;
+long scm_env_work = 0, scm_gcs = 0, scm_egcs = 0,
+ scm_stk_moved = 0, scm_clo_moved = 0, scm_egc_rt;
static void def_err_response P((void));
int handle_it(i)
@@ -928,12 +943,39 @@ int handle_it(i)
{
char *name = errmsgs[i-WNA].s_response;
SCM proc;
- if (errjmp_bad) return -1; /* sends it to def_err_response */
+ if (errjmp_bad)
+ wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */
if (name) {
- NEWCELL(proc); /* discard possibly-used cell */
+ SCM n[2];
+ int j;
+ for (j=0; j<2; j++) {
+ NEWCELL(n[j]); /* discard 2 possibly-used cells */
+ }
+ CDR(n[1]) = EOL;
proc = CDR(intern(name, (sizet)strlen(name)));
- if NIMP(proc) {
+ if NIMP(proc) { /* Save environment stack, in case it
+ moves when applying proc. Do an ecache gc
+ to protect contents of stack. */
+ SCM estk, *estk_ptr, env, env_tmp;
+ DEFER_INTS;
+#ifndef NO_ENV_CACHE
+ scm_egc();
+#endif
+ estk = scm_estk;
+ estk_ptr = scm_estk_ptr;
+ env = scm_env;
+ env_tmp = scm_env_tmp;
+ scm_estk = BOOL_F;
+ scm_estk_reset();
+ ALLOW_INTS;
apply(proc, EOL, EOL);
+ DEFER_INTS;
+ scm_estk = estk;
+ scm_estk_ptr = estk_ptr;
+ scm_env = env;
+ scm_env_tmp = env_tmp;
+ scm_fill_freelist();
+ ALLOW_INTS;
return i;
}
}
@@ -993,9 +1035,10 @@ SCM repl_driver(initpath)
case 0:
exitval = MAKINUM(EXIT_SUCCESS);
errjmp_bad = 0;
+ lflush(sys_errp);
errno = 0;
- alrm_deferred = 0;
- sig_deferred = 0;
+ SIG_deferred = 0;
+ deferred_proc = 0;
ints_disabled = 0;
if (dumped) {
lcells_allocated = cells_allocated;
@@ -1005,19 +1048,25 @@ SCM repl_driver(initpath)
}
else if (scm_ldfile(initpath)) /* load Scheme init files */
wta(*loc_errobj, "Could not open file", s_load);
- scm_evstr("(boot-tail)"); /* initialization tail-call */
+ {
+ SCM boot_tail = scm_evstr("boot-tail");
+ /* initialization tail-call */
+ apply(boot_tail, (dumped ? BOOL_T : BOOL_F), listofnull);
+ }
case -2: /* abrt */
reset_toplvl:
+ ints_disabled = 1;
errjmp_bad = 0;
- alrm_deferred = 0;
- sig_deferred = 0;
- ints_disabled = 0;
+ lflush(sys_errp);
+ SIG_deferred = 0;
+ deferred_proc = 0;
+ scm_estk_reset();
/* Closing the loading file turned out to be a bad idea. */
/* But I will leave the code here in case someone wants it. */
#ifdef CLOSE_LOADING_PORTS_ON_ABORT
if (NIMP(loadport) && OPINPORTP(loadport)) {
- if (verbose > 1) {
+ if (scm_verbose > 1) {
lputs("; Aborting load (closing): ", cur_errp);
display(*loc_loadpath, cur_errp);
newline(cur_errp);
@@ -1027,6 +1076,7 @@ SCM repl_driver(initpath)
#endif
*loc_loadpath = BOOL_F;
loadport = UNDEFINED;
+ ints_disabled = 0;
repl();
err_pos = (char *)EXIT;
i = EXIT;
@@ -1037,8 +1087,18 @@ SCM repl_driver(initpath)
return 0;
#ifdef CAN_DUMP
case -4: /* dump */
+ DEFER_INTS;
+ scm_estk_reset();
+ scm_egc();
igc(s_unexec, (STACKITEM *)0);
+ ALLOW_INTS;
dumped = 1;
+# ifdef linux
+ /* The last few words of the .data segment
+ were not being mapped in for dumped
+ executables. */
+ sbrk(getpagesize());
+# endif
unexec(CHARS(*loc_errobj), execpath, 0, 0, 0);
goto reset_toplvl;
#endif
@@ -1057,21 +1117,22 @@ SCM prog_args()
extern char s_heap[];
extern sizet hplim_ind;
extern CELLPTR *hplims;
-void growth_mon(obj, size, units)
+void growth_mon(obj, size, units, grewp)
char *obj;
long size;
char *units;
+ int grewp;
{
if (verbose>2)
{
- lputs("; grew ", cur_errp);
- lputs(obj, cur_errp);
- lputs(" to ", cur_errp);
- intprint(size, 10, cur_errp);
- lputc(' ', cur_errp);
- lputs(units, cur_errp);
+ lputs((grewp ? "; grew " : "; shrank "), sys_errp);
+ lputs(obj, sys_errp);
+ lputs(" to ", sys_errp);
+ intprint(size, -10, sys_errp);
+ lputc(' ', sys_errp);
+ lputs(units, sys_errp);
if ((verbose>4) && (obj==s_heap)) heap_report();
- lputs("\n", cur_errp);
+ lputs("\n", sys_errp);
}
}
@@ -1079,13 +1140,11 @@ void gc_start(what)
char *what;
{
if (verbose>3 && FPORTP(cur_errp)) {
- ALLOW_INTS;
- lputs(";GC(", cur_errp);
- lputs(what, cur_errp);
- lputs(")", cur_errp);
- lfflush(cur_errp);
- DEFER_INTS;
+ lputs(";GC(", sys_errp);
+ lputs(what, sys_errp);
+ lputs(")", sys_errp);
}
+ scm_gcs++;
gc_rt = INUM(my_time());
gc_cells_collected = 0;
gc_malloc_collected = 0;
@@ -1097,52 +1156,109 @@ void gc_end()
gc_rt = INUM(my_time()) - gc_rt;
gc_time_taken = gc_time_taken + gc_rt;
if (verbose>3) {
- ALLOW_INTS;
- if (!FPORTP(cur_errp)) lputs(";GC ", cur_errp);
- intprint(time_in_msec(gc_rt), 10, cur_errp);
- lputs(" cpu mSec, ", cur_errp);
- intprint(gc_cells_collected, 10, cur_errp);
- lputs(" cells, ", cur_errp);
- intprint(gc_malloc_collected, 10, cur_errp);
- lputs(" malloc, ", cur_errp);
- intprint(gc_syms_collected, 10, cur_errp);
- lputs(" syms, ", cur_errp);
- intprint(gc_ports_collected, 10, cur_errp);
- lputs(" ports collected\n", cur_errp);
- lfflush(cur_errp);
- DEFER_INTS;
+ if (!FPORTP(cur_errp)) lputs(";GC ", sys_errp);
+ intprint(time_in_msec(gc_rt), -10, sys_errp);
+ lputs(" cpu mSec, ", sys_errp);
+ intprint(gc_cells_collected, -10, sys_errp);
+ lputs(" cells, ", sys_errp);
+ intprint(gc_malloc_collected, -10, sys_errp);
+ lputs(" malloc, ", sys_errp);
+ intprint(gc_syms_collected, -10, sys_errp);
+ lputs(" syms, ", sys_errp);
+ intprint(gc_ports_collected, -10, sys_errp);
+ lputs(" ports collected\n", sys_errp);
}
}
+void scm_egc_start()
+{
+ scm_egc_rt = INUM(my_time());
+ scm_egcs++;
+}
+void scm_egc_end()
+{
+ scm_egc_rt = INUM(my_time()) - scm_egc_rt;
+ gc_time_taken = gc_time_taken + scm_egc_rt;
+}
void repl_report()
{
if (verbose>1) {
lfflush(cur_outp);
lputs(";Evaluation took ", cur_errp);
- intprint(time_in_msec(INUM(my_time())-rt), 10, cur_errp);
+ intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp);
lputs(" mSec (", cur_errp);
- intprint(time_in_msec(gc_time_taken), 10, cur_errp);
+ intprint(time_in_msec(gc_time_taken), -10, cur_errp);
lputs(" in gc) ", cur_errp);
- intprint(cells_allocated - lcells_allocated, 10, cur_errp);
+ intprint(cells_allocated - lcells_allocated, -10, cur_errp);
lputs(" cells work, ", cur_errp);
- intprint(mallocated - lmallocated, 10, cur_errp);
+ scm_env_work += scm_ecache_len - scm_ecache_index;
+ intprint(scm_env_work, -10, cur_errp);
+ lputs(" env, ", cur_errp);
+ intprint(mallocated - lmallocated, -10, cur_errp);
lputs(" bytes other\n", cur_errp);
+ if (verbose>2) {
+ lputc(';', cur_errp);
+ intprint(scm_gcs, -10, cur_errp);
+ lputs( " gc, ", cur_errp);
+ intprint(scm_egcs, -10, cur_errp);
+ lputs( " ecache gc, ", cur_errp);
+ intprint(scm_clo_moved, -10, cur_errp);
+ lputs(" env migrated from closures, ", cur_errp);
+ intprint(scm_stk_moved, -10, cur_errp);
+ lputs(" from stack\n", cur_errp);
+ }
lfflush(cur_errp);
}
}
-SCM lroom(args)
- SCM args;
+#ifndef LACK_SBRK
+extern long scm_init_brk, scm_dumped_brk;
+void scm_brk_report()
+{
+ long scm_curbrk = sbrk(0),
+ dif1 = ((dumped ? scm_dumped_brk : scm_curbrk) - scm_init_brk)/1024,
+ dif2 = (scm_curbrk - scm_dumped_brk)/1024;
+
+ lputs("initial brk = 0x", cur_errp);
+ intprint(scm_init_brk, -16, cur_errp);
+ if (dumped) {
+ lputs(", dumped = 0x", cur_errp);
+ intprint(scm_dumped_brk, -16, cur_errp);
+ }
+ lputs(", current = 0x", cur_errp);
+ intprint(scm_curbrk, -16, cur_errp);
+ lputs("; ", cur_errp);
+ intprint(dif1, 10, cur_errp);
+ if (dumped) {
+ lputs(dif2<0 ? " - " : " + ", cur_errp);
+ intprint(dif2<0 ? -dif2 : dif2, 10, cur_errp);
+ }
+ lputs(" kb\n", cur_errp);
+}
+#endif
+#ifdef NUM_HP
+extern long num_hp_total;
+#endif
+SCM lroom(opt)
+ SCM opt;
{
- intprint(cells_allocated, 10, cur_errp);
+ intprint(cells_allocated, -10, cur_errp);
lputs(" out of ", cur_errp);
- intprint(heap_size, 10, cur_errp);
+ intprint(heap_cells, -10, cur_errp);
lputs(" cells in use, ", cur_errp);
- intprint(mallocated, 10, cur_errp);
+ intprint(mallocated, -10, cur_errp);
lputs(" bytes allocated (of ", cur_errp);
intprint(mtrigger, 10, cur_errp);
lputs(")\n", cur_errp);
- if NIMP(args) {
+ if (!UNBNDP(opt)) {
+#ifdef NUM_HP
+ intprint(num_hp_total, 10, cur_errp);
+ lputs(" bytes allocated for flonums/bignums\n", cur_errp);
+#endif
+#ifndef LACK_SBRK
+ scm_brk_report();
+#endif
+ scm_ecache_report();
heap_report();
- lputs("\n", cur_errp);
+ lputc('\n', cur_errp);
stack_report();
}
return UNSPECIFIED;
@@ -1150,21 +1266,42 @@ SCM lroom(args)
void heap_report()
{
sizet i = 0;
- lputs("; heap segments:", cur_errp);
- while(i<hplim_ind) {
- lputs("\n; 0x", cur_errp);
- intprint((long)hplims[i++], 16, cur_errp);
- lputs(" - 0x", cur_errp);
- intprint((long)hplims[i++], 16, cur_errp);
- }
+ lputs(";; heap segments:", sys_errp);
+ while(i < hplim_ind) {
+ {
+ long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]);
+ lputs("\n; 0x", sys_errp);
+ intprint((long)hplims[i++], -16, sys_errp);
+ lputs(" - 0x", sys_errp);
+ intprint((long)hplims[i++], -16, sys_errp);
+ lputs("; ", sys_errp);
+ intprint(seg_cells, 10, sys_errp);
+ lputs(" cells; ", sys_errp);
+ intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp);
+ lputs(" kb", sys_errp);
+ }}
+}
+void scm_ecache_report()
+{
+ long n = LENGTH(scm_estk) - 1;
+ while (n-- && VELTS(scm_estk)[n]==UNSPECIFIED)
+ ;
+ intprint(n + 1L, 10 , cur_errp);
+ lputs(" out of ", cur_errp);
+ intprint(LENGTH(scm_estk), 10, cur_errp);
+ lputs(" env stack items touched, ", cur_errp);
+ intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp);
+ lputs(" out of ", cur_errp);
+ 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);
+ intprint(time_in_msec(INUM(my_time())), -10, cur_errp);
lputs(" mSec my time, ", cur_errp);
- intprint(time_in_msec(INUM(your_time())), 10, cur_errp);
+ intprint(time_in_msec(INUM(your_time())), -10, cur_errp);
lputs(" mSec your time\n", cur_errp);
}
}
@@ -1174,8 +1311,8 @@ SCM prolixity(arg)
{
int old = verbose;
if (!UNBNDP(arg)) {
- if FALSEP(arg) verbose = 1;
- else verbose = INUM(arg);
+ if FALSEP(arg) scm_verbose = 1;
+ else scm_verbose = INUM(arg);
}
return MAKINUM(old);
}
@@ -1183,6 +1320,7 @@ SCM prolixity(arg)
void repl()
{
SCM x;
+ int c;
repl_report();
while(1) {
if OPOUTPORTP(cur_inp) { /* This case for curses window */
@@ -1195,14 +1333,22 @@ void repl()
lfflush(cur_outp);
}
lcells_allocated = cells_allocated;
+ scm_env_work = scm_ecache_index - scm_ecache_len;
+ scm_egcs = scm_clo_moved = scm_stk_moved = 0;
lmallocated = mallocated;
x = lread(cur_inp);
rt = INUM(my_time());
+ scm_gcs = 0;
gc_time_taken = 0;
if (EOF_VAL==x) break;
- if (!CRDYP(cur_inp)) /* assure newline read (and transcripted) */
- lungetc(lgetc(cur_inp), cur_inp);
-#ifdef __TURBOC__
+ if (!CRDYP(cur_inp)) { /* assure newline read (and transcripted) */
+ if (EOF==(c = lgetc(cur_inp))) break;
+ lungetc(c, cur_inp);
+ }
+#ifdef __HIGHC__
+# define __MSDOS__
+#endif
+#ifdef __MSDOS__
if ('\n' != CGETUN(cur_inp))
if OPOUTPORTP(cur_inp) /* This case for curses window */
{lfflush(cur_outp); newline(cur_inp);}
@@ -1228,9 +1374,6 @@ SCM abrt()
{
if (errjmp_bad) exit(EXIT_FAILURE);
dowinds(EOL, ilength(dynwinds));
-#ifdef CAUTIOUS
- stacktrace = EOL;
-#endif
longjump(CONT(rootcont)->jmpbuf, COOKIE(-2));
}
char s_restart[] = "restart";
@@ -1238,9 +1381,6 @@ SCM restart()
{
/* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */
dowinds(EOL, ilength(dynwinds));
-#ifdef CAUTIOUS
- stacktrace = EOL;
-#endif
longjump(CONT(rootcont)->jmpbuf, COOKIE(-3));
}
@@ -1252,15 +1392,20 @@ SCM scm_execpath(newpath)
SCM retval = execpath ? makfrom0str(execpath) : BOOL_F;
if (UNBNDP(newpath))
return retval;
- if (FALSEP(newpath)) {
+ if (FALSEP(newpath) || BOOL_T==newpath) {
if (execpath) free(execpath);
execpath = 0;
- return retval;
+ if (BOOL_T==newpath) {
+ execpath = scm_find_executable();
+ return execpath ? makfrom0str(execpath) : BOOL_F;
+ }
+ else return retval;
}
ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath);
if (execpath) free(execpath);
- if ((execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1))))
- strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1);
+ execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1));
+ ASSERT(execpath, newpath, NALLOC, s_execpath);
+ strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1);
return retval;
}
@@ -1272,35 +1417,57 @@ SCM scm_unexec(newpath)
ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec);
ASSERT(execpath, UNSPECIFIED, s_no_ep, s_unexec);
*loc_errobj = newpath;
-# ifdef CAUTIOUS
- stacktrace = EOL;
-# endif
longjump(CONT(rootcont)->jmpbuf, COOKIE(-4));
}
#endif
#ifdef CAREFUL_INTS
-void ints_viol(sense)
- int sense;
+ints_infot *ints_info = 0;
+static void ints_viol_iprin(num)
+ long num;
{
- fputs(";ints already ", stderr);
- fputs(sense ? "en" : "dis", stderr);
- fputs("abled\n", stderr);
+ char num_buf[INTBUFLEN];
+ sizet i = iint2str(num, 10, num_buf);
+ num_buf[i] = 0;
+ fputs(num_buf, stderr);
}
-#endif
-
-void han_sig()
+void ints_viol(info, sense)
+ ints_infot *info;
+ int sense;
{
- sig_deferred = 0;
- if (INT_SIGNAL != handle_it(INT_SIGNAL))
- wta(UNDEFINED, (char *)INT_SIGNAL, "");
+ fputs(info->fname, stderr);
+ fputc(':', stderr);
+ ints_viol_iprin(info->linum);
+ fputs(": ints already ", stderr);
+ fputs(sense ? "dis" : "en", stderr);
+ fputs("abled (", stderr);
+ ints_viol_iprin((long)ints_disabled);
+ fputs(")\n", stderr);
+ if (ints_info) {
+ fputs(ints_info->fname, stderr);
+ fputc(':', stderr);
+ ints_viol_iprin(ints_info->linum);
+ fputs(": last change\n", stderr);
+ }
+ ints_info = info;
}
-void han_alrm()
+void ints_warn(str1, str2, fname, linum)
+ char *str1, *str2, *fname;
+ int linum;
{
- alrm_deferred = 0;
- if (ALRM_SIGNAL != handle_it(ALRM_SIGNAL))
- wta(UNDEFINED, (char *)ALRM_SIGNAL, "");
+ fputs(fname, stderr);
+ fputc(':', stderr);
+ ints_viol_iprin(linum);
+ fputs(" :uprotected call to ", stderr);
+ fputs(str1, stderr);
+ if (str2) {
+ fputs(" (", stderr);
+ fputs(str2, stderr);
+ fputc(')', stderr);
+ }
+ fputc('\n', stderr);
}
+#endif
#ifdef TAIL_RECURSIVE_LOAD
SCM tryload(filename)
@@ -1362,30 +1529,33 @@ SCM tryload(filename)
#endif
#ifdef CAUTIOUS
-void scm_print_stack(stk)
- SCM stk;
+static void trace1(estk, n)
+ SCM estk;
+ int n;
{
- switch (ilength(stk)) {
- case -1:
- lputs("\n; circular stacktrace!", cur_errp);
- return;
- case -2:
- lputs("\n; stacktrace not a list?", cur_errp);
- iprin1(stk, cur_errp, 1);
- return;
- default:
- while NNULLP(stk) {
- SCM ste = CAR(stk);
- lputc('\n', cur_errp);
- iprin1(ste, cur_errp, 1);
- stk = CDR(stk);
- }
- }
+ SCM ste = VELTS(estk)[SCM_ESTK_BASE + n*SCM_ESTK_FRLEN + 2];
+ lputs("\n\n", cur_errp);
+ intprint(n, -10, cur_errp);
+ lputs(": ", cur_errp);
+ iprin1(ste, cur_errp, 1);
}
+
SCM scm_stack_trace()
{
- if (0==ilength(stacktrace)) return BOOL_F;
- scm_print_stack(stacktrace);
+ long n = (scm_estk_ptr - VELTS(scm_estk));
+ n = (n - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
+ if (0>=n) return BOOL_F;
+ lputs("\n;STACK TRACE", cur_errp);
+ *scm_estk_ptr = scm_env;
+ if (n > 21) {
+ int i;
+ for (i = 0; i < 10; i++) trace1(scm_estk, n-i);
+ lputs("\n\n ...", cur_errp);
+ n = 10;
+ }
+ do {
+ trace1(scm_estk, n);
+ } while (--n > 0);
return BOOL_T;
}
#endif
@@ -1445,9 +1615,6 @@ SCM lperror(arg)
static void def_err_response()
{
SCM obj = *loc_errobj;
-#ifdef CAUTIOUS
- SCM stk = stacktrace;
-#endif
DEFER_INTS;
err_head("ERROR");
lputs("ERROR: ", cur_errp);
@@ -1483,7 +1650,7 @@ outobj:
}
else lputs(" (see errobj)", cur_errp);
#ifdef CAUTIOUS
- if NNULLP(stk) scm_print_stack(stk);
+ scm_stack_trace();
#endif
if UNBNDP(err_exp) goto getout;
if NIMP(err_exp) {
@@ -1496,6 +1663,7 @@ outobj:
if NULLP(err_env) lputs("\n; in top level environment.", cur_errp);
else {
SCM env = err_env;
+ if (NIMP(env) && tc16_env==CAR(env)) env = CDR(env);
lputs("\n; in scope:", cur_errp);
while NNULLP(env) {
lputc('\n', cur_errp);
@@ -1509,7 +1677,10 @@ outobj:
lfflush(cur_errp);
err_exp = err_env = UNDEFINED;
if (errjmp_bad) {
+ lputs("\nerrobj: ", cur_errp);
iprin1(obj, cur_errp, 1);
+ newline(cur_errp);
+ lroom(BOOL_T);
lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp);
#ifdef vms
exit(EXIT_FAILURE);
@@ -1529,21 +1700,14 @@ void everr(exp, env, arg, pos, s_subr)
*loc_errobj = arg;
err_pos = pos;
err_s_subr = s_subr;
-#ifndef CAUTIOUS
- if (((~0x1fL) & (long)pos) || (WNA>(long)pos)
- || NIMP(dynwinds) || errjmp_bad)
-#endif
- {
- def_err_response();
- dowinds(EOL, ilength(dynwinds));
- abrt();
- }
-#ifndef CAUTIOUS
- /* We don't have to clear stacktrace because CAUTIOUS never gets here */
- /* We don't have to dowinds() because dynwinds is EOL */
+ if (((~0x1fL) & (long)pos) || (WNA>(long)pos) || errjmp_bad) {
+ def_err_response();
+ abrt();
+ }
+ if IMP(rootcont) exit(INUM(exitval));
+ dowinds(EOL, ilength(dynwinds));
longjump(CONT(rootcont)->jmpbuf, COOKIE((int)pos));
/* will do error processing at stack base */
-#endif
}
void wta(arg, pos, s_subr)
SCM arg;
@@ -1590,6 +1754,14 @@ SCM set_errp(port)
cur_errp = port;
return oerrp;
}
+static char s_isatty[] = "isatty?";
+SCM l_isatty(port)
+ SCM port;
+{
+ ASSERT(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;
+}
static iproc subr0s[] = {
{&s_cur_inp[4], cur_input_port},
@@ -1617,6 +1789,7 @@ static iproc subr1s[] = {
{"make-arbiter", makarb},
{s_tryarb, tryarb},
{s_relarb, relarb},
+ {s_isatty, l_isatty},
{0, 0}};
static iproc subr1os[] = {
@@ -1632,6 +1805,8 @@ static iproc subr1os[] = {
{"verbose", prolixity},
{"errno", lerrno},
{s_execpath, scm_execpath},
+ {"find-init-file", scm_find_impl},
+ {"room", lroom},
{0, 0}};
static iproc subr2os[] = {
@@ -1655,12 +1830,11 @@ void init_repl( iverbose )
transcript = BOOL_F;
trans = 0;
linum = 1;
- verbose = iverbose;
+ scm_verbose = iverbose;
init_iprocs(subr0s, tc7_subr_0);
init_iprocs(subr1os, tc7_subr_1o);
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(subr2os, tc7_subr_2o);
- make_subr("room", tc7_lsubr, lroom);
#ifndef GO32
add_feature(s_char_readyp);
#endif
@@ -1671,7 +1845,7 @@ void init_repl( iverbose )
(cond ((null? thunk) (set! *interactive* #f) (set! *argv* #f))\n\
((not (car thunk)) (set! *argv* #f))\n\
((boolean? (car thunk)))\n\
- (else (set! boot-tail (car thunk))))\n\
+ (else (set! boot-tail (lambda (t) ((car thunk))))))\n\
(set! restart exec-self)\n\
(require #f)\n\
(unexec file))\n\
diff --git a/rgx.c b/rgx.c
index 974116a..1006cf8 100644
--- a/rgx.c
+++ b/rgx.c
@@ -51,7 +51,7 @@
#endif
static char rcsid[] =
- "$Id: rgx.c, v 1.20 1995/02/15 04:39:45 dpb Exp $";
+ "$Id: rgx.c,v 1.4 1998/09/11 18:13:43 radey Exp $";
#ifdef HAVE_ALLOCA
# include <alloca.h>
@@ -131,7 +131,7 @@ int prinregex(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#<regex ", port);
- intprint(CDR(exp), 16, port);
+ intprint(CDR(exp), -16, port);
lputc(' ', port);
iprin1(RGX_PATTERN(exp), port, writing);
lputc('>', port);
@@ -192,9 +192,10 @@ SCM lregcomp(pattern, flags)
ASSERT(NIMP(pattern) && STRINGP(pattern), pattern, ARG1, s_regcomp);
ASSERT(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)),
flags, ARG2, s_regcomp);
- NEWCELL(z);
DEFER_INTS;
- SETCHARS(z, info=(regex_info*)must_malloc((long)sizeof(regex_info), s_regex));
+ z = must_malloc_cell((long)sizeof(regex_info), s_regex);
+ scm_protect_temp(&z);
+ info=(regex_info*)CHARS(z);
prog = &(info->rgx);
CAR(z) = tc16_rgx;
#ifdef __REGEXP_LIBRARY_H__
@@ -250,12 +251,19 @@ SCM lregcomp(pattern, flags)
DEFER_INTS;
if (fastmap)
prog->fastmap = must_malloc(CHAR_SET_SIZE, s_regex);
+ else
+ prog->fastmap = NULL;
if (ignore_case) {
prog->translate = must_malloc(CHAR_SET_SIZE, s_regex);
for (i = 0; i < CHAR_SET_SIZE; i++)
prog->translate[i] = ISUPPER (i) ? tolower (i) : i;
}
+ else
+ prog->translate = NULL;
+
+ prog->buffer = NULL;
+ prog->allocated = 0;
re_set_syntax(options);
err_msg = (char *)re_compile_pattern(CHARS(pattern), LENGTH(pattern), prog);
diff --git a/rope.c b/rope.c
index 94b6631..25e90bb 100644
--- a/rope.c
+++ b/rope.c
@@ -356,6 +356,9 @@ int scm_cell_p(x)
&& PTR_GT(hplims[--j], ptr)) continue;
return !0; /* NFREEP(x) */
} while(i<j);
+ if (PTR_LE(scm_ecache, ptr)
+ && PTR_GT(scm_ecache+scm_ecache_len, ptr))
+ return !0; /* so we can print environments while debugging */
return 0;
}
diff --git a/scl.c b/scl.c
index 8e89bd8..1b4507d 100644
--- a/scl.c
+++ b/scl.c
@@ -50,10 +50,11 @@
static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar",
s_magnitude[] = "magnitude", s_angle[] = "angle",
s_real_part[] = "real-part", s_imag_part[] = "imag-part",
- s_in2ex[] = "inexact->exact";
+ s_in2ex[] = "inexact->exact",s_ex2in[] = "exact->inexact";
+
static char s_expt[] = "$expt", s_atan2[] = "$atan2";
-static char s_memv[] = "memv", s_assv[] = "assv";
#endif
+static char s_memv[] = "memv", s_assv[] = "assv";
SCM sys_protects[NUM_PROTECTS];
sizet num_protects = NUM_PROTECTS;
@@ -84,7 +85,7 @@ static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
static sizet idbl2str(f, a)
double f;
-char *a;
+ char *a;
{
int efmt, dpt, d, i, wp = dblprec;
sizet ch = 0;
@@ -189,19 +190,17 @@ static sizet iflo2str(flt, str)
}
#endif /* FLOATS */
-sizet iint2str(num, rad, p)
- long num;
+sizet iuint2str(num, rad, p)
+ unsigned long num;
int rad;
char *p;
{
sizet j;
register int i = 1, d;
- register long n = num;
- if (n < 0) {n = -n; i++;}
+ register unsigned long n = num;
for (n /= rad;n > 0;n /= rad) i++;
j = i;
n = num;
- if (n < 0) {n = -n; *p++ = '-'; i--;}
while (i--) {
d = n % rad;
n /= rad;
@@ -209,6 +208,17 @@ sizet iint2str(num, rad, p)
}
return j;
}
+sizet iint2str(num, rad, p)
+ long num;
+ int rad;
+ char *p;
+{
+ if ((num < 0) && !(rad < 0)) {
+ *p++ = '-';
+ return 1 + iuint2str((unsigned long) -num, rad, p);
+ }
+ return iuint2str((unsigned long) num, rad < 0 ? -rad : rad, p);
+}
#ifdef BIGDIG
static SCM big2str(b, radix)
SCM b;
@@ -226,6 +236,7 @@ static SCM big2str(b, radix)
BIGDIG radpow = 1, radmod = 0;
SCM ss = makstr((long)j);
char *s = CHARS(ss), c;
+ scm_protect_temp(&t);
while ((long) radpow * radix < BIGRAD) {
radpow *= radix;
radct++;
@@ -671,8 +682,6 @@ SCM makdbl (x, y)
{
SCM z;
if ((y==0.0) && (x==0.0)) return flo0;
- NEWCELL(z);
- DEFER_INTS;
if (y==0.0) {
# ifdef SINGLES
float fx;
@@ -680,17 +689,29 @@ SCM makdbl (x, y)
if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x))
# endif
{
+ NEWCELL(z);
+ DEFER_INTS;
CAR(z) = tc_flo;
FLO(z) = x;
ALLOW_INTS;
return z;
}
# endif /* def SINGLES */
- CDR(z) = (SCM)must_malloc(1L*sizeof(double), "real");
+ DEFER_INTS;
+# ifdef NUM_HP
+ CDR(z) = (SCM)num_hp_alloc(sizeof(double));
+# else
+ z = must_malloc_cell(1L*sizeof(double), "real");
+# endif
CAR(z) = tc_dblr;
}
else {
- CDR(z) = (SCM)must_malloc(2L*sizeof(double), "complex");
+ DEFER_INTS;
+# ifdef NUM_HP
+ CDR(z) = (SCM)num_hp_alloc(2L*sizeof(double));
+# else
+ z = must_malloc_cell(2L*sizeof(double), "complex");
+# endif
CAR(z) = tc_dblc;
IMAG(z) = y;
}
@@ -698,7 +719,9 @@ SCM makdbl (x, y)
ALLOW_INTS;
return z;
}
+#endif /* FLOATS */
+#ifndef INUMS_ONLY
SCM eqv(x, y)
SCM x, y;
{
@@ -711,9 +734,11 @@ SCM eqv(x, y)
# ifdef BIGDIG
if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
# endif
+# ifdef FLOATS
if (REALPART(x) != REALPART(y)) return BOOL_F;
if (CPLXP(x) && (IMAG(x) != IMAG(y))) return BOOL_F;
return BOOL_T;
+# endif
}
return BOOL_F;
}
@@ -746,7 +771,7 @@ SCM x, alist;
# endif
return BOOL_F;
}
-#endif /* FLOATS */
+#endif
SCM list_tail(lst, k)
SCM lst, k;
@@ -1905,7 +1930,8 @@ double ltrunc(x)
if (x < 0.0) return -floor(-x);
return floor(x);
}
-double round(x)
+
+double scm_round(x)
double x;
{
double plus_half = x + 0.5;
@@ -2063,10 +2089,17 @@ do_angle:
return makdbl(atan2(y, x), 0.0);
}
-double floident(z)
- double z;
+
+SCM ex2in(z)
+ SCM z;
{
- return z;
+ if INUMP(z) return makdbl((double)INUM(z), 0.0);
+ ASRTGO(NIMP(z), badz);
+ if INEXP(z) return z;
+# ifdef BIGDIG
+ if BIGP(z) return makdbl(big2dbl(z), 0.0);
+# endif
+ badz: wta(z, (char *)ARG1, s_ex2in);
}
SCM in2ex(z)
SCM z;
@@ -2257,6 +2290,7 @@ static iproc subr1s[] = {
{s_magnitude, magnitude},
{s_angle, angle},
{s_in2ex, in2ex},
+ {s_ex2in, ex2in},
#else
{"real?", numberp},
{"rational?", numberp},
@@ -2289,13 +2323,15 @@ static iproc subr2s[] = {
#ifdef FLOATS
{s_makrect, makrect},
{s_makpolar, makpolar},
- {s_memv, memv},
- {s_assv, assv},
{s_atan2, latan2},
{s_expt, expt},
+#endif
+#ifdef INUMS_ONLY
+ {s_memv, memq},
+ {s_assv, assq},
#else
- {"memv", memq},
- {"assv", assq},
+ {s_memv, memv},
+ {s_assv, assv},
#endif
{s_list_tail, list_tail},
{s_ve_fill, vector_fill},
@@ -2311,10 +2347,10 @@ static iproc subr2os[] = {
{0, 0}};
static iproc rpsubrs[] = {
-#ifdef FLOATS
- {"eqv?", eqv},
-#else
+#ifdef INUMS_ONLY
{"eqv?", eq},
+#else
+ {"eqv?", eqv},
#endif
{s_eqp, eqp},
{s_lessp, lessp},
@@ -2328,7 +2364,7 @@ static dblproc cxrs[] = {
{"floor", floor},
{"ceiling", ceil},
{"truncate", ltrunc},
- {"round", round},
+ {"round", scm_round},
{"$sqrt", sqrt},
{"$abs", fabs},
{"$exp", exp},
@@ -2346,7 +2382,6 @@ static dblproc cxrs[] = {
{"$asinh", lasinh},
{"$acosh", lacosh},
{"$atanh", latanh},
- {"exact->inexact", floident},
{0, 0}};
#endif
@@ -2372,14 +2407,16 @@ void init_scl()
#endif
#ifdef FLOATS
init_iprocs((iproc *)cxrs, tc7_cxr);
- NEWCELL(flo0);
# ifdef SINGLES
+ NEWCELL(flo0);
CAR(flo0) = tc_flo;
FLO(flo0) = 0.0;
# else
- CDR(flo0) = (SCM)must_malloc(1L*sizeof(double), "real");
+ DEFER_INTS;
+ flo0 = must_malloc_cell(1L*sizeof(double), "real");
REAL(flo0) = 0.0;
CAR(flo0) = tc_dblr;
+ ALLOW_INTS;
# endif
# ifdef DBL_DIG
dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
diff --git a/scm.1 b/scm.1
index d536061..671f528 100644
--- a/scm.1
+++ b/scm.1
@@ -1,5 +1,5 @@
.\" dummy line
-.TH SCM "Jan 9 1995"
+.TH SCM "Sep 2 1998"
.UC 4
.SH NAME
scm \- a Scheme Language Interpreter
@@ -92,7 +92,7 @@ is not already supported. If
is 2, 3, 4, or 5
.I scm
will require the features neccessary to support R2RS, R3RS, R4RS, or
-proposed R5RS, respectively.
+R5RS, respectively.
.TP
.BI -l filename
.TP
@@ -254,10 +254,10 @@ Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS,
Unix and similar systems. Support for ASCII and EBCDIC character
sets.
.PP
-Conforms to Revised^4 Report on the Algorithmic Language Scheme
+Conforms to Revised^5 Report on the Algorithmic Language Scheme
and the IEEE P1178 specification.
.PP
-Support for SICP, R2RS, R3RS, and (proposed) R5RS scheme code.
+Support for SICP, R2RS, R3RS, and R4RS scheme code.
.PP
Many Common Lisp functions:
logand, logor, logxor, lognot, ash, logcount, integer-length,
@@ -287,22 +287,21 @@ Setable levels of monitoring and timing information printed
interactively (the `verbose' function). Restart, quit, and exec.
.SH FILES
.TP
-code.doc
-.br
-Documentation on the internal representation and how to extend or
-include scm in other programs.
-.TP
scm.texi
.br
-Documentation of SCM in Texinfo format.
-.SH AUTHOR
-Aubrey Jaffer
+Texinfo documentation of
+.I scm
+enhancements, internal representations, and how to extend or include
+.I scm
+in other programs.
+.SH AUTHORS
+Aubrey Jaffer (jaffer @ai.mit.edu)
.br
-(jaffer@ai.mit.edu)
+Radey Shouman (Radey.Shouman @splashtech.com)
.SH BUGS
.SH SEE ALSO
The Scheme specifications for details on specific procedures
-(ftp-swiss.ai.mit.edu:archive/scheme-reports/) or
+(swissnet.ai.mit.edu:archive/scheme-reports/) or
.PP
IEEE Std 1178-1990,
.br
@@ -328,8 +327,3 @@ H. Abelson, G. J. Sussman, and J. Sussman,
Structure and Interpretation of Computer Programs,
.br
The MIT Press, Cambridge, Massachusetts, USA
-.PP
-Enhancements in
-.I scm
-not in the standards are detailed in MANUAL in the source directory.
-
diff --git a/scm.c b/scm.c
index 5f305a8..fc26a6f 100644
--- a/scm.c
+++ b/scm.c
@@ -64,20 +64,28 @@
void final_repl P((void));
void init_dynl P((void));
+void init_edline P((void));
void init_eval P((void));
void init_features P((void));
+void init_gsubr P((void));
void init_io P((void));
void init_ioext P((void));
+void init_posix P((void));
+void init_ramap P((void));
+void init_record P((void));
+void init_rgx P((void));
+void init_rope P((void));
void init_repl P((int iverbose));
void init_sc2 P((void));
void init_scl P((void));
void init_signals P((void));
+void init_socket P((void));
void init_subrs P((void));
void init_tables P((void));
void init_time P((void));
void init_types P((void));
void init_unif P((void));
-void init_ramap P((void));
+void reset_time P((void));
void init_banner()
{
@@ -128,22 +136,69 @@ SCM scm_init_extensions()
# endif
#endif
-#ifdef SIGHUP
-static SIGRETTYPE hup_signal(sig)
+#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];
+void process_signals()
+{
+ int i = NUM_SIGNALS;
+ unsigned long mask = (1L << (i-1));
+ if (output_deferred) {
+ output_deferred = 0;
+ lflush(sys_errp);
+ }
+ if (SIG_deferred)
+ while (i--) {
+ if (SIG_deferred & mask) {
+ SIG_deferred &= ~mask;
+ handle_it(i + SIGNAL_BASE);
+ }
+ mask >>= 1;
+ }
+ deferred_proc = 0;
+}
+static char s_unksig[] = "unknown signal";
+static SIGRETTYPE err_signal(sig)
int sig;
{
- signal(SIGHUP, hup_signal);
- wta(UNDEFINED, (char *)HUP_SIGNAL, "");
+ int i = NUM_SIGNALS;
+ signal(sig, err_signal);
+ while (i--)
+ if (sig == sigdesc[i].signo) break;
+ wta(MAKINUM(sig), (i < 0 ? s_unksig : (char *)(i + SIGNAL_BASE)), "");
}
-#endif
-static SIGRETTYPE int_signal(sig)
+static SIGRETTYPE scmable_signal(sig)
int sig;
{
- sig = errno;
- signal(SIGINT, int_signal);
- if (ints_disabled) sig_deferred = 1;
- else han_sig();
- errno = sig;
+ int oerr = errno;
+ int i = NUM_SIGNALS;
+ while (i--)
+ if (sig == sigdesc[i].signo) break;
+ ASSERT(i >= 0, MAKINUM(sig), s_unksig, "");
+ signal(sig, scmable_signal);
+ if (ints_disabled) {
+ deferred_proc = process_signals;
+ SIG_deferred |= (1L << i);
+ }
+ else {
+#ifdef SIG_UNBLOCK
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set, sig);
+ sigprocmask(SIG_UNBLOCK, &set, 0);
+#endif
+ SIG_deferred &= ~(1L << i);
+ i += SIGNAL_BASE;
+ if (i != handle_it(i)) {
+ errno = oerr;
+ wta(UNDEFINED, (char *)i, "");
+ }
+ }
+ errno = oerr;
}
/* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */
@@ -152,29 +207,8 @@ static SIGRETTYPE int_signal(sig)
# undef FLOATS
#endif
-#ifdef FLOATS
-static SIGRETTYPE fpe_signal(sig)
- int sig;
-{
- signal(SIGFPE, fpe_signal);
- wta(UNDEFINED, (char *)FPE_SIGNAL, "");
-}
-#endif
-#ifdef SIGBUS
-static SIGRETTYPE bus_signal(sig)
- int sig;
-{
- signal(SIGBUS, bus_signal);
- wta(UNDEFINED, (char *)BUS_SIGNAL, "");
-}
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
-static SIGRETTYPE segv_signal(sig)
- int sig;
-{
- signal(SIGSEGV, segv_signal);
- wta(UNDEFINED, (char *)SEGV_SIGNAL, "");
-}
+#ifdef macintosh
+# undef SIGALRM
#endif
#ifdef atarist
# undef SIGALRM /* only available via MiNT libs */
@@ -186,15 +220,6 @@ static SIGRETTYPE segv_signal(sig)
# undef SIGALRM
#endif
#ifdef SIGALRM
-static SIGRETTYPE alrm_signal(sig)
- int sig;
-{
- sig = errno;
- signal(SIGALRM, alrm_signal);
- if (ints_disabled) alrm_deferred = 1;
- else han_alrm();
- errno = sig;
-}
static char s_alarm[] = "alarm";
SCM lalarm(i)
SCM i;
@@ -204,12 +229,38 @@ SCM lalarm(i)
SYSCALL(j = alarm(INUM(i)););
return MAKINUM(j);
}
+# ifdef SIGPROF
+# include <sys/time.h>
+static char s_proftimer[] = "profile-timer";
+SCM scm_proftimer(interval)
+ SCM interval;
+{
+ struct itimerval tval, oval;
+ int w;
+ if (UNBNDP(interval))
+ SYSCALL(w = getitimer(ITIMER_PROF, &oval););
+ else {
+ if (BOOL_F==interval) interval = INUM0;
+ ASSERT(INUMP(interval), interval, ARG2, s_proftimer);
+ tval.it_interval.tv_sec = INUM(interval) / 1000;
+ tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000;
+ tval.it_value.tv_sec = tval.it_interval.tv_sec;
+ tval.it_value.tv_usec = tval.it_interval.tv_usec;
+ SYSCALL(w = setitimer(ITIMER_PROF, &tval, &oval););
+ }
+ if (w) return BOOL_F;
+ return MAKINUM(oval.it_interval.tv_usec/1000 +
+ oval.it_interval.tv_sec*1000);
+}
+# endif
# ifndef AMIGA
+# ifndef __CYGWIN32__
SCM l_pause()
{
pause();
return UNSPECIFIED;
}
+# endif
# endif
#endif /* SIGALRM */
@@ -232,8 +283,8 @@ SCM l_sleep(i)
# else
SYSCALL(j = sleep(INUM(i)););
# endif
- return MAKINUM(j);
# endif
+ return MAKINUM(j);
}
# endif
#endif
@@ -241,26 +292,32 @@ SCM l_sleep(i)
#ifndef _WIN32
# ifndef GO32
# ifndef sun
+# ifndef THINK_C
/* int raise P((int sig)); */
static char s_raise[] = "raise";
SCM l_raise(sig)
SCM sig;
{
ASSERT(INUMP(sig), sig, ARG1, s_raise);
-# ifdef vms
+# ifdef vms
return MAKINUM(gsignal((int)INUM(sig)));
-# else
-# ifndef __TURBOC__
-# ifdef STDC_HEADERS
+# else
+# ifndef __TURBOC__
+# ifdef STDC_HEADERS
+# ifndef __MWERKS__
return kill(getpid (), (int)INUM(sig)) ? BOOL_F : BOOL_T;
+# else
+ return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
+# endif
+# else
+ return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
+# endif
# else
return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
# endif
-# else
- return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
# endif
-# endif
}
+# endif
# endif
# endif
#endif
@@ -284,27 +341,14 @@ SCM lticks(i)
}
#endif
-#ifdef SIGHUP
-static SIGRETTYPE (*oldhup)();
-#endif
-static SIGRETTYPE (*oldint)();
-#ifdef FLOATS
-static SIGRETTYPE (*oldfpe)();
-#endif
-#ifdef SIGBUS
-static SIGRETTYPE (*oldbus)();
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
-static SIGRETTYPE (*oldsegv)();
-#endif
-#ifdef SIGALRM
-static SIGRETTYPE (*oldalrm) ();
-#endif
#ifdef SIGPIPE
static SIGRETTYPE (*oldpipe) ();
#endif
int dumped = 0; /* Is this an invocation of unexec exe? */
+#ifndef LACK_SBRK
+long scm_init_brk, scm_dumped_brk;
+#endif
#ifdef SHORT_ALIGN
typedef short STACKITEM;
@@ -325,7 +369,10 @@ void init_scm( iverbose, buf0stdin, init_heap_size )
init_types();
init_tables();
init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */
- if (buf0stdin) CAR(def_inp) |= BUF0;
+ }
+ if (buf0stdin) CAR(def_inp) |= BUF0;
+ else CAR(def_inp) &= ~BUF0;
+ if (!dumped) {
init_features();
init_subrs();
init_io();
@@ -334,26 +381,44 @@ void init_scm( iverbose, buf0stdin, init_heap_size )
init_time();
init_repl( iverbose );
init_unif();
- }}
+ }
+ else {
+ reset_time();
+ }
+}
+static void init_sig1(scm_err, signo, handler)
+ int scm_err;
+ int signo;
+ SIGRETTYPE (*handler)();
+{
+ int i = scm_err - SIGNAL_BASE;
+ ASSERT(i < NUM_SIGNALS, MAKINUM(i), OUTOFRANGE, "init_sig1");
+ sigdesc[i].signo = signo;
+ sigdesc[i].nsig = handler;
+ sigdesc[i].osig = signal(signo, handler);
+}
void init_signals()
{
- oldint = signal(SIGINT, int_signal);
+ init_sig1(INT_SIGNAL, SIGINT, scmable_signal);
#ifdef SIGHUP
- oldhup = signal(SIGHUP, hup_signal);
+ init_sig1(HUP_SIGNAL, SIGHUP, scmable_signal);
#endif
#ifdef FLOATS
- oldfpe = signal(SIGFPE, fpe_signal);
+ init_sig1(FPE_SIGNAL, SIGFPE, err_signal);
#endif
#ifdef SIGBUS
- oldbus = signal(SIGBUS, bus_signal);
+ init_sig1(BUS_SIGNAL, SIGBUS, err_signal);
#endif
#ifdef SIGSEGV /* AMIGA lacks! */
- oldsegv = signal(SIGSEGV, segv_signal);
+ init_sig1(SEGV_SIGNAL, SIGSEGV, err_signal);
#endif
#ifdef SIGALRM
alarm(0); /* kill any pending ALRM interrupts */
- oldalrm = signal(SIGALRM, alrm_signal);
+ init_sig1(ALRM_SIGNAL, SIGALRM, scmable_signal);
+# ifdef SIGPROF
+ init_sig1(PROF_SIGNAL, SIGPROF, scmable_signal);
+# endif
#endif
#ifdef SIGPIPE
oldpipe = signal(SIGPIPE, SIG_IGN);
@@ -365,63 +430,48 @@ void init_signals()
siginterrupt(SIGPIPE, 1);
#endif /* ultrix */
}
-
/* This is used in preparation for a possible fork(). Ignore all
signals before the fork so that child will catch only if it
establishes a handler */
void ignore_signals()
{
+ int i = NUM_SIGNALS;
#ifdef ultrix
siginterrupt(SIGINT, 0);
siginterrupt(SIGALRM, 0);
siginterrupt(SIGHUP, 0);
siginterrupt(SIGPIPE, 0);
#endif /* ultrix */
- signal(SIGINT, SIG_IGN);
-#ifdef SIGHUP
- signal(SIGHUP, SIG_DFL);
-#endif
-#ifdef FLOATS
- signal(SIGFPE, SIG_DFL);
-#endif
-#ifdef SIGBUS
- signal(SIGBUS, SIG_DFL);
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
- signal(SIGSEGV, SIG_DFL);
-#endif
+ while (i--)
+ if (sigdesc[i].signo)
+ signal(sigdesc[i].signo, SIG_DFL);
/* Some documentation claims that ALRMs are cleared accross forks.
If this is not always true then the value returned by alarm(0)
will have to be saved and unignore_signals() will have to
reinstate it. */
- /* This code should be neccessary only if the forked process calls
- alarm() without establishing a handler:
+ /* This code should be necessary only if the forked process calls
+ alarm() without establishing a handler: */
#ifdef SIGALRM
- oldalrm = signal(SIGALRM, SIG_DFL);
-#endif */
+ /* oldalrm = signal(SIGALRM, SIG_DFL); */
+#endif
/* These flushes are per warning in man page on fork(). */
fflush(stdout);
fflush(stderr);
+#ifdef SIG_UNBLOCK
+ {
+ sigset_t set;
+ sigfillset(&set);
+ sigprocmask(SIG_UNBLOCK, &set, 0);
+ }
+#endif
}
void unignore_signals()
{
- signal(SIGINT, int_signal);
-#ifdef SIGHUP
- signal(SIGHUP, hup_signal);
-#endif
-#ifdef FLOATS
- signal(SIGFPE, fpe_signal);
-#endif
-#ifdef SIGBUS
- signal(SIGBUS, bus_signal);
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
- signal(SIGSEGV, segv_signal);
-#endif
-#ifdef SIGALRM
- signal(SIGALRM, alrm_signal);
-#endif
+ int i = NUM_SIGNALS;
+ while (i--)
+ if (sigdesc[i].signo)
+ signal(sigdesc[i].signo, sigdesc[i].nsig);
#ifdef ultrix
siginterrupt(SIGINT, 1);
siginterrupt(SIGALRM, 1);
@@ -432,34 +482,26 @@ void unignore_signals()
void restore_signals()
{
+ int i = NUM_SIGNALS;
#ifdef ultrix
siginterrupt(SIGINT, 0);
siginterrupt(SIGALRM, 0);
siginterrupt(SIGHUP, 0);
siginterrupt(SIGPIPE, 0);
#endif /* ultrix */
- signal(SIGINT, oldint);
-#ifdef SIGHUP
- signal(SIGHUP, oldhup);
-#endif
-#ifdef FLOATS
- signal(SIGFPE, oldfpe);
-#endif
-#ifdef SIGBUS
- signal(SIGBUS, oldbus);
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
- signal(SIGSEGV, oldsegv);
-#endif
-#ifdef SIGPIPE
- signal(SIGPIPE, oldpipe);
-#endif
#ifdef SIGALRM
alarm(0); /* kill any pending ALRM interrupts */
- signal(SIGALRM, oldalrm);
+# ifdef SIGPROF
+ scm_proftimer(BOOL_F); /* Turn off interval timer interrupt */
+# endif
+#endif
+ while (i--)
+ if (sigdesc[i].signo)
+ signal(sigdesc[i].signo, sigdesc[i].osig);
+#ifdef SIGPIPE
+ oldpipe = signal(SIGPIPE, SIG_IGN);
#endif
}
-
int run_scm(argc, argv, iverbose, buf0stdin, initpath)
int argc;
char **argv;
@@ -487,10 +529,12 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
progargs = EOL;
progargs = makfromstrs(argc, argv);
- if (!dumped) {
#ifdef HAVE_DYNL
- init_dynl();
+ /* init_dynl() must check dumped to avoid redefining subrs */
+ init_dynl();
#endif
+
+ if (!dumped) {
#ifdef INITS
INITS; /* call initialization of extension files */
#endif
@@ -517,6 +561,10 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
return (int)INUM(i);
}
+#ifdef __CYGWIN32__
+# define SYSTNAME "unix"
+# define DIRSEP "/"
+#endif
#ifdef vms
# define SYSTNAME "vms"
#endif
@@ -553,6 +601,10 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
# define SYSTNAME "thinkc"
# define DIRSEP ":"
#endif
+#ifdef __MWERKS__
+# define SYSTNAME "macos"
+# define DIRSEP ":"
+#endif
#ifdef AMIGA
# define SYSTNAME "amiga"
# define DIRSEP "/"
@@ -569,7 +621,6 @@ int run_scm(argc, argv, iverbose, buf0stdin, initpath)
# define SYSTNAME "acorn"
#endif
#ifdef nosve
-# define INIT_FILE_NAME "Init_scm";
# define DIRSEP "."
#endif
@@ -582,11 +633,14 @@ SCM softtype()
#endif
}
+/* The argument giving the location of a script file, or NULL. */
+static char *script_arg = 0;
+/* The original argv[0], used to find executable. */
+static char *arg0 = 0;
+char *execpath = 0;
+
#ifndef RTL
-# ifndef INIT_FILE_NAME
-# define INIT_FILE_NAME "Init.scm"
-# endif
# ifndef DIRSEP
# define DIRSEP "/"
# endif
@@ -594,53 +648,73 @@ SCM softtype()
# define GENERIC_NAME "scm"
# endif
-char *execpath = 0;
int main(argc, argv)
int argc;
char **argv;
{
int retval, buf0stdin = 0, nargc;
char *getenvpath, *implpath = 0, **nargv;
-
+# ifdef macintosh
+ char *foo[] = { "scm" };
+ if (argc == 0) {
+ argc = 1;
+ argv = foo;
+ }
+# endif
execpath = 0;
+ arg0 = argv[0];
+ /*{
+ char ** argvv = argv;
+ for (;*argvv;argvv++) {
+ fputs(*argvv,stderr);
+ fputs(" ",stderr);
+ }
+ fputs("\n",stderr);
+ }*/
+ /* The following applies only to SCSH style scripts, execpath
+ does not (cannot?) work properly for simple #! scripts */
if ((nargv = script_process_argv(argc, argv))) {
+ script_arg = argv[2];
nargc = script_count_argv(nargv);
-# ifdef unix
-# ifndef MSDOS
- execpath = script_find_executable(argv[2]);
-# endif
-# endif
}
else {
nargv = argv;
nargc = argc;
}
- /* fprintf(stderr, "execpath = %s\n", execpath); fflush(stderr); */
- if (!execpath) execpath = dld_find_executable(argv[0]);
-
+# ifndef LACK_SBRK
+ if (dumped)
+ scm_dumped_brk = (long)sbrk(0);
+ else
+ scm_init_brk = (long)sbrk(0);
+# endif
+ if (!dumped) {
# ifndef nosve
- getenvpath = getenv("SCM_INIT_PATH");
- if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L);
- if (implpath) {
- /* The value of the environment variable supersedes other
- locations, as long as the file exists. */
- implpath = scm_try_path(implpath);
- if (!implpath) {
- fputs("Value of SCM_INIT_PATH (=\"", stderr);
- fputs(getenvpath, stderr);
- fputs("\") not found; Trying elsewhere\n", stderr);
+ getenvpath = getenv("SCM_INIT_PATH");
+ if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L);
+ if (implpath) {
+ /* The value of the environment variable supersedes other
+ locations, as long as the file exists. */
+ implpath = scm_try_path(implpath);
+ if (!implpath) {
+ fputs("Value of SCM_INIT_PATH (=\"", stderr);
+ fputs(getenvpath, stderr);
+ fputs("\") not found; Trying elsewhere\n", stderr);
+ }
}
- }
# endif
-
- if (execpath && (!implpath)) {
- implpath = scm_find_impl_file(execpath,
- GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
- /* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */
- }
+ if (!implpath) {
+ execpath = scm_find_executable();
+ if (execpath) {
+ implpath = scm_find_impl_file(execpath,
+ GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
+ /* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */
+ }
+ }
# ifdef IMPLINIT
- if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L);
+ /* Should IMPLINIT somehow be visible if we've been dumped? */
+ if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L);
# endif
+ }
# ifndef GO32
if (isatty(fileno(stdin))) {
buf0stdin = !0; /* stdin gets marked BUF0 in init_scm() */
@@ -648,7 +722,7 @@ int main(argc, argv)
# ifndef _DCC
# ifndef ultrix
# ifndef __WATCOMC__
-# ifndef THINK_C
+# ifndef macintosh
# if (__TURBOC__ != 1)
# ifndef _Windows
setbuf(stdin, 0); /* Often setbuf isn't actually required */
@@ -673,6 +747,38 @@ int main(argc, argv)
}
#endif
+char *scm_find_executable()
+{
+ char *execpath = 0;
+#ifndef macintosh
+# ifdef unix
+# ifndef MSDOS
+ if (script_arg)
+ execpath = script_find_executable(script_arg);
+# endif
+# endif
+ if (!execpath && arg0) execpath = dld_find_executable(arg0);
+ /* fprintf(stderr, "scm_find_executable: execpath = %s\n", execpath); fflush(stderr); */
+#endif
+ return execpath;
+}
+
+/* Initialized in repl.c */
+char s_scm_find_impl[] = "find-init-file";
+SCM scm_find_impl(execpath)
+ SCM execpath;
+{
+ SCM res;
+ char *implpath = 0;
+ ASSERT(NIMP(execpath) && STRINGP(execpath), execpath, ARG1, "find-init-file");
+ implpath = scm_find_impl_file(CHARS(execpath),
+ GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
+ res = (implpath ? makfrom0str(implpath) : BOOL_F);
+ if (implpath) free(implpath);
+ return res;
+}
+
+
#ifndef _Windows
char s_system[] = "system";
SCM lsystem(cmd)
@@ -737,7 +843,9 @@ static iproc subr0s[] = {
#endif
#ifdef SIGALRM
# ifndef AMIGA
+# ifndef __CYGWIN32__
{"pause", l_pause},
+# endif
# endif
#endif
{0, 0}};
@@ -751,6 +859,9 @@ static iproc subr1s[] = {
#endif
#ifdef SIGALRM
{s_alarm, lalarm},
+# ifdef SIGPROF
+ {s_proftimer, scm_proftimer},
+# endif
#endif
#ifndef AMIGA
# ifndef _Windows
diff --git a/scm.doc b/scm.doc
index eaa34e0..8f4dc75 100644
--- a/scm.doc
+++ b/scm.doc
@@ -1,7 +1,7 @@
-SCM(Jan 9 1995) SCM(Jan 9 1995)
+SCM(Sep 2 1998) SCM(Sep 2 1998)
NAME
@@ -67,12 +67,12 @@ OPTIONS
-SCM(Jan 9 1995) SCM(Jan 9 1995)
+SCM(Sep 2 1998) SCM(Sep 2 1998)
2, 3, 4, or 5 scm will require the features necces-
- sary to support R2RS, R3RS, R4RS, or proposed R5RS,
- respectively.
+ sary to support R2RS, R3RS, R4RS, or R5RS, respec-
+ tively.
-lfilename
@@ -133,7 +133,7 @@ SCM(Jan 9 1995) SCM(Jan 9 1995)
-SCM(Jan 9 1995) SCM(Jan 9 1995)
+SCM(Sep 2 1998) SCM(Sep 2 1998)
are to be treated as program aguments.
@@ -199,7 +199,7 @@ EXAMPLES
-SCM(Jan 9 1995) SCM(Jan 9 1995)
+SCM(Sep 2 1998) SCM(Sep 2 1998)
mode.
@@ -217,45 +217,45 @@ FEATURES
Unicos, VMS, Unix and similar systems. Support for ASCII
and EBCDIC character sets.
- Conforms to Revised^4 Report on the Algorithmic Language
+ Conforms to Revised^5 Report on the Algorithmic Language
Scheme and the IEEE P1178 specification.
- Support for SICP, R2RS, R3RS, and (proposed) R5RS scheme
- code.
+ Support for SICP, R2RS, R3RS, and R4RS scheme code.
Many Common Lisp functions: logand, logor, logxor, lognot,
- ash, logcount, integer-length, bit-extract, defmacro,
- macroexpand, macroexpand1, gentemp, defvar, force-output,
- software-type, get-decoded-time, get-internal-run-time,
+ ash, logcount, integer-length, bit-extract, defmacro,
+ macroexpand, macroexpand1, gentemp, defvar, force-output,
+ software-type, get-decoded-time, get-internal-run-time,
get-internal-real-time, delete-file, rename-file, copy-
tree, acons, and eval.
- Char-code-limit, most-positive-fixnum, most-negative-
- fixnum, and internal-time-units-per-second constants.
+ Char-code-limit, most-positive-fixnum, most-negative-
+ fixnum, and internal-time-units-per-second constants.
*Features* and *load-pathname* variables.
- Arrays and bit-vectors. String ports and software emula-
- tion ports. I/O extensions providing most of ANSI C and
+ Arrays and bit-vectors. String ports and software emula-
+ tion ports. I/O extensions providing most of ANSI C and
POSIX.1 facilities.
- User definable responses to interrupts and errors, Pro-
- cess-syncronization primitives, String regular expression
+ User definable responses to interrupts and errors, Pro-
+ cess-syncronization primitives, String regular expression
matching, and the CURSES screen management package.
- Available add-on packages including an interactive debug-
+ Available add-on packages including an interactive debug-
ger, database, X-window graphics, BGI graphics, Motif, and
Open-Windows packages.
- A compiler (HOBBIT, available separately) and dynamic
+ A compiler (HOBBIT, available separately) and dynamic
linking of compiled modules.
- Setable levels of monitoring and timing information
- printed interactively (the `verbose' function). Restart,
+ Setable levels of monitoring and timing information
+ printed interactively (the `verbose' function). Restart,
quit, and exec.
FILES
- code.doc
- Documentation on the internal representation and
+ scm.texi
+ Texinfo documentation of scm enhancements, internal
+ representations, and how to extend or include scm
@@ -265,22 +265,19 @@ FILES
-SCM(Jan 9 1995) SCM(Jan 9 1995)
-
+SCM(Sep 2 1998) SCM(Sep 2 1998)
- how to extend or include scm in other programs.
- scm.texi
- Documentation of SCM in Texinfo format.
+ in other programs.
-AUTHOR
- Aubrey Jaffer
- (jaffer@ai.mit.edu)
+AUTHORS
+ Aubrey Jaffer (jaffer @ai.mit.edu)
+ Radey Shouman (Radey.Shouman @splashtech.com)
BUGS
SEE ALSO
The Scheme specifications for details on specific proce-
- dures (ftp-swiss.ai.mit.edu:archive/scheme-reports/) or
+ dures (swissnet.ai.mit.edu:archive/scheme-reports/) or
IEEE Std 1178-1990,
IEEE Standard for the Scheme Programming Language,
@@ -298,8 +295,11 @@ SEE ALSO
Structure and Interpretation of Computer Programs,
The MIT Press, Cambridge, Massachusetts, USA
- Enhancements in scm not in the standards are detailed in
- MANUAL in the source directory.
+
+
+
+
+
diff --git a/scm.h b/scm.h
index 55be55a..1af22f1 100644
--- a/scm.h
+++ b/scm.h
@@ -100,6 +100,11 @@ typedef struct {
long inc;
} array_dim;
+#ifndef INUMS_ONLY
+# define NUM_HP_MAX_REQ 4*sizeof(double)
+
+#endif
+
#ifdef FLOATS
typedef struct {char *string;double (*cproc)P((double));} dblproc;
# ifdef SINGLES
@@ -137,7 +142,9 @@ typedef struct {SCM type;double *real;} dbl;
#define ISYMP(n) ((0x187 & (int)(n))==4)
/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */
#define IFLAGP(n) ((0x87 & (int)(n))==4)
-#define ISYMNUM(n) ((int)((n)>>9))
+#define ISYMNUM(n) (((int)((n)>>9)) & 0x7f)
+#define ISYMVAL(n) ((int)((n)>>16))
+#define ISYMSETVAL(isym, val) ((isym) | ((long)(val) <<16))
#define ISYMCHARS(n) (isymnames[ISYMNUM(n)])
#define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
#define MAKISYM(n) (((n)<<9)+0x74L)
@@ -183,17 +190,16 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
/* each symbol defined here must have a unique number which */
/* corresponds to it's position in isymnames[] in sys.c */
#define IM_APPLY MAKISYM(14)
-#define IM_CONT MAKISYM(15)
-#define IM_FARLOC_CAR MAKISYM(16)
-#define IM_FARLOC_CDR MAKISYM(17)
-#define IM_DELAY MAKISYM(18)
-#define IM_QUASIQUOTE MAKISYM(19)
-#define IM_UNQUOTE MAKISYM(20)
-#define IM_UQ_SPLICING MAKISYM(21)
-#define IM_ELSE MAKISYM(22)
-#define IM_ARROW MAKISYM(23)
-
-#define NUM_ISYMS 24
+#define IM_FARLOC_CAR MAKISYM(15)
+#define IM_FARLOC_CDR MAKISYM(16)
+#define IM_DELAY MAKISYM(17)
+#define IM_QUASIQUOTE MAKISYM(18)
+#define IM_UNQUOTE MAKISYM(19)
+#define IM_UQ_SPLICING MAKISYM(20)
+#define IM_ELSE MAKISYM(21)
+#define IM_ARROW MAKISYM(22)
+
+#define NUM_ISYMS 23
#define BOOL_F MAKIFLAG(NUM_ISYMS+0)
#define BOOL_T MAKIFLAG(NUM_ISYMS+1)
@@ -253,7 +259,16 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
#define CLOSUREP(x) (TYP3(x)==tc3_closure)
#define CODE(x) (CAR(x)-tc3_closure)
#define SETCODE(x, e) CAR(x) = (e)+tc3_closure
-#define ENV(x) CDR(x)
+#define ENV(x) ((~7L & CDR(x)) ? (~7L & CDR(x)) : EOL)
+#define GCENV ENV
+#define ARGC(x) ((6L & CDR(x))>>1)
+#ifdef CAUTIOUS
+# define SCM_ESTK_FRLEN 3
+#else
+# define SCM_ESTK_FRLEN 2
+#endif
+#define SCM_ESTK_BASE (2*SCM_ESTK_FRLEN)
+extern long tc16_env;
#define PORTP(x) (TYP7(x)==tc7_port)
#define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN))
@@ -273,7 +288,7 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
#define SETSTREAM SETCDR
#define CRDYP(port) (CAR(port) & CRDY)
#define CLRDY(port) {CAR(port) &= CUC;}
-#define CGETUN(port) ((int)SRS(CAR(port), 22))
+#define CGETUN(port) ((unsigned char)SRS(CAR(port), 22))
#define CUNGET(c, port) {CAR(port) += ((long)c<<22) + CRDY;}
#define tc_socket (tc7_port | OPN)
@@ -320,6 +335,7 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
#define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc)
#define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc)
#define CCLO_SUBR(x) (VELTS(x)[0])
+#define CCLO_LENGTH NUMDIGS
#define SYMBOLP(x) (TYP7S(x)==tc7_ssymbol)
#define STRINGP(x) (TYP7(x)==tc7_string)
@@ -387,7 +403,8 @@ extern long tc16_array;
#define tcs_symbols tc7_ssymbol:case tc7_msymbol
#define tcs_bignums tc16_bigpos:case tc16_bigneg
-#define tc3_cons 0
+#define tc3_cons_nimcar 0
+#define tc3_cons_imcar 2:case 4:case 6
#define tc3_cons_gloc 1
#define tc3_closure 3
@@ -405,7 +422,7 @@ extern long tc16_array;
#define tc7_cvect 53
#define tc7_port 55
#define tc7_contin 61
-#define tc7_cclo 63
+#define tc7_specfun 63
/* spare 69 71 77 79 */
#define tc7_subr_0 85
@@ -422,6 +439,11 @@ extern long tc16_array;
#define tc7_smob 127
#define tc_free_cell 127
+#define tc_broken_heart (tc_free_cell+0x10000)
+
+#define tc16_apply (tc7_specfun | (0L<<8))
+#define tc16_call_cc (tc7_specfun | (1L<<8))
+#define tc16_cclo (tc7_specfun | (2L<<8))
#define tc16_flo 0x017f
#define tc_flo 0x017fL
@@ -458,15 +480,15 @@ extern SCM sys_protects[];
#define def_inp sys_protects[3]
#define def_outp sys_protects[4]
#define def_errp sys_protects[5]
-#define listofnull sys_protects[6]
-#define undefineds sys_protects[7]
-#define nullvect sys_protects[8]
-#define nullstr sys_protects[9]
-#define progargs sys_protects[10]
-#define transcript sys_protects[11]
-#define rootcont sys_protects[12]
-#define dynwinds sys_protects[13]
-#define stacktrace sys_protects[14]
+#define sys_errp sys_protects[6]
+#define listofnull sys_protects[7]
+#define undefineds sys_protects[8]
+#define nullvect sys_protects[9]
+#define nullstr sys_protects[10]
+#define progargs sys_protects[11]
+#define transcript sys_protects[12]
+#define rootcont sys_protects[13]
+#define dynwinds sys_protects[14]
#ifdef FLOATS
# define flo0 sys_protects[15]
# define NUM_PROTECTS 16
@@ -481,9 +503,9 @@ extern void (**finals)P((void));
extern unsigned char upcase[], downcase[];
extern SCM symhash;
extern int symhash_dim;
-extern long heap_size;
+extern long heap_cells;
extern CELLPTR heap_org;
-extern SCM freelist;
+extern VOLATILE SCM freelist;
extern long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
extern long gc_syms_collected;
extern long cells_allocated, lcells_allocated, mallocated, lmallocated;
@@ -492,12 +514,15 @@ extern SCM *loc_loadpath;
extern SCM *loc_errobj;
extern SCM loadport;
extern long linum;
-extern int errjmp_bad, ints_disabled, sig_deferred, alrm_deferred;
+extern int errjmp_bad, ints_disabled, output_deferred;
+extern unsigned long SIG_deferred;
extern SCM exitval;
extern int cursinit;
extern unsigned int poll_count, tick_count;
extern int dumped;
extern char *execpath;
+extern int scm_verbose;
+#define verbose (scm_verbose+0)
/* strings used in several source files */
@@ -512,15 +537,20 @@ extern char s_ccl[];
#define s_limit (s_ccl+10)
extern char s_close_port[];
#define s_port_type (s_close_port+6)
+extern char s_call_cc[];
+#define s_cont (s_call_cc+18)
/* function prototypes */
-void gc_mark P((SCM p));
-void han_sig P((void));
-void han_alrm P((void));
+extern void (* deferred_proc) P((void));
+void process_signals P((void));
+int handle_it P((int i));
+SCM must_malloc_cell P((long len, char *what));
+void must_realloc_cell P((SCM z, long olen, long len, char *what));
char *must_malloc P((long len, char *what));
char *must_realloc P((char *where, long olen, long len, char *what));
-void must_free P((char *obj));
+void must_free P((char *obj, sizet len));
+void scm_protect_temp P((SCM *ptr));
long ilength P((SCM sx));
SCM hash P((SCM obj, SCM n));
SCM hashv P((SCM obj, SCM n));
@@ -535,9 +565,12 @@ long newsmob P((smobfuns *smob));
long newptob P((ptobfuns *ptob));
void prinport P((SCM exp, SCM port, char *type));
void repl P((void));
-void growth_mon P((char *obj, long size, char *units));
+void growth_mon P((char *obj, long size, char *units, int grewp));
void gc_start P((char *what));
void gc_end P((void));
+void gc_mark P((SCM p));
+void scm_egc_start P((void));
+void scm_egc_end P((void));
void heap_report P((void));
void exit_report P((void));
void stack_report P((void));
@@ -570,11 +603,11 @@ void warn P((char *str1, char *str2));
void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr));
void wta P((SCM arg, char *pos, char *s_subr));
SCM intern P((char *name, sizet len));
-SCM sysintern P((char *name, SCM val));
+SCM sysintern P((const char *name, SCM val));
SCM sym2vcell P((SCM sym));
SCM makstr P((long len));
-SCM make_subr P((char *name, int type, SCM (*fcn)()));
-SCM closure P((SCM code, SCM env));
+SCM make_subr P((const char *name, int type, SCM (*fcn)()));
+SCM closure P((SCM code, int nargs));
SCM makprom P((SCM code));
SCM force P((SCM x));
SCM makarb P((SCM name));
@@ -583,7 +616,7 @@ SCM relarb P((SCM arb));
SCM ceval P((SCM x, SCM env));
SCM prolixity P((SCM arg));
SCM gc_for_newcell P((void));
-SCM gc P((void));
+SCM gc P((SCM arg));
SCM tryload P((SCM filename));
SCM acons P((SCM w, SCM x, SCM y));
SCM cons2 P((SCM w, SCM x, SCM y));
@@ -652,6 +685,7 @@ int rafill P((SCM ra, SCM fill, SCM ignore));
SCM uve_fill P((SCM uve, SCM fill));
SCM array_fill P((SCM ra, SCM fill));
SCM array_prot P((SCM ra));
+SCM array_rank P((SCM ra));
int bigprint P((SCM exp, SCM port, int writing));
int floprint P((SCM sexp, SCM port, int writing));
SCM istr2int P((char *str, long len, long radix));
@@ -698,6 +732,7 @@ SCM scm_make_cont P((void));
SCM copytree P((SCM obj));
SCM eval P((SCM obj));
SCM identp P((SCM obj));
+SCM ident2sym P((SCM id));
SCM ident_eqp P((SCM id1, SCM id2, SCM env));
SCM renamed_ident P((SCM id, SCM env));
SCM input_portp P((SCM x));
@@ -705,6 +740,7 @@ SCM output_portp P((SCM x));
SCM cur_input_port P((void));
SCM cur_output_port P((void));
SCM i_setbuf0 P((SCM port));
+SCM try_open_file P((SCM filename, SCM modes));
SCM open_file P((SCM filename, SCM modes));
SCM open_pipe P((SCM pipestr, SCM modes));
SCM close_port P((SCM port));
@@ -737,9 +773,13 @@ SCM ura_read P((SCM v, SCM port));
SCM ura_write P((SCM v, SCM port));
SCM aset P((SCM v, SCM obj, SCM args));
SCM aref P((SCM v, SCM args));
+SCM scm_array_ref P((SCM args));
SCM cvref P((SCM v, sizet pos, SCM last));
SCM quit P((SCM n));
-void ints_viol P((int sense));
+#ifdef CAREFUL_INTS
+void ints_viol P((ints_infot *info, int sense));
+void ints_warn P((char *s1, char* s2, char *fname, int linum));
+#endif
void add_final P((void (*final)(void)));
SCM makcclo P((SCM proc, long len));
SCM make_uve P((long k, SCM prot));
@@ -751,7 +791,25 @@ SCM scm_eval_string P((SCM str));
SCM scm_load_string P((SCM str));
void scm_print_stack P((SCM stk));
char * dld_find_executable P((const char* command));
+char * scm_find_executable P((void));
+SCM scm_find_impl P((SCM execpath));
SCM scm_unexec P((const SCM pathname));
+SCM scm_log_aref P((SCM args));
+SCM scm_log_aset P((SCM ra, SCM obj, SCM args));
+SCM scm_logbitp P((SCM index, SCM j1));
+SCM scm_logtest P((SCM x, SCM y));
+SCM scm_logxor P((SCM x, SCM y));
+SCM scm_logand P((SCM x, SCM y));
+SCM scm_logior P((SCM x, SCM y));
+SCM scm_lognot P((SCM n));
+SCM scm_intexpt P((SCM z1, SCM z2));
+SCM scm_ash P((SCM n, SCM cnt));
+SCM scm_bitfield P((SCM n, SCM start, SCM end));
+SCM scm_logcount P((SCM n));
+SCM scm_intlength P((SCM n));
+SCM scm_copybit P((SCM index, SCM j1, SCM bit));
+SCM scm_bitif P((SCM mask, SCM n0, SCM n1));
+SCM scm_copybitfield P((SCM to, SCM start, SCM rest));
/* Defined in "rope.c" */
SCM long2num P((long n));
@@ -781,7 +839,7 @@ double lasinh P((double x));
double lacosh P((double x));
double latanh P((double x));
double ltrunc P((double x));
-double round P((double x));
+double scm_round P((double x));
double floident P((double x));
#endif
@@ -810,6 +868,25 @@ int script_count_argv P((char **argv));
char * scm_find_impl_file P((char *exec_path, const char *generic_name,
const char *initname, const char *sep));
+/* environment cache functions */
+void scm_ecache_report P((void));
+void scm_estk_reset P((void));
+void scm_estk_grow P((sizet inc));
+void scm_env_cons P((SCM x, SCM y));
+void scm_env_cons2 P((SCM w, SCM x, SCM y));
+void scm_env_cons_tmp P((SCM x));
+void scm_extend_env P((SCM names));
+void scm_egc P((void));
+
+/* Global state for environment cache */
+extern CELLPTR scm_ecache;
+extern VOLATILE long scm_ecache_index, scm_ecache_len;
+extern SCM scm_env, scm_env_tmp;
+extern SCM scm_egc_roots[];
+extern long scm_egc_root_index;
+extern SCM scm_estk;
+extern SCM *scm_estk_v, *scm_estk_ptr;
+
#ifdef RECKLESS
# define ASSERT(_cond, _arg, _pos, _subr) ;
# define ASRTGO(_cond, _label) ;
@@ -818,30 +895,39 @@ char * scm_find_impl_file P((char *exec_path, const char *generic_name,
# define ASRTGO(_cond, _label) if(!(_cond)) goto _label;
#endif
-#define ARGn 0
-#define ARG1 1
-#define ARG2 2
-#define ARG3 3
-#define ARG4 4
-#define ARG5 5
+#define ARGn 0
+#define ARG1 1
+#define ARG2 2
+#define ARG3 3
+#define ARG4 4
+#define ARG5 5
/* following must match entry indexes in errmsgs[] */
-#define WNA 6
-#define OVFLOW 7
-#define OUTOFRANGE 8
-#define NALLOC 9
-#define EXIT 10
-#define HUP_SIGNAL 11
-#define INT_SIGNAL 12
-#define FPE_SIGNAL 13
-#define BUS_SIGNAL 14
-#define SEGV_SIGNAL 15
-#define ALRM_SIGNAL 16
+#define WNA 6
+#define OVFLOW 7
+#define OUTOFRANGE 8
+#define NALLOC 9
+#define THRASH 10
+#define EXIT 11
+#define HUP_SIGNAL 12
+#define INT_SIGNAL 13
+#define FPE_SIGNAL 14
+#define BUS_SIGNAL 15
+#define SEGV_SIGNAL 16
+#define ALRM_SIGNAL 17
+#define PROF_SIGNAL 18
#define EVAL(x, env) (IMP(x)?(x):ceval((x), (env)))
#define SIDEVAL(x, env) if NIMP(x) ceval((x), (env))
#define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\
else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}}
+/*
+#define NEWCELL(_into) {DEFER_INTS;if IMP(freelist) _into = gc_for_newcell();\
+ else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}\
+ ALLOW_INTS;}
+*/
+
+int run_scm P((int argc, char **argv, int iverbose, int buf0stdin, char *initpath));
#ifdef __cplusplus
}
diff --git a/scm.texi b/scm.texi
index 5d93f63..199ebd9 100644
--- a/scm.texi
+++ b/scm.texi
@@ -4,16 +4,16 @@
@settitle SCM
@setchapternewpage on
@c Choices for setchapternewpage are {on,off,odd}.
-@paragraphindent 2
+@paragraphindent 0
@defcodeindex ft
@syncodeindex ft tp
-@c @dircategory Scheme
-@c @direntry
-@c * SCM: (scm). A Scheme interpreter.
-@c @end direntry
-
@c %**end of header
+@dircategory The Algorithmic Language Scheme
+@direntry
+* SCM: (scm). A Scheme interpreter.
+@end direntry
+
@iftex
@finalout
@c DL: lose the egregious vertical whitespace, esp. around examples
@@ -24,13 +24,13 @@
@titlepage
@title SCM
@subtitle Scheme Implementation
-@subtitle Version 5b3
-@subtitle May 1997
+@subtitle Version 5c3
+@subtitle April 1998
@author by Aubrey Jaffer
@page
@vskip 0pt plus 1filll
-Copyright @copyright{} 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation
+Copyright @copyright{} 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Free Software Foundation
Permission is granted to make and distribute verbatim copies of
this manual provided the copyright notice and this permission notice
@@ -53,10 +53,11 @@ by the author.
@ifinfo
This manual documents the SCM Scheme implementation. The most recent
information about SCM can be found on SCM's @dfn{WWW} home page:
-@center http://www-swiss.ai.mit.edu/~jaffer/SCM.html
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
-Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation
+
+Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Free Software Foundation
Permission is granted to make and distribute verbatim copies of
this manual provided the copyright notice and this permission notice
@@ -87,9 +88,7 @@ by the author.
* The Language:: Reference.
* Packages:: Optional Capabilities.
* The Implementation:: How it works.
-* Procedure and Macro Index::
-* Variable Index::
-* Type Index::
+* Index::
@end menu
@node Overview, Installing SCM, Top, Top
@@ -103,15 +102,7 @@ machine independent platform for [JACAL], a symbolic algebra system.
@noindent
The most recent information about SCM can be found on SCM's @dfn{WWW}
home page:
-@ifset html
-<A HREF="http://www-swiss.ai.mit.edu/~jaffer/SCM.html">
-@end ifset
-
-@center http://www-swiss.ai.mit.edu/~jaffer/SCM.html
-
-@ifset html
-</A>
-@end ifset
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
@end iftex
@menu
@@ -439,40 +430,40 @@ low priority. SLIB is available from the same sites as SCM:
@ifclear html
@itemize @bullet
@item
-ftp-swiss.ai.mit.edu:/pub/scm/slib2c0.tar.gz
+swissnet.ai.mit.edu:/pub/scm/slib2c3.tar.gz
@item
-prep.ai.mit.edu:/pub/gnu/jacal/slib2c0.tar.gz
+prep.ai.mit.edu:/pub/gnu/jacal/slib2c3.tar.gz
@item
-ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c0.tar.gz
+ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c3.tar.gz
@item
-ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c0.tar.gz
+ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c3.tar.gz
@end itemize
@end ifclear
@ifset html
-<A HREF="file://ftp-swiss.ai.mit.edu/pub/scm/slib2c0.tar.gz">
-ftp-swiss.ai.mit.edu:/pub/scm/slib2c0.tar.gz
+<A HREF="file://swissnet.ai.mit.edu/pub/scm/slib2c3.tar.gz">
+swissnet.ai.mit.edu:/pub/scm/slib2c3.tar.gz
</A>
-<A HREF="file://prep.ai.mit.edu/pub/gnu/jacal/slib2c0.tar.gz">
-prep.ai.mit.edu:/pub/gnu/jacal/slib2c0.tar.gz
+<A HREF="file://prep.ai.mit.edu/pub/gnu/jacal/slib2c3.tar.gz">
+prep.ai.mit.edu:/pub/gnu/jacal/slib2c3.tar.gz
</A>
-<A HREF="file://ftp.maths.tcd.ie/pub/bosullvn/jacal/slib2c0.tar.gz">
-ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c0.tar.gz
+<A HREF="file://ftp.maths.tcd.ie/pub/bosullvn/jacal/slib2c3.tar.gz">
+ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2c3.tar.gz
</A>
-<A HREF="file://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2c0.tar.gz">
-ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2c0.tar.gz
+<A HREF="file://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2c3.tar.gz">
+ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2c3.tar.gz
</A>
@end ifset
@noindent
-Unpack SLIB (@samp{tar xzf slib2c0.tar.gz} or @samp{unzip -ao
-slib2c0.zip}) in an appropriate directory for your system; both
+Unpack SLIB (@samp{tar xzf slib2c3.tar.gz} or @samp{unzip -ao
+slib2c3.zip}) in an appropriate directory for your system; both
@code{tar} and @code{unzip} will create the directory @file{slib}.
@noindent
Then create a file @file{require.scm} in the SCM
@dfn{implementation-vicinity} (this is the same directory as where the
-file @file{Init.scm} is installed). @file{require.scm} should have the
+file @file{Init5c3.scm} is installed). @file{require.scm} should have the
contents:
@example
@@ -551,7 +542,7 @@ bash$ ./build.scm
@print{}
#!/bin/sh
rm -f scmflags.h
-echo '#define IMPLINIT "/home/jaffer/scm/Init.scm"'>>scmflags.h
+echo '#define IMPLINIT "/home/jaffer/scm/Init5c3.scm"'>>scmflags.h
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
@@ -572,7 +563,7 @@ bash$ ./build.scm -p vms
$DELETE scmflags.h
$CREATE scmflags.h
$DECK
-#define IMPLINIT "/home/jaffer/scm/Init.scm"
+#define IMPLINIT "/home/jaffer/scm/Init5c3.scm"
#define BIGNUMS
#define FLOATS
#define ARRAYS
@@ -675,7 +666,7 @@ specifies that that @var{flag} will be put on linker command-lines.
@deffn {Build Option} -s @var{pathname}
@deffnx {Build Option} ---scheme-initial=@var{pathname}
specifies that @var{pathname} should be the default location of the SCM
-initialization file @file{Init.scm}. SCM tries several likely locations
+initialization file @file{Init5c3.scm}. SCM tries several likely locations
before resorting to @var{pathname} (@pxref{File-System Habitat}).
If not specified, the current directory (where build is building) is
used.
@@ -912,7 +903,7 @@ bash$ build -c foo.c -i init_foo
@print{}
#!/bin/sh
rm -f scmflags.h
-echo '#define IMPLINIT "/home/jaffer/scm/Init.scm"'>>scmflags.h
+echo '#define IMPLINIT "/home/jaffer/scm/Init5c3.scm"'>>scmflags.h
echo '#define COMPILED_INITS init_foo();'>>scmflags.h
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
@@ -931,7 +922,7 @@ bash$ build -t dll -c foo.c
@print{}
#!/bin/sh
rm -f scmflags.h
-echo '#define IMPLINIT "/home/jaffer/scm/Init.scm"'>>scmflags.h
+echo '#define IMPLINIT "/home/jaffer/scm/Init5c3.scm"'>>scmflags.h
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
@@ -1090,6 +1081,7 @@ the compilation command lines or add a @code{#define @var{flag}} line to
------- ----------
ARM_ULIB Huw Rogers free unix library for acorn archimedes
AZTEC_C Aztec_C 5.2a
+__CYGWIN32__ cygwin32(?)
_DCC Dice C on AMIGA
__GNUC__ Gnu CC (and DJGPP)
__EMX__ Gnu C port (gcc/emx 0.8e) to OS/2 2.0
@@ -1097,9 +1089,12 @@ __HIGHC__ MetaWare High C
__IBMC__ C-Set++ on OS/2 2.1
_MSC_VER MS VisualC++ 4.2
MWC Mark Williams C on COHERENT
+__MWERKS__ Metrowerks Compiler; Macintosh and WIN32 (?)
+_POSIX_SOURCE ??
_QC Microsoft QuickC
__STDC__ ANSI C compliant
__TURBOC__ Turbo C and Borland C
+__USE_POSIX ??
__WATCOMC__ Watcom C on MS-DOS
__ZTC__ Zortech C
@@ -1111,6 +1106,7 @@ GNUDOS DJGPP (obsolete in version 1.08)
__GO32__ DJGPP (future?)
hpux HP-UX
linux Linux
+macintosh Macintosh (THINK_C and __MWERKS__ define)
MCH_AMIGA Aztec_c 5.2a on AMIGA
MSDOS Microsoft C 5.10 and 6.00A
__MSDOS__ Turbo C, Borland C, and DJGPP
@@ -1214,14 +1210,14 @@ Don't try to run as subproccess
@item remove @dots{} in scmfig.h and recompile scm
@itemx add @dots{} in scmfig.h and recompile scm
Do it and recompile files.
-@item ERROR: @file{Init.scm} not found
+@item ERROR: @file{Init5c3.scm} not found
Assign correct IMPLINIT in makefile or @file{scmfig.h} or define
environment variable @code{SCM_INIT_PATH} to be the full pathname of
-@file{Init.scm} (@pxref{Installing SCM}).
+@file{Init5c3.scm} (@pxref{Installing SCM}).
@item WARNING: require.scm not found
define environment variable @code{SCHEME_LIBRARY_PATH} to be the full
pathname of the scheme library [SLIB] or change @code{library-vicinity} in
-@file{Init.scm} to point to library or remove. @xref{Installation, , , slib,
+@file{Init5c3.scm} to point to library or remove. @xref{Installation, , , slib,
SLIB}.
Make sure the value of @code{(library-vicinity)} has a trailing file
@@ -1291,7 +1287,7 @@ smaller than @code{HEAP_SEG_SIZE}).
@item ERROR: Rogue pointer in Heap.
See above under machine crashes.
@item Newlines don't appear correctly in output files.
-Check file mode (define OPEN_@dots{} in @file{Init.scm}
+Check file mode (define OPEN_@dots{} in @file{Init5c3.scm}
@item Spaces or control characters appear in symbol names
Check character defines in @file{scmfig.h}.
@item Negative numbers turn positive.
@@ -1371,7 +1367,7 @@ variable @var{SCM_INIT_PATH}.
If @var{SCM_INIT_PATH} is not defined or if the file it names is not
present, @code{scm} tries to find the directory containing the
executable file. If it is able to locate the executable, @code{scm}
-looks for the initialization file (usually @file{Init.scm}) in
+looks for the initialization file (usually @file{Init5c3.scm}) in
platform-dependent directories relative to this directory.
@xref{File-System Habitat} for a blow-by-blow description.
@@ -1382,13 +1378,13 @@ compile parameter @var{IMPLINIT} (defined in the makefile or
@noindent
Unless the option @code{-no-init-file} or @code{--no-init-file} occurs
-in the command line, @file{Init.scm} checks to see if there is file
+in the command line, @file{Init5c3.scm} checks to see if there is file
@file{ScmInit.scm} in the path specified by the environment variable
@var{HOME} (or in the current directory if @var{HOME} is undefined). If
it finds such a file it is loaded.
@noindent
-@file{Init.scm} then looks for command input from one of three sources:
+@file{Init5c3.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.
@@ -1558,7 +1554,7 @@ Like above but @code{rev4-optional-procedures} are also loaded.
@defvr {Environment Variable} SCM_INIT_PATH
is the pathname where @code{scm} will look for its initialization
-code. The default is the file @file{Init.scm} in the source directory.
+code. The default is the file @file{Init5c3.scm} in the source directory.
@end defvr
@defvr {Environment Variable} SCHEME_LIBRARY_PATH
@@ -1566,7 +1562,7 @@ is the [SLIB] Scheme library directory.
@end defvr
@defvr {Environment Variable} HOME
-is the directory where @file{Init.scm} will look for the user
+is the directory where @file{Init5c3.scm} will look for the user
initialization file @file{ScmInit.scm}.
@end defvr
@@ -1655,18 +1651,7 @@ Editing of Scheme code is supported by emacs. Buffers holding files
ending in .scm are automatically put into scheme-mode. EMACS for MS-DOS
and MS-Windows systems is available (free) from:
-@ifclear html
-@itemize @bullet
-@item
-http://simtel.coast.net/SimTel/gnu/demacs.html
-@end itemize
-@end ifclear
-
-@ifset html
-<A HREF="http://simtel.coast.net/SimTel/gnu/demacs.html">
-http://simtel.coast.net/SimTel/gnu/demacs.html
-</A>
-@end ifset
+@center @url{http://simtel.coast.net/SimTel/gnu/demacs.html}
If your Emacs can run a process in a buffer you can use the Emacs
command @samp{M-x run-scheme} with SCM. Otherwise, use the emacs
@@ -1800,7 +1785,7 @@ offers source code debugging from
GNU Emacs. PSD runs slowly, so start by instrumenting only a few
functions at a time.
@lisp
-ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz
+swissnet.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz
prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz
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
@@ -1899,14 +1884,14 @@ signal warnings and errors.
@defun warn arg1 arg2 arg3 @dots{}
Alias for @ref{System, slib:warn, , slib, SLIB}. Outputs an error
message containing the arguments. @code{warn} is defined in
-@file{Init.scm}.
+@file{Init5c3.scm}.
@end defun
@defun error arg1 arg2 arg3 @dots{}
Alias for @ref{System, slib:error, , slib, SLIB}. Outputs an error
message containing the arguments, aborts evaluation of the current form
and resumes the top level read-eval-print loop. @code{Error} is defined
-in @file{Init.scm}.
+in @file{Init5c3.scm}.
@end defun
@noindent
@@ -1927,7 +1912,7 @@ systems.
@defun stack-trace
Prints information describing the stack of partially evaluated
expressions. @code{stack-trace} returns @code{#t} if any lines were
-printed and @code{#f} otherwise. See @file{Init.scm} for an example of
+printed and @code{#f} otherwise. See @file{Init5c3.scm} for an example of
the use of @code{stack-trace}.
@end defun
@@ -1958,7 +1943,7 @@ top-level have @r{#@@} prepended.
@noindent
For instance, @code{open-input-file} is defined as follows in
-@file{Init.scm}:
+@file{Init5c3.scm}:
@example
(define (open-input-file str)
@@ -2016,7 +2001,7 @@ interactive, or should quit after the command line is processed.
@var{*interactive*} is controlled directly by the command-line options
@samp{-b}, @samp{-i}, and @samp{-s} (@pxref{Invoking SCM}). If none of
these options are specified, the rules to determine interactivity are
-more complicated; see @file{Init.scm} for details.
+more complicated; see @file{Init5c3.scm} for details.
@end defvar
@defun abort
@@ -2072,7 +2057,7 @@ also gives the hexadecimal heap segment and stack bounds.
@end defun
@defvr Constant *scm-version*
-Contains the version string (e.g. @file{5b3}) of SCM.
+Contains the version string (e.g. @file{5c3}) of SCM.
@end defvr
@subsection Executable path
@@ -2088,6 +2073,7 @@ by calling @code{execpath} with the pathname.
Returns the path (string) which SCM uses to find the executable file
whose invocation the currently running session is, or #f if the path is
not set.
+
@defunx execpath #f
@defunx execpath newpath
Sets the path to @code{#f} or @var{newpath}, respectively. The old path
@@ -2701,9 +2687,15 @@ These procedures generalize and extend the standard capabilities in
@ref{Ports, , ,r4rs, Revised(4) Scheme}.
@defun open-file string modes
+@defunx try-open-file string modes
Returns a port capable of receiving or delivering characters as
specified by the @var{modes} string. If a file cannot be opened
@code{#f} is returned.
+
+Internal functions opening files @dfn{callback} to the SCM function
+@code{open-file}. You can extend @code{open-file} by redefining it.
+@code{try-open-file} is the primitive procedure; Do not redefine
+@code{try-open-file}!
@end defun
@defvr Constant open_read
@@ -2784,6 +2776,10 @@ interactive port that has no ready characters.
@c end rationale
@end deffn
+@defun isatty? port
+Returns @code{#t} if @var{port} is input or output to a serial non-file device.
+@end defun
+
@node Soft Ports, Syntax Extensions, Files and Ports, The Language
@section Soft Ports
@@ -2915,7 +2911,64 @@ If @var{identifier} is unbound in the top level environment, then
@var{initial-value} as if the @code{defvar} form were instead the form
@code{(define identifier initial-value)} . If @var{identifier} already
has a value, then @var{initial-value} is @emph{not} evaluated and
-@var{identifier}'s value is not changed.
+@var{identifier}'s value is not changed. @code{defconst} is valid only
+when used at top-level.
+@end defspec
+
+@defspec defconst identifier value
+If @var{identifier} is unbound in the top level environment, then
+@var{identifier} is @code{define}d to the result of evaluating the form
+@var{value} as if the @code{defconst} form were instead the form
+@code{(define identifier value)} . If @var{identifier} already has a
+value, then @var{value} is @emph{not} evaluated, @var{identifier}'s
+value is not changed, and an error is signaled. @code{defconst} is
+valid only when used at top-level.
+@end defspec
+
+@defspec casev key clause1 clause2 @dots{}
+@code{casev} is an extension of standard Scheme @code{case}: Each
+@var{clause} of a @code{casev} statement must have as first element a
+list containing elements which are:
+
+@itemize @bullet
+@item
+literal datums, or
+@item
+a comma followed by the name of a symbolic constant, or
+@item
+a comma followed by an at-sign (@@) followed by the name of a symbolic
+constant whose value is a list.
+@end itemize
+
+A @code{casev} statement is equivalent to a @code{case} statement in
+which these symbolic constants preceded by commas have been replaced by
+the values of the constants, and all symbolic constants preceded by
+comma-at-signs have been replaced by the elements of the list values of
+the constants. This use of comma, (or, equivalently, @code{unquote}) is
+similar to that of @code{quasiquote} except that the unquoted
+expressions must be @dfn{symbolic constants}.
+
+Symbolic constants are defined using @code{defconst}, their values are
+substituted in the head of each @code{casev} clause during macro
+expansion. @code{defconst} constants should be defined before use.
+@code{casev} can be substituted for any correct use of @code{case}.
+
+@format
+@t{(defconst unit '1)
+(defconst semivowels '(w y))
+(casev (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((,unit 4 6 8 9) 'composite)) ==> composite
+(casev (car '(c d))
+ ((a) 'a)
+ ((b) 'b)) ==> @emph{unspecified}
+(casev (car '(c d))
+ ((a e i o u) 'vowel)
+ ((,@@semivowels) 'semivowel)
+ (else 'consonant)) ==> consonant
+}
+@end format
+
@end defspec
@noindent
@@ -2966,9 +3019,13 @@ from @var{proc} which has been passed to
(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).
@end example
+@end defun
-An @dfn{environment} is a list of @dfn{environment frames}. There are 2
-types of environment frames:
+@defun environment->tree env
+An @dfn{environment} is an opaque object representing lexical bindings.
+@code{environment->tree} returns a representation of the environment
+@var{env} as a list of environment frames. There are 2 types of
+environment frames:
@table @code
@item ((lambda (variable1 @dots{}) @dots{}) value1 @dots{})
@@ -2989,8 +3046,19 @@ result in an environment frame for each variable:
@end defun
@defspec @@apply procedure argument-list
-Returns the result of applying procedure to argument-list. (apply
-procedure argument-list) will produce the same result.
+Returns the result of applying @var{procedure} to @var{argument-list}.
+@code{@@apply} differs from @code{apply} when the identifiers bound by
+the closure being applied are @code{set!}; setting affects
+@var{argument-list}.
+
+@example
+(define lst (list 'a 'b 'c))
+(@@apply (lambda (v1 v2 v3) (set! v1 (cons v2 v3))) lst)
+lst @result{} ((b . c) b c)
+@end example
+
+Thus a mutable environment can be treated as both a list and local
+bindings.
@end defspec
@defspec @@call-with-current-continuation procedure)
@@ -3022,7 +3090,7 @@ use the predicate @code{symbol?}.
A synthetic identifier includes two data: a parent, which is an
identifier, and an environment, which is either @code{#f} or a lexical
-environment which has been passed to a macro expander
+environment which has been passed to a @dfn{macro expander}
(a procedure passed as an argument to @code{procedure->macro},
@code{procedure->memoizing-macro}, or @code{procedure->syntax}).
@@ -3149,10 +3217,10 @@ redefinition, for example:
* Dump:: Create Fast-Booting Executables
* Numeric:: Numeric Language Extensions
* Arrays:: As in APL
-* I/O-Extensions:: 'i/o-extensions
-* Posix Extensions:: 'posix
-* Regular Expression Pattern Matching:: 'regex
-* Line Editing:: 'edit-line
+* I/O-Extensions:: i/o-extensions
+* Posix Extensions:: posix
+* Regular Expression Pattern Matching:: regex
+* Line Editing:: edit-line
* Curses:: Screen Control
* Sockets:: Cruise the Net
@end menu
@@ -3183,7 +3251,7 @@ scm -e'(link-named-scm"cute""cube")'
(lambda (fp)
(for-each
(lambda (string) (write-line string fp))
- '("#define IMPLINIT \"/home/jaffer/scm/Init.scm\""
+ '("#define IMPLINIT \"/home/jaffer/scm/Init5c3.scm\""
"#define COMPILED_INITS init_cube();"
"#define BIGNUMS"
"#define FLOATS"
@@ -3520,7 +3588,7 @@ is not real.
@menu
* Conventional Arrays::
-* Array Mapping::
+* Array Mapping:: array-for-each
* Uniform Array::
* Bit Vectors::
@end menu
@@ -3829,8 +3897,7 @@ Returns @code{#t} if the @var{obj} is an array of type corresponding to
@defun make-uniform-array prototype bound1 bound2 @dots{}
Creates and returns a uniform array of type corresponding to
-@var{prototype} that has as many dimensions as there are @var{bound}s
-and fills it with @var{prototype}.
+@var{prototype} that has as many dimensions as there are @var{bound}s.
@end defun
@defun array-prototype array
@@ -3890,6 +3957,34 @@ omitted, in which case it defaults to the value returned by
@code{(current-output-port)}.
@end defun
+@defun logaref array index1 index2 @dots{}
+If an @var{index} is provided for each dimension of @var{array} returns
+the @var{index1}, @var{index2}, @dots{}'th element of @var{array}. If
+one more @var{index} is provided, then the last index specifies bit
+position of the twos-complement representation of the array element
+indexed by the other @var{index}s returning @code{#t} if the bit is 1,
+and @code{#f} if 0. It is an error if this element is not an exact
+integer.
+
+@example
+(logaref '#(#b1101 #b0010) 0) @result{} #b1101
+(logaref '#(#b1101 #b0010) 0 1) @result{} #f
+(logaref '#2((#b1101 #b0010)) 0 0) @result{} #b1101
+@end example
+@end defun
+
+@defun logaset! array val index1 index2 @dots{}
+If an @var{index} is provided for each dimension of @var{array} sets the
+@var{index1}, @var{index2}, @dots{}'th element of @var{array} to
+@var{val}. If one more @var{index} is provided, then the last index
+specifies bit position of the twos-complement representation of an exact
+integer array element, setting the bit to 1 if @var{bool} is @code{#t}
+and to 0 if @var{bool} is @code{#f} if 0. In this case it is an error
+if the array element is not an exact integer or if @var{val} is not
+boolean.
+@end defun
+
+
@node Bit Vectors, , Uniform Array, Arrays
@subsection Bit Vectors
@@ -3947,10 +4042,6 @@ Returns
If @code{'i/o-extensions} is provided (by linking in @file{ioext.o}),
@ref{Line I/O, , , slib, SLIB}, and the following functions are defined:
-@defun isatty? port
-Returns @code{#t} if @var{port} is input or output to a serial non-file device.
-@end defun
-
@defun stat <port-or-string>
Returns a vector of integers describing the argument. The argument
can be either a string or an open input port. If the argument is an
@@ -5242,7 +5333,7 @@ Returns the host address number (integer) for host @var{string} or
@defun inet:address->string address
Converts an internet (integer) address to a string in numbers and dots
-notation. This is an inverse function to inet:address.
+notation.
@end defun
@defun inet:network address
@@ -5461,7 +5552,7 @@ or you can use a client written in scheme:
@end example
-@node The Implementation, Procedure and Macro Index, Packages, Top
+@node The Implementation, Index, Packages, Top
@chapter The Implementation
@menu
@@ -5705,8 +5796,14 @@ Returns non-zero if @var{x} is a @code{tc3_cons} or isn't, respectively.
@deftp Cell tc3_closure
applicable object returned by (lambda (args) @dots{}).
-@code{tc3_closure}s have a pointer to other the body of the procedure in
-the @code{CAR} and a pointer to the environment in the @code{CDR}.
+@code{tc3_closure}s have a pointer to the body of the procedure in the
+@code{CAR} and a pointer to the environment in the @code{CDR}. Bits 1
+and 2 (zero-based) in the @code{CDR} indicate a lower bound on the
+number of required arguments to the closure, which is used to avoid
+allocating rest argument lists in the environment cache. This encoding
+precludes an immediate value for the @code{CDR}: In the case of
+an empty environment all bits above 2 in the @code{CDR} are zero.
+
@defmac CLOSUREP x
Returns non-zero if @var{x} is a @code{tc3_closure}.
@@ -5717,6 +5814,11 @@ Returns non-zero if @var{x} is a @code{tc3_closure}.
Returns the code body or environment of closure @var{x}, respectively.
@end defmac
+@defmac ARGC x
+Returns the a lower bound on the number of required arguments to closure
+@var{x}, it cannot exceed 3.
+@end defmac
+
@end deftp
@node Header Cells, Subr Cells, Cells, Data Types
@@ -6077,7 +6179,7 @@ gloc PPPPPPPPPPPPPPPPPPPPPPPPPPPPP001}
1s and 0s here indicate type. G missing means sys (not GC'd)
SIMPLE:}
@t{cons ..........SCM car..............0 ...........SCM cdr.............G
-closure ..........SCM code...........011 ...........SCM env.............G
+closure ..........SCM code...........011 ...........SCM env...........CCG
HEADERs:
ssymbol .........long length....G0000101 ..........char *chars...........
msymbol .........long length....G0000111 ..........char *chars...........
@@ -6139,6 +6241,7 @@ array ...short rank..cxxxxxxxxG1111111 ............*array..............}
@menu
* Garbage Collection:: Automatically reclaims unused storage
+* Memory Management for Environments::
* Signals::
* C Macros::
* Changing Scm::
@@ -6152,7 +6255,7 @@ array ...short rank..cxxxxxxxxG1111111 ............*array..............}
* Evaluation:: Why SCM is fast
@end menu
-@node Garbage Collection, Signals, Operations, Operations
+@node Garbage Collection, Memory Management for Environments, Operations, Operations
@subsection Garbage Collection
The garbage collector is in the latter half of @file{sys.c}. The
@@ -6237,7 +6340,116 @@ 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 Signals, C Macros, Garbage Collection, Operations
+@node Memory Management for Environments, Signals, Garbage Collection, Operations
+@subsection Memory Management for Environments
+
+@itemize @bullet
+@item
+@dfn{Ecache} was designed and implemented by Radey Shouman.
+
+@item
+This documentation of ecache was written by Tom Lord.
+@end itemize
+
+The memory management component of SCM contains special features which
+optimize the allocation and garbage collection of environments.
+
+The optimizations are based on certain facts and assumptions:
+
+The SCM evaluator creates many environments with short lifetimes and
+these account of a @emph{large portion} of the total number of objects
+allocated.
+
+The general purpose allocator allocates objects from a freelist, and
+collects using a mark/sweep algorithm. Research into garbage
+collection suggests that such an allocator is sub-optimal for object
+populations containing a large portion of short-lived members and that
+allocation strategies involving a copying collector are more
+appropriate.
+
+It is a property of SCM, reflected throughout the source code, that a
+simple copying collector can not be used as the general purpose memory
+manager: much code assumes that the run-time stack can be treated as a
+garbage collection root set using @dfn{conservative garbage collection}
+techniques, which are incompatible with objects that change location.
+
+Nevertheless, it is possible to use a mostly-separate
+copying-collector, just for environments. Roughly speaking, cons
+pairs making up environments are initially allocated from a small heap
+that is collected by a precise copying collector. These objects must
+be handled specially for the collector to work. The (presumably)
+small number of these objects that survive one collection of the
+copying heap are copied to the general purpose heap, where they will
+later be collected by the mark/sweep collector. The remaining pairs
+are more rapidly collected than they would otherwise be and all of
+this collection is accomplished without having to mark or sweep any
+other segment of the heap.
+
+Allocating cons pairs for environments from this special heap is a
+heuristic that approximates the (unachievable) goal:
+
+@quotation
+allocate all short-lived objects from the copying-heap, at no extra cost
+in allocation time.
+@end quotation
+
+
+@subsubheading Implementation Details
+
+A separate heap (@code{ecache_v}) is maintained for the copying
+collector. Pairs are allocated from this heap in a stack-like fashion.
+Objects in this heap may be protected from garbage collection by:
+
+@enumerate
+@item
+Pushing a reference to the object on a stack specially maintained for
+that purpose. This stack (@code{scm_estk}) is used in place of the C
+run-time stack by the SCM evaluator to hold local variables which refer
+to the copying heap.
+
+@item
+Saving a reference to every object in the mark/sweep heap which directly
+references the copying heap in a root set that is specially maintained
+for that purpose (@code{scm_egc_roots}). If no object in the mark/sweep
+heap directly references an object from the copying heap, that object
+can be preserved by storing a direct reference to it in the
+copying-collector root set.
+@item
+Keeping no other references to these objects, except references between
+the objects themselves, during copying collection.
+@end enumerate
+
+When the copying heap or root-set becomes full, the copying collector is
+invoked. All protected objects are copied to the mark-sweep heap. All
+references to those objects are updated. The copying collector root-set
+and heap are emptied.
+
+References to pairs allocated specificly for environments are
+inaccessible to the Scheme procedures evaluated by SCM. These pairs
+are manipulated by only a small number of code fragments in the
+interpreter. To support copying collection, those code fragments
+(mostly in @file{eval.c}) have been modified to protect environments from
+garbage collection using the three rules listed above.
+
+During a mark-sweep collection, the copying collector heap is marked
+and swept almost like any ordinary segment of the general purpose
+heap. The only difference is that pairs from the copying heap that
+become free during a sweep phase are not added to the freelist.
+
+The environment cache is disabled by adding @code{#define NO_ENV_CACHE}
+to @file{eval.c}; all environment cells are then allocated from the
+regular heap.
+
+@subsubheading Relation to Other Work
+
+This work seems to build upon a considerable amount of previous work
+into garbage collection techniques about which a considerable amount
+of literature is available.
+
+
+
+
+@node Signals, C Macros, Memory Management for Environments, Operations
@subsection Signals
@defun init_signals
@@ -6263,9 +6475,10 @@ macros @code{DEFER_INTS} and @code{ALLOW_INTS}.
@defmac DEFER_INTS
sets the global variable @code{ints_disabled} to 1. If an interrupt
-occurs during a time when @code{ints_disabled} is 1 one of the global
-variables @code{sig_deferred} or @code{alrm_deferred} is set to 1 and
-the handler returns.
+occurs during a time when @code{ints_disabled} is 1, then
+@code{deferred_proc} is set to non-zero, one of the global variables
+@code{SIGINT_deferred} or @code{SIGALRM_deferred} is set to 1, and the
+handler returns.
@defmacx ALLOW_INTS
Checks the deferred variables and if set the appropriate handler is
@@ -6348,7 +6561,8 @@ SCM_dummy1 = (SCM) &@i{foo};
@noindent
@code{SCM_dummy} variables are not currently defined. Passing the
address of the local @code{SCM} variable to @emph{any} procedure also
-protects it.
+protects it. The procedure @code{scm_protect_temp} is provided for
+this purpose.
@noindent
Also, if you maintain a static pointer to some (non-immediate)
@@ -6436,7 +6650,7 @@ will append a symbol @code{'@i{foo}} to the (list) value of
put any scheme code which needs to be run as part of your package into
@file{I@i{foo}.scm}.
@item
-put an @code{if} into @file{Init.scm} which loads @file{I@i{foo}.scm} if
+put an @code{if} into @file{Init5c3.scm} which loads @file{I@i{foo}.scm} if
your package is included:
@example
@@ -6695,7 +6909,7 @@ The source code for these routines are found in @file{rope.c}.
@deftypefun int scm_ldfile (char *@var{file})
Loads the Scheme source file @var{file}. Returns 0 if successful, non-0
if not. This function is used to load SCM's initialization file
-@file{Init.scm}.
+@file{Init5c3.scm}.
@end deftypefun
@deftypefun int scm_ldprog (char *@var{file})
@@ -6979,24 +7193,6 @@ the size down, certain @code{EVALCAR} calls which don't need to be fast
(because they rarely occur or because they are part of expensive
operations) are instead calls to the C function @code{evalcar}.
-There was some discussion a year ago about a "Forth" style Scheme
-interpreter. This is the only improvement I know of which would beat
-SCM in speed.
-
-@quotation
-Provided there is still type code space available in SCM, if we devote
-some of the IMCAR codes to "inlined" operations, we should get a
-significant performance boost. What is eliminated is the having to look
-up a @code{GLOC} or @code{ILOC} and then dispatch on the subr type. The
-IMCAR operation would be dispatched to directly. Another way to view
-this is that we make available special form versions of @code{CAR},
-@code{CDR}, etc. Since the actual operation code is localized in the
-interpreter, it is much easier than uncompilation and then recompilation
-to handle @code{(trace car)}; For instance a switch gets set which tells
-the interpreter to instead always look up the values of the associated
-symbols.
-@end quotation
-
@defvar symhash
Top level symbol values are stored in the @code{symhash} table.
@code{symhash} is an array of lists of @code{ISYM}s and pairs of symbols
@@ -7011,6 +7207,18 @@ far in to go for the value. When this immediate object is subsequently
encountered, the value can be retrieved quickly.
@end deftp
+@code{ILOC}s work up to a maximum depth of 4096 frames or 4096
+identifiers in a frame. Radey Shouman added @dfn{FARLOC}
+@tindex FARLOC
+to handle cases exceeding these limits. A @code{FARLOC} consists of a
+pair whose CAR is the immediate type @code{IM_FARLOC_CAR} or
+@code{IM_FARLOC_CDR}, and whose CDR is a pair of INUMs specifying the
+frame and distance with a larger range than @code{ILOC}s span.
+
+Adding @code{#define TEST_FARLOC} to @file{eval.c} causes @code{FARLOC}s
+to be generated for all local identifiers; this is useful only for
+testing memoization.
+
@deftp Immediate GLOC
Pointers to symbols not defined in local environments are changed to one
plus the value cell address in symhash. This incremented pointer is
@@ -7145,7 +7353,7 @@ subdirectory. For example, the executable might be
@subsection Executable Pathname
@noindent
-For purposes of finding @file{Init.scm}, dumping an executable, and
+For purposes of finding @file{Init5c3.scm}, dumping an executable, and
dynamic linking, a SCM session needs the pathname of its executable
image.
@@ -7230,6 +7438,8 @@ Returns the number of argument strings in @var{argv}.
@itemize @bullet
@item
+Allow users to set limits for @code{malloc()} storage.
+@item
Prefix and make more uniform all C function, variable, and constant
names. Provide a file full of #define's to provide backward
compatability.
@@ -7248,10 +7458,6 @@ Currently, @code{dump}ing an executable does not preserve ports. When
loading a @code{dump}ed executable, disk files could be reopened to the
same file and position as they had when the executable was dumped.
@item
-Compaction could be done to @code{malloc}ed objects by freeing and
-reallocing all the malloc objects encountered in a scan of the heap.
-Whether compactions would actually occur is system depenedent.
-@item
Copying all of the stack is wasteful of storage. Any time a
call-with-current-continuation is called the stack could be re-rooted
with a frame which calls the contin just created. This in combination
@@ -7274,6 +7480,25 @@ This is trickier than it first looks because the must_malloc() routine
is also used for allocating heap segments, which do not have the
@code{LENGTH} field restriction. Putting the 24 bit test into
@code{must_malloc()} should be tested for speed impact.
+
+@item
+In the quest for speed, there has been some discussion about a "Forth"
+style Scheme interpreter.
+
+@quotation
+Provided there is still type code space available in SCM, if we devote
+some of the IMCAR codes to "inlined" operations, we should get a
+significant performance boost. What is eliminated is the having to look
+up a @code{GLOC} or @code{ILOC} and then dispatch on the subr type. The
+IMCAR operation would be dispatched to directly. Another way to view
+this is that we make available special form versions of @code{CAR},
+@code{CDR}, etc. Since the actual operation code is localized in the
+interpreter, it is much easier than uncompilation and then recompilation
+to handle @code{(trace car)}; For instance a switch gets set which tells
+the interpreter to instead always look up the values of the associated
+symbols.
+@end quotation
+
@end itemize
@menu
@@ -7534,21 +7759,22 @@ copying various files over to MS-DOS/WINDOWS.
@end itemize
-@node Procedure and Macro Index, Variable Index, The Implementation, Top
+@node Index, , The Implementation, Top
+@c @node Procedure and Macro Index, Variable Index, The Implementation, Top
@unnumbered Procedure and Macro Index
This is an alphabetical list of all the procedures and macros in SCM.
@printindex fn
-@node Variable Index, Type Index, Procedure and Macro Index, Top
+@c @node Variable Index, Type Index, Procedure and Macro Index, Top
@unnumbered Variable Index
This is an alphabetical list of all the global variables in SCM.
@printindex vr
-@node Type Index, , Variable Index, Top
+@c @node Type Index, , Variable Index, Top
@unnumbered Type Index
This is an alphabetical list of data types and feature names in SCM.
diff --git a/scmfig.h b/scmfig.h
index df8fb8b..0e5bf35 100644
--- a/scmfig.h
+++ b/scmfig.h
@@ -42,38 +42,20 @@
/* "scmfig.h" system-dependent configuration.
Author: Aubrey Jaffer */
-#ifdef HAVE_CONFIG_H
-# include "scmconfig.h"
-# ifdef HAVE_STRING_H
-# include <string.h>
-# else
-# include <strings.h>
-# endif
-
-# ifndef HAVE_GETCWD
-# define getcwd(S,L) getwd(S)
-# endif
-
-# ifdef __amigados__
-# define STDC_HEADERS
-# endif
-
-#else /* HAVE_CONFIG_H */
-
-# ifdef sequent
-# include <strings.h>
-# define strchr index
-# define strrchr rindex
-# else
-# include <string.h>
-# endif
+#ifdef sequent
+# include <strings.h>
+# define strchr index
+# define strrchr rindex
+#else
+# include <string.h>
+#endif
-# include "scmflags.h" /* user specified, system independent flags */
+#include "scmflags.h" /* user specified, system independent flags */
/* IMPLINIT is the full pathname (surrounded by double quotes) of
Init.scm, the Scheme initialization code. This is best defined in
- the makefile, if possible. If available, scm uses the value of
- environment variable SCM_INIT_PATH instead of IMPLINIT. */
+ the makefile. If available, scm uses the value of environment
+ variable SCM_INIT_PATH instead of IMPLINIT. */
/* #define IMPLINIT "/usr/jaffer/scm/Init.scm" */
@@ -109,28 +91,28 @@ rgx.c init_rgx(); regcomp and regexec. */
/* Define SINGLES if you want single precision floats and
(sizeof(float)==sizeof(long)) */
-# ifdef FLOATS
-# define SINGLES
-# endif
+#ifdef FLOATS
+# define SINGLES
+#endif
/* #define SINGLESONLY */
/* Define CDR_DOUBLES if (sizeof(double)==sizeof(long)), i.e.
a `single' is really a double. */
-# ifdef FLOATS
-# ifdef __alpha
-# define CDR_DOUBLES
-# endif
+#ifdef FLOATS
+# ifdef __alpha
+# define CDR_DOUBLES
+# endif
-# ifdef _UNICOS /* doubles are no better than singles on Cray. */
-# define SINGLESONLY
-# endif
+# ifdef _UNICOS /* doubles are no better than singles on Cray. */
+# define SINGLESONLY
+# endif
-# ifdef CDR_DOUBLES
-# define SINGLES
-# define SINGLESONLY
-# endif
+# ifdef CDR_DOUBLES
+# define SINGLES
+# define SINGLESONLY
# endif
+#endif
/* #define ENGNOT */
@@ -149,27 +131,27 @@ rgx.c init_rgx(); regcomp and regexec. */
/* Define HAVE_DYNL if dynamic linking is available */
-# ifdef DLD
-# define HAVE_DYNL
-# endif
-# ifdef SUN_DL
-# define HAVE_DYNL
-# endif
-# ifdef HP_SHL
-# define HAVE_DYNL
-# endif
+#ifdef DLD
+# define HAVE_DYNL
+#endif
+#ifdef SUN_DL
+# define HAVE_DYNL
+#endif
+#ifdef HP_SHL
+# define HAVE_DYNL
+#endif
-# ifdef HAVE_DYNL
-# define CCLO
-# endif
+#ifdef HAVE_DYNL
+# define CCLO
+#endif
/* Define GC_FREE_SEGMENTS if you want segments of unused heap to
be freed up after garbage collection. Don't define it if you
never want the heap to shrink. */
-# ifndef DONT_GC_FREE_SEGMENTS
-# define GC_FREE_SEGMENTS
-# endif
+#ifndef DONT_GC_FREE_SEGMENTS
+# define GC_FREE_SEGMENTS
+#endif
/* #define CHEAP_CONTINUATIONS */
@@ -204,103 +186,121 @@ rgx.c init_rgx(); regcomp and regexec. */
ANSI C. For most modern systems this is the case. */
/* added by Yasuaki Honda */
-# ifdef THINK_C
-# define __STDC__
+#ifdef THINK_C
+# define __STDC__
+# ifndef macintosh
+# define macintosh
# endif
+#endif
+/* added by Bob Schumaker, cobblers@netcom.com */
+#ifdef __MWERKS__
+# ifndef macintosh
+# define macintosh
+# endif
+# define bzero(p, n) memset(p, 0, n)
+# define bcopy memcpy
+#endif
/* added by Denys Duchier */
-# ifndef SVR4
-# ifdef __svr4__
-# define SVR4
-# endif
+#ifndef SVR4
+# ifdef __svr4__
+# define SVR4
# endif
+#endif
-# ifdef __STDC__
-# ifndef __HIGHC__ /* overly fussy compiler */
-# define USE_ANSI_PROTOTYPES
-# endif
-# ifndef __GNUC__
-# define STDC_HEADERS
+#ifdef __STDC__
+# ifndef __HIGHC__ /* overly fussy compiler */
+# define USE_ANSI_PROTOTYPES
+# endif
+# ifndef __GNUC__
+# define STDC_HEADERS
+# else
+# ifdef sparc
+# ifdef SVR4
+# define STDC_HEADERS
+# endif
# else
-# ifdef sparc
-# ifdef SVR4
+# ifndef tahoe
+# ifndef sun
# define STDC_HEADERS
# endif
-# else
-# ifndef tahoe
-# ifndef sun
-# define STDC_HEADERS
-# endif
-# endif
# endif
# endif
# endif
-# ifdef MSDOS /* Microsoft C 5.10 and 6.00A */
-# ifndef GO32
-# define SHORT_INT
-# endif
-# endif
-# ifdef _QC
-# define SHORT_INT
-# endif
-# ifdef __TURBOC__
+#endif
+#ifdef MSDOS /* Microsoft C 5.10 and 6.00A */
+# ifndef GO32
# define SHORT_INT
-# ifndef __TOS__
-# define MSDOS
-# endif
# endif
-# ifdef _WIN32
-# define MSDOS
-# define LACK_TIMES
-# endif
-# ifdef _MSDOS
+#endif
+#ifdef _QC
+# define SHORT_INT
+#endif
+#ifdef __TURBOC__
+# define SHORT_INT
+# define LACK_SBRK
+# ifndef __TOS__
# define MSDOS
# endif
-# ifdef MSDOS
-# define STDC_HEADERS
-# endif
-# ifdef vms
-# define STDC_HEADERS
-# endif
-# ifdef nosve
-# define STDC_HEADERS
-# endif
+#endif
+#ifdef __HIGHC__
+# define LACK_SBRK
+#endif
+#ifdef _WIN32
+# define MSDOS
+# define LACK_TIMES
+#endif
+#ifdef _MSDOS
+# define MSDOS
+#endif
+#ifdef MSDOS
+# define STDC_HEADERS
+#endif
+#ifdef vms
+# define STDC_HEADERS
+#endif
+#ifdef nosve
+# define STDC_HEADERS
+#endif
-# ifdef linux
-# define HAVE_SELECT
-# define HAVE_SYS_TIME_H
-# undef STDC_HEADERS
-# endif
+#ifdef linux
+# define HAVE_SELECT
+# define HAVE_SYS_TIME_H
+# define STDC_HEADERS
+#endif
-# ifdef _UNICOS
-# define STDC_HEADERS
-# endif
+#ifdef _UNICOS
+# define STDC_HEADERS
+#endif
-# ifdef _AIX
-# define _POSIX_SOURCE
-# define LACK_FTIME
-# endif
+#ifdef _AIX
+# define _POSIX_SOURCE
+# define LACK_FTIME
+#endif
-# ifdef __sgi__
-# define LACK_FTIME
-# define STDC_HEADERS
-# define USE_ANSI_PROTOTYPES
-# define HAVE_SELECT
-# define HAVE_SYS_TIME_H
-# define __svr4__
-# endif
+#ifdef __sgi__
+# define LACK_FTIME
+# define STDC_HEADERS
+# define USE_ANSI_PROTOTYPES
+# define HAVE_SELECT
+# define HAVE_SYS_TIME_H
+# define __svr4__
+#endif
-# ifdef hpux
-# define LACK_E_IDs
-# endif
+#ifdef hpux
+# define LACK_E_IDs
+#endif
/* C-Set++ for OS/2 */
-# ifdef __IBMC__
-# define STDC_HEADERS
-# define LACK_TIMES
-# endif
+#ifdef __IBMC__
+# define STDC_HEADERS
+# define LACK_TIMES
+#endif
-#endif /* HAVE_CONFIG_H */
+#ifdef __CYGWIN32__
+# define LACK_FTIME
+# undef MSDOS
+#endif
/* PROMPT is the prompt string printed at top level */
@@ -330,15 +330,6 @@ rgx.c init_rgx(); regcomp and regexec. */
# define WHITE_SPACES ' ':case '\t':case '\r':case '\f'
#endif
-/* NUM_HASH_BUCKETS is the number of symbol hash table buckets. */
-
-#define NUM_HASH_BUCKETS 137
-
-/* If fewer than MIN_GC_YIELD cells are recovered during a garbage
- collection (GC) more space is allocated for the heap. */
-
-#define MIN_GC_YIELD (heap_size/4)
-
/* 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. */
@@ -375,6 +366,7 @@ rgx.c init_rgx(); regcomp and regexec. */
#endif
#ifdef NON_PREEMPTIVE
+# define VERIFY_INTS(s1, s2) /**/
# define DEFER_INTS /**/
# ifdef TICKS
# define POLL {if (0==poll_count--) poll_routine(); \
@@ -384,22 +376,42 @@ rgx.c init_rgx(); regcomp and regexec. */
# endif
# define CHECK_INTS POLL
# define ALLOW_INTS POLL
+# define DEFER_INTS_EGC /**/
+# define ALLOW_INTS_EGC /**/
#else
# ifdef CAREFUL_INTS
+typedef struct {char *fname; long linum;} ints_infot;
+extern ints_infot *ints_info;
+# define VERIFY_INTS(s1, s2) {if (!ints_disabled)\
+ ints_warn(s1, s2, __FILE__,__LINE__); }
# define DEFER_INTS \
-{FENCE;if (ints_disabled) ints_viol(!0);else ints_disabled = !0;FENCE;}
+ {static ints_infot info = {__FILE__, __LINE__};\
+ FENCE;if (1==ints_disabled) ints_viol(&info, 1);\
+ else {ints_info = &info; ints_disabled = 1;FENCE;}}
# define ALLOW_INTS \
-{FENCE;if (!ints_disabled) ints_viol(0);else ints_disabled = 0;FENCE;CHECK_INTS}
+ {static ints_infot info = {__FILE__, __LINE__};\
+ FENCE;if (1!=ints_disabled) ints_viol(&info, 0);\
+ else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}}
+# define DEFER_INTS_EGC \
+ {static ints_infot info = {__FILE__, __LINE__};\
+ FENCE;if (1==ints_disabled) ints_viol(&info, 1);\
+ else {ints_info = &info; ints_disabled = 2;FENCE;}}
+# define ALLOW_INTS_EGC \
+ {static ints_infot info = {__FILE__, __LINE__};\
+ FENCE;if (1==ints_disabled) ints_viol(&info, 0);\
+ else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}}
# else
-# define DEFER_INTS {FENCE;ints_disabled = !0;FENCE;}
+# define VERIFY_INTS(s1, s2) /**/
+# define DEFER_INTS {FENCE;ints_disabled = 1;FENCE;}
# define ALLOW_INTS {FENCE;ints_disabled = 0;FENCE;CHECK_INTS}
+# define DEFER_INTS_EGC {FENCE;ints_disabled = 2;FENCE;}
+# define ALLOW_INTS_EGC {FENCE;ints_disabled = 0;FENCE;CHECK_INTS}
# endif
# ifdef TICKS
-# define CHECK_INTS {if (sig_deferred) han_sig();if (alrm_deferred) han_alrm();\
- POLL;}
+# define CHECK_INTS {if (deferred_proc) (*deferred_proc)(); POLL;}
# define POLL {if (0==tick_count--) tick_signal();}
# else
-# define CHECK_INTS {if (sig_deferred) han_sig();if (alrm_deferred) han_alrm();}
+# define CHECK_INTS {if (deferred_proc) (*deferred_proc)();}
# define POLL /**/
# endif
#endif
@@ -535,7 +547,9 @@ rgx.c init_rgx(); regcomp and regexec. */
#ifdef FLOATS
# ifdef STDC_HEADERS
# ifndef GO32
-# include <float.h>
+# ifndef macintosh
+# include <float.h>
+# endif
# endif
# endif
# ifdef DBL_MAX_10_EXP
@@ -568,7 +582,7 @@ rgx.c init_rgx(); regcomp and regexec. */
# define IS_INF(x) ((x)==(x)/2)
#endif
-#ifndef THINK_C
+#ifndef macintosh
# ifdef __WINDOWS__ /* there should be a better flag for this. */
# define PROT386
# endif
@@ -613,6 +627,10 @@ typedef SCM *SCMPTR;
# endif
#endif
+#ifdef macintosh
+# include <unistd.h>
+#endif
+
/* On VMS, GNU C's errno.h contains a special hack to get link attributes
for errno correct for linking to the C RTL. */
@@ -673,13 +691,19 @@ typedef SCM *SCMPTR;
# endif
#endif
-/* Yasuaki Honda */
-/* Think C lacks isascii macro */
-#ifdef THINK_C
+/* Yasuaki Honda, Bob Schumaker */
+/* Think C and Metrowerks lack isascii macro */
+#ifdef macintosh
# define isascii(c) ((unsigned)(c) <= 0x7f)
#endif
#ifdef _DCC
# define isascii(c) ((unsigned)(c) <= 0x7f)
#endif
+#ifdef __STDC__
+# define VOLATILE volatile
+#else
+# define VOLATILE /**/
+#endif
+
/* end of automatic C pre-processor definitions */
diff --git a/setjump.h b/setjump.h
index 17caa49..09a1377 100644
--- a/setjump.h
+++ b/setjump.h
@@ -74,7 +74,7 @@
is in init_storage() and alloc_some_heap() in sys.c
If INIT_HEAP_SIZE can be allocated initially, the heap will grow by
- EXPHEAP(heap_size) when more heap is needed.
+ EXPHEAP(heap_cells) when more heap is needed.
MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
is needed.
@@ -93,21 +93,39 @@
# define HEAP_SEG_SIZE (8100L*sizeof(cell))
# endif
#endif
-#define EXPHEAP(heap_size) (heap_size*2)
+#define EXPHEAP(heap_cells) (heap_cells*2)
#define INIT_MALLOC_LIMIT 100000
+/* ECACHE_SIZE is the number of cells in the copy-collected environment
+ cache used for environment frames */
+#define ECACHE_SIZE 2000
+
+/* If fewer than MIN_GC_YIELD cells are recovered during a
+ cell-requested garbage collection (GC), then another heap segment
+ is allocated. */
+
+#define MIN_GC_YIELD (heap_cells / 4)
+
+/* If fewer than MIN_MALLOC_YIELD cells are free after a
+ malloc-requested garbage collection (GC), then the mtrigger limit
+ is raised. */
+
+#define MIN_MALLOC_YIELD (mtrigger / 8)
+
+/* NUM_HASH_BUCKETS is the number of symbol hash table buckets. */
+
+#define NUM_HASH_BUCKETS 137
+
#ifdef IN_CONTINUE_C
# include "scm.h"
# define malloc(size) must_malloc((long)(size), s_cont)
-# define free(obj) must_free((char *)(obj))
+# define free(obj) must_free((char *)(obj), 0)
#endif
/* other.dynenv and other.parent get GCed just by being there. */
struct scm_other {SCM dynenv;
SCM parent;
-#ifdef CAUTIOUS
- SCM stack_trace;
-#endif
+ SCM env;
};
#define CONTINUATION_OTHER struct scm_other
#define CONT(x) ((CONTINUATION *)CDR(x))
@@ -115,8 +133,3 @@ struct scm_other {SCM dynenv;
void dowinds P((SCM to, long delta));
#include "continue.h"
-
-/* See scm.h for definition of P */
-void mark_locations P((STACKITEM x[], sizet n ));
-void scm_dynthrow P((CONTINUATION *cont, SCM val));
-#define s_cont (ISYMCHARS(IM_CONT)+20)
diff --git a/socket.c b/socket.c
index b562fd5..6296b38 100644
--- a/socket.c
+++ b/socket.c
@@ -46,6 +46,12 @@
*/
#include "scm.h"
+
+#ifdef macintosh
+#define SOCKETDEFS
+#include "macsocket.h"
+#endif
+
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/un.h>
@@ -242,8 +248,9 @@ SCM l_servinfo(args)
proto = CAR(proto);
ASSERT(NIMP(proto) && STRINGP(proto), args, ARG2, s_servinfo);
DEFER_INTS;
- if (NIMP(name) && STRINGP(name))
+ if (NIMP(name) && STRINGP(name)) {
SYSCALL(entry = getservbyname(CHARS(name), CHARS(proto)););
+ }
else {
ASSERT(INUMP(proto), proto, ARG1, s_servinfo);
SYSCALL(entry = getservbyport(INUM(proto), CHARS(proto)););
@@ -310,7 +317,11 @@ SCM l_socket(fam, proto)
i_setbuf0(port);
ALLOW_INTS;
if (AF_INET==tp) {
+#ifdef macintosh
+ sd = setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, (char *)&j, sizeof(j));
+#else
sd = setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, &j, sizeof(j));
+#endif
ASSERT(!sd, port, "could not set socket option", s_socket);
}
return port;
@@ -469,11 +480,15 @@ SCM l_accept(sockpt)
NEWCELL(newpt);
ASSERT(NIMP(sockpt) && OPINPORTP(sockpt), sockpt, ARG1, s_accept);
sadlen=sizeof(sad);
- DEFER_INTS;
SYSCALL(newsd = accept(fileno(STREAM(sockpt)), &sad, &sadlen););
- if (-1==newsd)
+ if (-1==newsd) {
+#ifndef macintosh
if (EWOULDBLOCK != errno) return BOOL_F;
- else wta(sockpt, "couldn't", s_accept);
+ else
+#endif
+ wta(sockpt, "couldn't", s_accept);
+ }
+ DEFER_INTS;
SYSCALL(newfd = fdopen(newsd, "r+"););
if (!newfd) {
close(newsd);
@@ -511,7 +526,7 @@ int sknm_print(exp, port, writing)
sizet sknm_free(p)
CELLPTR p;
{
- must_free(CHARS((SCM)p));
+ must_free(CHARS((SCM)p), sizeof(struct sockaddr));
return sizeof(struct sockaddr);
}
long tc16_sknm;
@@ -558,12 +573,11 @@ SCM maksknm(sad)
{
SCM sknm;
struct sockaddr *msknm;
- NEWCELL(sknm);
DEFER_INTS;
- msknm = (struct sockaddr *)must_malloc(0L+sizeof(struct sockaddr), "sknm");
+ sknm = must_malloc_cell(0L+sizeof(struct sockaddr), "sknm");
+ msknm = (struct sockaddr *)CDR(sknm);
*msknm = *sad;
CAR(sknm) = tc16_sknm;
- SETCDR(sknm, msknm);
ALLOW_INTS;
return sknm;
}
diff --git a/subr.c b/subr.c
index f9552c2..5612c1a 100644
--- a/subr.c
+++ b/subr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 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
@@ -798,10 +798,13 @@ SCM scm_big_test(x, nx, xsgn, bigy)
static char s_logand[] = "logand", s_lognot[] = "lognot",
s_logior[] = "logior", s_logxor[] = "logxor",
s_logtest[] = "logtest", s_logbitp[] = "logbit?",
+ s_copybit[] = "copy-bit",
+ s_copybitfield[] = "copy-bit-field",
s_ash[] = "ash", s_logcount[] = "logcount",
s_intlength[] = "integer-length",
s_intexpt[] = "integer-expt",
- s_bitextract[] = "bit-extract";
+ s_bitfield[] = "bit-field",
+ s_bitif[] = "bitwise-if";
SCM scm_logior(x, y)
SCM x, y;
@@ -1011,6 +1014,28 @@ SCM scm_logbitp(index, j1)
return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F;
}
+SCM scm_copybit(index, j1, bit)
+ SCM index, j1, bit;
+{
+ ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_copybit);
+#ifdef BIGDIG
+ if (NINUMP(j1) || (INUM(index) >= LONG_BIT - 3))
+ /* This function makes more bignums than it needs to. */
+ if NFALSEP(bit)
+ return scm_logior(j1, scm_ash(MAKINUM(1), index));
+ else
+ return scm_logand(j1, difference(MAKINUM(-1L),
+ scm_ash(MAKINUM(1), index)));
+#else
+ ASSERT(INUMP(j1), j1, ARG2, s_copybit);
+ ASSERT(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
+#endif
+ if NFALSEP(bit)
+ return MAKINUM(INUM(j1) | (1L << INUM(index)));
+ else
+ return MAKINUM(INUM(j1) & (~(1L << INUM(index))));
+}
+
SCM scm_lognot(n)
SCM n;
{
@@ -1062,23 +1087,75 @@ SCM scm_ash(n, cnt)
#endif
}
-SCM scm_bitextract(n, start, end)
+SCM scm_bitfield(n, start, end)
SCM n, start, end;
{
- ASSERT(INUMP(start), start, ARG2, s_bitextract);
- ASSERT(INUMP(end), end, ARG3, s_bitextract);
+ ASSERT(INUMP(start), start, ARG2, s_bitfield);
+ ASSERT(INUMP(end), end, ARG3, s_bitfield);
start = INUM(start); end = INUM(end);
- ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitextract);
+ ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield);
#ifdef BIGDIG
- if NINUMP(n)
+ if (NINUMP(n) || end >= LONG_BIT - 2)
return
scm_logand(difference(scm_intexpt(MAKINUM(2), MAKINUM(end - start)),
MAKINUM(1L)),
scm_ash(n, MAKINUM(-start)));
#else
- ASSERT(INUMP(n), n, ARG1, s_bitextract);
+ ASSERT(INUMP(n), n, ARG1, s_bitfield);
+ ASSERT(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield);
+#endif
+ return MAKINUM((INUM(n)>>start) & ((1L<<(end - start)) - 1));
+}
+
+SCM scm_bitif(mask, n0, n1)
+ SCM mask, n0, n1;
+{
+#ifdef BIGDIG
+ if (NINUMP(mask) || NINUMP(n0) || NINUMP(n1))
+ return scm_logior(scm_logand(mask, n0),
+ scm_logand(scm_lognot(mask), n1));
+#else
+ ASSERT(INUMP(mask), mask, ARG1, s_bitif);
+ ASSERT(INUMP(n0), n0, ARG2, s_bitif);
+ ASSERT(INUMP(n1), n1, ARG3, s_bitif);
#endif
- return MAKINUM((INUM(n)>>start) & ((1L<<(end-start))-1));
+ return MAKINUM((INUM(mask) & INUM(n0)) | (~(INUM(mask)) & INUM(n1)));
+}
+
+SCM scm_copybitfield(to, start, rest)
+ SCM to, start, rest;
+{
+ long len;
+ SCM end, from;
+#ifndef RECKLESS
+ if (!(NIMP(rest) && CONSP(rest)))
+ wna: wta(UNDEFINED, (char *)WNA, s_copybitfield);
+#endif
+ end = CAR(rest);
+ rest = CDR(rest);
+ ASRTGO(NIMP(rest) && CONSP(rest), wna);
+ from = CAR(rest);
+ ASRTGO(NULLP(CDR(rest)), wna);
+ ASSERT(INUMP(start) && INUM(start)>=0, start, ARG2, s_copybitfield);
+ len = INUM(end) - INUM(start);
+ ASSERT(INUMP(end), end, ARG3, s_copybitfield);
+ ASSERT(len >= 0, MAKINUM(len), OUTOFRANGE, s_copybitfield);
+#ifdef BIGDIG
+ if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) {
+ SCM mask = difference(scm_intexpt(MAKINUM(2), MAKINUM(len)), MAKINUM(1L));
+ mask = scm_ash(mask, start);
+ return scm_logior(scm_logand(mask, scm_ash(from, start)),
+ scm_logand(scm_lognot(mask), to));
+ }
+#else
+ ASSERT(INUMP(to), to, ARG1, s_copybitfield);
+ ASSERT(INUMP(from), from, ARG4, s_copybitfield);
+ ASSERT(INUM(end) < LONG_BIT - 2, end, OUTOFRANGE, s_copybitfield);
+#endif
+ {
+ long mask = ((1L<<len) - 1)<<INUM(start);
+ return MAKINUM((mask & (INUM(from)<<INUM(start))) | ((~mask) & INUM(to)));
+ }
}
char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
@@ -1496,20 +1573,19 @@ char s_make_vector[] = "make-vector";
SCM make_vector(k, fill)
SCM k, fill;
{
- SCM v;
- register long i;
- register SCM *velts;
- ASSERT(INUMP(k), k, ARG1, s_make_vector);
- if UNBNDP(fill) fill = UNSPECIFIED;
- i = INUM(k);
- NEWCELL(v);
- DEFER_INTS;
- SETCHARS(v, must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
- SETLENGTH(v, i, tc7_vector);
- velts = VELTS(v);
- while(--i >= 0) (velts)[i] = fill;
- ALLOW_INTS;
- return v;
+ SCM v;
+ register long i;
+ register SCM *velts;
+ ASSERT(INUMP(k), k, ARG1, s_make_vector);
+ if UNBNDP(fill) fill = UNSPECIFIED;
+ i = INUM(k);
+ DEFER_INTS;
+ v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, s_vector);
+ SETLENGTH(v, i, tc7_vector);
+ velts = VELTS(v);
+ while(--i >= 0) (velts)[i] = fill;
+ ALLOW_INTS;
+ return v;
}
#ifdef BIGDIG
char s_bignum[] = "bignum";
@@ -1517,15 +1593,21 @@ SCM mkbig(nlen, sign)
sizet nlen;
int sign;
{
- SCM v = nlen;
- if (((v << 16) >> 16) != nlen)
- wta(MAKINUM(v), (char *)NALLOC, s_bignum);
- NEWCELL(v);
- DEFER_INTS;
- SETCHARS(v, must_malloc((long)(nlen*sizeof(BIGDIG)), s_bignum));
- SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
- ALLOW_INTS;
- return v;
+ SCM v = nlen;
+ if (((v << 16) >> 16) != nlen)
+ wta(MAKINUM(v), (char *)NALLOC, s_bignum);
+ DEFER_INTS;
+#ifdef NUM_HP
+ if (nlen*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) {
+ NEWCELL(v);
+ SETCHARS(v, num_hp_alloc(nlen*sizeof(BIGDIG)));
+ }
+ else
+#endif
+ v = must_malloc_cell((long)(nlen*sizeof(BIGDIG)), s_bignum);
+ SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
+ ALLOW_INTS;
+ return v;
}
SCM big2inum(b, l)
SCM b;
@@ -1546,11 +1628,17 @@ SCM adjbig(b, nlen)
sizet nlen;
{
long nsiz = nlen;
- if (((nsiz << 16) >> 16) != nlen) wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
+ if (((nsiz << 16) >> 16) != nlen)
+ wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
DEFER_INTS;
- SETCHARS(b, (BIGDIG *)must_realloc((char *)CHARS(b),
- (long)(NUMDIGS(b)*sizeof(BIGDIG)),
- (long)(nsiz*sizeof(BIGDIG)), s_adjbig));
+#ifdef NUM_HP
+ SETCHARS(b, (BIGDIG *)num_hp_realloc((char *)CHARS(b),
+ (long)NUMDIGS(b)*sizeof(BIGDIG),
+ nsiz*sizeof(BIGDIG), s_adjbig));
+#else
+ must_realloc_cell(b, (long)(NUMDIGS(b)*sizeof(BIGDIG)),
+ (long)(nsiz*sizeof(BIGDIG)), s_adjbig);
+#endif
SETNUMDIGS(b, nsiz, TYP16(b));
ALLOW_INTS;
return b;
@@ -1613,7 +1701,8 @@ int bigcomp(x, y)
{
int xsign = BIGSIGN(x);
int ysign = BIGSIGN(y);
- sizet xlen, ylen;
+ long xlen;
+ sizet ylen;
if (ysign < xsign) return 1;
if (ysign > xsign) return -1;
if ((ylen = NUMDIGS(y)) > (xlen = NUMDIGS(x))) return (xsign) ? -1 : 1;
@@ -1979,7 +2068,9 @@ static iproc rpsubrs[] = {
{0, 0}};
static iproc subr3s[] = {
- {s_bitextract, scm_bitextract},
+ {s_bitfield, scm_bitfield},
+ {s_bitif, scm_bitif},
+ {s_copybit, scm_copybit},
{s_substring, substring},
{s_acons, acons},
{s_st_set, st_set},
@@ -2006,4 +2097,5 @@ void init_subrs()
init_iprocs(lsubrs, tc7_lsubr);
init_iprocs(asubrs, tc7_asubr);
init_iprocs(subr3s, tc7_subr_3);
+ make_subr(s_copybitfield, tc7_lsubr_2, scm_copybitfield);
}
diff --git a/sys.c b/sys.c
index 9767fe0..82ea647 100644
--- a/sys.c
+++ b/sys.c
@@ -46,6 +46,8 @@
#include "scm.h"
#include "setjump.h"
void igc P((char *what, STACKITEM *stackbase));
+void lfflush P((SCM port)); /* internal SCM call */
+SCM *loc_open_file; /* for open-file callback */
/* ttyname() etc. should be defined in <unistd.h>. But unistd.h is
missing on many systems. */
@@ -66,15 +68,21 @@ void igc P((char *what, STACKITEM *stackbase));
int pclose P((FILE* stream));
int unlink P((const char *pathname));
char *mktemp P((char *template));
+#else
+# ifdef linux
+# include <unistd.h>
+# endif
#endif
static void gc_sweep P((int contin_bad));
char s_nogrow[] = "could not grow", s_heap[] = "heap",
s_hplims[] = "hplims";
+static char s_segs[] = "segments", s_numheaps[] = "number of heaps";
static char s_input_portp[] = "input-port?",
s_output_portp[] = "output-port?";
-static char s_open_file[] = "open-file";
+static char s_try_open_file[] = "try-open-file";
+#define s_open_file (&s_try_open_file[4])
char s_close_port[] = "close-port";
#ifdef __IBMC__
@@ -92,7 +100,7 @@ char s_close_port[] = "close-port";
# ifdef MWC
# include <sys/io.h>
# else
-# ifndef THINK_C
+# ifndef macintosh
# ifndef ARM_ULIB
# include <sys/ioctl.h>
# endif
@@ -126,7 +134,7 @@ long mode_bits(modes)
| (strchr(modes, '0') ? BUF0 : 0);
}
-SCM open_file(filename, modes)
+SCM try_open_file(filename, modes)
SCM filename, modes;
{
register SCM port;
@@ -146,6 +154,15 @@ SCM open_file(filename, modes)
return port;
}
+ /* Callback to Scheme */
+SCM open_file(filename, modes)
+ SCM filename, modes;
+{
+ return apply(*loc_open_file,
+ filename,
+ cons(modes, listofnull));
+}
+
SCM close_port(port)
SCM port;
{
@@ -270,7 +287,7 @@ void prinport(exp, port, type)
# ifndef __EMX__
# ifndef _DCC
# ifndef AMIGA
-# ifndef THINK_C
+# ifndef macintosh
if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp))))
lputs(ttyname(fileno(STREAM(exp))), port);
else
@@ -280,7 +297,7 @@ void prinport(exp, port, type)
# endif
#endif
if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port);
- else intprint(CDR(exp), 16, port);
+ else intprint(CDR(exp), -16, port);
lputc('>', port);
}
static int prinfport(exp, port, writing)
@@ -337,7 +354,7 @@ static int stgetc(p)
sizet ind = INUM(CAR(p));
if (ind >= LENGTH(CDR(p))) return EOF;
CAR(p) = MAKINUM(ind + 1);
- return CHARS(CDR(p))[ind];
+ return UCHARS(CDR(p))[ind];
}
int noop0(stream)
FILE *stream;
@@ -400,8 +417,13 @@ static ptobfuns fptob = {
prinfport,
0,
fputc,
+#ifdef __MWERKS__
+ (int (*)(char *, struct _FILE *))fputs,
+ (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
+#else
fputs,
ffwrite,
+#endif
fflush,
fgetc,
fclose};
@@ -411,8 +433,13 @@ ptobfuns pipob = {
0, /* replaced by prinpipe in init_ioext() */
0,
fputc,
+#ifdef __MWERKS__
+ (int (*)(char *, struct _FILE *))fputs,
+ (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
+#else
fputs,
ffwrite,
+#endif
fflush,
fgetc,
0}; /* replaced by pclose in init_ioext() */
@@ -513,10 +540,105 @@ static ptobfuns sfptob = {
sfgetc,
sfclose};
+/* The following ptob is for printing system messages in an interrupt-safe
+ way. Writing to sys_errp while interrupts are disabled will never enable
+ interrupts, do any actual i/o, or any allocation. Messages will be
+ written to cur_errp as soon as interrupts are enabled. There will only
+ ever be one of these. */
+int output_deferred = 0;
+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;
+{
+ sizet src, dst = errbuf_end;
+ sizet n = siz*num;
+ if (ints_disabled) {
+ deferred_proc = process_signals;
+ output_deferred = !0;
+ for (src = 0; src < n; src++, dst++)
+ errbuf[dst % SYS_ERRP_SIZE] = str[src];
+ errbuf_end = dst;
+ }
+ else {
+ if NIMP(cur_outp) lflush(cur_outp);
+ if (errbuf_end > 0) {
+ if (errbuf_end > SYS_ERRP_SIZE) {
+ warn("output buffer", " overflowed");
+ 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,
+ SYS_ERRP_SIZE - errbuf_end, cur_errp);
+ }
+ lfwrite(errbuf, sizeof(char), errbuf_end, cur_errp);
+ errbuf_end = 0;
+ }
+ num = lfwrite(str, siz, num, cur_errp);
+ lflush(cur_errp);
+ }
+ errno = 0;
+ return num;
+}
+static int sysputs(s, p)
+ char *s; FILE *p;
+{
+ syswrite(s, 1, strlen(s), p);
+ return 0;
+}
+static int sysputc(c, p)
+ int c; FILE *p;
+{
+ char cc = c;
+ syswrite(&cc, 1, 1, p);
+ return c;
+}
+static int sysflush(p)
+ FILE *p;
+{
+ syswrite(0, 0, 0, p);
+ return 0;
+}
+static ptobfuns sysptob = {
+ mark0,
+ noop0,
+ 0,
+ 0,
+ sysputc,
+ sysputs,
+ syswrite,
+ sysflush,
+ noop0,
+ noop0};
+
+static int freeprint(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ if (tc_broken_heart==CAR(exp)) {
+ lputs("#<GC-FORWARD->", port);
+ iprin1(CDR(exp), port, writing);
+ }
+ else {
+ if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) {
+ lputs("#<FREE-CELL ", port);
+ }
+ else {
+ lputs("#<NEW-CELL . ", port);
+ iprin1(CDR(exp), port, writing);
+ }
+ lputs(" @0x", port);
+ intprint((long)exp, -16, port);
+ }
+ lputc('>', port);
+ return !0;
+}
static smobfuns freecell = {
mark0,
free0,
- 0,
+ freeprint,
0};
static smobfuns flob = {
mark0,
@@ -541,6 +663,7 @@ void init_types()
/* tc16_pipe = */ newptob(&pipob);
/* tc16_strport = */ newptob(&stptob);
/* tc16_sfport = */ newptob(&sfptob);
+ tc16_sysport = newptob(&sysptob);
numsmob = 0;
smobs = (smobfuns *)malloc(7*sizeof(smobfuns));
/* These newsmob calls must be done in this order */
@@ -557,7 +680,7 @@ void add_final(final)
{
DEFER_INTS;
finals = (void (**)()) must_realloc((char *)finals,
- 1L*(num_finals)*sizeof(finals[0]),
+ (long)(num_finals)*sizeof(finals[0]),
(1L+num_finals)*sizeof(finals[0]),
s_final);
finals[num_finals++] = final;
@@ -565,9 +688,141 @@ void add_final(final)
return;
}
-char s_obunhash[] = "object-unhash", s_gc[] = "gc";
+static char s_estk[] = "environment stack";
+static cell ecache_v[ECACHE_SIZE];
+SCM scm_egc_roots[ECACHE_SIZE/20];
+CELLPTR scm_ecache;
+VOLATILE long scm_ecache_index, scm_ecache_len, scm_egc_root_index;
+SCM scm_estk = UNDEFINED, *scm_estk_ptr;
+void scm_estk_reset()
+{
+ SCM nstk = scm_estk, *v;
+ sizet i;
+ VERIFY_INTS("scm_estk_reset", 0);
+ /* We might be here because we blew the stack, or got tired of
+ watching it grow, so make sure the stack size is sane. */
+ if (IMP(nstk) || 50*SCM_ESTK_FRLEN < LENGTH(nstk)) {
+ i = 50L*SCM_ESTK_FRLEN + 1;
+ nstk = must_malloc_cell((long)i*sizeof(SCM), s_estk);
+ SETLENGTH(nstk, i, tc7_vector);
+ }
+ i = LENGTH(nstk);
+ v = VELTS(nstk);
+ while (i--) v[i] = UNSPECIFIED;
+ v[LENGTH(nstk)-1] = INUM0; /* overflow sentinel */
+ v[0] = INUM0; /* underflow sentinel */
+ /* The following are for a (future) segmented
+ stack implementation. */
+ v[1] = BOOL_T; /* writable? */
+ v[SCM_ESTK_FRLEN] = EOL; /* Must look like an environment */
+ v[SCM_ESTK_FRLEN + 1] = EOL; /* next stack segment */
+ scm_estk = nstk;
+ scm_estk_ptr = &(v[SCM_ESTK_BASE - SCM_ESTK_FRLEN]);
+}
+
+void scm_estk_grow(inc)
+ sizet inc;
+{
+ SCM estk = make_vector(MAKINUM(LENGTH(scm_estk) + inc*SCM_ESTK_FRLEN),
+ UNSPECIFIED);
+ sizet n, i;
+ DEFER_INTS;
+ n = scm_estk_ptr - VELTS(scm_estk);
+ ASSERT(n<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", "scm_estk_grow");
+ for (i = n + 1; i--;)
+ VELTS(estk)[i] = VELTS(scm_estk)[i];
+ /* Sentinel for stack overflow. */
+ VELTS(estk)[LENGTH(estk)-1] = INUM0;
+ scm_estk = estk;
+ scm_estk_ptr = &(VELTS(estk)[n + SCM_ESTK_FRLEN]);
+ ALLOW_INTS;
+ growth_mon(s_estk, LENGTH(scm_estk), "locations", !0);
+}
+
+/* Will be useful when segmented stack is implemented. */
+void scm_estk_shrink()
+{
+#if 0
+ SCM next = VELTS(scm_estk)[SCM_ESTK_FRLEN];
+ int istrt;
+ if IMP(next) wta(UNDEFINED, "underflow", "stack");
+ istrt = INUM(CDR(next));
+ next = CAR(next);
+ if (BOOL_T != VELTS(next)[1]) {
+ SCM new_estk = make_vector(MAKINUM(LENGTH(scm_estk)), UNSPECIFIED);
+ int i = istrt;
+ while (--i) VELTS(new_estk)[i] = VELTS(next)[i];
+ VELTS(new_estk)[1] = BOOL_T;
+ VELTS(new_estk)[LENGTH(new_estk)-1] = INUM0;
+ next = new_estk;
+ }
+ scm_estk = next;
+ scm_estk_ptr = &(VELTS(scm_estk)[istrt]);
+#else
+ wta(UNDEFINED, "underflow", s_estk);
+#endif
+}
+
+void scm_env_cons(x, y)
+ SCM x, y;
+{
+ register SCM z;
+ DEFER_INTS_EGC;
+ if (1>scm_ecache_index) scm_egc();
+ z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z) = x;
+ CDR(z) = y;
+ scm_env_tmp = z;
+}
+
+void scm_env_cons2(w, x, y)
+ SCM w, x, y;
+{
+ SCM z1, z2;
+ DEFER_INTS_EGC;
+ if (2>scm_ecache_index) scm_egc();
+ z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z1) = x;
+ CDR(z1) = y;
+ z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z2) = w;
+ CDR(z2) = z1;
+ scm_env_tmp = z2;
+}
+
+/* scm_env_tmp = cons(x, scm_env_tmp) */
+void scm_env_cons_tmp(x)
+ SCM x;
+{
+ register SCM z;
+ DEFER_INTS_EGC;
+ if (1>scm_ecache_index) scm_egc();
+ z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z) = x;
+ CDR(z) = scm_env_tmp;
+ scm_env_tmp = z;
+}
+
+/* scm_env = acons(names, scm_env_tmp, scm_env) */
+void scm_extend_env(names)
+ SCM names;
+{
+ SCM z1, z2;
+ DEFER_INTS_EGC;
+ if (2>scm_ecache_index) scm_egc();
+ z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z1) = names;
+ CDR(z1) = scm_env_tmp;
+ z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z2) = z1;
+ CDR(z2) = scm_env;
+ scm_env = z2;
+}
+char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
+char s_recursive[] = "recursive";
+#define s_gc (s_cache_gc+6)
static iproc subr0s[] = {
- {s_gc, gc},
+ /* {s_gc, gc}, */
{"tmpnam", ltmpnam},
{0, 0}};
@@ -583,17 +838,22 @@ static iproc subr1s[] = {
{0, 0}};
static iproc subr2s[] = {
- {s_open_file, open_file},
+ {s_try_open_file, try_open_file},
{s_cwis, cwis},
{s_mksfpt, mksfpt},
{0, 0}};
SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
-void init_io(){
+void init_io()
+{
make_subr("dynamic-wind", tc7_subr_3, dynwind);
+ make_subr(s_gc, tc7_subr_1o, gc);
init_iprocs(subr0s, tc7_subr_0);
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(subr2s, tc7_subr_2);
+ loc_open_file =
+ &CDR(sysintern(s_open_file,
+ CDR(intern(s_try_open_file, sizeof(s_try_open_file)-1))));
#ifndef CHEAP_CONTINUATIONS
add_feature("full-continuation");
#endif
@@ -602,75 +862,245 @@ void init_io(){
void grew_lim(nm)
long nm;
{
- ALLOW_INTS;
- growth_mon(s_limit, nm, "bytes");
- DEFER_INTS;
+ growth_mon(s_limit, nm, "bytes", !0);
}
int expmem = 0;
sizet hplim_ind = 0;
-long heap_size = 0;
+long heap_cells = 0;
CELLPTR *hplims, heap_org;
-SCM freelist = EOL;
-long mtrigger;
+VOLATILE SCM freelist = EOL;
+long mtrigger, mltrigger;
+
+/* Ints should be deferred when calling igc_for_malloc. */
+static char *igc_for_alloc(where, olen, size, what)
+ char *where;
+ long olen;
+ sizet size;
+ char *what;
+{
+ char *ptr;
+ long nm;
+ igc(what, CONT(rootcont)->stkbse);
+ nm = mallocated + size - olen;
+ if (nm > mltrigger) {
+ if (nm > mtrigger) grew_lim(nm + nm/2);
+ else grew_lim(mtrigger + mtrigger/2);
+ }
+ if (where)
+ SYSCALL(ptr = (char *)realloc(where, size););
+ else
+ SYSCALL(ptr = (char *)malloc(size););
+ ASSERT(ptr, MAKINUM(size), NALLOC, what);
+ if (nm > mltrigger) {
+ if (nm > mtrigger) mtrigger = nm + nm/2;
+ else mtrigger += mtrigger/2;
+ mltrigger = mtrigger - MIN_MALLOC_YIELD;
+ }
+ return ptr;
+}
char *must_malloc(len, what)
long len;
char *what;
{
- char *ptr;
- sizet size = len;
- long nm = mallocated+size;
- if (len != size)
-malerr:
- wta(MAKINUM(len), (char *)NALLOC, what);
- if ((nm <= mtrigger)) {
- SYSCALL(ptr = (char *)malloc(size););
- if (NULL != ptr) {mallocated = nm; return ptr;}
- }
- igc(what, CONT(rootcont)->stkbse);
- nm = mallocated+size;
- if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before malloc */
- SYSCALL(ptr = (char *)malloc(size););
- if (NULL != ptr) {
- mallocated = nm;
- if (nm > mtrigger) mtrigger = nm + nm/2;
- return ptr;}
- goto malerr;
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated + size;
+ VERIFY_INTS("must_malloc", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)malloc(size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(0, 0, size, what);
+ mallocated = nm;
+ return ptr;
+}
+SCM must_malloc_cell(len, what)
+ long len;
+ char *what;
+{
+ SCM z;
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated + size;
+ VERIFY_INTS("must_malloc_cell", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ NEWCELL(z);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)malloc(size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(0, 0, size, what);
+ mallocated = nm;
+ SETCHARS(z, ptr);
+ return z;
}
char *must_realloc(where, olen, len, what)
char *where;
long olen, len;
char *what;
{
- char *ptr;
- sizet size = len;
- long nm = mallocated+size-olen;
- if (len != size)
-ralerr:
- wta(MAKINUM(len), (char *)NALLOC, what);
- if ((nm <= mtrigger)) {
- SYSCALL(ptr = (char *)realloc(where, size););
- if (NULL != ptr) {mallocated = nm; return ptr;}
- }
- igc(what, CONT(rootcont)->stkbse);
- nm = mallocated+size-olen;
- if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before realloc */
- SYSCALL(ptr = (char *)realloc(where, size););
- if (NULL != ptr) {
- mallocated = nm;
- if (nm > mtrigger) mtrigger = nm + nm/2;
- return ptr;}
- goto ralerr;
-}
-void must_free(obj)
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated + size - olen;
+ VERIFY_INTS("must_realloc", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)realloc(where, size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+ mallocated = nm;
+ return ptr;
+}
+void must_realloc_cell(z, olen, len, what)
+ SCM z;
+ long olen, len;
+ char *what;
+{
+ char *ptr, *where = CHARS(z);
+ sizet size = len;
+ long nm = mallocated + size - olen;
+ VERIFY_INTS("must_realloc_cell", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)realloc(where, size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+ mallocated = nm;
+ SETCHARS(z, ptr);
+}
+void must_free(obj, len)
char *obj;
+ sizet len;
{
- if (obj) free(obj);
+ if (obj) {
+#ifdef CAREFUL_INTS
+ while (len--) obj[len] = '#';
+#endif
+ free(obj);
+ }
else wta(INUM0, "already free", "");
}
+#ifdef NUM_HP
+# define NUM_HP_SIZE 240*sizeof(double)
+
+struct num_hp {
+ struct num_hp *next; /* Next heap in list */
+ sizet size; /* Size of one half-heap, in doubles */
+ sizet offset; /* 0 or size, depending on which half-heap is in use */
+ sizet ind; /* index of next available double */
+ double hp[1]; /* Make sure we are optimally aligned for doubles, more
+ follow */
+};
+typedef struct num_hp num_hp;
+static num_hp *num_hp_head = 0, *num_hp_cur = 0;
+long num_hp_total = 0;
+
+/* size is in bytes */
+static char s_num_hp[] = "flonum/bignum heap";
+static void num_hp_add(size)
+ sizet size;
+{
+ num_hp *new_hp;
+ sizet dsz = size / sizeof(double);
+ tail:
+ new_hp = (num_hp_cur ? num_hp_cur->next : 0);
+ if (new_hp) {
+ new_hp->ind = new_hp->size;
+ num_hp_cur = new_hp;
+ return;
+ }
+ new_hp = (num_hp *)must_malloc(sizeof(num_hp) + (2*dsz-1)*sizeof(double),
+ s_num_hp);
+ num_hp_total += sizeof(num_hp) + (2*dsz-1)*sizeof(double) ;
+ growth_mon(s_num_hp, num_hp_total, "doubles", !0);
+ new_hp->next = 0;
+ new_hp->size = dsz;
+ new_hp->offset = 0;
+ new_hp->ind = new_hp->size;
+ /* must_malloc might have called gc, moving num_hp_cur. */
+ if (num_hp_cur) {
+ num_hp *hp = num_hp_cur;
+ while (hp->next) hp = hp->next;
+ hp->next = new_hp;
+ }
+ else
+ num_hp_cur = new_hp;
+ if (num_hp_cur->ind >= NUM_HP_MAX_REQ/sizeof(double)) return;
+ goto tail;
+}
+
+static void num_hp_switch()
+{
+ num_hp *hp = num_hp_head;
+ while (hp) {
+ hp->offset = (hp->offset + hp->size) % (2*hp->size);
+ hp->ind = hp->size;
+ hp = hp->next;
+ }
+ num_hp_cur = num_hp_head;
+}
+
+/* len is in bytes */
+char *num_hp_alloc(len)
+ sizet len;
+{
+ num_hp *hp = num_hp_cur;
+ len = (len + sizeof(double) - 1)/sizeof(double);
+ if ((!hp) || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
+ num_hp_add(NUM_HP_SIZE);
+ hp = num_hp_cur;
+ }
+ hp->ind -= len;
+ return (char *)&(hp->hp[hp->ind + hp->offset]);
+}
+
+char *num_hp_realloc(where, olen, len, what)
+ char *where, *what;
+ long olen, len;
+{
+ char *ret;
+ sizet i;
+ if (len <= NUM_HP_MAX_REQ) {
+ num_hp *hp = num_hp_cur;
+ if (len <= olen) return where;
+ if (!hp || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
+ num_hp_add(NUM_HP_SIZE);
+ hp = num_hp_cur;
+ }
+ hp->ind -= (len + sizeof(double) - 1)/sizeof(double);
+ ret = (char *)&(hp->hp[hp->ind + hp->offset]);
+ for (i = len; i--;)
+ ret[i] = where[i];
+ if (olen > NUM_HP_MAX_REQ) must_free(where, (long)olen);
+ return ret;
+ }
+ if (olen > NUM_HP_MAX_REQ)
+ return must_realloc(where, olen, len, what);
+ ret = must_malloc((long)len, what);
+ for (i = len; i--;)
+ ret[i] = where[i];
+ return ret;
+}
+void num_hp_free(hp)
+ num_hp *hp;
+{
+ num_hp *next;
+ while (hp) {
+ next = hp->next;
+ num_hp_total -= 2*hp->size;
+ must_free((char *)hp, sizeof(num_hp) + hp->size*2 - sizeof(double));
+ hp = next;
+ }
+}
+#endif /* NUM_HP */
+
SCM symhash; /* This used to be a sys_protect, but
Radey Shouman <shouman@zianet.com>
- added GC for unuesd, UNDEFINED
+ added GC for unused, UNDEFINED
symbols.*/
int symhash_dim = NUM_HASH_BUCKETS;
/* sym2vcell looks up the symbol in the symhash table. */
@@ -718,7 +1148,7 @@ SCM intern(name, len)
return z;
}
SCM sysintern(name, val)
- char *name;
+ const char *name;
SCM val;
{
SCM lsym, z;
@@ -738,8 +1168,10 @@ SCM sysintern(name, val)
trynext: ;
}
NEWCELL(lsym);
+ DEFER_INTS;
SETLENGTH(lsym, (long)len, tc7_ssymbol);
SETCHARS(lsym, name);
+ ALLOW_INTS;
lsym = cons(lsym, val);
z = cons(lsym, UNDEFINED);
CDR(z) = VELTS(symhash)[hash];
@@ -786,17 +1218,16 @@ SCM makstr(len)
long len;
{
SCM s;
- NEWCELL(s);
DEFER_INTS;
- SETCHARS(s, must_malloc(len+1, s_string));
+ s = must_malloc_cell(len+1, s_string);
SETLENGTH(s, len, tc7_string);
- ALLOW_INTS;
CHARS(s)[len] = 0;
+ ALLOW_INTS;
return s;
}
SCM make_subr(name, type, fcn)
- char *name;
+ const char *name;
int type;
SCM (*fcn)();
{
@@ -806,8 +1237,8 @@ SCM make_subr(name, type, fcn)
if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
tmp = 0;
NEWCELL(z);
- SUBRF(z) = fcn;
CAR(z) = tmp + type;
+ SUBRF(z) = fcn;
CDR(symcell) = z;
return z;
}
@@ -818,10 +1249,9 @@ SCM makcclo(proc, len)
long len;
{
SCM s;
- NEWCELL(s);
DEFER_INTS;
- SETCHARS(s, must_malloc(len*sizeof(SCM), "compiled-closure"));
- SETLENGTH(s, len, tc7_cclo);
+ s = must_malloc_cell(len*sizeof(SCM), "compiled-closure");
+ SETNUMDIGS(s, len, tc16_cclo);
while (--len) VELTS(s)[len] = UNSPECIFIED;
CCLO_SUBR(s) = proc;
ALLOW_INTS;
@@ -839,18 +1269,22 @@ void stack_check()
# else
if (start - &stack > STACK_LIMIT/sizeof(STACKITEM))
# endif /* def STACK_GROWS_UP */
- wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
+ {
+ stack_report();
+ wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
+ }
}
#endif
void stack_report()
{
STACKITEM stack;
- intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 16, cur_errp);
- lputs(" of stack: 0x", cur_errp);
- intprint((long)CONT(rootcont)->stkbse, 16, cur_errp);
+ lputs(";; stack: 0x", cur_errp);
+ intprint((long)CONT(rootcont)->stkbse, -16, cur_errp);
lputs(" - 0x", cur_errp);
- intprint((long)&stack, 16, cur_errp);
- lputs("\n", cur_errp);
+ intprint((long)&stack, -16, cur_errp);
+ lputs("; ", cur_errp);
+ intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp);
+ lputs(" bytes\n", cur_errp);
}
SCM dynwind(thunk1, thunk2, thunk3)
@@ -887,20 +1321,26 @@ void dowinds(to, delta)
SCM scm_make_cont()
{
- SCM cont;
+ SCM cont, env, *from, *to;
CONTINUATION *ncont;
+ sizet n;
+ VERIFY_INTS("scm_make_cont", 0);
NEWCELL(cont);
- DEFER_INTS;
+ from = VELTS(scm_estk);
+ n = scm_estk_ptr - from + SCM_ESTK_FRLEN + 2;
+ env = must_malloc_cell((long)n*sizeof(SCM), s_cont);
+ SETLENGTH(env, (long)n, tc7_vector);
+ to = VELTS(env);
+ to[--n] = scm_env;
+ to[--n] = scm_env_tmp;
+ while(n--) to[n] = from[n];
ncont = make_continuation(CONT(rootcont));
if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont);
ncont->other.parent = rootcont;
SETCONT(cont, ncont);
SETLENGTH(cont, ncont->length, tc7_contin);
ncont->other.dynenv = dynwinds;
-#ifdef CAUTIOUS
- CONT(cont)->other.stack_trace = stacktrace;
-#endif
- ALLOW_INTS;
+ ncont->other.env = env;
return cont;
}
static char s_sstale[] = "strangely stale";
@@ -912,9 +1352,20 @@ void scm_dynthrow(cont, val)
wta(cont->other.dynenv, &s_sstale[10], s_cont);
dowinds(cont->other.dynenv,
ilength(dynwinds)-ilength(cont->other.dynenv));
-#ifdef CAUTIOUS
- stacktrace = cont->other.stack_trace;
-#endif
+ {
+ SCM *from, *to;
+ sizet n = LENGTH(cont->other.env);
+ if (LENGTH(scm_estk) < n)
+ scm_estk_grow((n - (LENGTH(scm_estk))) / SCM_ESTK_FRLEN + 20);
+ DEFER_INTS;
+ from = VELTS(cont->other.env);
+ to = VELTS(scm_estk);
+ scm_env = from[--n];
+ scm_env_tmp = from[--n];
+ scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
+ while(n--) to[n] = from[n];
+ ALLOW_INTS;
+ }
throw_to_continuation(cont, val, CONT(rootcont));
wta(cont->other.dynenv, s_sstale, s_cont);
}
@@ -1035,7 +1486,7 @@ sizet init_heap_seg(seg_org, size)
/* CDR(scmptr) = freelist; */
CDR(PTR2SCM(--ptr)) = freelist;
freelist = PTR2SCM(CELL_UP(seg_org));
- heap_size += ni;
+ heap_cells += ni;
return size;
#ifdef scmptr
# undef scmptr
@@ -1047,15 +1498,18 @@ static void alloc_some_heap()
sizet len = (2+hplim_ind)*sizeof(CELLPTR);
ASRTGO(len==(2+hplim_ind)*sizeof(CELLPTR), badhplims);
if (errjmp_bad) wta(UNDEFINED, "need larger initial", s_heap);
- SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len););
+ tmplims = (CELLPTR *)must_realloc((char *)hplims,
+ len-2L*sizeof(CELLPTR), (long)len,
+ s_heap);
+ /* SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len);); */
if (!tmplims)
badhplims:
wta(UNDEFINED, s_nogrow, s_hplims);
else hplims = tmplims;
/* hplim_ind gets incremented in init_heap_seg() */
if (expmem) {
- len = (sizet)(EXPHEAP(heap_size)*sizeof(cell));
- if ((sizet)(EXPHEAP(heap_size)*sizeof(cell)) != len) len = 0;
+ len = (sizet)(EXPHEAP(heap_cells)*sizeof(cell));
+ if ((sizet)(EXPHEAP(heap_cells)*sizeof(cell)) != len) len = 0;
}
else len = HEAP_SEG_SIZE;
while (len >= MIN_HEAP_SEG_SIZE) {
@@ -1141,8 +1595,9 @@ SCM equal0(ptr1, ptr2)
return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
}
-/* statically allocated port for diagnostic messages */
-cell tmp_errp = {(SCM)((0L<<8)|tc16_fport|OPN|WRTNG), 0};
+/* statically allocated ports for diagnostic messages */
+static cell tmp_errpbuf[3];
+static SCM tmp_errp;
static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
extern sizet num_protects; /* sys_protects now in scl.c */
@@ -1153,8 +1608,9 @@ void init_storage(stack_start_ptr, init_heap_size)
sizet j = num_protects;
/* Because not all protects may get initialized */
while(j) sys_protects[--j] = BOOL_F;
- tmp_errp.cdr = (SCM)stderr;
- cur_errp = PTR2SCM(&tmp_errp);
+ tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
+ CAR(tmp_errp) = (SCM)(tc16_fport|OPN|WRTNG);
+ CDR(tmp_errp) = (SCM)stderr;
freelist = EOL;
expmem = 0;
@@ -1197,6 +1653,7 @@ void init_storage(stack_start_ptr, init_heap_size)
fixconfig("reduce", "size of HEAP_SEG_SIZE", 0);
mtrigger = INIT_MALLOC_LIMIT;
+ mltrigger = mtrigger - MIN_MALLOC_YIELD;
hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
j = init_heap_size;
@@ -1221,16 +1678,15 @@ void init_storage(stack_start_ptr, init_heap_size)
cur_inp = def_inp;
cur_outp = def_outp;
cur_errp = def_errp;
+ NEWCELL(sys_errp);
+ CAR(sys_errp) = (tc16_sysport|OPN|WRTNG);
+ SETSTREAM(sys_errp, 0);
dynwinds = EOL;
NEWCELL(rootcont);
SETCONT(rootcont, make_root_continuation(stack_start_ptr));
CAR(rootcont) = tc7_contin;
CONT(rootcont)->other.dynenv = EOL;
CONT(rootcont)->other.parent = BOOL_F;
- stacktrace = EOL;
-#ifdef CAUTIOUS
- CONT(rootcont)->other.stack_trace = EOL;
-#endif
listofnull = cons(EOL, EOL);
undefineds = cons(UNDEFINED, EOL);
CDR(undefineds) = undefineds;
@@ -1246,6 +1702,20 @@ void init_storage(stack_start_ptr, init_heap_size)
sysintern("bignum-radix", MAKINUM(BIGRAD));
#endif
/* flo0 is now setup in scl.c */
+ /* Set up environment cache */
+ scm_ecache_len = sizeof(ecache_v)/sizeof(cell);
+ scm_ecache = CELL_UP(ecache_v);
+ scm_ecache_len = CELL_DN(ecache_v + scm_ecache_len - 1) - scm_ecache + 1;
+ scm_ecache_index = scm_ecache_len;
+ scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
+ scm_estk_reset();
+
+#ifdef NUM_HP
+ /* Allocate a very small initial num_hp in case
+ we need it only for flo0. */
+ num_hp_add(10*sizeof(double));
+ num_hp_head = num_hp_cur;
+#endif /* def NUM_HP */
}
/* The way of garbage collecting which allows use of the cstack is due to */
@@ -1281,33 +1751,50 @@ char s_cells[] = "cells";
SCM gc_for_newcell()
{
SCM fl;
- DEFER_INTS;
+ int oints = ints_disabled; /* Temporary expedient */
+ if (!oints) ints_disabled = 1;
igc(s_cells, CONT(rootcont)->stkbse);
- ALLOW_INTS;
if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
- DEFER_INTS;
alloc_some_heap();
- ALLOW_INTS;
- growth_mon("number of heaps", (long)(hplim_ind/2), "segments");
- growth_mon(s_heap, heap_size, s_cells);
+ growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
+ growth_mon(s_heap, heap_cells, s_cells, !0);
}
++cells_allocated;
fl = freelist;
freelist = CDR(fl);
+ ints_disabled = oints;
return fl;
}
+void scm_fill_freelist()
+{
+ while IMP(freelist) {
+ igc(s_cells, CONT(rootcont)->stkbse);
+ if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
+ alloc_some_heap();
+ growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
+ growth_mon(s_heap, heap_cells, s_cells, !0);
+ }
+ }
+}
+
static char s_bad_type[] = "unknown type in ";
jump_buf save_regs_gc_mark;
void mark_locations P((STACKITEM x[], sizet n));
static void mark_syms P((SCM v));
static void mark_sym_values P((SCM v));
static void sweep_symhash P((SCM v));
+static void egc_mark P((void));
+static void egc_sweep P((void));
-SCM gc()
+SCM gc(arg)
+ SCM arg;
{
DEFER_INTS;
- igc("call", CONT(rootcont)->stkbse);
+ if UNBNDP(arg)
+ igc("call", CONT(rootcont)->stkbse);
+ else
+ scm_egc();
ALLOW_INTS;
return UNSPECIFIED;
}
@@ -1316,21 +1803,25 @@ void igc(what, stackbase)
STACKITEM *stackbase;
{
int j = num_protects;
- long oheap_size = heap_size;
+ long oheap_cells = heap_cells;
gc_start(what);
if (++errjmp_bad > 1)
- wta(MAKINUM(errjmp_bad), "gc called from within ", s_gc);
+ wta(MAKINUM(errjmp_bad), s_recursive, s_gc);
+#ifdef NUM_HP
+ num_hp_switch(); /* Switch half-heaps for flonums/bignums */
+#endif
+#ifdef NO_SYM_GC
+ gc_mark(symhash);
+#else
/* By marking symhash first, we provide the best immunity from
accidental references. In order to accidentally protect a
symbol, a pointer will have to point directly at the symbol (as
opposed to the vector or bucket lists). */
mark_syms(symhash);
/* mark_sym_values() can be called anytime after mark_syms. */
-#ifdef NO_SYM_GC
- gc_mark(symhash);
-#else
mark_sym_values(symhash);
#endif
+ egc_mark();
if (stackbase) {
FLUSH_REGISTER_WINDOWS;
/* This assumes that all registers are saved into the jump_buf */
@@ -1360,14 +1851,24 @@ void igc(what, stackbase)
}
while(j--)
gc_mark(sys_protects[j]);
+#ifndef NO_SYM_GC
sweep_symhash(symhash);
+#endif
gc_sweep(!stackbase);
+ egc_sweep();
+#if 0 /* def NUM_HP */
+ if (num_hp_cur) {
+ num_hp *hp = num_hp_cur->next;
+ num_hp_cur->next = 0;
+ if (hp) num_hp_free(hp);
+ }
+#endif
--errjmp_bad;
gc_end();
- if (oheap_size != heap_size) {
- ALLOW_INTS;
- growth_mon(s_heap, heap_size, s_cells);
- DEFER_INTS;
+ if (oheap_cells != heap_cells) {
+ int grewp = heap_cells > oheap_cells;
+ growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp);
+ growth_mon(s_heap, heap_cells, s_cells, grewp);
}
}
@@ -1377,7 +1878,8 @@ void free_storage()
DEFER_INTS;
gc_start("free");
++errjmp_bad;
- cur_inp = BOOL_F; cur_outp = BOOL_F; cur_errp = PTR2SCM(&tmp_errp);
+ cur_inp = BOOL_F; cur_outp = BOOL_F;
+ cur_errp = tmp_errp; sys_errp = tmp_errp;
gc_mark(def_inp); /* don't want to close stdin */
gc_mark(def_outp); /* don't want to close stdout */
gc_mark(def_errp); /* don't want to close stderr */
@@ -1387,44 +1889,65 @@ void free_storage()
hplim_ind -= 2;
{
CELLPTR ptr = CELL_UP(hplims[hplim_ind]);
- sizet seg_size = CELL_DN(hplims[hplim_ind+1]) - ptr;
- heap_size -= seg_size;
- must_free((char *)hplims[hplim_ind]);
+ sizet seg_cells = CELL_DN(hplims[hplim_ind+1]) - ptr;
+ heap_cells -= seg_cells;
+ free((char *)hplims[hplim_ind]);
hplims[hplim_ind] = 0;
- growth_mon(s_heap, heap_size, s_cells);
+ growth_mon(s_heap, heap_cells, s_cells, 0); fflush(stderr);
}}
- if (heap_size) wta(MAKINUM(heap_size), s_not_free, s_heap);
+ if (heap_cells) wta(MAKINUM(heap_cells), s_not_free, s_heap);
if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
/* Not all cells get freed (see gc_mark() calls above). */
/* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */
+#ifdef NUM_HP
+ num_hp_free(num_hp_head);
+#endif
/* either there is a small memory leak or I am counting wrong. */
+ must_free((char *)hplims, 0);
/* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */
- must_free((char *)hplims);
hplims = 0;
- must_free((char *)smobs);
+ /* must_free((char *)smobs, numsmob * sizeof(smobfuns)); */
+ free((char *)smobs);
smobs = 0;
- gc_end();
+ gc_end();
ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
exit_report();
- must_free((char *)ptobs);
+ lflush(sys_errp);
+ /* must_free((char *)ptobs, numptob * sizeof(ptobfuns)); */
+ free((char *)ptobs);
ptobs = 0;
lmallocated = mallocated = 0;
/* Can't do gc_end() here because it uses ptobs which have been freed */
+ fflush(stdout); /* in lieu of close */
+ fflush(stderr); /* in lieu of close */
+}
+
+#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
+
+/* This is used to force allocation of SCM temporaries on the stack,
+ it should be called with any SCM variables used for malloc headers
+ and entirely local to a C procedure. */
+void scm_protect_temp(ptr)
+ SCM *ptr;
+{
+ return;
}
+static char s_gc_sym[] = "mark_syms", s_wrong_length[] = "wrong length";
void gc_mark(p)
SCM p;
{
register long i;
register SCM ptr = p;
+ CHECK_STACK;
gc_mark_loop:
if IMP(ptr) return;
gc_mark_nimp:
if (NCELLP(ptr)
- /* #ifndef RECKLESS
- || PTR_GT(hplims[0], (CELLPTR)ptr)
- || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1])
-#endif */
+ /* #ifndef RECKLESS */
+ /* || PTR_GT(hplims[0], (CELLPTR)ptr) */
+ /* || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1]) */
+ /* #endif */
) wta(ptr, "rogue pointer in ", s_heap);
switch TYP7(ptr) {
case tcs_cons_nimcar:
@@ -1446,17 +1969,28 @@ void gc_mark(p)
case tcs_closures:
if GCMARKP(ptr) break;
SETGCMARK(ptr);
- if IMP(CDR(ptr)) {
+ if IMP(GCENV(ptr)) {
ptr = CODE(ptr);
goto gc_mark_nimp;
}
gc_mark(CODE(ptr));
- ptr = GCCDR(ptr);
+ ptr = GCENV(ptr);
goto gc_mark_nimp;
- case tc7_vector:
+ case tc7_specfun:
+ if GC8MARKP(ptr) break;
+ SETGC8MARK(ptr);
#ifdef CCLO
- case tc7_cclo:
+ if (tc16_cclo==GCTYP16(ptr)) {
+ i = CCLO_LENGTH(ptr);
+ if (i==0) break;
+ while(--i>0) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]);
+ ptr = VELTS(ptr)[0];
+ }
+ else
#endif
+ ptr = CDR(ptr);
+ goto gc_mark_loop;
+ case tc7_vector:
if GC8MARKP(ptr) break;
SETGC8MARK(ptr);
i = LENGTH(ptr);
@@ -1472,15 +2006,18 @@ void gc_mark(p)
(sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) /
sizeof(STACKITEM)));
break;
+ case tc7_string:
+ case tc7_msymbol:
+ if GC8MARKP(ptr) break;
+ ASSERT(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
+ s_wrong_length, s_gc);
+ case tc7_ssymbol:
case tc7_bvect:
case tc7_ivect:
case tc7_uvect:
case tc7_fvect:
case tc7_dvect:
case tc7_cvect:
- case tc7_string:
- case tc7_msymbol:
- case tc7_ssymbol:
SETGC8MARK(ptr);
case tcs_subrs:
break;
@@ -1495,12 +2032,46 @@ void gc_mark(p)
case tc_free_cell:
/* printf("found free_cell %X ", ptr); fflush(stdout); */
SETGC8MARK(ptr);
- CDR(ptr) = EOL;
+ ASSERT(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
+ /* CDR(ptr) = UNDEFINED */;
break;
+#ifdef BIGDIG
case tcs_bignums:
+#ifdef NUM_HP
+ if (NUMDIGS(ptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) {
+ sizet i = NUMDIGS(ptr);
+ BIGDIG *nw = (BIGDIG *)num_hp_alloc(i*sizeof(BIGDIG));
+ while (i--) nw[i] = BDIGITS(ptr)[i];
+ }
+#endif
+ SETGC8MARK(ptr);
+ break;
+#endif
+#ifdef FLOATS
case tc16_flo:
+# ifdef NUM_HP
+ {
+ double *nw;
+ switch ((int)(CAR(ptr)>>16)) {
+ default: goto def;
+ case (IMAG_PART | REAL_PART)>>16:
+ nw = (double *)num_hp_alloc(2*sizeof(double));
+ nw[0] = REAL(ptr);
+ nw[1] = IMAG(ptr);
+ CDR(ptr) = (SCM)nw;
+ break;
+ case REAL_PART>>16: case IMAG_PART>>16:
+ nw = (double *)num_hp_alloc(sizeof(double));
+ nw[0] = REAL(ptr);
+ CDR(ptr) = (SCM)nw;
+ break;
+ case 0: break;
+ }
+ }
+# endif /* def NUM_HP */
SETGC8MARK(ptr);
break;
+#endif
default:
i = SMOBNUM(ptr);
if (!(i < numsmob)) goto def;
@@ -1541,8 +2112,6 @@ void mark_locations(x, n)
}
}
-#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
-
static void gc_sweep(contin_bad)
int contin_bad;
{
@@ -1550,17 +2119,17 @@ static void gc_sweep(contin_bad)
#ifdef POINTERS_MUNGED
register SCM scmptr;
#else
-#define scmptr (SCM)ptr
+# define scmptr (SCM)ptr
#endif
register SCM nfreelist = EOL;
register long n = 0, m = 0;
- register sizet j;
+ register sizet j, minc;
sizet i = 0;
- sizet seg_size;
+ sizet seg_cells;
while (i<hplim_ind) {
ptr = CELL_UP(hplims[i++]);
- seg_size = CELL_DN(hplims[i++]) - ptr;
- for(j = seg_size;j--;++ptr) {
+ seg_cells = CELL_DN(hplims[i++]) - ptr;
+ for(j = seg_cells;j--;++ptr) {
#ifdef POINTERS_MUNGED
scmptr = PTR2SCM(ptr);
#endif
@@ -1571,44 +2140,51 @@ static void gc_sweep(contin_bad)
case tcs_closures:
if GCMARKP(scmptr) goto cmrkcontinue;
break;
- case tc7_vector:
+ case tc7_specfun:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
#ifdef CCLO
- case tc7_cclo:
+ if (tc16_cclo==GCTYP16(scmptr)) {
+ minc = (CCLO_LENGTH(scmptr)*sizeof(SCM));
+ goto freechars;
+ }
#endif
+ break;
+ case tc7_vector:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += (LENGTH(scmptr)*sizeof(SCM));
+ minc = (LENGTH(scmptr)*sizeof(SCM));
freechars:
- must_free(CHARS(scmptr));
+ m += minc;
+ must_free(CHARS(scmptr), minc);
/* SETCHARS(scmptr, 0);*/
break;
case tc7_bvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
+ minc = sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
goto freechars;
case tc7_ivect:
case tc7_uvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*sizeof(long);
+ minc = HUGE_LENGTH(scmptr)*sizeof(long);
goto freechars;
case tc7_fvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*sizeof(float);
+ minc = HUGE_LENGTH(scmptr)*sizeof(float);
goto freechars;
case tc7_dvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*sizeof(double);
+ minc = HUGE_LENGTH(scmptr)*sizeof(double);
goto freechars;
case tc7_cvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*2*sizeof(double);
+ minc = HUGE_LENGTH(scmptr)*2*sizeof(double);
goto freechars;
case tc7_string:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)+1;
+ minc = HUGE_LENGTH(scmptr)+1;
goto freechars;
case tc7_msymbol:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += LENGTH(scmptr)+1;
+ minc = LENGTH(scmptr)+1;
goto freechars;
case tc7_contin:
if GC8MARKP(scmptr) {
@@ -1620,7 +2196,7 @@ static void gc_sweep(contin_bad)
}
goto c8mrkcontinue;
}
- m += LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
+ minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
free_continuation(CONT(scmptr)); break; /* goto freechars; */
case tc7_ssymbol:
if GC8MARKP(scmptr) goto c8mrkcontinue;
@@ -1651,30 +2227,38 @@ static void gc_sweep(contin_bad)
#ifdef BIGDIG
case tcs_bignums:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
+# ifdef NUM_HP
+ if (NUMDIGS(scmptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) break;
+# endif /* def NUM_HP */
+ minc = (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
goto freechars;
#endif /* def BIGDIG */
+#ifdef FLOATS
case tc16_flo:
if GC8MARKP(scmptr) goto c8mrkcontinue;
+# ifndef NUM_HP
switch ((int)(CAR(scmptr)>>16)) {
case (IMAG_PART | REAL_PART)>>16:
- m += sizeof(double);
+ minc = 2*sizeof(double);
+ goto freechars;
case REAL_PART>>16:
case IMAG_PART>>16:
- m += sizeof(double);
+ minc = sizeof(double);
goto freechars;
case 0:
break;
default:
goto sweeperr;
}
+# endif /* ndef NUM_HP */
+#endif /* def FLOATS */
break;
default:
if GC8MARKP(scmptr) goto c8mrkcontinue;
{
int k = SMOBNUM(scmptr);
if (!(k < numsmob)) goto sweeperr;
- m += (smobs[k].free)((CELLPTR)scmptr);
+ minc = (smobs[k].free)((CELLPTR)scmptr);
}
}
break;
@@ -1692,9 +2276,12 @@ static void gc_sweep(contin_bad)
CLRGCMARK(scmptr);
}
#ifdef GC_FREE_SEGMENTS
- if (n==seg_size) {
- heap_size -= seg_size;
- must_free((char *)hplims[i-2]);
+ if (n==seg_cells) {
+ heap_cells -= seg_cells;
+ n = 0;
+ free((char *)hplims[i-2]);
+ /* 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];
hplim_ind -= 2;
@@ -1707,16 +2294,16 @@ static void gc_sweep(contin_bad)
gc_cells_collected += n;
n = 0;
}
- lcells_allocated += (heap_size - gc_cells_collected - cells_allocated);
- cells_allocated = (heap_size - gc_cells_collected);
+ lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated);
+ cells_allocated = (heap_cells - gc_cells_collected);
lmallocated -= m;
mallocated -= m;
gc_malloc_collected = m;
}
+#ifndef NO_SYM_GC
/* mark_syms marks those symbols of hash table V which have
non-UNDEFINED values. */
-static char s_gc_sym[] = "mark_syms";
static void mark_syms(v)
SCM v;
{
@@ -1728,7 +2315,14 @@ static void mark_syms(v)
ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym);
x = CAR(al);
SETGCMARK(al); /* Do mark bucket list */
- ASSERT(!GCMARKP(x), x, s_bad_type, s_gc_sym);
+# ifdef CAREFUL_INTS
+ ASSERT(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym);
+ ASSERT(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]),
+ CAR(x), s_wrong_length, s_gc_sym);
+ ASSERT(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)),
+ (unsigned long)symhash_dim)==k,
+ CAR(x), "bad hash", s_gc_sym);
+# endif
if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x)))
goto used; /* Don't mark symbol. */
SETGC8MARK(CAR(x));
@@ -1747,7 +2341,7 @@ static void mark_sym_values(v)
{
SCM x, al;
int k = LENGTH(v);
- SETGC8MARK(v);
+ /* SETGC8MARK(v); */ /* already set by mark_syms */
while (k--)
for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
x = GCCDR(CAR(al));
@@ -1780,3 +2374,172 @@ static void sweep_symhash(v)
VELTS(v)[k] &= ~1L; /* We may have deleted the first cell */
}
}
+#endif
+
+/* Environment cache GC routines */
+/* This is called during a non-cache gc. We only mark those stack frames
+ that are in use. */
+static void egc_mark()
+{
+ SCM *v;
+ int i;
+ gc_mark(scm_env);
+ gc_mark(scm_env_tmp);
+ if IMP(scm_estk) return; /* Can happen when moving estk. */
+ if GC8MARKP(scm_estk) return;
+ v = VELTS(scm_estk);
+ SETGC8MARK(scm_estk);
+ i = scm_estk_ptr - v + SCM_ESTK_FRLEN;
+ while(--i >= 0)
+ if NIMP(v[i])
+ gc_mark(v[i]);
+}
+static void egc_sweep()
+{
+ SCM z;
+ int i;
+ for (i = scm_ecache_index; i < scm_ecache_len; i++) {
+ z = PTR2SCM(&(scm_ecache[i]));
+ if CONSP(z) {
+ CLRGCMARK(z);
+ }
+ else {
+ CLRGC8MARK(z);
+ }
+ }
+}
+
+#define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \
+ PTR_GT((CELLPTR)(ecache_v) + ECACHE_SIZE, (CELLPTR)SCM2PTR(x)))
+static void egc_copy(px)
+ SCM *px;
+{
+ SCM z, x = *px;
+ do {
+ if (tc_broken_heart==CAR(x)) {
+ *px = CDR(x);
+ return;
+ }
+ if IMP(freelist) wta(freelist, "empty freelist", "ecache gc");
+ z = freelist;
+ freelist = CDR(freelist);
+ ++cells_allocated;
+ CAR(z) = CAR(x);
+ CDR(z) = CDR(x);
+ CAR(x) = (SCM)tc_broken_heart;
+ CDR(x) = z;
+ *px = z;
+ x = CAR(z);
+ if (NIMP(x) && ECACHEP(x))
+ egc_copy(&(CAR(z)));
+ px = &(CDR(z));
+ x = *px;
+ } while (NIMP(x) && ECACHEP(x));
+}
+
+static void egc_copy_stack(ve, len)
+ SCM *ve;
+ sizet len;
+{
+ SCM x;
+ while (len--) {
+ x = ve[len];
+ if (NIMP(x) && ECACHEP(x))
+ if (tc_broken_heart==CAR(x))
+ ve[len] = CDR(x);
+ else
+ egc_copy(&(ve[len]));
+ }
+}
+
+extern long tc16_env, tc16_promise;
+static void egc_copy_roots()
+{
+ SCM *roots = &(scm_egc_roots[scm_egc_root_index]);
+ SCM e, x;
+ int len = sizeof(scm_egc_roots)/sizeof(SCM) - scm_egc_root_index ;
+ if (!(len>=0 && len <= sizeof(scm_egc_roots)/sizeof(SCM)))
+ wta(MAKINUM(scm_egc_root_index), "egc-root-index", "corrupted");
+ while (len--) {
+ x = roots[len];
+ if IMP(x) continue;
+ switch TYP3(x) {
+ clo:
+ case tc3_closure:
+ e = ENV(x);
+ if (NIMP(e) && ECACHEP(e)) {
+ egc_copy(&e);
+ CDR(x) = (6L & CDR(x)) | e;
+ }
+ break;
+ case tc3_cons_imcar:
+ case tc3_cons_nimcar: /* These are environment frames that have
+ been destructively altered by DEFINE or
+ LETREC. This is only a problem if a
+ non-cache cell was made to point into the
+ cache. */
+ if ECACHEP(x) break;
+ e = CDR(x);
+ if (NIMP(e) && ECACHEP(e))
+ egc_copy(&(CDR(x)));
+ break;
+ default:
+ if (tc7_contin==TYP7(x)) {
+ x = CONT(x)->other.env;
+ egc_copy_stack(VELTS(x), (sizet)LENGTH(x));
+ break;
+ }
+ if (tc16_env==CAR(x)) {
+ e = CDR(x);
+ if (NIMP(e) && ECACHEP(e))
+ egc_copy(&(CDR(x)));
+ break;
+ }
+ if (tc16_promise==CAR(x)) {
+ x = CDR(x);
+ goto clo;
+ }
+ }
+ }
+ scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
+}
+extern long scm_stk_moved, scm_clo_moved, scm_env_work;
+void scm_egc()
+{
+ VERIFY_INTS("scm_egc", 0);
+/* We need to make sure there are enough cells available to migrate
+ the entire environment cache, gc does not work properly during ecache gc */
+ while ((heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
+ igc("ecache", CONT(rootcont)->stkbse);
+ if ((gc_cells_collected < MIN_GC_YIELD) ||
+ (heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
+ alloc_some_heap();
+ growth_mon("number of heaps", (long)(hplim_ind/2), "segments", !0);
+ growth_mon(s_heap, heap_cells, s_cells, !0);
+ }
+ }
+ if (++errjmp_bad > 1)
+ wta(MAKINUM(errjmp_bad), s_recursive, s_cache_gc);
+ {
+ SCM stkframe[2];
+ long lcells = cells_allocated;
+ sizet nstk = (scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN);
+ ASSERT(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc);
+ scm_egc_start();
+ stkframe[0] = scm_env;
+ stkframe[1] = scm_env_tmp;
+ egc_copy_roots();
+ scm_clo_moved += cells_allocated - lcells;
+ lcells = cells_allocated;
+ egc_copy_stack(stkframe, sizeof(stkframe)/sizeof(SCM));
+ egc_copy_stack(VELTS(scm_estk), nstk);
+ scm_env = stkframe[0];
+ scm_env_tmp = stkframe[1];
+ scm_stk_moved += cells_allocated - lcells;
+ scm_ecache_index = scm_ecache_len;
+ scm_env_work += scm_ecache_len;
+ scm_egc_end();
+ }
+ --errjmp_bad;
+}
+
diff --git a/time.c b/time.c
index 4b4368c..4d0d723 100644
--- a/time.c
+++ b/time.c
@@ -44,177 +44,146 @@
#include "scm.h"
-#ifdef HAVE_CONFIG_H
-
-# ifndef HAVE_FTIME
-# define LACK_FTIME
+#ifdef STDC_HEADERS
+# include <time.h>
+# ifdef M_SYSV
+# include <sys/types.h>
+# include <sys/times.h>
# endif
-# ifndef HAVE_TIMES
-# define LACK_TIMES
+# ifdef sun
+# include <sys/types.h>
+# include <sys/times.h>
# endif
-# ifdef HAVE_SYS_TYPES_H
+# ifdef ultrix
# include <sys/types.h>
+# include <sys/times.h>
# endif
-# ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-# else
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# ifdef HAVE_TIME_H
-# include <time.h>
-# endif
-# endif
+# ifdef nosve
+# include <sys/types.h>
+# include <sys/times.h>
# endif
-# ifdef HAVE_SYS_TIMES_H
+# ifdef _UNICOS
+# include <sys/types.h>
# include <sys/times.h>
-# else
-# ifdef HAVE_SYS_TIMEB_H
-# include <sys/timeb.h>
-# endif
# endif
-# ifdef HAVE_FTIME
-# ifdef unix
-# ifndef GO32
-# include <sys/timeb.h>
-# endif
-# else
-# ifdef __amigados__
-# include <sys/timeb.h>
-# endif
-# endif
+# ifdef __IBMC__
+# include <sys/timeb.h>
# endif
-
#else
-
-# ifdef STDC_HEADERS
+# ifdef SVR2
# include <time.h>
-# ifdef M_SYSV
-# include <sys/types.h>
-# include <sys/times.h>
-# endif
-# ifdef sun
-# include <sys/types.h>
-# include <sys/times.h>
-# endif
-# ifdef ultrix
-# include <sys/types.h>
-# include <sys/times.h>
-# endif
-# ifdef nosve
-# include <sys/types.h>
-# include <sys/times.h>
-# endif
-# ifdef _UNICOS
-# include <sys/types.h>
-# include <sys/times.h>
-# endif
-# ifdef __IBMC__
-# include <sys/timeb.h>
-# endif
# else
-# ifdef SVR2
-# include <time.h>
-# else
-# ifndef ARM_ULIB
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-# endif
-# include <sys/types.h>
-
# ifndef ARM_ULIB
-# include <sys/times.h>
+# include <sys/time.h>
# else
# include <time.h>
# endif
+# endif
+# include <sys/types.h>
+# ifndef ARM_ULIB
+# include <sys/times.h>
+# else
+# include <time.h>
# endif
+#endif
+
/* Define this if your system lacks ftime(). */
/* #define LACK_FTIME */
+/* Define this if your system has gettimeofday()
+ (LACK_FTIME should not be defined). */
+/* #define USE_GETTIMEOFDAY */
/* Define this if your system lacks times(). */
/* #define LACK_TIMES */
-# ifdef __TURBOC__
-# define LACK_TIMES
-# endif
-# if (__TURBOC__==1) /* Needed for TURBOC V1.0 */
-# define LACK_FTIME
-# undef MSDOS
-# endif
-# ifdef __HIGHC__
-# define LACK_TIMES
-# endif
-# ifdef THINK_C
-# define LACK_FTIME
-# define LACK_TIMES
-# define CLK_TCK 60
-# endif
-# ifdef SVR2
-# define LACK_FTIME
-# endif
-# ifdef SVR4
-# define LACK_FTIME
-# endif
-# ifdef __svr4__
-# define LACK_FTIME
-# endif
-# ifdef nosve
-# define LACK_FTIME
-# endif
-# ifdef GO32
-# define LACK_FTIME
-# define LACK_TIMES
-# endif
-# ifdef atarist
-# define LACK_FTIME
-# define LACK_TIMES
-# endif
-# ifdef ARM_ULIB
-# define LACK_FTIME
-# define LACK_TIMES
-# endif
-# ifdef _DCC
-# define LACK_FTIME
+#ifdef linux
+# include <sys/types.h>
+# include <sys/time.h>
+# include <sys/timeb.h>
+# define USE_GETTIMEOFDAY
+#endif
+#ifdef freebsd
+# include <sys/types.h>
+# include <sys/time.h>
+# include <sys/timeb.h>
+# define USE_GETTIMEOFDAY
+#endif
+#ifdef __TURBOC__
+# define LACK_TIMES
+#endif
+#if (__TURBOC__==1) /* Needed for TURBOC V1.0 */
+# define LACK_FTIME
+# undef MSDOS
+#endif
+#ifdef __HIGHC__
+# define LACK_TIMES
+#endif
+#ifdef macintosh
+# define LACK_FTIME
+# define LACK_TIMES
+# define CLK_TCK 60
+#endif
+#ifdef SVR2
+# define LACK_FTIME
+#endif
+#ifdef SVR4
+# define LACK_FTIME
+#endif
+#ifdef __svr4__
+# define LACK_FTIME
+#endif
+#ifdef nosve
+# define LACK_FTIME
+#endif
+#ifdef GO32
+# define LACK_FTIME
+# define LACK_TIMES
+#endif
+#ifdef atarist
+# define LACK_FTIME
+# define LACK_TIMES
+#endif
+#ifdef ARM_ULIB
+# define LACK_FTIME
+# define LACK_TIMES
+#endif
+#ifdef _DCC
+# define LACK_FTIME
+#endif
+#ifdef MSDOS
+# ifndef GO32
+# include <sys/types.h>
+# include <sys/timeb.h>
# endif
-# ifdef MSDOS
+#endif
+#ifdef _UNICOS
+# define LACK_FTIME
+#endif
+
+#ifndef LACK_FTIME
+# ifdef unix
# ifndef GO32
-# include <sys/types.h>
# include <sys/timeb.h>
# endif
# endif
-# ifdef _UNICOS
-# define LACK_FTIME
-# endif
-
-# ifndef LACK_FTIME
-# ifdef unix
-# ifndef GO32
-# include <sys/timeb.h>
-# endif
-# endif
-# endif
-
-# ifdef __EMX__
-# define LACK_TIMES
-# include <sys/types.h>
-# include <sys/timeb.h>
-# endif
+#endif
-# ifdef MWC
-# include <time.h>
-# include <sys/timeb.h>
-# endif
+#ifdef __EMX__
+# define LACK_TIMES
+# include <sys/types.h>
+# include <sys/timeb.h>
+#endif
-# ifdef ARM_ULIB
-# include <sys/types.h>
-# include <time.h>
-# endif
+#ifdef MWC
+# include <time.h>
+# include <sys/timeb.h>
+#endif
-#endif /* HAVE_CONFIG_H */
+#ifdef ARM_ULIB
+# include <sys/types.h>
+# include <time.h>
+#endif
#ifdef vms
# define LACK_TIMES
@@ -327,18 +296,48 @@ SCM your_time()
}
# endif /* AMIGA */
#else /* LACK_FTIME */
+# ifdef USE_GETTIMEOFDAY
+int scm_ftime(time_buffer)
+ struct timeb *time_buffer;
+{
+ struct timezone t_z; struct timeval t_v;
+ if (gettimeofday(&t_v, &t_z) < 0) return -1;
+ time_buffer->timezone = t_z.tz_minuteswest;
+ time_buffer->dstflag = t_z.tz_dsttime;
+ time_buffer->millitm = t_v.tv_usec / 1000;
+ time_buffer->time = t_v.tv_sec;
+ return 0;}
+# else /* USE_GETTIMEOFDAY */
+# define scm_ftime ftime
+# endif /* USE_GETTIMEOFDAY */
struct timeb your_base = {0};
+# define TIMETRIES 10
SCM your_time()
{
- struct timeb time_buffer;
- long tmp;
- ftime(&time_buffer);
- time_buffer.time -= your_base.time;
- tmp = time_buffer.millitm - your_base.millitm;
- tmp = time_buffer.time*1000L + tmp;
- tmp *= CLKTCK;
- tmp /= 1000;
- return MAKINUM(tmp);
+ long tmp;
+ struct timeb time_buffer1;
+ struct timeb time_buffer2;
+ int cnt = 0;
+ tryagain:
+ cnt++;
+ scm_ftime(&time_buffer1);
+ scm_ftime(&time_buffer2);
+ if (time_buffer1.time==time_buffer2.time) {
+ if (time_buffer1.millitm > time_buffer2.millitm)
+ time_buffer2.time = time_buffer2.time + 1;
+ }
+ else if ((1 + time_buffer1.time)==time_buffer2.time) ;
+ else if (cnt < TIMETRIES) goto tryagain;
+ else {
+ warn("could not read two ftime()s within one second in 10 tries",0L);
+ return MAKINUM(-1);
+ }
+ time_buffer2.time -= your_base.time;
+ tmp = time_buffer2.millitm - your_base.millitm;
+ tmp = time_buffer2.time*1000L + tmp;
+ tmp *= CLKTCK;
+ tmp /= 1000;
+ return MAKINUM(tmp);
}
#endif /* LACK_FTIME */
@@ -377,32 +376,22 @@ static iproc subr0s[] = {
{"current-time", curtime},
{0, 0}};
-void init_time()
+void reset_time()
{
- sysintern("internal-time-units-per-second",
- MAKINUM((long)CLKTCK));
#ifdef LACK_FTIME
# ifndef AMIGA
- if (!your_base) time(&your_base);
+ time(&your_base);
# endif
#else
- if (!your_base.time) ftime(&your_base);
+ scm_ftime(&your_base);
#endif
- if (!my_base) my_base = mytime();
- init_iprocs(subr0s, tc7_subr_0);
+ my_base = 0;
+ my_base = mytime();
}
-#ifdef freebsd
-# include <sys/types.h>
-# include <sys/time.h>
-# include <sys/timeb.h>
-int ftime(time_buffer)
- struct timeb *time_buffer;
+void init_time()
{
- struct timezone t_z; struct timeval t_v;
- if (gettimeofday(&t_v, &t_z) < 0) return -1;
- time_buffer->timezone = t_z.tz_minuteswest;
- time_buffer->dstflag = t_z.tz_dsttime;
- time_buffer->millitm = t_v.tv_usec / 1000;
- time_buffer->time = t_v.tv_sec;
- return 0;}
-#endif
+ sysintern("internal-time-units-per-second",
+ MAKINUM((long)CLKTCK));
+ reset_time();
+ init_iprocs(subr0s, tc7_subr_0);
+}
diff --git a/unif.c b/unif.c
index 6a5fe84..35fc86e 100644
--- a/unif.c
+++ b/unif.c
@@ -107,9 +107,8 @@ SCM resizuve(vect, len)
siz = l * sz;
if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve);
DEFER_INTS;
- SETCHARS(vect, (char *)must_realloc((char *)CHARS(vect),
- (long)LENGTH(vect)*sz,
- (long)siz, s_resizuve));
+ must_realloc_cell(vect, (long)LENGTH(vect)*sz,
+ (long)siz, s_resizuve);
if VECTORP(vect) {
sz = LENGTH(vect);
while(l > sz) VELTS(vect)[--l] = UNSPECIFIED;
@@ -144,13 +143,13 @@ SCM make_uve(k, prot)
SCM prot;
{
SCM v;
- long i, type;
+ long i, type;
if (BOOL_T==prot) {
i = sizeof(long)*((k+LONG_BIT-1)/LONG_BIT);
type = tc7_bvect;
}
else if ICHRP(prot) {
- i = sizeof(char)*k;
+ i = sizeof(char)*(k + 1);
type = tc7_string;
}
else if INUMP(prot) {
@@ -191,11 +190,10 @@ SCM make_uve(k, prot)
type = tc7_dvect;
}
# endif
-
- NEWCELL(v);
DEFER_INTS;
- SETCHARS(v, must_malloc((i ? i : 1L), s_vector));
+ v = must_malloc_cell((i ? i : 1L), s_vector);
SETLENGTH(v, (k<LENGTH_MAX ? k : LENGTH_MAX), type);
+ if (tc7_string==type) CHARS(v)[k] = 0;
ALLOW_INTS;
return v;
}
@@ -324,10 +322,8 @@ SCM make_ra(ndim)
int ndim;
{
SCM ra;
- NEWCELL(ra);
DEFER_INTS;
- SETCDR(ra, must_malloc((long)(sizeof(array)+ndim*sizeof(array_dim)),
- "array"));
+ ra = must_malloc_cell((long)(sizeof(array)+ndim*sizeof(array_dim)), "array");
CAR(ra) = ((long)ndim << 17) + tc16_array;
ARRAY_V(ra) = nullvect;
ALLOW_INTS;
@@ -788,10 +784,10 @@ SCM array_inbp(args)
args = CDR(args);
if IMP(v) goto scalar;
switch TYP7(v) {
- default:
- scalar: if NULLP(args) return BOOL_T;
- badarg1: wta(v, (char *)ARG1, s_array_inbp);
wna: wta(UNDEFINED, (char *)WNA, s_array_inbp);
+ default: scalar:
+ if NULLP(args) return BOOL_T;
+ wta(v, (char *)ARG1, s_array_inbp);
case tc7_smob:
if (ARRAYP(v)) {
SCM ret = BOOL_T;
@@ -1765,10 +1761,10 @@ static void rapr1(ra, j, k, port, writing)
ipruk("uvect", ra, port);
break;
}
- if (n-- > 0) iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+ if (n-- > 0) intprint(VELTS(ra)[j], -10, port);
for (j += inc; n-- > 0; j += inc) {
lputc(' ', port);
- iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+ intprint(VELTS(ra)[j], -10, port);
}
break;
case tc7_ivect:
@@ -1896,6 +1892,88 @@ SCM array_prot(ra)
}
}
+/* Looks like ARRAY-REF, if just enough indices are provided,
+ If one extra is provided then the last index specifies bit
+ position in an integer element.
+*/
+static char s_logaref[] = "logaref";
+SCM scm_logaref(args)
+ SCM args;
+{
+ SCM ra, inds, ibit;
+ int i, rank = 1;
+ ASSERT(NIMP(args), UNDEFINED, WNA, s_logaref);
+ ra = CAR(args);
+ ASSERT(NIMP(ra), ra, ARG1, s_logaref);
+ if ARRAYP(ra) rank = ARRAY_NDIM(ra);
+ inds = args = CDR(args);
+ for (i = rank; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaref);
+ args = CDR(args);
+ }
+ if NULLP(args) return aref(ra, inds);
+ ASSERT(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
+ inds, WNA, s_logaref);
+ ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaref);
+ ibit = CAR(args);
+ if (1==rank)
+ inds = CAR(inds);
+ else { /* Destructively modify arglist */
+ args = inds;
+ for (i = rank-1; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaref);
+ args = CDR(args);
+ }
+ CDR(args) = EOL;
+ }
+ args = aref(ra, inds);
+ return INUMP(args) ?
+ ((1<<INUM(ibit)) & INUM(args) ? BOOL_T : BOOL_F) :
+ scm_logbitp(ibit, args);
+}
+
+static char s_logaset[] = "logaset!";
+SCM scm_logaset(ra, obj, args)
+ SCM ra, obj, args;
+{
+ SCM oval, inds, ibit;
+ int i, rank = 1;
+ ASSERT(NIMP(ra), ra, ARG1, s_logaset);
+ if ARRAYP(ra) rank = ARRAY_NDIM(ra);
+ inds = args;
+ for (i = rank; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaset);
+ args = CDR(args);
+ }
+ if NNULLP(args) {
+ ASSERT(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
+ inds, WNA, s_logaset);
+ ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaset);
+ ibit = CAR(args);
+ if (1==rank) inds = CAR(inds);
+ else { /* Destructively modify arglist */
+ args = inds;
+ for (i = rank-1; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaset);
+ args = CDR(args);
+ }
+ CDR(args) = EOL;
+ }
+ oval = aref(ra, inds);
+ ASSERT(INUMP(ibit), ibit, ARGn, s_logaset);
+ if (BOOL_T==obj)
+ obj = INUMP(oval) ? MAKINUM(INUM(oval) | (1<<INUM(ibit))) :
+ scm_logior(oval, MAKINUM(1<<INUM(ibit)));
+ else if (BOOL_F==obj)
+ obj = INUMP(oval) ? MAKINUM(INUM(oval) & (~(1<<INUM(ibit)))) :
+ scm_logand(oval, MAKINUM(~(1<<INUM(ibit))));
+#ifndef RECKLESS
+ else wta(obj, (char *)ARG2, s_logaset);
+#endif
+ }
+ return aset(ra, obj, inds);
+}
+
static iproc subr3s[] = {
{"uniform-vector-set1!", aset},
{s_uve_pos, position},
@@ -1928,12 +2006,14 @@ static iproc lsubrs[] = {
{s_trans_array, trans_array},
{s_encl_array, encl_array},
{s_array_inbp, array_inbp},
+ {s_logaref, scm_logaref},
{0, 0}};
static iproc lsubr2s[] = {
{s_make_sh_array, make_sh_array},
{s_dims2ura, dims2ura},
{s_aset, aset},
+ {s_logaset, scm_logaset},
{0, 0}};
static iproc subr2os[] = {
@@ -1953,7 +2033,7 @@ static SCM markra(ptr)
static sizet freera(ptr)
CELLPTR ptr;
{
- must_free(CHARS(ptr));
+ must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim));
return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim);
}
static smobfuns rasmob = {markra, freera, raprin1, 0};
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 09:52:26 +0000