summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitc7d035ae1a729232579a0fe41ed5affa131d3623 (patch)
treefb387f7c2a8e01cf603d4c75fbbaa68f711df986
parentdeda2c0fd8689349fea2a900199a76ff7ecb319e (diff)
downloadscm-c7d035ae1a729232579a0fe41ed5affa131d3623.tar.gz
scm-c7d035ae1a729232579a0fe41ed5affa131d3623.zip
Import Upstream version 5d9upstream/5d9
-rw-r--r--ANNOUNCE161
-rw-r--r--ChangeLog551
-rw-r--r--Init5d9.scm (renamed from Init5d6.scm)303
-rw-r--r--Link.scm1
-rw-r--r--Macro.scm8
-rw-r--r--Makefile206
-rw-r--r--README28
-rw-r--r--Xlibscm.info28
-rw-r--r--Xlibscm.texi4
-rw-r--r--bench.scm99
-rwxr-xr-xbuild64
-rw-r--r--build.scm477
-rw-r--r--byte.c285
-rwxr-xr-xcompile.scm60
-rw-r--r--continue.h5
-rw-r--r--crs.c78
-rw-r--r--debug.c22
-rw-r--r--dynl.c153
-rw-r--r--edline.c4
-rw-r--r--eval.c341
-rw-r--r--features.txi200
-rw-r--r--findexec.c8
-rw-r--r--gsubr.c4
-rw-r--r--hobbit.info132
-rw-r--r--hobbit.scm33
-rw-r--r--hobbit.texi53
-rwxr-xr-xinc2scm22
-rw-r--r--ioext.c227
-rw-r--r--keysymdef.scm828
-rw-r--r--mkimpcat.scm23
-rw-r--r--patchlvl.h4
-rw-r--r--platform.txi47
-rw-r--r--posix.c67
-rw-r--r--r4rstest.scm67
-rw-r--r--ramap.c21
-rw-r--r--record.c25
-rw-r--r--repl.c551
-rw-r--r--requires.scm3
-rw-r--r--rgx.c40
-rw-r--r--rope.c16
-rw-r--r--sc2.c64
-rw-r--r--scl.c223
-rw-r--r--scm.c122
-rw-r--r--scm.h925
-rw-r--r--scm.info2314
-rw-r--r--scm.spec18
-rw-r--r--scm.texi1367
-rw-r--r--scmfig.h66
-rw-r--r--scmmain.c26
-rw-r--r--script.c41
-rw-r--r--socket.c64
-rw-r--r--subr.c294
-rw-r--r--sys.c126
-rw-r--r--time.c10
-rw-r--r--unif.c166
-rw-r--r--unix.c21
-rw-r--r--version.txi2
-rw-r--r--x.c229
-rw-r--r--x11.scm105
-rwxr-xr-xxgen.scm26
60 files changed, 7230 insertions, 4228 deletions
diff --git a/ANNOUNCE b/ANNOUNCE
index 062f2da..fc0f9f9 100644
--- a/ANNOUNCE
+++ b/ANNOUNCE
@@ -1,31 +1,94 @@
-This message announces the availability of Scheme release scm5d6.
-
-New in scm5d6:
-
-From Aubrey Jaffer:
-
- + Tanel Tammet's Hobbit compiler is now integrated into the SCM
- distribution.
-
- + hobbit.scm modified for (symbol) GC changes in SCM. Use of
- scm_gc_protect() instead of lists of protected objects means code
- produced by Hobbit is smaller and more readable.
-
- + Converted the hobbit documentation to texinfo format.
- http://swissnet.ai.mit.edu/~jaffer/hobbit_toc.html
-
-From George Bronnikov:
-
- + Ported SCM to the PLAN9 operating-system.
-
-From Martin Lafaix
-
- + scm.c (l_raise, l_sleep):
- + script.c (dld_find_executable):
- + scmmain.c, scmfig.h: Ported to OS/2, IBM VisualAge C++ v3.
-
-Plus improvements and bug fixes too numerous to include here (see
-scm/ChangeLog).
+This message announces the availability of Scheme release scm5d9.
+
+New in scm5d9:
+
+ * ramap.c (array-map): Added.
+ * byte.c: Added. Improves RANDOM speed by 32%.
+ * subr.c (scm_logbitp, scm_ash): Prevent wraparound (1>>32==1).
+ * ioext.c, posix.c (system->line): Defined.
+ * scl.c (floequal): Fixed so 0/0==0/0.
+ (eqv, eqp): Use floequal.
+ * eval.c (init_eval): add_feature("primitive-hygiene").
+ * scl.c (eqp): Fixed so (let ((nan 0/0)) (= nan nan)) ==> #t.
+ (in2ex): Infinite loop on (inexact->exact 0/0) change to err.
+ * scl.c (iflo2str): Use negated conditional to handle 0/0.
+ (NaN2str): Removed "#i" prefix.
+
+ * scm.texi (Embedding SCM): Updated libtest example for
+ init_user_scm indirection (which Radey added 2003-01-24).
+ * scm.texi (MS-DOS Compatible Scripts): Added sharpbang URL.
+ * scm.texi (Build Options): Described *.opt option files.
+ * scm.texi (Automatic C Preprocessor Definitions): Added IA64.
+ * scm.texi (Line Numbers): Added read-for-load.
+ (Load Syntax): Distinguished from Read syntax; documented #?line,
+ #?column, and #?file.
+ (Data Type Representations): Updated port formats.
+
+ * Makefile (dfiles): Added version.txi platform.txi features.txi.
+ * Makefile (CFLAGS): Removed "-g".
+ * Makefile (pg.opt, gdb.opt, dlls.opt): Added. Cleanup options.
+ * Makefile (continue.o): Was missing scmfig.h and scm.h
+ dependencies.
+ * Makefile (uninstallinfo): Created.
+ (uninstall): Remove libscmdir files.
+ * Makefile (release): Make pdf(s).
+
+ * Init5d8.scm (slib:eval-load): Use *load-reader*.
+ * repl.c (scm_read_for_load): Added.
+ (p_read_numbered, p_read_for_load, p_read): Added locatives.
+ (lreadr): Pass appropriate read routine to load:sharp; read:sharp.
+ (flgs): Renamed from nump to reduce interference with INUMP, etc.
+ * Init5d8.scm (load:sharp, read:sharp): Split read:sharp.
+ (load:sharp, read:sharp, char:sharp, read:array): Added READ arg.
+ (char:sharp): Renamed from read:sharp-char.
+ (read:sharp): Integrated #; into.
+ * repl.c (scm_read): Renamed from lread().
+ (loc_charsharp): Renamed from loc_readsharpc.
+ (loc_loadsharp): Added to separate LOAD-macros from READ-macros.
+ (f_read_numbered): Removed unused variable.
+ (repl, tryload, scm_load_string): Use scm_read_numbered().
+ (lreadpr): Dispatch to loc_readsharp or loc_loadsharp depending on
+ nump.
+ * Init5d8.scm (make-array): Alias of create-array.
+ (read:sharp): Feature evaluation now slib:provided?
+
+ * mkimpcat.scm: Added rwb-isam feature.
+ * mkimpcat.scm (primitive-hygiene): Use feature to conditionalize
+ macro association.
+
+ * scmfig.h (CDR_DOUBLES, SHORT_INT): Added __ia64 #defines.
+
+ * build.scm (build): processor-family now symbol; i8086 <- 8086.
+ * build.scm (manifest): Added "byte.c".
+ * build.scm (compile-c-files): Removed "-O" and "-Wall" options;
+ use --compiler-options= instead.
+ * build.scm: Use open-table! and open-table.
+ * build (print-manifest, make-features-txi): Use open-table.
+ * build, build.scm: Moved requires to top.
+ * compile.scm, hobbit.scm: Added REQUIRE-IFs.
+ * hobbit.texi (SLIB Logical Procedures): Removed "logical:"
+ aliases.
+
+ * bench.scm (benchmark-prng): Limit to 1000 samples if no bignums.
+
+ * r4rstest.scm (inexact->exact): Added tests.
+ (exact->inexact): check for both exact and inexact argument.
+ * r4rstest.scm (6 5 5): Added some kawa chokers: #i, #e.
+ Added more kawa STRING->NUMBER bait.
+ * r4rstest.scm (test-string->number): Implementations which don't
+ allow division by 0 can have fragile string->number.
+
+ From Sam Hocevar
+ * r4rstest.scm (test-inexact): SECTION 6.2 checks that
+ (not (eqv? 1 1.0)).
+
+ From Andy Gaynor
+ * Makefile (Xlibscm.info, hobbit.info): Fixed / separators.
+ * unif.c (make_sh_array): Bracket with ifndef RECKLESS.
+
+ From Radey Shouman
+ * eval.c (m_case): Check on clauses for CASE was
+ confused by line-number annotations.
-=-=-
@@ -41,28 +104,24 @@ include SCM in other programs. Documentation is online at:
http://swissnet.ai.mit.edu/~jaffer/SCM.html
SCM source is available from:
- http://swissnet.ai.mit.edu/ftpdir/scm/scm5d6.zip
- swissnet.ai.mit.edu:/pub/scm/scm5d6.zip
- http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d6-1.src.rpm
- swissnet.ai.mit.edu:/pub/scm/scm-5d6-1.src.rpm
+ http://swissnet.ai.mit.edu/ftpdir/scm/scm5d9.zip
+ swissnet.ai.mit.edu:/pub/scm/scm5d9.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d9-1.src.rpm
+ swissnet.ai.mit.edu:/pub/scm/scm-5d9-1.src.rpm
Also available as i386 binary RPM:
- http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d6-1.i386.rpm
- swissnet.ai.mit.edu:/pub/scm/scm-5d6-1.i386.rpm
+ http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d9-1.i386.rpm
+ swissnet.ai.mit.edu:/pub/scm/scm-5d9-1.i386.rpm
SLIB is a portable Scheme library which SCM uses:
- http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip
- swissnet.ai.mit.edu:/pub/scm/slib2d4.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/slib3a1.zip
+ swissnet.ai.mit.edu:/pub/scm/slib3a1.zip
Also available as RPM:
- http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d4-1.noarch.rpm
- swissnet.ai.mit.edu:/pub/scm/slib-2d4-1.noarch.rpm
+ http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a1-1.noarch.rpm
+ swissnet.ai.mit.edu:/pub/scm/slib-3a1-1.noarch.rpm
JACAL is a symbolic math system written in Scheme:
- http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b2.zip
- swissnet.ai.mit.edu:/pub/scm/jacal1b2.zip
-
-HOBBIT is a compiler for SCM code:
- http://swissnet.ai.mit.edu/ftpdir/scm/hobbit5x.tar.gz
- swissnet.ai.mit.edu:/pub/scm/hobbit5x.tar.gz
+ http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b4.zip
+ swissnet.ai.mit.edu:/pub/scm/jacal1b4.zip
SLIB-PSD is a portable debugger for Scheme (requires emacs editor):
http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz
@@ -90,13 +149,13 @@ SCM (similar to XSCM).
WB is a disk based, sorted associative array (B-tree) library for SCM.
Using WB, large databases can be created and managed from SCM.
- http://swissnet.ai.mit.edu/ftpdir/scm/wb1a7.zip
- swissnet.ai.mit.edu:/pub/scm/wb1a7.zip
- http://swissnet.ai.mit.edu/ftpdir/scm/wb-1a7-1.src.rpm
- swissnet.ai.mit.edu:/pub/scm/wb-1a7-1.src.rpm
+ http://swissnet.ai.mit.edu/ftpdir/scm/wb1b1.zip
+ swissnet.ai.mit.edu:/pub/scm/wb1b1.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/wb-1b1-1.src.rpm
+ swissnet.ai.mit.edu:/pub/scm/wb-1b1-1.src.rpm
Also available as i386 binary RPM:
- http://swissnet.ai.mit.edu/ftpdir/scm/wb-1a7-1.i386.rpm
- swissnet.ai.mit.edu:/pub/scm/wb-1a7-1.i386.rpm
+ http://swissnet.ai.mit.edu/ftpdir/scm/wb-1b1-1.i386.rpm
+ swissnet.ai.mit.edu:/pub/scm/wb-1b1-1.i386.rpm
SIMSYNCH is a digital logic simulation system written in SCM.
http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip
@@ -109,7 +168,7 @@ systems.
ftp.gnu.org:pub/gnu/dld/dld-3.3.tar.gz
SCM.EXE (282k) is a SCM executable for DOS and MS-Windows.
-Note: SCM.EXE still requires slib2d4 and scm5d6 above.
+Note: SCM.EXE still requires slib3a1 and scm5d9 above.
http://swissnet.ai.mit.edu/ftpdir/scm/scm.exe
swissnet.ai.mit.edu:/pub/scm/scm.exe
diff --git a/ChangeLog b/ChangeLog
index 6b10d92..0e564f2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,553 @@
+2003-11-30 Aubrey Jaffer <jaffer@scm.jaffer>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5d8 to 5d9.
+
+2003-11-13 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (Embedding SCM): Updated libtest example for
+ init_user_scm indirection (which Radey added 2003-01-24).
+
+2003-11-08 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (MS-DOS Compatible Scripts): Added sharpbang URL.
+
+2003-11-05 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * ramap.c (array-map): Added.
+
+2003-10-30 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * r4rstest.scm (inexact->exact): Added tests.
+ (exact->inexact): check for both exact and inexact argument.
+
+2003-10-25 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build.scm (build): processor-family now symbol; i8086 <- 8086.
+
+ * mkimpcat.scm: Added rwb-isam feature.
+
+2003-10-23 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (dfiles): Added version.txi platform.txi features.txi.
+
+2003-10-18 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build.scm (manifest): Added "byte.c".
+
+ * byte.c: Added. Improves RANDOM speed by 32%.
+
+2003-10-15 <agj@alum.mit.edu>
+
+ * scm.texi (Build Options): Described *.opt option files.
+
+ * Makefile (CFLAGS): Removed "-g".
+
+ * bench.scm (benchmark-prng): Limit to 1000 samples if no bignums.
+
+ * Makefile (pg.opt, gdb.opt, dlls.opt): Added. Cleanup options.
+
+2003-10-08 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build.scm (compile-c-files): Removed "-O" and "-Wall" options;
+ use --compiler-options= instead.
+
+ * subr.c (scm_logbitp, scm_ash): Prevent wraparound (1>>32==1).
+
+2003-09-25 Sam Hocevar
+
+ * r4rstest.scm (test-inexact): SECTION 6.2 checks that
+ (not (eqv? 1 1.0)).
+
+2003-09-23 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * bench.scm (prng): Calls to random:random --> random.
+
+2003-09-22 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scmfig.h (CDR_DOUBLES, SHORT_INT): Added __ia64 #defines.
+
+ * scm.texi (Automatic C Preprocessor Definitions): Added IA64.
+
+2003-09-21 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * ioext.c, posix.c (system->line): Defined.
+
+2003-09-10 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (continue.o): Was missing scmfig.h and scm.h
+ dependencies.
+
+2003-08-26 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build.scm: Use open-table! and open-table.
+
+ * build (print-manifest, make-features-txi): Use open-table.
+
+2003-08-23 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * r4rstest.scm (6 5 5): Added some kawa chokers: #i, #e.
+ Added more kawa STRING->NUMBER bait.
+
+2003-08-17 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (Line Numbers): Added read-for-load.
+ (Load Syntax): Distinguished from Read syntax; documented #?line,
+ #?column, and #?file.
+ (Data Type Representations): Updated port formats.
+
+ * Init5d8.scm (slib:eval-load): Use *load-reader*.
+
+ * repl.c (scm_read_for_load): Added.
+ (p_read_numbered, p_read_for_load, p_read): Added locatives.
+ (lreadr): Pass appropriate read routine to load:sharp; read:sharp.
+ (flgs): Renamed from nump to reduce interference with INUMP, etc.
+
+2003-08-16 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Init5d8.scm (load:sharp, read:sharp): Split read:sharp.
+ (load:sharp, read:sharp, char:sharp, read:array): Added READ arg.
+ (char:sharp): Renamed from read:sharp-char.
+ (read:sharp): Integrated #; into.
+
+ * repl.c (scm_read): Renamed from lread().
+ (loc_charsharp): Renamed from loc_readsharpc.
+ (loc_loadsharp): Added to separate LOAD-macros from READ-macros.
+ (f_read_numbered): Removed unused variable.
+ (repl, tryload, scm_load_string): Use scm_read_numbered().
+ (lreadpr): Dispatch to loc_readsharp or loc_loadsharp depending on
+ nump.
+
+2003-08-15 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scl.c (floequal): Fixed so 0/0==0/0.
+ (eqv, eqp): Use floequal.
+
+2003-08-14 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * eval.c (init_eval): add_feature("primitive-hygiene").
+
+ * mkimpcat.scm (primitive-hygiene): Use feature to conditionalize
+ macro association.
+
+2003-08-13 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scl.c (eqp): Fixed so (let ((nan 0/0)) (= nan nan)) ==> #t.
+ (in2ex): Infinite loop on (inexact->exact 0/0) change to err.
+
+2003-07-22 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (uninstallinfo): Created.
+ (uninstall): Remove libscmdir files.
+
+2003-07-22 Andy Gaynor <silver@silver.reedkin.org>
+
+ * Makefile (Xlibscm.info, hobbit.info): Fixed / separators.
+
+ * unif.c (make_sh_array): Bracket with ifndef RECKLESS.
+
+2003-07-16 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (release): Make pdf(s).
+
+2003-07-11 Radey Shouman <shouman@comcast.net>
+
+ * eval.c (m_case): Check on clauses for CASE was
+ confused by line-number annotations.
+
+2003-07-10 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * hobbit.texi (SLIB Logical Procedures): Removed "logical:"
+ aliases.
+
+ * compile.scm, hobbit.scm: Added REQUIRE-IFs.
+
+ * build, build.scm: Moved requires to top.
+
+2003-07-02 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Init5d8.scm (make-array): Alias of create-array.
+ (read:sharp): Feature evaluation now slib:provided?
+
+2003-06-29 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * r4rstest.scm (test-string->number): Implementations which don't
+ allow division by 0 can have fragile string->number.
+
+2003-06-24 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scl.c (iflo2str): Use negated conditional to handle 0/0.
+ (NaN2str): Removed "#i" prefix.
+
+2003-06-22 Aubrey Jaffer <jaffer@aubrey.jaffer>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5d7 to 5d8.
+
+ * hobbit.texi (Macro-Expansion and Analysis): Put @code{} around
+ some confusing words (or or and).
+
+2003-06-20 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (Array Mapping): Moved after uniform arrays.
+
+ * Init5d7.scm (make-array): Removed legacy procedure.
+
+ * x.c (x_free_color_cells, x_screen_size): Corrected prot numbers.
+
+ * eval.c (scm_profile): Corrected prot numbers.
+
+ * record.c (MAKE_REC_INDS): Corrected prot number.
+
+ * ramap.c (ramapc, array_imap): Corrected prot codes.
+ (array-fill!) Removed.
+
+ * unif.c (uniform-vector-fill!): Removed.
+
+2003-06-18 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Macro.scm (@pprint, @print): display --> write.
+
+2003-06-17 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scl.c (istr2flo): 1/0, -1/0, 0/0 are inexact infinities.
+ (idbl2str): Infinities represented by #i+1/0, #i-1/0, #i0/0.
+
+ * x11.scm: Lots of symbol ID-codes changed in XFree86-4.2.0.
+
+ * keysymdef.scm: Lots of new symbols in XFree86-4.2.0.
+
+2003-04-04 Radey Shouman <radey@attbi.com>
+
+ * sys.c (prinport): print column and line numbers if available.
+
+2003-03-12 Radey Shouman <radey@attbi.com>
+
+ * Init5d7.scm (read:sharp-char): Add #\x<hex-number>
+ #\o<octal-number>, #\d<decimal-number> character read syntax.
+
+ * repl.c (lreadr): Remove #\<octal-number> syntax,
+ moved to read:sharp-char.
+
+2003-03-12 Radey Shouman <shouman@attbi.com>
+
+ * rope.c (init_rope): Replace static initializer for scm_protidx
+ with initialization in init_rope so that RESTART works.
+
+ * sys.c (init_storage):
+ * eval.c (init_eval): Replace static initializers so that
+ RESTART works.
+
+2003-03-11 Radey Shouman <shouman@attbi.com>
+
+ * sys.c (close_port): Return value from port close function so
+ we can get the exit status of pipes at close time.
+ (free_storage): Re-initialize some values for RESTART.
+
+2003-03-06 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * eval.c (for_each): Fixed arity_check message.
+
+2003-02-22 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build.scm (compile-dll-c-files, make-dll-archive, make-archive):
+ Added for gnu-win32.
+
+2003-02-21 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build.scm (make-archive, make-dll-archive, compile-dll-c-files):
+ Added for microsoft-c-nt.
+
+2003-01-29 Radey Shouman <shouman@attbi.com>
+
+ * repl.c (final_repl): Make sure to reinitialize closure print
+ information strings when restarting -- this caused segfaults under
+ windows.
+
+2003-01-27 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * eval.c, sys.c (s_redefining): Definition moved to "sys.c" from
+ "eval.c".
+
+2003-01-24 Radey Shouman <shouman@attbi.com>
+
+ * dynl.c (prinshl, scm_dyn_link, scm_dyn_unlink, scm_dyn_call,
+ scm_dyn_main_call, init_dynl):
+ * scm.c (scm_init_extensions):
+ * scm.h (SCM_EXPORT):
+ * scmmain.c (main):
+
+ Changes to allow dynamic linking under MS win32.c
+
+2003-01-11 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * eval.c (ceval_1): Added workaround for GCC-2.3.1 on SPARC bug
+ reported by Steve VanDevender.
+
+2003-01-07 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * bench.scm (benchmark-prng): Increased time threshold.
+
+ * eval.c (ceval_1): arg1 now #defined to (struct) t.arg_1.
+ Consistently nets 3% on pi benchmark.
+
+ * bench.scm (benchmark-pi): Moved threshold; 450.MHz Pentium II
+ was on edge.
+
+2003-01-05 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * eval.c (ceval_1): "SCM arg1" replaces unused "union {} t".
+
+2003-01-02 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * hobbit.texi (Index): Added.
+ (Compiling And Linking): Documented option-files.
+
+ * compile.scm (compile-file, compile->executable): Use
+ option-files named for the first argument with ".opt" appended.
+
+ * build.scm (options-file): Made nary parameter.
+ (build:build): Report option-files used.
+
+ * build (build-from-argv): Don't splice out "-f <options-file>".
+
+2003-01-02 Steve VanDevender <stevev@hexadecimal.uoregon.edu>
+
+ * build.scm (compile-c-files, compile-dll-c-files)
+ (make-dll-archive): Added for OSF1 (was ALPHA).
+
+ * socket.c (inet:make-address): Removed duplicate definition.
+
+2002-12-30 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.h: Removed unused prototypes.
+
+ * scl.c (difference, divide):
+ * sys.c (init_storage, egc_copy_stack):
+ * unif.c (dims2ura, bit_position):
+ * repl.c (everr): Added {} to squelch gcc -Wall.
+
+ * ramap.c (sc2array): Moved prototype from "scm.h".
+
+2002-12-29 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Init5d7.scm (logical:ones): Return 0 for 0 argument.
+ (gray-code->integer): Improved running time from O(b^2) to
+ O(b*log(b)).
+
+2002-12-19 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (SCM Options): Clarified descriptions of -, --, and -s.
+
+2002-12-19 Radey Shouman <shouman@attbi.com>
+
+ * Init5d7.scm (error): Terminate in breakpointing error function
+ even if REQUIRE fails (and calls ERROR).
+
+2002-12-18 Radey Shouman <shouman@attbi.com>
+
+ * ioext.c (l_opendir, l_readdir, l_closedir, l_rewinddir):
+ Added for win32 (tested on XP).
+
+2002-12-11 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile (scmlit): #define CAUTIOUS.
+
+ * sys.c (make_subr): Reuse repeated names.
+
+ * eval.c (checked_define): Share warning strings.
+
+ * time.c (your_time): Shortened long warning message.
+
+ * rope.c (scm_gc_protect): Check if argument is already protected.
+
+ * scm.texi (Changing Scm): Added scm_protect_temp() and
+ scm_gc_protect().
+ (Type Conversions): Added num2short(), num2dbl(), and
+ scm_base_addr().
+
+2002-12-09 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build.scm (array-for-each, record, generalized-c-arguments)
+ (curses, regex, socket, posix, unix): Changed to compiled-inits.
+
+ * Makefile (udscm4.opt, udscm5.opt, libscm.opt): Added.
+ (udscm4, udscm5, libscm.a): Take feature options from .opt file.
+ The *.opt files are never overwritten.
+
+ * posix.c (scm_getlogin): Removed.
+
+ * scm.texi (SCM Session): getlogin moved from Posix Extensions.
+
+ * Init5d7.scm (getlogin): Posix getlogin is useless; always define
+ getlogin using getenv.
+
+2002-12-08 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * build (build-from-argv): Fluid-let getopt-- to splice in options
+ from -f <filename>.
+
+ * build.scm (build): Added -f <filename> option.
+
+ * Makefile (bench): Run both pi and prng benchmarks.
+
+ * bench.scm (time-call): Abstracted timing procedure.
+ (benchmark-prng): Added.
+
+2002-12-02 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Init5d7.scm:
+ * build (build-from-argv): Global variable *argv* replaces argc,
+ argv arguments.
+ (build-from-whole-argv, bi): Straightened.
+
+2002-11-26 Aubrey Jaffer <jaffer@aubrey.jaffer>
+
+ * patchlvl.h (SCMVERSION): Bumped from 5d6 to 5d7.
+
+2002-11-26 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Init5d6.scm (error, warn): Simplified.
+
+2002-11-25 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.c (init_buf0): ifndef scoping didn't match "{}"s.
+
+ * x.c, unix.c, unif.c, sys.c, subr.c, socket.c, scm.texi, scm.h,
+ scm.c, scl.c, sc2.c, rope.c, rgx.c, repl.c, record.c, ramap.c,
+ posix.c, ioext.c, gsubr.c, eval.c, edline.c, dynl.c, debug.c,
+ crs.c (ASRTER): Renamed from ASSERT; conflict with "windows.h".
+
+ * scm.texi (Compiling and Linking Custom Files): ./build.
+
+2002-11-25 dai <inukai.d@jeans.ocn.ne.jp>
+
+ * build.scm (compile-c-files freebsd, compile-dll-c-files
+ freebsd): Fixed for FreeBSD.
+
+ * build: Added -no-init-file to first line.
+
+2002-11-20 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Init5d6.scm (browse-url): Added.
+
+2002-11-17 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (I/O-Extensions): directory feature renamed from
+ directory-for-each.
+
+ * ioext.c (current-directory, make-directory): Added.
+
+2002-11-15 Radey Shouman <shouman@attbi.com>
+
+ * sys.c (scm_dynthrow): Fix bug in throwing to continuation
+ when environment stack segment needed to grow.
+ (scm_estk_shrink): Make sure the entire chain of non-writable
+ environment stack segments is appropriately marked.
+ Thanks to <david@anvil.com> for calling attention to the problem.
+
+2002-11-11 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Init5d6.scm (logical:rotate): Added.
+
+2002-10-30 Radey Shouman <shouman@attbi.com>
+
+ * eval.c (m_body): Fixed error reporting -- was segfaulting.
+
+2002-10-24 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * unif.c (make_sh_array): scm_arity_check(mapfunc).
+
+2002-08-20 Radey Shouman <shouman@attbi.com>
+
+ * eval.c (m_do): Splicing BEGIN in the test of a DO removed because
+ it is buggy. Thanks for bug report from Daniel Skarda <0rfelyus@ucw.cz>.
+
+2002-07-14 Rainer Urian <rainer.urian@symbolictool.de>
+
+ * sys.c: include <io.h> ifdef POCKETCONSOLE.
+
+ * scmmain.c (scm_find_implpath): Don't scm_try_path ifdef
+ POCKETCONSOLE.
+
+ * scmfig.h (NOSETBUF): Set ifdef POCKETCONSOLE.
+
+ * scm.texi (Automatic C Preprocessor Definitions): Added
+ _WIN32_WCE, _M_ARM, _M_ARMT.
+
+ * scm.h (CODE):
+ * eval.c (I_SYM, I_VAL):
+ * repl.c (iprin1): Workaround Microsoft CLARM compiler bug.
+
+2002-06-07 Rainer Urian <rainer.urian@symbolictool.de>
+
+ * scm.c (scmable_signal):
+ * repl.c (wait_for_input):
+ * scmmain.c (main):
+ * scmfig.h:
+ Fixed console break handling for win32 systems, tested using
+ Microsoft visual C and the MinGW gcc port.
+
+2002-06-02 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (Syntax): Added example of SLIB/repl use.
+ (The Language): Reorganization of most sections.
+
+ * hobbit.texi: Fixed stale email address.
+
+2002-06-01 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (Unix Scheme Scripts, Unix Shell Scripts): Updated
+ script mechanics.
+ (Files and Ports): Moved port-filename, port-line, and port-column
+ from "Miscellaneous Procedures".
+
+2002-05-26 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * inc2scm (inc2scm): Replaces go-script; takes args.
+
+ * xgen.scm (xgen.scm): Replaces go-script; takes args.
+
+ * compile.scm (compile.scm): Replaces go-script; takes args.
+
+2002-05-25 David S. <davids@idiom.com>
+
+ * scmmain.c, scm.c, time.c, repl.c, ioext.c, sys.c, crs.c,
+ posix.c, socket.c, unix.c, findexec.c: __NetBSD__ support.
+
+ * scm.texi (Automatic C Preprocessor Definitions): Add __NetBSD__
+
+2002-05-21 Radey Shouman <shouman@attbi.com>
+
+ * unif.c (shap2ra): Check that upper bound is >= lower bound.
+
+2002-05-18 Radey Shouman <shouman@attbi.com>
+
+ * unif.c (dim2ura): Fix unsigned vs signed comparison problem that
+ caused negative sizes to be passed to make_uve.
+
+2002-04-26 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (SLIB): Load of "require" unneeded.
+
+ * requires.scm (library-vicinity): Removed call of LOAD.
+
+ * Init5d6.scm (set-vicinities!): Fluid-let of LOAD unneeded.
+ (program-vicinity, pathname->vicinity): Removed to slib.
+
+2002-04-24 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * scm.texi (Unix Extensions, Posix Extensions): Added @cindexs.
+
+ * scl.c (dbl_mant_dig): Always use variable dbl_mant_dig when
+ ifdef FLOATS.
+
+2002-04-23 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * script.c (dld_find_executable): Eliminated unused #defines.
+
+2002-04-18 Aubrey Jaffer <agj@alum.mit.edu>
+
+ * Makefile, scm.spec (install): Added patchlvl.h.
+
2002-04-14 Aubrey Jaffer <jaffer@aubrey.jaffer>
* patchlvl.h (SCMVERSION): Bumped from 5d5 to 5d6.
@@ -6981,4 +7531,3 @@ Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid)
* scm.c (err_head, wta): added fflush calls to error routines so
that error message come out in proper order.
-
diff --git a/Init5d6.scm b/Init5d9.scm
index a847689..a95fada 100644
--- a/Init5d6.scm
+++ b/Init5d9.scm
@@ -42,37 +42,9 @@
;;; Author: Aubrey Jaffer.
(define (scheme-implementation-type) 'SCM)
-(define (scheme-implementation-version) "5d6")
+(define (scheme-implementation-version) "5d9")
(define (scheme-implementation-home-page)
- "http://swissnet.ai.mit.edu/~jaffer/SCM.html")
-
-(define vicinity:suffix?
- (let ((suffi
- (case (software-type)
- ((AMIGA) '(#\: #\/))
- ((MACOS THINKC) '(#\:))
- ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/))
- ((NOSVE) '(#\: #\.))
- ((UNIX COHERENT PLAN9) '(#\/))
- ((VMS) '(#\: #\])))))
- (lambda (chr) (memv chr suffi))))
-
-(define (pathname->vicinity pathname)
- ;;Go up one level if PATHNAME ends in a vicinity suffix.
- (let loop ((i (- (string-length pathname) 2)))
- (cond ((negative? i) "")
- ((vicinity:suffix? (string-ref pathname i))
- (substring pathname 0 (+ i 1)))
- (else (loop (- i 1))))))
-
-;;; This definition of PROGRAM-VICINITY is equivalent to the one defined
-;;; SLIB/require.scm. It is used here to bootstrap
-;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY.
-
-(define (program-vicinity)
- (if *load-pathname*
- (pathname->vicinity *load-pathname*)
- (error "not loading but called" 'program-vicinity)))
+ "http://swissnet.ai.mit.edu/~jaffer/SCM")
(define in-vicinity string-append)
@@ -116,7 +88,7 @@
(- (char->integer (read-char port)) chr0))))
(else arg)))))
-(define (read:array rank port)
+(define (read:array rank port read)
(define (bomb pc wid)
(error (string-append "array syntax? #"
(number->string rank)
@@ -165,36 +137,11 @@
(else #f))
(read port)))
-(define (read:sharp c port)
- (define (barf c) (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))))))
+;;; read-macros valid only in LOAD.
+(define (load:sharp c port read)
(case c
((#\') (read port))
((#\.) (eval (read port)))
- ((#\+) (if (feature? (read port))
- (read port)
- (begin (read port) (if #f #f))))
- ((#\-) (if (not (feature? (read port)))
- (read port)
- (begin (read port) (if #f #f))))
- ((#\a #\A) (read:array 1 port))
- ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
- (let* ((num (read:try-number port c))
- (c (peek-char port)))
- (cond ((memv c '(#\a #\A)) (read-char port) (read:array num port))
- (else (error "syntax? #" num c)))))
((#\!) (let skip ((metarg? #f))
(let ((c (read-char port)))
(case c
@@ -205,21 +152,54 @@
(if #f #f))
(else (skip metarg?))))
(else (if (char? c) (skip metarg?) c))))))
+ ;; Make #; convert the rest of the line to a (comment ...) form.
+ ;; "build.scm" uses this.
+ ((#\;) (let skip-semi ()
+ (cond ((eqv? #\; (peek-char port))
+ (read-char port)
+ (skip-semi))
+ (else (require 'line-i/o)
+ `(comment ,(read-line port))))))
((#\?) (case (read port)
((line) (port-line port))
((column) (port-column port))
((file) (port-filename port))
(else #f)))
- (else (barf c))))
+ (else (read:sharp c port read))))
+
+;;; read-macros valid for LOAD and READ.
+(define (read:sharp c port read)
+ (case c
+ ;; Used in "implcat" and "slibcat"
+ ((#\+) (if (slib:provided? (read port))
+ (read port)
+ (begin (read port) (if #f #f))))
+ ;; Used in "implcat" and "slibcat"
+ ((#\-) (if (slib:provided? (read port))
+ (begin (read port) (if #f #f))
+ (read port)))
+ ((#\a #\A) (read:array 1 port read))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (let* ((num (read:try-number port c))
+ (c (peek-char port)))
+ (cond ((memv c '(#\a #\A)) (read-char port) (read:array num port read))
+ (else (error "syntax? #" num c)))))
+ (else (error "unknown # object" c))))
;;; We can assume TOK has at least 2 characters.
-(define read:sharp-char
- (letrec ((process
+(define char:sharp
+ (letrec ((numeric-1
+ (lambda (tok radix)
+ (numeric (substring tok 1 (string-length tok)) radix)))
+ (numeric
+ (lambda (tok radix)
+ (cond ((string->number tok radix) => integer->char))))
+ (compose
(lambda (modifier tok)
(and (char=? #\- (string-ref tok 1))
(if (= 3 (string-length tok))
(modifier (string-ref tok 2))
- (let ((c (read:sharp-char
+ (let ((c (char:sharp
(substring tok 2 (string-length tok)))))
(and c (modifier c)))))))
(control
@@ -234,9 +214,13 @@
(integer->char (logior 128 (char->integer c)))))))
(lambda (tok)
(case (string-ref tok 0)
- ((#\C #\c) (process control tok))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) (numeric tok 8))
+ ((#\O #\o) (numeric-1 tok 8))
+ ((#\D #\d) (numeric-1 tok 10))
+ ((#\X #\x) (numeric-1 tok 16))
+ ((#\C #\c) (compose control tok))
((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1))))
- ((#\M #\m) (process meta tok))))))
+ ((#\M #\m) (compose meta tok))))))
;;;; Function used to accumulate comments before a definition.
(define comment
@@ -249,29 +233,13 @@
(string-append (or comment "") "\n"))
(reverse *accumulated-comments*)))))
(set! *accumulated-comments* '())
- (if (equal? "" ans)
+ (if (equal? "" ans)
"no-comment" ;#f
(substring ans 0 (+ -1 (string-length ans))))))
(else (set! *accumulated-comments*
(append (reverse args) *accumulated-comments*)))))))
-;;; Make #; convert the rest of the line to a (comment ...) form.
-;;; "build.scm" uses this.
-;;; requires line-i/o
-(define read:sharp
- (let ((rdsharp read:sharp))
- (lambda (c port)
- (if (eqv? c #\;)
- (let skip-semi ()
- (cond ((eqv? #\; (peek-char port))
- (read-char port)
- (skip-semi))
- (else `(comment ,(read-line port)))))
- (rdsharp c port)))))
-
-
-(define type 'type) ;for /bin/sh hack.
-(define : ':)
+(define : ':) ;for /bin/sh hack.
(define !#(if #f #f)) ;for scsh hack.
;;;; Here are some Revised^2 Scheme functions:
@@ -343,7 +311,7 @@
(define (try-create-file str modes . perms)
(if (symbol? modes) (set! modes (symbol->string modes)))
(let ((idx (string-index modes #\x)))
- (cond ((require:feature->path 'i/o-extensions)
+ (cond ((slib:in-catalog? 'i/o-extensions)
(require 'i/o-extensions)
(apply try-create-file str modes perms))
((not idx)
@@ -438,31 +406,37 @@
(if (not status) (escape #f))))))))))))
(apply proc stdout stderr (or status '())))
+(define browse-url
+ (case (software-type)
+ ((UNIX COHERENT PLAN9)
+ (lambda (url)
+ (define (try cmd end) (zero? (system (string-append cmd url end))))
+ (or (try "netscape-remote -remote 'openURL(" ")'")
+ (try "netscape -remote 'openURL(" ")'")
+ (try "netscape '" "'&")
+ (try "netscape '" "'"))))
+ (else
+ (lambda (url)
+ (slib:warn 'define (software-type) 'case 'of 'browse-url 'in
+ *load-pathname*)))))
+
(define (warn . args)
(define cep (current-error-port))
- (if (defined? print-call-stack)
- (print-call-stack cep))
+ (if (defined? print-call-stack) (print-call-stack cep))
(perror "WARN")
(errno 0)
- (display "WARN: " cep)
- (if (not (null? args))
- (begin (display (car args) cep)
- (for-each (lambda (x) (display #\ cep) (write x cep))
- (cdr args))))
+ (display "WARN:" cep)
+ (for-each (lambda (x) (display #\ cep) (write x cep)) args)
(newline cep)
(force-output cep))
(define (error . args)
(define cep (current-error-port))
- (if (defined? print-call-stack)
- (print-call-stack cep))
+ (if (defined? print-call-stack) (print-call-stack cep))
(perror "ERROR")
(errno 0)
- (display "ERROR: " cep)
- (if (not (null? args))
- (begin (display (car args) cep)
- (for-each (lambda (x) (display #\ cep) (write x cep))
- (cdr args))))
+ (display "ERROR:" cep)
+ (for-each (lambda (x) (display #\ cep) (write x cep)) args)
(newline cep)
(force-output cep)
(abort))
@@ -642,36 +616,28 @@
((or (negative? cnt) (not ans)) ans)))
(else (tryline))))))))))))
-(if (not (defined? getlogin))
-(define (getlogin) (or (getenv "USER") (getenv "LOGNAME"))))
+(define (getlogin) (or (getenv "USER") (getenv "LOGNAME")))
;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use
;;; (implementation-vicinity) as (library-vicinity). "require.scm",
;;; the first file loaded from (library-vicinity), can redirect it.
(define (set-vicinities! init-file)
(set! implementation-vicinity
- (let ((vic (pathname->vicinity init-file)))
+ (let ((vic (substring
+ init-file
+ 0
+ (- (string-length init-file)
+ (string-length "Init.scm")
+ (string-length (scheme-implementation-version))))))
(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 ()
- (let ((filename (in-vicinity (implementation-vicinity)
- "require.scm")))
- (or (try-load filename)
- (try-load (in-vicinity (implementation-vicinity)
- "requires.scm"))
- (error "Can't load" filename))))
- (lambda () (set! load oload)))
- (if (eq? olv library-vicinity)
- (error "Can't find library-vicinity"))
- (library-vicinity))))))
+ (let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
+ (if library-path
+ (set! library-vicinity (lambda () library-path))
+ (let ((filename (in-vicinity (implementation-vicinity) "require.scm")))
+ (or (try-load filename)
+ (try-load (in-vicinity (implementation-vicinity) "requires.scm"))
+ (error "Can't load" filename))
+ (if (not library-vicinity) (error "Can't find library-vicinity")))))
(set! home-vicinity
(let ((home (getenv "HOME")))
(and (not home) login->home-directory
@@ -690,7 +656,7 @@
;;;; Initialize SLIB
(load (in-vicinity (library-vicinity) "require"))
-;;; This turns off line-numbering off for SLIB loads.
+;;; This enables line-numbering for SLIB loads.
(define *slib-load-reader* (and (defined? read-numbered) read-numbered))
;;; DO NOT MOVE! SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after
@@ -698,9 +664,11 @@
(define (slib:load-source file . libs)
(fluid-let ((*load-reader* *slib-load-reader*))
(apply scm:load file libs)))
-(define (slib:load file . libs)
- (fluid-let ((*load-reader* *slib-load-reader*))
- (apply scm:load file libs)))
+(define slib:load slib:load-source)
+
+;;; Legacy grease
+(if (not (defined? slib:in-catalog?))
+ (define slib:in-catalog? require:feature->path))
;;; Dynamic link-loading
(cond ((or (defined? dyn:link)
@@ -710,7 +678,7 @@
(cond ((defined? link:link)
(define (slib:load-compiled . args)
(cond ((symbol? (car args))
- (require:require (car args))
+ (require (car args))
(apply slib:load-compiled (cdr args)))
((apply link:link args))
(else (error "Couldn't link files " args))))
@@ -766,6 +734,15 @@
;;;; Bit order and lamination
+(define (logical:ones deg)
+ (if (zero? deg) 0 (+ (* 2 (+ -1 (integer-expt 2 (- deg 1)))) 1)))
+
+(define (rotate k count len)
+ (set! count (modulo count len))
+ (logior (logand (ash k count) (logical:ones len))
+ (ash k (- count len))))
+(define logical:rotate rotate)
+
(define (bit-reverse k n)
(do ((m (if (negative? n) (lognot n) n) (ash m -1))
(k (+ -1 k) (+ -1 k))
@@ -814,15 +791,18 @@
(define (gray-code->integer k)
(if (negative? k)
(error 'gray-code->integer 'negative? k)
- (do ((ktmp k (ash ktmp -1))
- (ans 0 (logxor ans ktmp)))
- ((zero? ktmp) ans))))
+ (let ((kln (integer-length k)))
+ (do ((d 1 (* d 2))
+ (ans (logxor k (ash k -1)) ; == (integer->gray-code k)
+ (logxor ans (ash ans (* d -2)))))
+ ((>= (* 2 d) kln) ans)))))
(define (grayter k1 k2)
(define kl1 (integer-length k1))
(define kl2 (integer-length k2))
- (cond ((eqv? kl1 kl2) (> (gray-code->integer k1) (gray-code->integer k2)))
- (else (> kl1 kl2))))
+ (if (eqv? kl1 kl2)
+ (> (gray-code->integer k1) (gray-code->integer k2))
+ (> kl1 kl2)))
(define (gray-code<? k1 k2)
(not (or (eqv? k1 k2) (grayter k1 k2))))
@@ -948,7 +928,7 @@
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <filename>)
- (do ((o (read port) (read port)))
+ (do ((o (*load-reader* port) (*load-reader* port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
@@ -1041,24 +1021,32 @@
(cond
((defined? stack-trace)
- ;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
-(define (error . args)
- (define cep (current-error-port))
- (if (defined? print-call-stack)
- (print-call-stack cep))
- (perror "ERROR")
- (errno 0)
- (display "ERROR: " cep)
- (if (not (null? args))
- (begin (display (car args) cep)
- (for-each (lambda (x) (display #\ cep) (write x cep))
- (cdr args))))
- (newline cep)
- (cond ((stack-trace) (newline cep)))
- (display " * Breakpoint established: (continue <val>) to return." cep)
- (newline cep) (force-output cep)
- (require 'debug) (apply breakpoint args))
-
+;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
+(define error
+ (letrec ((oerror error)
+ (nerror
+ (lambda args
+ (dynamic-wind
+ (lambda () (set! error oerror))
+ (lambda ()
+ (define cep (current-error-port))
+ (if (defined? print-call-stack)
+ (print-call-stack cep))
+ (perror "ERROR")
+ (errno 0)
+ (display "ERROR: " cep)
+ (if (not (null? args))
+ (begin (display (car args) cep)
+ (for-each (lambda (x) (display #\ cep) (write x cep))
+ (cdr args))))
+ (newline cep)
+ (cond ((stack-trace) (newline cep)))
+ (display " * Breakpoint established: (continue <val>) to return." cep)
+ (newline cep) (force-output cep)
+ (require 'debug) (apply breakpoint args))
+ (lambda () (set! error nerror))))))
+ nerror))
+
(define (user-interrupt . args)
(define cep (current-error-port))
(newline cep)
@@ -1093,8 +1081,7 @@
(dimensions->uniform-array args (array-prototype prot)
(apply array-ref prot
(map car (array-shape prot))))))
-(define (make-array initial-value . dimensions)
- (apply create-array (vector initial-value) dimensions))
+(define make-array create-array)
(define (make-uniform-wrapper prot)
(if (string? prot) (set! prot (string->number prot)))
(if prot
@@ -1193,7 +1180,7 @@
;;; (else
;;; (define *optind* 1)
;;; (define getopt:opt #f)
-;;; (define (getopt argc argv optstring) #f))
+;;; (define (getopt optstring) #f))
(let* ((simple-opts "muvqibs")
(arg-opts '("a kbytes" "-version" "-help"
@@ -1205,7 +1192,6 @@
(map (lambda (o)
(string-append (string (string-ref o 0)) ":"))
arg-opts)))
- (argc (length *argv*))
(didsomething #f)
(moreopts #t)
(exe-name (symbol->string (scheme-implementation-type)))
@@ -1284,7 +1270,7 @@
;; --version => print and exit
;; -- => last option
- (let loop ((option (getopt-- argc *argv* opts)))
+ (let loop ((option (getopt-- opts)))
(case option
((#\a)
(cond ((> *optind* 3)
@@ -1374,7 +1360,7 @@ There is no warranty, to the extent permitted by law.
(usage "scm: unknown option `--" option "'" #f))))
(cond ((and moreopts (< *optind* (length *argv*)))
- (loop (getopt-- argc *argv* opts)))
+ (loop (getopt-- opts)))
((< *optind* (length *argv*)) ;No more opts
(set! *argv* (list-tail *argv* *optind*))
(set! *optind* 1)
@@ -1403,7 +1389,6 @@ There is no warranty, to the extent permitted by law.
(oquit))))
;;otherwise, fall into natural SCM repl.
)
- (else
- (begin (errno 0)
- (set! *interactive* #t)
- (for-each load (cdr (program-arguments)))))))
+ (else (errno 0)
+ (set! *interactive* #t)
+ (for-each load (cdr (program-arguments))))))
diff --git a/Link.scm b/Link.scm
index 0bed48e..8e01de9 100644
--- a/Link.scm
+++ b/Link.scm
@@ -47,6 +47,7 @@
(cond ((provided? 'shl) ".sl")
((provided? 'sun-dl) ".so")
((provided? 'mac-dl) ".shlb")
+ ((provided? 'win32-dl) ".dll")
(else ".o")))
(define (file->init_name name)
(string-append
diff --git a/Macro.scm b/Macro.scm
index 911098b..2d85050 100644
--- a/Macro.scm
+++ b/Macro.scm
@@ -432,10 +432,10 @@
(define-syntax @print
(syntax-rules (quote)
((_ '?arg)
- (begin (display '?arg)
+ (begin (write '?arg)
(newline)))
((_ ?arg)
- (begin (display '?arg)
+ (begin (write '?arg)
(display " => ")
(let ((x ?arg))
(write x)
@@ -452,10 +452,10 @@
(define-syntax @pprint
(syntax-rules (quote)
((_ '?arg)
- (begin (display '?arg)
+ (begin (write '?arg)
(newline)))
((_ ?arg)
- (begin (display '?arg)
+ (begin (write '?arg)
(display " => ")
(let ((x ?arg))
(pprint x)
diff --git a/Makefile b/Makefile
index 57f6594..4f2a011 100644
--- a/Makefile
+++ b/Makefile
@@ -43,9 +43,10 @@
SHELL = /bin/sh
#CC = gcc
-CFLAGS = -g
+#CFLAGS = -g
#LIBS =
-LD = $(CC) -g
+#LD = $(CC) -g
+LD = $(CC)
SCMLIT = ./scmlit
SCMEXE = ./scm
@@ -59,7 +60,7 @@ intro:
@echo
@echo "This is the scm$(VERSION) distribution. Read \"scm.info\""
@echo "to learn how to build and install SCM. Or browse"
- @echo " http://swissnet.ai.mit.edu/~jaffer/SCM.html"
+ @echo " http://swissnet.ai.mit.edu/~jaffer/SCM"
@echo
$(MAKE) scm
@@ -85,7 +86,7 @@ IMPLINIT = $(IMPLPATH)Init$(VERSION).scm
cfiles = scmmain.c scm.c time.c repl.c ioext.c scl.c sys.c eval.c \
subr.c sc2.c unif.c rgx.c crs.c dynl.c record.c posix.c socket.c\
unix.c rope.c ramap.c gsubr.c edline.c Iedline.scm continue.c \
- findexec.c script.c debug.c
+ findexec.c script.c debug.c byte.c
ofiles = scm.o time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \
continue.o findexec.o script.o debug.o
# ramap.o
@@ -102,6 +103,7 @@ all: require.scm
require.scm:
cp -p requires.scm require.scm
+# SCMLIT -- try making this first!
scmlit: $(ofiles) scmmain.o require.scm Makefile
$(LD) -o scmlit $(ofiles) scmmain.o $(LIBS)
$(MAKE) checklit
@@ -110,10 +112,9 @@ scmflags:
echo "#ifndef IMPLINIT" > newflags.h
echo "#define IMPLINIT \"$(IMPLINIT)\"" >> newflags.h
echo "#endif" >> newflags.h
- echo "/*#define CAUTIOUS*/" >> newflags.h
+ echo "#define CAUTIOUS" >> newflags.h
-if (diff newflags.h scmflags.h) then rm newflags.h; \
else mv newflags.h scmflags.h; fi
-
.c.o:
$(CC) -c $(CFLAGS) $< -o $@
scm.o: scm.c scm.h scmfig.h scmflags.h patchlvl.h
@@ -128,25 +129,33 @@ sys.o: sys.c scm.h scmfig.h scmflags.h setjump.h
time.o: time.c scm.h scmfig.h scmflags.h
subr.o: subr.c scm.h scmfig.h scmflags.h
rope.o: rope.c scm.h scmfig.h scmflags.h
-continue.o: continue.c continue.h setjump.h scmflags.h
+continue.o: continue.c continue.h setjump.h scm.h scmfig.h scmflags.h
-udscm4: $(cfiles) $(hfiles) build.scm build
- $(BUILD) -o udscm4 -s $(IMPLPATH) \
- -Fcautious bignums arrays inexact dump dynamic-linking \
- engineering-notation
- rm $(ofiles) scmmain.o
+# Simple build with bignums for running JACAL
+scm:
+ $(BUILD) -s $(IMPLPATH) -F cautious bignums arrays # i/o-extensions
+ $(MAKE) check
-udscm5: $(cfiles) $(hfiles) build.scm build Makefile
- $(BUILD) -o udscm5 -s $(IMPLPATH) \
- -Fcautious bignums arrays inexact dump dynamic-linking \
- macro engineering-notation #-DNO_SYM_GC
+# R4RS interpreter
+udscm4.opt:
+ echo "-F cautious bignums arrays inexact" >> udscm4.opt
+ echo "-F engineering-notation dump dynamic-linking" >> udscm4.opt
+udscm4: $(cfiles) $(hfiles) build.scm build udscm4.opt
+ $(BUILD) -f udscm4.opt -o udscm4 -s $(IMPLPATH)
rm $(ofiles) scmmain.o
-
myscm4: udscm4 $(ifiles) require.scm
-rm slibcat implcat
-mv scm scm~
echo "(quit)" | ./udscm4 -no-init-file -o scm
+# R5RS interpreter
+udscm5.opt: udscm4.opt
+ cat udscm4.opt >> udscm5.opt
+ echo "-F macro" >> udscm5.opt
+# echo "-DNO_SYM_GC" >> udscm5.opt
+udscm5: $(cfiles) $(hfiles) build.scm build Makefile udscm5.opt
+ $(BUILD) -f udscm5.opt -o udscm5 -s $(IMPLPATH)
+ rm $(ofiles) scmmain.o
myscm5: udscm5 $(ifiles) require.scm
-rm slibcat implcat
-mv scm scm~
@@ -154,30 +163,60 @@ myscm5: udscm5 $(ifiles) require.scm
$(MAKE) check
$(MAKE) checkmacro
-scm: scmlit
- $(BUILD) -s $(IMPLPATH) -Fcautious bignums arrays
- $(MAKE) check
+# R5RS interpreter for debugging with GDB.
+gdb.opt: udscm5.opt
+ cat udscm5.opt >> gdb.opt
+ echo "-F debug" >> gdb.opt
+ echo "--compiler-options=-Wall" >> gdb.opt
+ echo "--linker-options=-Wall" >> gdb.opt
+ echo "-D NO_ENV_CACHE" >> gdb.opt
+# echo "-DTEST_FARLOC -DTEST_SCM2PTR" >> gdb.opt
+udgdbscm: gdb.opt
+ $(BUILD) -f gdb.opt -o udgdbscm -s $(IMPLPATH)
+gdbscm: udgdbscm
+ echo "(quit)" | ./udgdbscm -no-init-file -r5 -o gdbscm
+# R4RS interpreter for profiling
+pg.opt: udscm4.opt
+ cat udscm4.opt >> pg.opt
+ echo "--compiler-options=-pg" >> pg.opt
+ echo "--linker-options=-pg" >> pg.opt
+ echo "-DLACK_SETITIMER" >> pg.opt
+udpgscm: pg.opt
+ $(BUILD) -f pg.opt -o udpgscm -s $(IMPLPATH)
+pgscm: udpgscm
+ echo "(quit)" | ./udpgscm -no-init-file -o pgscm
+
+# R4RS SCM library
+libscm.opt:
+ echo "-F cautious bignums arrays inexact" >> libscm.opt
+ echo "-F engineering-notation" >> libscm.opt
+ echo "-F dynamic-linking" >> libscm.opt
mylib: libscm.a
-libscm.a:
- $(BUILD) -Fcautious bignums arrays inexact \
- dynamic-linking -t lib
+libscm.a: libscm.opt
+ $(BUILD) -t lib -f libscm.opt
libtest: libscm.a libtest.c
- gcc -o libtest libtest.c libscm.a -ldl -lm -lc
+ $(LD) -o libtest libtest.c libscm.a -ldl -lm -lc
./libtest
-pgscm:
- $(BUILD) -s $(IMPLPATH) -Fcautious bignums arrays \
- inexact engineering-notation dump dynamic-linking -o udscm \
- --compiler-options=-pg --linker-options=-pg -DLACK_SETITIMER
- echo "(quit)" | ./udscm -no-init-file -o pgscm
-mydebug:
- $(BUILD) -oudgdbscm -s $(IMPLPATH) \
- -F cautious bignums arrays inexact engineering-notation dump \
- dynamic-linking macro debug \
- --compiler-options=-Wall --linker-options=-Wall \
- -DNO_ENV_CACHE #-DTEST_FARLOC -DTEST_SCM2PTR
- echo "(quit)" | ./udgdbscm -no-init-file -r5 -o gdbscm
+# DLLs for dynamic linking
+dlls.opt:
+ echo "--compiler-options=-Wall" >> dlls.opt
+ echo "--linker-options=-Wall" >> dlls.opt
+mydlls: dlls.opt
+ if [ -f /usr/lib/libreadline.so ]; \
+ then $(BUILD) -t dll -f dlls.opt -F edit-line; fi
+ $(BUILD) -t dll -f dlls.opt -F curses
+ $(BUILD) -t dll -f dlls.opt -c sc2.c rgx.c record.c gsubr.c \
+ ioext.c posix.c unix.c socket.c ramap.c byte.c
+
+myturtle: dlls.opt
+ $(BUILD) -t dll -f dlls.opt -F turtlegr
+
+x.so: x.c x.h xevent.h dlls.opt
+ $(BUILD) -t dll -f dlls.opt -F x
+
+# Generate x11 include and Scheme files
incdir=/usr/include/
x11.scm: inc2scm
rm -f x11.scm
@@ -190,20 +229,8 @@ xevent.h xevent.scm xatoms.scm: xgen.scm Makefile
$(SCMLIT) -l xgen.scm $(incdir)X11/Xlib.h
x.h: x.c xevent.h
if [ ! -z "$(CPROTO)" ]; then $(CPROTO) x.c > x.h; fi
-x.so: x.c x.h xevent.h
- $(BUILD) -Fx -t dll --compiler-options=-Wall
-mydlls:
- if [ -f /usr/lib/libreadline.so ]; \
- then $(BUILD) -Fedit-line -t dll; fi
- $(BUILD) -Fcurses -t dll
- $(BUILD) -t dll -c sc2.c rgx.c record.c gsubr.c \
- ioext.c posix.c unix.c socket.c ramap.c
-myturtle:
- $(BUILD) -Fturtlegr -t dll
-
-implcat: *.so mkimpcat.scm
- $(SCMLIT) -lmkimpcat.scm
+# Check SCM; SCMLIT function.
checklit:
$(SCMLIT) -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' \
-e '(or (null? errs) (quit 1))'
@@ -214,6 +241,9 @@ checkmacro: syntest1.scm syntest2.scm r4rstest.scm
$(SCMEXE) -rmacro -fsyntest1.scm -fsyntest2.scm \
-fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)' -fsyntest1 \
-e '(or (null? errs) (quit 1))'
+
+# Measuare running speed of SCM; SCMLIT. Results are appended to file
+# "BenchLog"
bench:
echo `whoami`@`hostname` testing scm \
`$(SCMEXE) -e'(display *scm-version*)'` >> BenchLog
@@ -222,10 +252,13 @@ bench:
size scm >> BenchLog
uname -a >> BenchLog
$(SCMEXE) -lbench.scm
- cat bench.log >> BenchLog
+ -cat prng.log >> BenchLog
+ echo >> BenchLog
+ -cat pi.log >> BenchLog
echo >> BenchLog
echo
tail -20 BenchLog
+ -rm -f pi.log prng.log
benchlit:
echo `whoami`@`hostname` testing scmlit \
`$(SCMLIT) -e'(display *scm-version*)'` >> BenchLog
@@ -234,14 +267,20 @@ benchlit:
size scmlit >> BenchLog
uname -a >> BenchLog
$(SCMLIT) -lbench.scm
- cat bench.log >> BenchLog
+ -cat prng.log >> BenchLog
+ echo >> BenchLog
+ -cat pi.log >> BenchLog
echo >> BenchLog
echo
tail -20 BenchLog
+ -rm -f pi.log prng.log
report:
$(SCMLIT) -e"(slib:report #t)"
$(SCMEXE) -e"(slib:report #t)"
+implcat: *.so mkimpcat.scm
+ $(SCMLIT) -lmkimpcat.scm
+
htmldir=../public_html/
dvidir=../dvi/
dvi: $(dvidir)scm.dvi $(dvidir)Xlibscm.dvi $(dvidir)hobbit.dvi
@@ -265,11 +304,11 @@ $(dvidir)hobbit.dvi: version.txi hobbit.texi $(dvidir)hobbit.fn Makefile
$(dvidir)hobbit.fn:
cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)hobbit.texi
xdvi: $(dvidir)scm.dvi
- xdvi -s 6 $(dvidir)scm.dvi
+ xdvi -s 3 $(dvidir)scm.dvi
Xdvi: $(dvidir)Xlibscm.dvi
- xdvi -s 6 $(dvidir)Xlibscm.dvi
+ xdvi -s 3 $(dvidir)Xlibscm.dvi
hobdvi: $(dvidir)hobbit.dvi
- xdvi -s 6 $(dvidir)hobbit.dvi
+ xdvi -s 3 $(dvidir)hobbit.dvi
pdf: $(htmldir)scm.pdf $(htmldir)Xlibscm.pdf $(htmldir)hobbit.pdf
$(htmldir)scm.pdf: version.txi scm.texi platform.txi features.txi\
@@ -292,12 +331,13 @@ hobpdf: $(htmldir)hobbit.pdf
PREVDOCS = prevdocs/
html: $(htmldir)scm_toc.html $(htmldir)Xlibscm_toc.html $(htmldir)hobbit_toc.html
+TEXI2HTML = /usr/local/bin/texi2html -split -verbose
scm_toc.html: version.txi scm.texi platform.txi features.txi
- texi2html -split -verbose scm.texi
+ ${TEXI2HTML} scm.texi
Xlibscm_toc.html: version.txi Xlibscm.texi
- texi2html -split -verbose Xlibscm.texi
+ ${TEXI2HTML} Xlibscm.texi
hobbit_toc.html: version.txi hobbit.texi
- texi2html -split -verbose hobbit.texi
+ ${TEXI2HTML} hobbit.texi
$(htmldir)scm_toc.html: scm_toc.html Makefile
-rm -f scm_stoc.html
@@ -361,14 +401,14 @@ Xlibscm.info: version.txi Xlibscm.texi
makeinfo Xlibscm.texi --no-split -o Xlibscm.info
$(infodir)Xlibscm.info: Xlibscm.info
cp Xlibscm.info $(infodir)Xlibscm.info
- -install-info $(infodir)Xlibscm.info $(infodir)/dir
+ -install-info $(infodir)Xlibscm.info $(infodir)dir
-rm $(infodir)Xlibscm.info*.gz
hobbit.info: version.txi hobbit.texi
makeinfo hobbit.texi --no-split -o hobbit.info
$(infodir)hobbit.info: hobbit.info
cp hobbit.info $(infodir)hobbit.info
- -install-info $(infodir)hobbit.info $(infodir)/dir
+ -install-info $(infodir)hobbit.info $(infodir)dir
-rm $(infodir)hobbit.info*.gz
infoz: installinfoz
@@ -392,8 +432,8 @@ install: scm.1
-cp $(ifiles) $(hobfiles) COPYING r4rstest.scm $(libscmdir)
test -f $(libscmdir)require.scm || \
cp requires.scm $(libscmdir)require.scm
- -cp build build.scm mkimpcat.scm Iedline.scm *.sl *.so $(xafiles)\
- $(libscmdir)
+ -cp build build.scm mkimpcat.scm Iedline.scm *.sl *.so patchlvl.h\
+ $(xafiles) $(libscmdir)
installlib:
test -d $(includedir) || mkdir $(includedir)
@@ -402,14 +442,26 @@ installlib:
cp libscm.a $(libdir)libscm.a
uninstall:
- -rm $(bindir)scm
+ -rm $(bindir)scm $(bindir)scmlit
-rm $(man1dir)scm.1
-rm $(includedir)scm.h $(includedir)scmfig.h $(includedir)scmflags.h
-rm $(libdir)libscm.a
-# -rm $(libscmdir)Init$(VERSION).scm
-# -rm $(libscmdir)Link.scm
-# -rm $(libscmdir)Transcen.scm
-# -rm $(libscmdir)COPYING
+ -rm $(libscmdir)Transcen.scm\
+ $(libscmdir)Link.scm\
+ $(libscmdir)Macro.scm\
+ $(libscmdir)Macexp.scm\
+ $(libscmdir)Tscript.scm\
+ $(libscmdir)compile.scm\
+ $(libscmdir)hobbit.scm\
+ $(libscmdir)scmhob.scm\
+ $(libscmdir)scmhob.h\
+ $(libscmdir)COPYING\
+ $(libscmdir)r4rstest.scm
+ -rm $(libscmdir)Init$(VERSION).scm
+
+uninstallinfo:
+ -rm $(infodir)scm.info.gz $(infodir)Xlibscm.info.gz\
+ $(infodir)hobbit.info.gz
scm.doc: scm.1
nroff -man $< | ul -tunknown >$@
@@ -418,7 +470,7 @@ scm.doc: scm.1
ver = $(VERSION)
version.txi: patchlvl.h
- echo @set SCMVERSION $(VERSION) > version.txi
+ echo @set SCMVERSION $(ver) > version.txi
echo @set SCMDATE `date +"%B %Y"` >> version.txi
RM_R = rm -rf
@@ -438,7 +490,7 @@ tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm \
syntest2.scm syntest1.scm
dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \
scm.info scm.texi Xlibscm.info Xlibscm.texi hobbit.info hobbit.texi \
- ChangeLog
+ version.txi platform.txi features.txi ChangeLog
mfiles = Makefile build.scm build build.bat requires.scm \
.gdbinit mkimpcat.scm disarm.scm scm.spec
vfiles = setjump.mar setjump.s
@@ -448,6 +500,7 @@ afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \
makedev = make -f $(HOME)/makefile.dev
CHPAT=$(HOME)/bin/chpat
RSYNC=rsync -avessh
+UPLOADEE=swissnet_upload
dest = $(HOME)/dist/
temp/scm: $(afiles)
-$(RM_R) temp
@@ -455,13 +508,13 @@ temp/scm: $(afiles)
mkdir temp/scm
ln $(afiles) temp/scm
-release: dist rpm
+release: dist pdf # rpm
cvs tag -F scm$(VERSION)
cp $(srcdir)ANNOUNCE $(htmldir)SCM_ANNOUNCE.txt
- $(RSYNC) $(htmldir)SCM.html $(htmldir)SCM_ANNOUNCE.txt nestle.ai.mit.edu:public_html/
+ $(RSYNC) $(htmldir)SCM.html $(htmldir)SCM_ANNOUNCE.txt $(UPLOADEE):public_html/
$(RSYNC) $(dest)README $(dest)scm$(VERSION).zip \
$(dest)scm-$(VERSION)-$(RELEASE).src.rpm $(dest)scm-$(VERSION)-$(RELEASE).i386.rpm \
- nestle.ai.mit.edu:dist/
+ $(htmldir)hobbit.pdf $(htmldir)Xlibscm.pdf $(UPLOADEE):dist/
# upload $(dest)README $(dest)scm$(VERSION).zip ftp.gnu.org:gnu/jacal/
# $(MAKE) indiana
indiana:
@@ -478,7 +531,7 @@ postnews:
-t "SCM$(VERSION) Released" -d world
upzip: $(HOME)/pub/scm.zip
- $(RSYNC) $(HOME)/pub/scm.zip nestle.ai.mit.edu:pub/
+ $(RSYNC) $(HOME)/pub/scm.zip $(UPLOADEE):pub/
dist: $(dest)scm$(VERSION).zip
$(dest)scm$(VERSION).zip: temp/scm
@@ -573,9 +626,9 @@ lints: $(cfiles) $(hfiles)
SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//' -e 's/.* T //'
#old, bad for T [^_] on suns: SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//'
# For a System V nm where plain C identifiers have _ prepended:
-#SED_TO_STRIP_NM=sed -e '/^_[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' -e 's/^_//'
+#SED_TO_STRIP_NM=sed -e '/^_[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' -e 's/^_//'
# For a System V nm where plain C identifiers have nothing prepended:
-#SED_TO_STRIP_NM=sed -e '/^[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g'
+#SED_TO_STRIP_NM=sed -e '/^[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g'
name8: name8s
name8s: scmlit
@@ -594,8 +647,9 @@ ctags: $(ctagfiles)
etags $(ctagfiles)
TAGFILES = $(hfiles) $(cfiles) $(ifiles) $(vfiles)\
- version.txi scm.texi Xlibscm.texi hobbit.texi build $(xfiles) $(mfiles)
-# # $(ufiles) ChangeLog hobbit.scm
+ version.txi scm.texi Xlibscm.texi hobbit.texi build $(xfiles) $(mfiles)\
+ hobbit.scm
+# # $(ufiles) ChangeLog
TAGS: $(TAGFILES)
etags $(TAGFILES)
tags: TAGS
diff --git a/README b/README
index 4cadd59..e672a56 100644
--- a/README
+++ b/README
@@ -1,9 +1,9 @@
-This directory contains the distribution of scm5d6. Scm conforms to
+This directory contains the distribution of scm5d9. Scm conforms to
Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178
specification. SCM runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2,
NOS/VE, Unicos, VMS, Unix and similar systems.
- <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
+ <http://swissnet.ai.mit.edu/~jaffer/SCM>
Manifest
========
@@ -24,6 +24,7 @@ Manifest
`bench.scm' computes and records performance statistics of pi.scm.
`build.bat' invokes build.scm for MS-DOS
`build.scm' database for compiling and linking new SCM programs.
+`byte.c' strings as bytes.
`compile.scm' Hobbit compilation to C.
`continue.c' continuations.
`continue.h' continuations.
@@ -101,22 +102,21 @@ SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and
install it. Bug reports about running SCM without SLIB have very low
priority. SLIB is available from the same sites as SCM:
- * swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz
+ * swissnet.ai.mit.edu:/pub/scm/slib3a1.tar.gz
- * ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz
+ * ftp.gnu.org:/pub/gnu/jacal/slib3a1.tar.gz
- * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz
+ * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a1.tar.gz
-Unpack SLIB (`tar xzf slib2d4.tar.gz' or `unzip -ao slib2d4.zip') in an
+Unpack SLIB (`tar xzf slib3a1.tar.gz' or `unzip -ao slib3a1.zip') in an
appropriate directory for your system; both `tar' and `unzip' will
create the directory `slib'.
Then create a file `require.scm' in the SCM "implementation-vicinity"
-(this is the same directory as where the file `Init5d6.scm' is
+(this is the same directory as where the file `Init5d9.scm' is
installed). `require.scm' should have the contents:
(define (library-vicinity) "/usr/local/lib/slib/")
- (load (in-vicinity (library-vicinity) "require"))
where the pathname string `/usr/local/lib/slib/' is to be replaced by
the pathname into which you installed SLIB. Absolute pathnames are
@@ -128,7 +128,6 @@ implementation-vicinity, which is absolute:
(define library-vicinity
(let ((lv (string-append (implementation-vicinity) "../slib/")))
(lambda () lv)))
- (load (in-vicinity (library-vicinity) "require"))
Alternatively, you can set the (shell) environment variable
`SCHEME_LIBRARY_PATH' to the pathname of the SLIB directory (*note
@@ -180,9 +179,6 @@ Editing Scheme Code
Gnu Emacs:
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:
-
- <http://simtel.coast.net/SimTel/gnu/demacs.html>
If your Emacs can run a process in a buffer you can use the Emacs
command `M-x run-scheme' with SCM. Otherwise, use the emacs
@@ -282,17 +278,17 @@ remove <FLAG> in scmfig.h and Do so and recompile files.
recompile scm.
add <FLAG> in scmfig.h and
recompile scm.
-ERROR: Init5d6.scm not found. Assign correct IMPLINIT in makefile
+ERROR: Init5d9.scm not found. Assign correct IMPLINIT in makefile
or scmfig.h.
Define environment variable
SCM_INIT_PATH to be the full
- pathname of Init5d6.scm.
+ pathname of Init5d9.scm.
WARNING: require.scm not found. Define environment variable
SCHEME_LIBRARY_PATH to be the full
pathname of the scheme library
[SLIB].
Change library-vicinity in
- Init5d6.scm to point to library or
+ Init5d9.scm to point to library or
remove.
Make sure the value of
(library-vicinity) has a trailing
@@ -353,7 +349,7 @@ Some symbol names print incorrectly. Change memory model option to C
than HEAP_SEG_SIZE).
ERROR: Rogue pointer in Heap. See above under machine crashes.
Newlines don't appear correctly in Check file mode (define OPEN_... in
-output files. `Init5d6.scm').
+output files. `Init5d9.scm').
Spaces or control characters appear Check character defines in
in symbol names. `scmfig.h'.
Negative numbers turn positive. Check SRS in `scmfig.h'.
diff --git a/Xlibscm.info b/Xlibscm.info
index 1052cba..a9d7325 100644
--- a/Xlibscm.info
+++ b/Xlibscm.info
@@ -12,7 +12,7 @@ File: Xlibscm.info, Node: Top, Next: Xlibscm, Prev: (dir), Up: (dir)
This manual documents the X - SCM Language X Interface. The most recent
information about SCM can be found on SCM's "WWW" home page:
- <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
+ <http://swissnet.ai.mit.edu/~jaffer/SCM>
Copyright (C) 1990-1999 Free Software Foundation
@@ -2071,18 +2071,18 @@ Concept Index

Tag Table:
Node: Top215
-Node: Xlibscm1333
-Node: Display and Screens4123
-Node: Drawables11108
-Node: Windows and Pixmaps11369
-Node: Window Attributes18448
-Node: Window Properties and Visibility34428
-Node: Graphics Context38885
-Node: Cursor54592
-Node: Colormap57095
-Node: Rendering66961
-Node: Images74518
-Node: Event74659
-Node: Index89134
+Node: Xlibscm1330
+Node: Display and Screens4120
+Node: Drawables11105
+Node: Windows and Pixmaps11366
+Node: Window Attributes18445
+Node: Window Properties and Visibility34425
+Node: Graphics Context38882
+Node: Cursor54589
+Node: Colormap57092
+Node: Rendering66958
+Node: Images74515
+Node: Event74656
+Node: Index89131

End Tag Table
diff --git a/Xlibscm.texi b/Xlibscm.texi
index 1d41a3c..9ecaee1 100644
--- a/Xlibscm.texi
+++ b/Xlibscm.texi
@@ -54,7 +54,7 @@ by the author.
This manual documents the X - SCM Language X Interface. The most recent
information about SCM can be found on SCM's @dfn{WWW} home page:
-@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM}
Copyright (C) 1990-1999 Free Software Foundation
@@ -126,7 +126,7 @@ dynamic linking, compiled separately and loaded with @code{(require
@noindent
The most recent information about SCM can be found on SCM's @dfn{WWW}
home page:
-@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM}
@end iftex
Much of this X documentation is dervied from:
diff --git a/bench.scm b/bench.scm
index 2d1cc07..4262564 100644
--- a/bench.scm
+++ b/bench.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1996, 1997, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2001, 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -38,11 +38,17 @@
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.
-;;;; "bench.scm", Scheme benchmark computing digits of pi.
+;;;; "bench.scm", Scheme benchmarks: digits of pi and random statistics.
;;; Author: Aubrey Jaffer.
-(load (in-vicinity (implementation-vicinity) "pi.scm"))
(require 'transcript)
+(require-if 'inexact 'root)
+(require-if 'inexact 'printf)
+(require 'random)
+(require 'array)
+;;(load (in-vicinity (implementation-vicinity) "prng-v.scm"))
+
+(load (in-vicinity (implementation-vicinity) "pi.scm"))
(define isqrt
(cond ((provided? 'inexact) sqrt)
(else (require 'root) integer-sqrt)))
@@ -51,26 +57,23 @@
(else quotient)))
(define around
(cond ((provided? 'inexact)
- (lambda (x bnd)
- (cond ((>= 99999 (abs x) bnd) (inexact->exact (round x)))
- ((> (abs x) 99999) (round x))
- (else x))))
- (else (lambda (x bnd) x))))
+ (let ()
+ (require 'printf)
+ (lambda (x prec) (sprintf #f "%.*g" prec x))))
+ (else (lambda (x prec) x))))
-(define (time-pi digits)
+(define (time-call proc . args)
(let ((start-time (get-internal-run-time)))
- (pi digits 4)
+ (apply proc args)
(i/ (* 1000 (- (get-internal-run-time) start-time))
internal-time-units-per-second)))
-(define (benchmark . arg)
- (define file
- (cond ((null? arg) "bench.log")
- (else (car arg))))
+(define (benchmark-pi . arg)
+ (define file (if (null? arg) "pi.log" (car arg)))
(do ((digits 50 (+ digits digits))
- (t 0 (time-pi (+ digits digits))))
- ((> t 3000)
- (do ((tl '() (cons (time-pi digits) tl))
+ (t 0 (time-call pi (+ digits digits) 4)))
+ ((> t 3600)
+ (do ((tl '() (cons (time-call pi digits 4) tl))
(j 12 (+ -1 j)))
((zero? j)
(let* ((avg (i/ (apply + tl) (length tl)))
@@ -80,18 +83,68 @@
(length tl)))))
(and file (transcript-on file))
(for-each display
- (list digits " digits took " (around avg 99)
- " +/- " (around dev 3) ".ms"))
+ (list digits " digits of pi took " (around avg 4) ".ms"
+ " +/- " (around dev 2) ".ms"))
(newline)
(let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits))
(scaled-dev (i/ (* (i/ (* dev 1000) digits) 1000) digits)))
(for-each display
(list " That is about "
- (around scaled-avg 99)
+ (around scaled-avg 4) ".ms/(kB)^2"
" +/- "
- (around scaled-dev 3)
- ".ms/(kB)^2"))
+ (around scaled-dev 2) ".ms/(kB)^2"))
(newline)
(and file (transcript-off)))
))))))
-(benchmark)
+
+(define (prng samples modu sta)
+ (define sra (create-array (Au32) samples))
+ (do ((cnt (+ -1 samples) (+ -1 cnt))
+ (num (random modu sta) (random modu sta))
+ (sum 0 (+ sum num)))
+ ((negative? cnt)
+ (set! sum (+ sum num))
+ (let ((mean (i/ sum samples)))
+ (define (square-diff x) (define z (- x mean)) (* z z))
+ (do ((cnt (+ -1 samples) (+ -1 cnt))
+ (var2 0 (+ (square-diff (array-ref sra cnt)) var2)))
+ ((negative? cnt)
+ (for-each display
+ (list sum " / " samples " = "
+ mean " +/- " (isqrt (i/ var2 samples))))
+ (newline)))))
+ (array-set! sra num cnt)))
+
+(define (benchmark-prng . arg)
+ (define file (if (null? arg) "prng.log" (car arg)))
+ (define sta
+ (seed->random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
+ (do ((samples 125 (* 4 samples))
+ (t 0 (time-call prng (* 2 samples) 999 sta)))
+ ((or (> t 1000) (and (not (provided? 'bignum)) (> samples 1000)))
+ (do ((tl '() (cons (time-call prng samples 999 sta) tl))
+ (j 12 (+ -1 j)))
+ ((zero? j)
+ (let* ((avg (i/ (apply + tl) (length tl)))
+ (dev (isqrt (i/ (apply
+ + (map (lambda (x) (* (- x avg) (- x avg)))
+ tl))
+ (length tl)))))
+ (and file (transcript-on file))
+ (for-each display
+ (list samples " random samples took " (around avg 4) ".ms"
+ " +/- " (around dev 2) ".ms"))
+ (newline)
+ (let ((scaled-avg (i/ (* avg 1000) samples))
+ (scaled-dev (i/ (* dev 1000) samples)))
+ (for-each display
+ (list " That is about "
+ (around scaled-avg 4) ".ms/kB"
+ " +/- "
+ (around scaled-dev 2) ".ms/kB"))
+ (newline)
+ (and file (transcript-off)))))))))
+
+(benchmark-prng)
+(newline)
+(benchmark-pi)
diff --git a/build b/build
index cde6729..dd43759 100755
--- a/build
+++ b/build
@@ -1,24 +1,29 @@
#! /bin/sh
-:;exec scmlit -f $0 -e"(bi)" build $*
+:;exec ./scmlit -no-init-file -f $0 -e"(bi)" build $*
-(require (in-vicinity (program-vicinity) "build.scm"))
(require 'getopt)
(require 'getopt-parameters)
+(require-if 'compiling 'posix)
+(require-if 'compiling 'fluid-let)
+(require-if 'compiling 'read-command)
+(require-if 'compiling 'common-list-functions)
+(load (in-vicinity (program-vicinity) "build.scm"))
+;@
(define (make-features-txi)
(call-with-output-file "features.txi"
(lambda (port)
- ((((build 'open-table) 'features #f) 'for-each-row)
+ (((open-table build 'features) 'for-each-row-in-order)
(lambda (row)
(apply (lambda (name spec documentation)
(display "@item " port) (display name port) (newline port)
(display "@cindex " port) (display name port) (newline port)
(display documentation port) (newline port) (newline port))
row))))))
-
+;@
(define (print-manifest port)
(display "@multitable @columnfractions .22 .78" port) (newline port)
- ((((build 'open-table) 'manifest #f) 'for-each-row)
+ (((open-table build 'manifest) 'for-each-row-in-order)
(lambda (row)
(apply (lambda (file format category documentation)
(display (string-append "@item @code{" file) port)
@@ -34,7 +39,7 @@
((negative? n) (close-port cat))
(newline cat)))
(system (string-append "info -f " path " -n '" node "' -o - >> " afile)))
-
+;@
(define (make-readme)
(require 'posix)
(let ((pipe (open-output-pipe "makeinfo --no-headers -o README"))
@@ -49,7 +54,7 @@ Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178
specification. SCM runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2,
NOS/VE, Unicos, VMS, Unix and similar systems.
-@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM}
@section Manifest
"
@@ -66,22 +71,29 @@ NOS/VE, Unicos, VMS, Unix and similar systems.
(append-info-node scm-info "Testing" "README")))
(define build:csv (make-command-server build '*commands*))
-(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))
+(define (build-from-argv)
+ (define command (string->symbol (list-ref *argv* *optind*)))
+ (define getopt- getopt--)
+ (require 'fluid-let)
+ (fluid-let ((getopt--
+ (lambda (optstring)
+ (let* ((opt (getopt- (string-append optstring "f:-:"))))
+ (cond ((eqv? #\f opt)
+ (let ()
+ (require 'read-command)
+ (require 'common-list-functions)
+ (set! *argv* (append (butnthcdr *optind* *argv*)
+ (read-options-file *optarg*)
+ (nthcdr *optind* *argv*))))))
+ opt))))
(cond
- ((pair? argv)
+ ((pair? *argv*)
(set! *optind* (+ 1 *optind*))
(build:csv
command
(lambda (comname comval options positions arities types
defaulters checks aliases)
- (let* ((params (getopt->parameter-list
- argc argv options arities types aliases))
+ (let* ((params (getopt->parameter-list options arities types aliases))
(fparams (and params (fill-empty-parameters defaulters params))))
(cond ((not (list? params))
;;(slib:warn 'build-from-argv 'not-parameters? fparams)
@@ -90,16 +102,24 @@ NOS/VE, Unicos, VMS, Unix and similar systems.
(slib:warn 'build-from-argv 'check-parameters 'failed)
#f)
((not (check-arities (map arity->arity-spec arities) fparams))
- (slib:error 'build-from-argv "arity error" fparams) #f)
+ (slib:error 'build-from-argv 'bad 'arity fparams) #f)
(else (comval fparams))))))))))
-
+;@
(define (build-from-whole-argv argv)
+ (if (string? argv)
+ (let ()
+ (require 'read-command)
+ (set! argv (call-with-input-string argv read-command))))
(set! *optind* 0)
(set! *optarg* #f)
- (build-from-argv argv))
+ (set! *argv* argv)
+ (build-from-argv))
+;;;@ Used when invoked as script
+(define (bi) (exit (and (build-from-argv) #t)))
+;@
(define b build-from-whole-argv)
-
+;@
(define (b*)
(require 'read-command)
(do ((e (read-command) (read-command)))
@@ -113,8 +133,6 @@ NOS/VE, Unicos, VMS, Unix and similar systems.
(display "build> ")
(force-output)))
-(define (bi) (if (build-from-argv *argv*) #t (exit #f)))
-
(cond (*interactive*
(display "type (b \"build <command-line>\") to build") (newline)
(display "type (b*) to enter build command loop") (newline)))
diff --git a/build.scm b/build.scm
index 7f896d4..0c66ccc 100644
--- a/build.scm
+++ b/build.scm
@@ -1,18 +1,36 @@
-;;; "build.scm" Build database and program -*-scheme-*-
-;;; Copyright (C) 1994-2002 Aubrey Jaffer.
-;;; See the file `COPYING' for terms applying to this program.
+;; "build.scm" Build database and program -*-scheme-*-
+;; Copyright (C) 1994-2003 Aubrey Jaffer.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, 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 program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(require 'parameters)
(require 'databases)
(require 'database-commands)
+(require 'alist)
+(require 'common-list-functions)
+(require 'object->string)
+(require 'glob)
+(require 'batch)
+(require-if 'compiling 'posix-time)
+;@
(set! OPEN_WRITE "w") ; Because MS-DOS scripts need ^M
-
+;@
(define build (add-command-tables (create-database #f 'alist-table)))
-(require 'glob)
-(require 'batch)
(batch:initialize! build)
-((((build 'open-table) 'batch-dialect #t) 'row:insert)
+(((open-table! build 'batch-dialect) 'row:insert)
'(default-for-platform 0))
;;;; This first part is about SCM files and features.
@@ -98,6 +116,7 @@
("ramap.c" c-source optional "array mapping")
("dynl.c" c-source optional "dynamically load object files.")
("sc2.c" c-source linkable "procedures from R2RS and R3RS not in R4RS.")
+ ("byte.c" c-source linkable "strings as bytes.")
("rgx.c" c-source linkable "string regular expression match.")
("crs.c" c-source linkable "interactive terminal control.")
("split.scm" Scheme test "example use of crs.c. Input, output, and diagnostic output directed to separate windows.")
@@ -142,14 +161,14 @@
(documentation string))
((none () "No features"))))
-(for-each (build 'add-domain)
- '((optstring #f (lambda (x) (or (not x) (string? x))) string #f)
- (filename #f #f string #f)
- (features features #f symbol #f)
- (build-whats build-whats #f symbol #f)))
+(define-domains build
+ '(optstring #f (lambda (x) (or (not x) (string? x))) string #f)
+ '(filename #f #f string #f)
+ '(features features #f symbol #f)
+ '(build-whats build-whats #f symbol #f))
(define define-build-feature
- (let ((defeature (((build 'open-table) 'features #t) 'row:insert)))
+ (let ((defeature ((open-table! build 'features) 'row:insert)))
(lambda args
(defeature (append args (list (comment)))))))
@@ -222,7 +241,7 @@
#;array-map! and array-for-each (arrays must also be featured).
(define-build-feature
'array-for-each
- '((c-file "ramap.c") (init "init_ramap")))
+ '((c-file "ramap.c") (compiled-init "init_ramap")))
#;Use if you want floating point numbers.
(define-build-feature
@@ -268,11 +287,16 @@
'rev2-procedures
'((c-file "sc2.c") (init "init_sc2")))
+#;Treating strings as byte-vectors.
+(define-build-feature
+ 'byte
+ '((c-file "byte.c") (init "init_byte")))
+
#;The Record package provides a facility for user to define their own
#;record data types. See SLIB for documentation.
(define-build-feature
'record
- '((define "CCLO") (c-file "record.c") (init "init_record")))
+ '((define "CCLO") (c-file "record.c") (compiled-init "init_record")))
#;Use if you want to use compiled closures.
(define-build-feature
@@ -282,7 +306,7 @@
#;@code{make_gsubr} for arbitrary (< 11) arguments to C functions.
(define-build-feature
'generalized-c-arguments
- '((c-file "gsubr.c") (init "init_gsubr")))
+ '((c-file "gsubr.c") (compiled-init "init_gsubr")))
#;Use if you want the ticks and ticks-interrupt functions.
(define-build-feature
@@ -315,7 +339,7 @@
#;For the @dfn{curses} screen management package.
(define-build-feature
'curses
- '((c-file "crs.c") (c-lib curses) (init "init_crs")))
+ '((c-file "crs.c") (c-lib curses) (compiled-init "init_crs")))
#;interface to the editline or GNU readline library.
(define-build-feature
@@ -330,25 +354,25 @@
#;String regular expression matching.
(define-build-feature
'regex
- '((c-file "rgx.c") (c-lib regex) (init "init_rgx")))
+ '((c-file "rgx.c") (c-lib regex) (compiled-init "init_rgx")))
#;BSD @dfn{socket} interface.
(define-build-feature
'socket
- '((c-lib socket) (c-file "socket.c") (init "init_socket")))
+ '((c-lib socket) (c-file "socket.c") (compiled-init "init_socket")))
#;Posix functions available on all @dfn{Unix-like} systems. fork and
#;process functions, user and group IDs, file permissions, and
#;@dfn{link}.
(define-build-feature
'posix
- '((c-file "posix.c") (init "init_posix")))
+ '((c-file "posix.c") (compiled-init "init_posix")))
#;Those unix features which have not made it into the Posix specs:
#;nice, acct, lstat, readlink, symlink, mknod and sync.
(define-build-feature
'unix
- '((c-file "unix.c") (init "init_unix")))
+ '((c-file "unix.c") (compiled-init "init_unix")))
#;Microsoft Windows executable.
(define-build-feature
@@ -396,15 +420,15 @@
(define-tables build
'(processor-family
- ((family atom))
+ ((family symbol))
((also-runs processor-family))
((*unknown* #f)
- (8086 #f)
+ (i8086 #f)
(acorn #f)
(alpha #f)
(cray #f)
(hp-risc #f)
- (i386 8086)
+ (i386 i8086)
(m68000 #f)
(m68030 m68000)
(mips #f)
@@ -430,7 +454,7 @@
((*unknown* *unknown* unix cc ) ;ld
(acorn-unixlib acorn *unknown* cc ) ;link
(aix powerpc aix cc ) ;cc
- (alpha alpha osf1 cc ) ;cc
+ (osf1 alpha unix cc ) ;cc
(alpha-elf alpha unix cc ) ;cc
(alpha-linux alpha linux gcc ) ;gcc
(amiga-aztec m68000 amiga cc ) ;cc
@@ -439,8 +463,8 @@
(amiga-sas m68000 amiga lc ) ;link
(atari-st-gcc m68000 atari.st gcc ) ;gcc
(atari-st-turbo-c m68000 atari.st tcc ) ;tlink
- (borland-c 8086 ms-dos bcc ) ;bcc
- (cygwin32 i386 unix gcc ) ;gcc
+ (borland-c i8086 ms-dos bcc ) ;bcc
+ (gnu-win32 i386 unix gcc ) ;gcc
(djgpp i386 ms-dos gcc ) ;gcc
(freebsd i386 unix cc ) ;cc
(gcc *unknown* unix gcc ) ;gcc
@@ -450,10 +474,11 @@
(linux i386 linux gcc ) ;gcc
(linux-aout i386 linux gcc ) ;gcc
(darwin powerpc unix cc ) ;gcc
- (microsoft-c 8086 ms-dos cl ) ;link
+ (microsoft-c i8086 ms-dos cl ) ;link
(microsoft-c-nt i386 ms-dos cl ) ;link
- (microsoft-quick-c 8086 ms-dos qcl ) ;qlink
- (ms-dos 8086 ms-dos cc ) ;link
+ (microsoft-quick-c i8086 ms-dos qcl ) ;qlink
+ (ms-dos i8086 ms-dos cc ) ;link
+ (netbsd *unknown* unix gcc ) ;gcc
(openbsd *unknown* unix gcc ) ;gcc
(os/2-cset i386 os/2 icc ) ;link386
(os/2-emx i386 os/2 gcc ) ;gcc
@@ -461,7 +486,7 @@
(svr4-gcc-sun-ld sparc sunos gcc ) ;ld
(sunos sparc sunos cc ) ;ld
(svr4 *unknown* unix cc ) ;ld
- (turbo-c 8086 ms-dos tcc ) ;tcc
+ (turbo-c i8086 ms-dos tcc ) ;tcc
(unicos cray unicos cc ) ;cc
(unix *unknown* unix cc ) ;cc
(vms vax vms cc ) ;link
@@ -492,8 +517,9 @@
(mysql *unknown* "-I/usr/include/mysql" "-L/usr/lib/mysql -lmysqlclient"
"/usr/lib/mysql/libmysqlclient.a" () ())
- (m cygwin32 "" "" "" () ())
- (c cygwin32 "" "" "" () ())
+ (m gnu-win32 "" "" "" () ())
+ (c gnu-win32 "" "" "" () ())
+ (dlll gnu-win32 "-DSCM_DLL" "" #f () ("posix.c" "unix.c" "socket.c"))
(m linux-aout "" "-lm" "/usr/lib/libm.sa" () ())
(c linux-aout "" "-lc" "/usr/lib/libc.sa" () ())
(dlll linux-aout "-DDLD -DDLD_DYNCM" "-ldld" #f () ("findexec.c"))
@@ -506,6 +532,7 @@
(m linux "" "-lm" "/lib/libm.so" () ())
(c linux "" "-lc" "/lib/libc.so" () ())
(dlll linux "-DSUN_DL" "-ldl" #f () ())
+ (regex linux "" "" "" () ())
(graphics linux "-I/usr/include/X11 -DX11" "-L/usr/X11R6/lib -lX11"
"/usr/X11R6/lib/libX11.so" () ())
(curses linux "" "-lcurses" "/lib/libncurses.so" () ())
@@ -516,8 +543,12 @@
(m acorn-unixlib "" "" #f () ())
- (nostart alpha "" "-non_shared" #f ("pre-crt0.c") ())
- (dump alpha "" "" #f ("unexalpha.c") ())
+ (nostart osf1 "" "" #f ("pre-crt0.c") ())
+ (dlll osf1 "-DSUN_DL" "" #f () ())
+ (dump osf1 "" "" #f ("unexalpha.c" "gmalloc.c") ())
+ (regex osf1 "" "" #f () ())
+ (graphics osf1 "-I/usr/include/X11 -DX11" "-lX11"
+ #f () ())
(m amiga-dice-c "" "-lm" #f () ())
(m amiga-sas "" "lcmieee.lib" #f () ())
@@ -564,13 +595,14 @@
;;; (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 () ())
- (debug Microsoft-C-nt "-Zi" "/debug" #f () ())
- (c Microsoft-Quick-C "" "" #f () ("findexec.c"))
- (m Microsoft-Quick-C "" "" #f () ())
+ (c microsoft-c "" "" #f () ("findexec.c"))
+ (m microsoft-c "" "" #f () ())
+ (c microsoft-c-nt "" "" #f () ("findexec.c"))
+ (m microsoft-c-nt "" "" #f () ())
+ (dlll microsoft-c-nt "-DSCM_DLL -MD" "" #f () ("posix.c" "unix.c" "socket.c"))
+ (debug microsoft-c-nt "-Zi" "/debug" #f () ())
+ (c microsoft-quick-c "" "" #f () ("findexec.c"))
+ (m microsoft-quick-c "" "" #f () ())
(c turbo-c "" "" #f () ("findexec.c"))
(m turbo-c "" "" #f () ())
@@ -590,13 +622,18 @@
(curses darwin "" "" #f () ())
(regex darwin "" "" #f () ())
+ (c freebsd "" "-export-dynamic" #f () ())
(m freebsd "" "-lm" #f () ())
(curses freebsd "" "-lncurses" "/usr/lib/libncurses.a" () ())
(regex freebsd "" "-lgnuregex" "" () ())
(editline freebsd "" "-lreadline" "" () ())
- (dlll freebsd "-DSUN_DL" "" "" () ())
+ (dlll freebsd "-DSUN_DL" "-export-dynamic" "" () ())
(nostart freebsd "" "-e start -dc -dp -Bstatic -lgnumalloc" #f ("pre-crt0.c") ())
(dump freebsd "" "/usr/lib/crt0.o" "" ("unexsunos4.c") ())
+ (curses netbsd "-I/usr/pkg/include" "-lncurses" "-Wl,-rpath -Wl,/usr/pkg/lib -L/usr/pkg/lib" () ())
+ (editline netbsd "-I/usr/pkg/include" "-lreadline" "-Wl,-rpath -Wl,/usr/pkg/lib -L/usr/pkg/lib" () ())
+ (graphics netbsd "-I/usr/X11R6/include -DX11" "-lX11" "-Wl,-rpath -Wl,/usr/X11R6/lib -L/usr/X11R6/lib" () ())
+ (m netbsd "" "-lm" #f () ())
(m openbsd "" "-lm" #f () ())
(curses openbsd "" "-lcurses" "/usr/lib/libcurses.a" () ())
))
@@ -612,7 +649,7 @@
objects))))))
(define define-compile-commands
- (let ((defcomms (((build 'open-table) 'compile-commands #t) 'row:insert)))
+ (let ((defcomms ((open-table! build 'compile-commands) 'row:insert)))
(lambda args
(defcomms args)))) ;(append args (list (comment)))
(defmacro defcommand (name platform procedure)
@@ -624,7 +661,7 @@
(apply batch:lines->file parms rsp-name files)
(and (batch:try-command
parms
- "bcc" "-d" "-O" "-Z" "-G" "-w-pro" "-ml" "-c"
+ "bcc" "-d" "-Z" "-G" "-w-pro" "-ml" "-c"
(if (member '(define "FLOATS" #t)
(c-defines parms))
"" "-f-")
@@ -648,7 +685,7 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "tcc" "-c" "-d" "-O" "-Z" "-G" "-ml" "-c"
+ "tcc" "-c" "-d" "-Z" "-G" "-ml" "-c"
"-Ic:\\turboc\\include"
(include-spec "-I" parms)
(c-includes parms)
@@ -667,7 +704,7 @@
(batch:rename-file parms exe oexe))
oexe))))
-(defcommand compile-c-files Microsoft-C
+(defcommand compile-c-files microsoft-c
(lambda (files parms)
(and (batch:try-chopped-command
parms "cl" "-c" "Oxp" "-AH"
@@ -676,7 +713,7 @@
(c-flags parms)
files)
(truncate-up-to (map c->obj files) #\\))))
-(defcommand link-c-program Microsoft-C
+(defcommand link-c-program microsoft-c
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to (obj->exe (car objects)) #\\))
(oexe (string-append oname ".exe")))
@@ -689,7 +726,8 @@
(or (string-ci=? exe oexe)
(batch:rename-file parms exe oexe))
oexe))))
-(defcommand compile-c-files Microsoft-C-nt
+
+(defcommand compile-c-files microsoft-c-nt
(lambda (files parms)
(and (batch:try-chopped-command
parms
@@ -701,7 +739,47 @@
(c-flags parms)
files)
(truncate-up-to (map c->obj files) #\\))))
-(defcommand link-c-program Microsoft-C-nt
+(defcommand compile-dll-c-files microsoft-c-nt
+ (lambda (files parms)
+ (define platform (car (parameter-list-ref parms 'platform)))
+ (let ((suppressors (build:c-suppress 'dlll platform)))
+ (define c-files (remove-if (lambda (file) (member file suppressors))
+ files))
+ (and (batch:try-chopped-command
+ parms
+ "cl" "-c" "-nologo"
+ (if (memq 'stack-limit (parameter-list-ref parms 'features))
+ "-Oityb1" "-Ox")
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ c-files)
+ (let ((results
+ (map
+ (lambda (fname)
+ (and (batch:try-command
+ parms "link" "/dll" "/nologo"
+ (string-append "/out:" fname ".dll")
+ (string-append "/implib:" fname ".lib")
+ fname
+ (map (lambda (l) (build:lib-ld-flag l platform))
+ (parameter-list-ref parms 'c-lib))
+ "scm.lib")
+ (string-append fname ".dll")))
+ (map c-> c-files))))
+ (and (apply and? results) results))))))
+(defcommand make-dll-archive microsoft-c-nt
+ (lambda (oname objects libs parms) objects))
+(defcommand make-archive microsoft-c-nt
+ (lambda (oname objects libs parms)
+ (let ((aname (string-append oname ".dll")))
+ (and (batch:try-command parms
+ "link" "/dll" "/nologo"
+ (string-append "/out:" aname)
+ (string-append "/implib:" oname ".lib")
+ libs (map obj-> objects))
+ aname))))
+(defcommand link-c-program microsoft-c-nt
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to (obj->exe (car objects)) #\\))
(oexe (string-append oname ".exe")))
@@ -712,7 +790,7 @@
libs)
oexe))))
-(defcommand compile-c-files Microsoft-Quick-C
+(defcommand compile-c-files microsoft-quick-c
(lambda (files parms)
(and (batch:try-chopped-command
parms
@@ -721,7 +799,7 @@
(c-flags parms)
files)
(truncate-up-to (map c->obj files) #\\))))
-(defcommand link-c-program Microsoft-Quick-C
+(defcommand link-c-program microsoft-quick-c
(lambda (oname objects libs parms)
(define crf-name (string-append oname ".crf"))
(apply batch:lines->file parms
@@ -738,7 +816,7 @@
crf-name)
(string-append oname ".exe"))))
-(defcommand compile-c-files Watcom-9.0
+(defcommand compile-c-files watcom-9.0
(lambda (files parms)
(and (batch:try-chopped-command
parms
@@ -748,7 +826,7 @@
(c-flags parms)
files)
(truncate-up-to (map c->obj files) #\\))))
-(defcommand link-c-program Watcom-9.0
+(defcommand link-c-program watcom-9.0
(lambda (oname objects libs parms)
(let ((exe (truncate-up-to (obj->exe (car objects)) #\\))
(oexe (string-append oname ".exe")))
@@ -796,7 +874,7 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "gcc" "-Wall" "-O2" "-c"
+ "gcc" "-c"
(include-spec "-I" parms)
(c-includes parms) (c-flags parms)
files)
@@ -835,7 +913,7 @@
(defcommand compile-c-files os/2-emx
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-O" "-m386" "-c"
+ "gcc" "-m386" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -905,7 +983,7 @@
(defcommand compile-c-files linux-aout
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-Wall" "-O2" "-c"
+ "gcc" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -915,7 +993,7 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "gcc" "-Wall" "-O2" "-c"
+ "gcc" "-c"
(c-includes parms)
(c-flags parms)
files)
@@ -929,7 +1007,7 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "gcc" "-O2"
+ "gcc"
;;(if (member "-g" (c-includes parms)) "" "-O2")
"-c" (c-includes parms)
(include-spec "-I" parms)
@@ -941,8 +1019,7 @@
(and
(batch:try-chopped-command
parms
- "gcc" "-O2"
- "-fpic" "-c" (c-includes parms)
+ "gcc" "-fpic" "-c" (c-includes parms)
(c-flags parms)
files)
(let* ((platform (car (parameter-list-ref parms 'platform)))
@@ -1036,7 +1113,7 @@
(defcommand compile-c-files gcc
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-O2" "-c" ; "-Wall"
+ "gcc" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1057,7 +1134,7 @@
(defcommand compile-dll-c-files gcc
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-O" "-c"
+ "gcc" "-c"
(c-includes parms)
(c-flags parms)
files)
@@ -1076,16 +1153,56 @@
(car (parameter-list-ref parms 'implvic))
oname ".so.1.0"))))
-(defcommand compile-c-files cygwin32
+(defcommand compile-dll-c-files gnu-win32
+ (lambda (files parms)
+ (define platform (car (parameter-list-ref parms 'platform)))
+ (let ((suppressors (build:c-suppress 'dlll platform)))
+ (define c-files (remove-if (lambda (file) (member file suppressors))
+ files))
+ (and (batch:try-chopped-command
+ parms
+ "gcc" "-c"
+ (include-spec "-I" parms)
+ (c-includes parms)
+ (c-flags parms)
+ c-files)
+ (let ((results
+ (map
+ (lambda (fname)
+ (and (batch:try-command
+ parms "dllwrap"
+ "--output-lib" (string-append fname ".lib")
+ "-dllname" (string-append fname ".dll")
+ "--output-def" (string-append fname ".def")
+ (string-append fname ".o")
+ (map (lambda (l) (build:lib-ld-flag l platform))
+ (parameter-list-ref parms 'c-lib))
+ "scm.lib")
+ (string-append fname ".dll")))
+ (map c-> c-files))))
+ (and (apply and? results) results))))))
+(defcommand make-dll-archive gnu-win32
+ (lambda (oname objects libs parms) objects))
+(defcommand make-archive gnu-win32
+ (lambda (oname objects libs parms)
+ (let ((aname (string-append oname ".dll")))
+ (and (batch:try-command parms
+ "dllwrap"
+ "--output-lib" (string-append oname ".lib")
+ "-dllname" aname
+ "--output-def" (string-append oname ".def")
+ libs objects)
+ aname))))
+(defcommand compile-c-files gnu-win32
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-Wall" "-O2" "-c"
+ "gcc" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
files)
(truncate-up-to (map c->o files) #\/))))
-(defcommand link-c-program cygwin32
+(defcommand link-c-program gnu-win32
(lambda (oname objects libs parms)
(batch:rename-file parms
(string-append oname ".exe")
@@ -1099,10 +1216,62 @@
(append objects libs)))
oname)))
+(defcommand compile-c-files osf1
+ (lambda (files parms)
+ (and (batch:try-chopped-command
+ parms
+ "cc" "-std1"
+ ;;(if (member "-g" (c-includes parms)) "" "-O")
+ "-c" (c-includes parms)
+ (include-spec "-I" parms)
+ (c-flags parms)
+ files)
+ (truncate-up-to (map c->o files) #\/))))
+(defcommand compile-dll-c-files osf1
+ (lambda (files parms)
+ (and
+ (batch:try-chopped-command
+ parms "cc" "-std1" "-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-command
+ parms
+ "cc" "-shared" "-o"
+ (string-append fname ".so")
+ (string-append fname ".o")
+ ld-opts)
+ (batch:delete-file
+ parms (string-append fname ".o"))
+ (string-append fname ".so")))
+ (truncate-up-to (map c-> files) #\/))))
+ (and (apply and? results) results)))))
+(defcommand make-dll-archive osf1
+ (lambda (oname objects libs parms)
+ (let ((platform (car (parameter-list-ref
+ parms 'platform))))
+ (and (batch:try-command
+ parms
+ "cc" "-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")))))
+
(defcommand compile-c-files svr4-gcc-sun-ld
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-O2" "-c" ; "-Wall"
+ "gcc" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1125,7 +1294,7 @@
(and
(batch:try-chopped-command
parms
- "gcc" "-O2"
+ "gcc"
"-fpic" "-c" (c-includes parms)
(c-flags parms)
files)
@@ -1151,7 +1320,7 @@
(defcommand compile-c-files svr4
(lambda (files parms)
(and (batch:try-chopped-command parms
- "cc" "-O" "-DSVR4" "-c"
+ "cc" "-DSVR4" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1161,7 +1330,7 @@
(defcommand compile-c-files aix
(lambda (files parms)
(and (batch:try-chopped-command parms
- "cc" "-O" "-Dunix" "-c"
+ "cc" "-Dunix" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1192,7 +1361,7 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "lc" "-d3" "-M" "-fi" "-O"
+ "lc" "-d3" "-M" "-fi"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1239,7 +1408,7 @@
(defcommand compile-c-files amiga-gcc
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-Wall" "-O2" "-c"
+ "gcc" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1261,7 +1430,7 @@
(defcommand compile-c-files atari-st-gcc
(lambda (files parms)
(and (batch:try-chopped-command parms
- "gcc" "-v" "-O" "-c"
+ "gcc" "-v" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1372,7 +1541,7 @@
(lambda (files parms)
(batch:try-chopped-command
parms
- "cc" "-O" "-c"
+ "cc" "-c"
(include-spec "-I" parms)
(c-includes parms)
(c-flags parms)
@@ -1399,7 +1568,7 @@
(defcommand compile-dll-c-files *unknown*
(lambda (files parms)
(and (batch:try-chopped-command parms
- "cc" "-O" "-c"
+ "cc" "-c"
(c-includes parms)
(c-flags parms)
files)
@@ -1419,7 +1588,7 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "cc" "-O" "-c"
+ "cc" "-O3 -pipe " "-c"
(c-includes parms)
(c-flags parms)
files)
@@ -1440,27 +1609,33 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "cc" "-O" "-fpic" "-c"
- (string-append
- "-I" (parameter-list-ref parms 'scm-srcdir))
- (c-includes parms)
+ "cc" "-O3 -pipe "
+ "-fPIC" "-c" (c-includes parms)
(c-flags parms)
files)
- (let ((objs (map c->o files)))
- (every
- (lambda (f)
- (and (batch:try-command
- parms "ld" "-Bshareable" f)
- (batch:try-command
- parms "mv" "a.out" f)))
- objs)
- objs))))
-
+ (let ((results
+ (map
+ (lambda (fname)
+ (and (batch:try-command
+ parms
+ "cc" "-shared"
+ (cond
+ ((equal? fname "edline") "-lreadline")
+ ((equal? fname "x") "-L/usr/X11R6/lib -lSM -lICE -lXext -lX11 -lxpg4")
+ (else ""))
+ "-o"
+ (string-append fname ".so")
+ (string-append fname ".o"))
+ (batch:delete-file
+ parms (string-append fname ".o"))
+ (string-append fname ".so")))
+ (truncate-up-to (map c-> files) #\/))))
+ (and (apply and? results) results)))))
(defcommand make-dll-archive freebsd
(lambda (oname objects libs parms)
(and (batch:try-command
parms
- "ld" "-Bshareable" "-o"
+ "cc" "-shared" "-o"
(string-append
(car (parameter-list-ref parms 'implvic))
oname ".so")
@@ -1488,11 +1663,66 @@
(append objects libs))
oname)))
+(defcommand compile-c-files netbsd
+ (lambda (files parms)
+ (and (batch:try-chopped-command
+ parms
+ "cc" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (map c->o files))))
+(defcommand link-c-program netbsd
+ (lambda (oname objects libs parms)
+ (batch:rename-file parms
+ oname (string-append oname "~"))
+ (and (batch:try-command parms
+ "cc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "crt0.o"
+ "/usr/lib/crt0.o")
+ (append libs objects)))
+ oname)))
+(defcommand compile-dll-c-files netbsd
+ (lambda (files parms)
+ (and (batch:try-chopped-command
+ parms
+ "cc" "-fPIC" "-c"
+ (string-append
+ "-I" (parameter-list-ref parms 'scm-srcdir))
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (let ((objs (map c->o files)))
+ (every
+ (lambda (f)
+ (and (batch:try-command
+ parms "gcc" "-shared" "-fPIC" f)
+ (batch:try-command
+ parms "mv" "a.out" f)))
+ objs)
+ objs))))
+
+(defcommand make-dll-archive netbsd
+ (lambda (oname objects libs parms)
+ (and (batch:try-command
+ parms
+ "gcc" "-shared" "-fPIC" "-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"))))
+
(defcommand compile-c-files openbsd
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "cc" "-O2" "-Wall" "-c"
+ "cc" "-c"
(c-includes parms)
(c-flags parms)
files)
@@ -1513,7 +1743,7 @@
(lambda (files parms)
(and (batch:try-chopped-command
parms
- "cc" "-O2" "-Wall" "-fPIC" "-c"
+ "cc" "-fPIC" "-c"
(string-append
"-I" (parameter-list-ref parms 'scm-srcdir))
(c-includes parms)
@@ -1543,8 +1773,8 @@
(car (parameter-list-ref parms 'implvic))
oname ".so"))))
-(for-each (build 'add-domain)
- '((C-libraries C-libraries #f symbol #f)))
+(define-domains build
+ '(C-libraries C-libraries #f symbol #f))
(define-tables build
@@ -1568,15 +1798,15 @@
(9 compiled-init nary string #f #f "later initialization calls")
(10 features nary features
(lambda (pl) '(arrays inexact bignums))
- (lambda (rdb) (((rdb 'open-table) 'features #f) 'get 'spec))
+ (lambda (rdb) ((open-table rdb 'features) 'get 'spec))
"features to include")
(11 what single build-whats
(lambda (pl) '(exe))
(lambda (rdb)
- (let* ((bwt ((rdb 'open-table) 'build-whats #f))
+ (let* ((bwt (open-table rdb 'build-whats))
(getclass (bwt 'get 'class))
(getspec (bwt 'get 'spec))
- (getfile (((rdb 'open-table) 'manifest #f) 'get* 'file)))
+ (getfile ((open-table rdb 'manifest) 'get* 'file)))
(lambda (what)
`((c-file ,@(getfile #f 'c-source (getclass what)))
,@(or (getspec what) '())))))
@@ -1596,6 +1826,10 @@
(18 c-includes nary expression #f #f "library induced defines for C")
(19 batch-port nary expression #f #f
"port batch file will be written to.")
+ ;; The options file is read by a fluid-let getopt-- in "build".
+ ;; This is here so the usage message will include -f <filename>.
+ (20 options-file nary filename #f #f
+ "file containing more build options.")
))
'(build-pnames
((name string))
@@ -1616,6 +1850,7 @@
("compiler options" 14)
("linker options" 15)
("scm srcdir" 16)
+ ("f" 20)
))
'(*commands*
@@ -1627,7 +1862,7 @@
((build
build-params
build-pnames
- build:build
+ build:command
"compile and link SCM programs.")
(*initialize*
no-parameters
@@ -1658,22 +1893,18 @@
(else (look '*unknown*)))))
(look plat)))
-(require 'alist)
-(require 'common-list-functions)
-(require 'object->string)
-
-(define (build:build rdb)
+(define (build:command rdb)
(lambda (parms)
(let ((expanders
(map (lambda (e) (and e (lambda (s) (e s))))
(map (lambda (f) (if f ((slib:eval f) rdb) f))
- ((((rdb 'open-table) 'build-params #f)
+ (((open-table rdb 'build-params)
'get* 'expander))))))
(parameter-list-expand expanders parms)
(set! parms
(fill-empty-parameters
(map slib:eval
- ((((rdb 'open-table) 'build-params #f)
+ (((open-table rdb 'build-params)
'get* 'defaulter)))
parms))
(parameter-list-expand expanders parms))
@@ -1713,14 +1944,14 @@
(map (lambda (l) (build:lib-cc-flag l platform))
(parameter-list-ref parms 'c-lib)))
(what (car (parameter-list-ref parms 'what)))
- (c-proc (plan-command ((((rdb 'open-table) 'build-whats #f)
+ (c-proc (plan-command (((open-table rdb 'build-whats)
'get 'c-proc)
what)
platform)))
(case (car (parameter-list-ref parms 'batch-dialect))
((default-for-platform)
- (let ((os ((((build 'open-table) 'platform #f)
+ (let ((os (((open-table build 'platform)
'get 'operating-system) platform)))
(if (not os)
(build:error "OS corresponding to " platform " unknown"))
@@ -1736,7 +1967,7 @@
(cons 'operating-system
(map platform->os (parameter-list-ref parms 'platform)))
parms))
-
+
(let ((name (parameter-list-ref parms 'who)))
(set! name (if (null? name) (current-output-port) (car name)))
(batch:call-with-output-script
@@ -1748,6 +1979,11 @@
parms
(list 'batch-port batch-port))
+ (let ((options-file (parameter-list-ref parms 'options-file)))
+ (and (not (null? options-file))
+ (batch:comment
+ parms
+ (apply string-join " " "used options from:" options-file))))
(batch:comment parms "================ Write file with C defines")
(cond
((not (apply batch:lines->file parms
@@ -1780,7 +2016,7 @@
(batch:comment parms "================ Link C object files")
(let ((ans
((plan-command
- ((((rdb 'open-table) 'build-whats #f) 'get 'o-proc) what)
+ (((open-table rdb 'build-whats) 'get 'o-proc) what)
platform)
(car (parameter-list-ref parms 'target-name))
(append o-files (parameter-list-ref parms 'o-file))
@@ -1849,16 +2085,17 @@
(define (logger . args)
(define cep (current-error-port))
- (cond ((provided? 'bignum)
- (require 'posix-time)
- (let ((ct (ctime (current-time))))
- (string-set! ct (+ -1 (string-length ct)) #\:)
- (for-each (lambda (x) (display x cep))
- (cons ct (cons #\ args)))))
- (else (for-each (lambda (x) (display x cep)) args)))
+ (for-each (lambda (x) (display #\ cep) (display x cep))
+ (cond ((provided? 'bignum)
+ (require 'posix-time)
+ (let ((ct (ctime (current-time))))
+ (string-set! ct (+ -1 (string-length ct)) #\:)
+ (cons ct args)))
+ (else args)))
(newline cep))
(define build:qacs #f)
+;@
(define (build:serve request-line query-string header)
(define query-alist (and query-string (uri:decode-query query-string)))
(if (not build:qacs)
@@ -1889,7 +2126,7 @@
(define build:initializer
(lambda (rdb)
- (set! build:c-libraries ((rdb 'open-table) 'c-libraries #f))
+ (set! build:c-libraries (open-table rdb 'c-libraries))
(set! build:lib-cc-flag
(make-defaulting-platform-lookup
(build:c-libraries 'get 'compiler-flags)))
@@ -1902,11 +2139,11 @@
(set! build:c-suppress
(make-defaulting-platform-lookup
(build:c-libraries 'get 'suppress-files)))
- (set! platform->os (((rdb 'open-table) 'platform #f)
+ (set! platform->os ((open-table rdb 'platform)
'get 'operating-system))
(set! plan-command
(let ((lookup (make-defaulting-platform-lookup
- (((rdb 'open-table) 'compile-commands #f)
+ ((open-table rdb 'compile-commands)
'get 'procedure))))
(lambda (thing plat)
;;(print 'thing thing 'plat plat)
diff --git a/byte.c b/byte.c
new file mode 100644
index 0000000..1ef014f
--- /dev/null
+++ b/byte.c
@@ -0,0 +1,285 @@
+/* Copyright (C) 2003 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of SCM.
+ *
+ * The exception is that, if you link the SCM library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the SCM library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name SCM. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * SCM, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for SCM, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "byte.c" Strings as Bytes
+ Author: Aubrey Jaffer */
+
+#include "scm.h"
+
+char s_make_bytes[] = "make-bytes";
+SCM scm_make_bytes(k, n)
+ SCM k, n;
+{
+ SCM res;
+ register unsigned char *dst;
+ register long i;
+ ASRTER(INUMP(k) && (k >= 0), k, ARG1, s_make_bytes);
+ i = INUM(k);
+ res = makstr(i);
+ dst = UCHARS(res);
+ if (!UNBNDP(n)) {
+ ASRTER(INUMP(n) && 0 <= n && n <= MAKINUM(255), n, ARG2, s_make_bytes);
+ for(i--;i >= 0;i--) dst[i] = INUM(n);
+ }
+ return res;
+}
+#define s_bytes (s_make_bytes+5)
+SCM scm_bytes(ints)
+ SCM ints;
+{
+ SCM res;
+ register unsigned char *data;
+ long i = ilength(ints);
+ ASRTER(i >= 0, ints, ARG1, s_bytes);
+ res = makstr(i);
+ data = UCHARS(res);
+ for(;NNULLP(ints);ints = CDR(ints)) {
+ int n = INUM(CAR(ints));
+ ASRTER(INUMP(CAR(ints)) && 0 <= n && n <= 255, ints, ARG1, s_bytes);
+ *data++ = n;
+ }
+ return res;
+}
+static char s_bt_ref[] = "byte-ref";
+SCM scm_byte_ref(str, k)
+ SCM str, k;
+{
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bt_ref);
+ ASRTER(INUMP(k), k, ARG2, s_bt_ref);
+ ASRTER(0 <= INUM(k) && INUM(k) < LENGTH(str), k, OUTOFRANGE, s_bt_ref);
+ return MAKINUM(UCHARS(str)[INUM(k)]);
+}
+static char s_bt_set[] = "byte-set!";
+SCM scm_byte_set(str, k, n)
+ SCM str, k, n;
+{
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bt_set);
+ ASRTER(INUMP(k), k, ARG2, s_bt_set);
+ ASRTER(INUMP(n), n, ARG3, s_bt_set);
+ ASRTER(0 <= INUM(k) && INUM(k) < LENGTH(str), k, OUTOFRANGE, s_bt_set);
+ UCHARS(str)[INUM(k)] = INUM(n);
+ return UNSPECIFIED;
+}
+static char s_bytes2list[] = "bytes->list";
+SCM scm_bytes2list(str)
+ SCM str;
+{
+ long i;
+ SCM res = EOL;
+ unsigned char *src;
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bytes2list);
+ src = UCHARS(str);
+ for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKINUM(src[i]), res);
+ return res;
+}
+static char s_bt_reverse[] = "bytes-reverse!";
+SCM scm_bytes_reverse(str)
+ SCM str;
+{
+ register char *dst;
+ register long k, len;
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_bt_reverse);
+ len = LENGTH(str);
+ dst = CHARS(str);
+ for(k = len/2;k >= 0;k--) {
+ int tmp = dst[k];
+ dst[k] = dst[len - k - 1];
+ dst[len - k - 1] = tmp;
+ }
+ return str;
+}
+static char s_write_byte[] = "write-byte";
+SCM scm_write_byte(chr, port)
+ SCM chr, port;
+{
+ int k = INUM(chr);
+ if UNBNDP(port) port = cur_outp;
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_byte);
+ ASRTER(INUMP(chr) && 0 <= k && k <= 255, chr, ARG1, s_write_byte);
+ lputc(k, port);
+ return UNSPECIFIED;
+}
+static char s_read_byte[] = "read-byte";
+SCM scm_read_byte(port)
+ SCM port;
+{
+ int c;
+ if UNBNDP(port) port = cur_inp;
+ ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_byte);
+ c = lgetc(port);
+ if (EOF==c) return EOF_VAL;
+ return MAKINUM(c);
+}
+
+static char s_sub_rd[] = "substring-read!";
+SCM scm_substring_read(sstr, start, args)
+ SCM sstr, start, args;
+{
+ SCM end, port;
+ long len;
+ long alen = ilength(args);
+ ASRTER(1 <= alen && alen <= 2, args, WNA, s_sub_rd);
+ end = CAR(args);
+ port = (2==alen) ? CAR(CDR(args)) : cur_inp;
+ ASRTER(NIMP(sstr) && STRINGP(sstr), sstr, ARG1, s_sub_rd);
+ ASRTER(INUMP(start), start, ARG2, s_sub_rd);
+ ASRTER(INUMP(end), end, ARG3, s_sub_rd);
+ ASRTER(NIMP(port) && OPINFPORTP(port), port, ARG4, s_sub_rd);
+ len = LENGTH(sstr);
+ start = INUM(start);
+ end = INUM(end);
+ ASRTER(0 <= start && start <= len, MAKINUM(start), OUTOFRANGE, s_sub_rd);
+ ASRTER(0 <= end && end <= len, MAKINUM(end), OUTOFRANGE, s_sub_rd);
+ if (start==end) return INUM0;
+ if (start < end) {
+ long ans = 0;
+ /* An ungetc before an fread will not work on some systems if setbuf(0),
+ so we read one element char by char. */
+ if CRDYP(port) {
+ CHARS(sstr)[start] = lgetc(port);
+ start += 1;
+ len -= 1;
+ ans = 1;
+ }
+ SYSCALL(ans += fread(CHARS(sstr)+start,
+ (sizet)1,
+ (sizet)(end - start),
+ STREAM(port)););
+ return MAKINUM(ans);
+ }
+ else {
+ long idx = start;
+ while (end <= idx) {
+ int chr = lgetc(port);
+ if (EOF==chr) return MAKINUM(start - idx);
+ CHARS(sstr)[--idx] = chr;
+ }
+ return MAKINUM(start - end);
+ }
+}
+
+static char s_sub_wr[] = "substring-write";
+SCM scm_substring_write(sstr, start, args)
+ SCM sstr, start, args;
+{
+ SCM end, port;
+ long len;
+ long alen = ilength(args);
+ ASRTER(1 <= alen && alen <= 2, args, WNA, s_sub_wr);
+ end = CAR(args);
+ port = (2==alen) ? CAR(CDR(args)) : cur_outp;
+ ASRTER(NIMP(sstr) && STRINGP(sstr), sstr, ARG1, s_sub_wr);
+ ASRTER(INUMP(start), start, ARG2, s_sub_wr);
+ ASRTER(INUMP(end), end, ARG3, s_sub_wr);
+ ASRTER(NIMP(port) && OPOUTFPORTP(port), port, ARG4, s_sub_wr);
+ len = LENGTH(sstr);
+ start = INUM(start);
+ end = INUM(end);
+ ASRTER(0 <= start && start <= len, MAKINUM(start), OUTOFRANGE, s_sub_wr);
+ ASRTER(0 <= end && end <= len, MAKINUM(end), OUTOFRANGE, s_sub_wr);
+ if (start==end) return INUM0;
+ if (start < end) {
+ long ans;
+ SYSCALL(ans = lfwrite(CHARS(sstr)+start,
+ (sizet)1,
+ (sizet)(sizet)(end - start),
+ port););
+ return MAKINUM(ans);
+ }
+ else {
+ long idx = start;
+ while (end <= --idx) {
+ if (feof(STREAM(port))) return MAKINUM(start - idx - 1);
+ lputc(CHARS(sstr)[idx], port);
+ }
+ return MAKINUM(start - end);
+ }
+}
+
+static iproc subr1s[] = {
+ {"list->bytes", scm_bytes},
+ {s_bytes2list, scm_bytes2list},
+ {s_bt_reverse, scm_bytes_reverse},
+ {0, 0}};
+
+static iproc subr2os[] = {
+ {s_write_byte, scm_write_byte},
+ {s_make_bytes, scm_make_bytes},
+ {0, 0}};
+
+static iproc lsubr2s[] = {
+ {s_sub_rd, scm_substring_read},
+ {s_sub_wr, scm_substring_write},
+ {0, 0}};
+
+
+void init_byte()
+{
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2os, tc7_subr_2o);
+ init_iprocs(lsubr2s, tc7_lsubr_2);
+ make_subr(s_bytes, tc7_lsubr, scm_bytes);
+ make_subr(s_read_byte, tc7_subr_1o, scm_read_byte);
+ make_subr(s_bt_ref, tc7_subr_2, scm_byte_ref);
+ make_subr(s_bt_set, tc7_subr_3, scm_byte_set);
+ add_feature("byte");
+ scm_ldstr("\n\
+(define bytes-length string-length)\n\
+(define bytes-copy string-copy)\n\
+(define (bytes-reverse bytes)\n\
+ (bytes-reverse! (bytes-copy bytes)))\n\
+(define (read-bytes n . port)\n\
+ (let* ((len (abs n))\n\
+ (byts (make-bytes len))\n\
+ (cnt (if (positive? n)\n\
+ (apply substring-read! byts 0 n port)\n\
+ (apply substring-read! byts (- n) 0 port))))\n\
+ (if (= cnt len)\n\
+ byts\n\
+ (if (positive? n)\n\
+ (substring byts 0 cnt)\n\
+ (substring byts (- len cnt) len)))))\n\
+(define (write-bytes bytes n . port)\n\
+ (if (positive? n)\n\
+ (apply substring-write bytes 0 n port)\n\
+ (apply substring-write bytes (- n) 0 port)))\n\
+");
+}
diff --git a/compile.scm b/compile.scm
index ce96822..1242231 100755
--- a/compile.scm
+++ b/compile.scm
@@ -44,13 +44,18 @@
;;;; "compile.scm", Compile C ==> Scheme ==> object-file.
;;; Author: Aubrey Jaffer.
-(define (go-script)
- (cond ((not *script*))
- ((and (<= 1 (- (length *argv*) *optind*))
- (not (eqv? #\- (string-ref (car (list-tail *argv* *optind*)) 0))))
- (apply compile-file (list-tail *argv* *optind*)))
- (else
- (display "\
+(require-if 'compiling 'hobbit)
+(require-if 'compiling 'glob)
+(require-if 'compiling 'build)
+
+(define (compile.scm args)
+ (cond ((and (<= 1 (length args))
+ (not (eqv? #\- (string-ref (car args) 0))))
+ (apply compile-file args))
+ (else (compile.usage))))
+
+(define (compile.usage)
+ (display "\
\
Usage: compile.scm FILE1.scm FILE2.scm ...
\
@@ -58,9 +63,11 @@ Usage: compile.scm FILE1.scm FILE2.scm ...
FILE1<object-suffix>, where <object-suffix> is the object file suffix
for your computer (for instance, `.o'). FILE1.scm must be in the
current directory; FILE2.scm ... can be in other directories.
+
+http://swissnet.ai.mit.edu/~jaffer/SCM
"
- (current-error-port))
- (exit #f))))
+ (current-error-port))
+ #f)
;;; This unusual autoload loads either the
;;; source or compiled version if present.
@@ -69,44 +76,53 @@ Usage: compile.scm FILE1.scm FILE2.scm ...
(require 'hobbit)
(apply hobbit args)))
+(define (find-option-file file)
+ (let ((opt file))
+ (if (file-exists? opt)
+ (list "-f" opt)
+ '())))
+;@
(define (compile-file file . args)
+ (define sfs (scheme-file-suffix))
(require 'glob)
(apply hobbit file args)
(let ((command
- (list "build"
- "-hsystem"
- "-tdll"
- (string-append "--compiler-options=-I" (implementation-vicinity))
- "-c" (replace-suffix file (scheme-file-suffix) ".c"))))
+ (apply list
+ "build"
+ "-hsystem"
+ "-tdll"
+ (string-append "--compiler-options=-I" (implementation-vicinity))
+ "-c" (replace-suffix file sfs ".c")
+ (find-option-file (replace-suffix file sfs ".opt")))))
(require 'build)
(cond ((>= (verbose) 3) (write command) (newline)))
(build-from-whole-argv command)))
-
-(define (compile->executable name . args)
+;@
+(define (compile->executable exename . files)
(define sfs (scheme-file-suffix))
(require 'glob)
- (for-each hobbit args)
+ (for-each hobbit files)
(let ((inits (map (lambda (file)
(string-append "-iinit_" (replace-suffix file sfs "")))
- args))
+ files))
(files (map (lambda (file)
(string-append "-c" (replace-suffix file sfs ".c")))
- args)))
+ files)))
(define command (append (list "build"
"-hsystem"
"--type=exe"
- "-o" name
+ "-o" exename
"-F" "compiled-closure" "inexact"
(string-append "--linker-options=-L"
(implementation-vicinity)))
+ (find-option-file (string-append exename ".opt"))
files
inits))
(require 'build)
(cond ((>= (verbose) 3) (write command) (newline)))
(build-from-whole-argv command)))
-(go-script)
-
;;; Local Variables:
;;; mode:scheme
;;; End:
+(and *script* (exit (compile.scm (list-tail *argv* *optind*))))
diff --git a/continue.h b/continue.h
index 42a5ff5..040b4b5 100644
--- a/continue.h
+++ b/continue.h
@@ -98,7 +98,10 @@
# endif
#endif
#ifdef MSDOS
-# define SHORT_ALIGN
+# ifndef _M_ARM
+/* arm processors need DWORD aligned data access */
+# define SHORT_ALIGN
+# endif
#endif
#ifdef atarist
# define SHORT_ALIGN
diff --git a/crs.c b/crs.c
index 665b0bd..0b4fe5f 100644
--- a/crs.c
+++ b/crs.c
@@ -47,7 +47,11 @@
#ifdef __FreeBSD__
# include <ncurses.h>
#else
-# include <curses.h>
+# ifdef __NetBSD__
+# include <ncurses.h>
+# else
+# include <curses.h>
+# endif
#endif
#ifdef MWC
@@ -128,13 +132,13 @@ SCM lnewwin(lines, cols, args)
{
SCM begin_y, begin_x;
WINDOW *win;
- ASSERT(INUMP(lines), lines, ARG1, s_newwin);
- ASSERT(INUMP(cols), cols, ARG2, s_newwin);
- ASSERT(2==ilength(args), args, WNA, s_newwin);
+ ASRTER(INUMP(lines), lines, ARG1, s_newwin);
+ ASRTER(INUMP(cols), cols, ARG2, s_newwin);
+ ASRTER(2==ilength(args), args, WNA, s_newwin);
begin_y = CAR(args);
begin_x = CAR(CDR(args));
- ASSERT(INUMP(begin_y), begin_y, ARG3, s_newwin);
- ASSERT(INUMP(begin_x), begin_y, ARG4, s_newwin);
+ ASRTER(INUMP(begin_y), begin_y, ARG3, s_newwin);
+ ASRTER(INUMP(begin_x), begin_y, ARG4, s_newwin);
win = newwin(INUM(lines), INUM(cols),
INUM(begin_y), INUM(begin_x));
return mkwindow(win);
@@ -143,9 +147,9 @@ SCM lnewwin(lines, cols, args)
SCM lmvwin(win, y, x)
SCM win, y, x;
{
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_mvwin);
- ASSERT(INUMP(x), x, ARG2, s_mvwin);
- ASSERT(INUMP(y), y, ARG3, s_mvwin);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_mvwin);
+ ASRTER(INUMP(x), x, ARG2, s_mvwin);
+ ASRTER(INUMP(y), y, ARG3, s_mvwin);
return ERR==mvwin(WIN(win), INUM(y), INUM(x)) ? BOOL_F : BOOL_T;
}
@@ -154,16 +158,16 @@ SCM lsubwin(win, lines, args)
{
SCM cols, begin_y, begin_x;
WINDOW *nwin;
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_subwin);
- ASSERT(INUMP(lines), lines, ARG2, s_subwin);
- ASSERT(3==ilength(args), args, WNA, s_subwin);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_subwin);
+ ASRTER(INUMP(lines), lines, ARG2, s_subwin);
+ ASRTER(3==ilength(args), args, WNA, s_subwin);
cols = CAR(args);
args = CDR(args);
begin_y = CAR(args);
begin_x = CAR(CDR(args));
- ASSERT(INUMP(cols), cols, ARG3, s_subwin);
- ASSERT(INUMP(begin_y), begin_y, ARG3, s_subwin);
- ASSERT(INUMP(begin_x), begin_y, ARG4, s_subwin);
+ ASRTER(INUMP(cols), cols, ARG3, s_subwin);
+ ASRTER(INUMP(begin_y), begin_y, ARG3, s_subwin);
+ ASRTER(INUMP(begin_x), begin_y, ARG4, s_subwin);
nwin = subwin(WIN(win), INUM(lines), INUM(cols),
INUM(begin_y), INUM(begin_x));
return mkwindow(nwin);
@@ -172,16 +176,16 @@ SCM lsubwin(win, lines, args)
SCM loverlay(srcwin, dstwin)
SCM srcwin, dstwin;
{
- ASSERT(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overlay);
- ASSERT(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overlay);
+ ASRTER(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overlay);
+ ASRTER(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overlay);
return ERR==overlay(WIN(srcwin), WIN(dstwin)) ? BOOL_F : BOOL_T;
}
SCM loverwrite(srcwin, dstwin)
SCM srcwin, dstwin;
{
- ASSERT(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overwrite);
- ASSERT(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overwrite);
+ ASRTER(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overwrite);
+ ASRTER(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overwrite);
return ERR==overwrite(WIN(srcwin), WIN(dstwin)) ? BOOL_F : BOOL_T;
}
@@ -190,31 +194,31 @@ static char s_wmove[] = "wmove", s_wadd[] = "wadd", s_winsch[] = "winsch",
SCM lwmove(win, y, x)
SCM win, y, x;
{
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_wmove);
- ASSERT(INUMP(x), x, ARG2, s_wmove);
- ASSERT(INUMP(y), y, ARG3, s_wmove);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_wmove);
+ ASRTER(INUMP(x), x, ARG2, s_wmove);
+ ASRTER(INUMP(y), y, ARG3, s_wmove);
return ERR==wmove(WIN(win), INUM(y), INUM(x)) ? BOOL_F : BOOL_T;
}
SCM lwadd(win, obj)
SCM win, obj;
{
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_wadd);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_wadd);
if ICHRP(obj)
return ERR==waddch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T;
if INUMP(obj)
return ERR==waddch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T;
- ASSERT(NIMP(obj) && STRINGP(obj), obj, ARG2, s_wadd);
+ ASRTER(NIMP(obj) && STRINGP(obj), obj, ARG2, s_wadd);
return ERR==waddstr(WIN(win), CHARS(obj)) ? BOOL_F : BOOL_T;
}
SCM lwinsch(win, obj)
SCM win, obj;
{
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winsch);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_winsch);
if INUMP(obj)
return ERR==winsch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T;
- ASSERT(ICHRP(obj), obj, ARG2, s_winsch);
+ ASRTER(ICHRP(obj), obj, ARG2, s_winsch);
return ERR==winsch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T;
}
@@ -222,15 +226,15 @@ SCM lbox(win, vertch, horch)
SCM win, vertch, horch;
{
int v, h;
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_box);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_box);
if INUMP(vertch) v = INUM(vertch);
else {
- ASSERT(ICHRP(vertch), vertch, ARG2, s_box);
+ ASRTER(ICHRP(vertch), vertch, ARG2, s_box);
v = ICHR(vertch);
}
if INUMP(horch) h = INUM(horch);
else {
- ASSERT(ICHRP(horch), horch, ARG3, s_box);
+ ASRTER(ICHRP(horch), horch, ARG3, s_box);
h = ICHR(horch);
}
return ERR==box(WIN(win), v, h) ? BOOL_F : BOOL_T;
@@ -241,7 +245,7 @@ SCM lgetyx(win)
SCM win;
{
int y, x;
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_getyx);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_getyx);
getyx(WIN(win), y, x);
return cons2(MAKINUM(y), MAKINUM(x), EOL);
}
@@ -249,14 +253,14 @@ SCM lgetyx(win)
SCM lwinch(win)
SCM win;
{
- ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winch);
+ ASRTER(NIMP(win) && WINP(win), win, ARG1, s_winch);
return MAKICHR(winch(WIN(win)));
}
SCM lunctrl(c)
SCM c;
{
- ASSERT(ICHRP(c), c, ARG1, s_unctrl);
+ ASRTER(ICHRP(c), c, ARG1, s_unctrl);
{
char *str = unctrl(ICHR(c));
return makfrom0str(str);
@@ -268,7 +272,7 @@ SCM owidth(arg)
SCM arg;
{
if UNBNDP(arg) arg = cur_outp;
- ASSERT(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth);
+ ASRTER(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth);
if NIMP(*loc_stdscr)
if WINP(arg) return MAKINUM(WIN(arg)->_maxx+1);
else return MAKINUM(COLS);
@@ -278,7 +282,7 @@ SCM oheight(arg)
SCM arg;
{
if UNBNDP(arg) arg = cur_outp;
- ASSERT(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth);
+ ASRTER(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth);
if NIMP(*loc_stdscr)
if WINP(arg) return MAKINUM(WIN(arg)->_maxy+1);
else return MAKINUM(LINES);
@@ -322,7 +326,7 @@ static iproc subr0s[] = {
#define SUBRW(ln, n, s_n, sn) static char s_n[]=sn;\
SCM ln(w)SCM w;\
- {ASSERT(NIMP(w) && WINP(w), w, ARG1, sn);\
+ {ASRTER(NIMP(w) && WINP(w), w, ARG1, sn);\
return ERR==n(WIN(w))?BOOL_F:BOOL_T;}
SUBRW(lwerase, werase, s_werase, "werase")
@@ -356,7 +360,7 @@ static iproc subr1s[] = {
#define SUBROPT(ln, n, s_n, sn) static char s_n[]=sn;\
SCM ln(w, b)SCM w, b;\
- {ASSERT(NIMP(w) && WINP(w), w, ARG1, sn);\
+ {ASRTER(NIMP(w) && WINP(w), w, ARG1, sn);\
return ERR==n(WIN(w), BOOL_F != b)?BOOL_F:BOOL_T;}
SUBROPT(lidlok, idlok, s_idlok, "idlok")
@@ -369,7 +373,7 @@ static char s_clearok[] = "clearok";
SCM lclearok(w, b) SCM w, b;
{
if (BOOL_T==w) return ERR==clearok(curscr, BOOL_F != b)?BOOL_F:BOOL_T;
- ASSERT(NIMP(w) && WINP(w), w, ARG1, s_clearok);
+ ASRTER(NIMP(w) && WINP(w), w, ARG1, s_clearok);
return ERR==clearok(WIN(w), BOOL_F != b)?BOOL_F:BOOL_T;
}
diff --git a/debug.c b/debug.c
index 22c387b..aff8251 100644
--- a/debug.c
+++ b/debug.c
@@ -82,7 +82,7 @@ SCM scm_env_rlookup(addr, stenv, what)
for (env = stenv; NIMP(env); env = CDR(env)) {
fr = CAR(env);
if (INUMP(fr)) {
- ASSERT(NIMP(env) && CONSP(env), stenv, s_badenv, what);
+ ASRTER(NIMP(env) && CONSP(env), stenv, s_badenv, what);
env = CDR(env);
continue;
}
@@ -122,7 +122,7 @@ SCM scm_env_getprop(prop, env)
if (INUMP(CAR(e))) {
if (CAR(e)==prop) return CDR(e);
e = CDR(e);
- ASSERT(NIMP(e), env, s_badenv, "env_getprop");
+ ASRTER(NIMP(e), env, s_badenv, "env_getprop");
}
e = CDR(e);
}
@@ -348,7 +348,7 @@ SCM scm_int2linum(n)
SCM n;
{
int i = INUM(n);
- ASSERT(INUMP(n) && i >= 0, n, ARG1, s_int2linum);
+ ASRTER(INUMP(n) && i >= 0, n, ARG1, s_int2linum);
return SCM_MAKE_LINUM(i);
}
@@ -356,7 +356,7 @@ static char s_linum2int[] = "line-number->integer";
SCM scm_linum2int(linum)
SCM linum;
{
- ASSERT(SCM_LINUMP(linum), linum, ARG1, s_linum2int);
+ ASRTER(SCM_LINUMP(linum), linum, ARG1, s_linum2int);
return MAKINUM(SCM_LINUM(linum));
}
@@ -490,7 +490,7 @@ SCM scm_stack_trace(contin)
}
else {
CONTINUATION *cont;
- ASSERT(NIMP(contin) && (tc7_contin==TYP7(contin)), contin, ARG1,
+ ASRTER(NIMP(contin) && (tc7_contin==TYP7(contin)), contin, ARG1,
s_stack_trace);
cont = CONT(contin);
estk = cont->other.estk;
@@ -504,9 +504,9 @@ SCM scm_frame_trace(contin, nf)
SCM contin, nf;
{
SCM *stkframe, code, env;
- ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+ ASRTER(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
s_frame_trace);
- ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_trace);
+ ASRTER(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_trace);
if (!(stkframe = cont_frame(contin, INUM(nf))))
return BOOL_F;
env = stkframe[2];
@@ -521,9 +521,9 @@ SCM scm_frame2env(contin, nf)
SCM contin, nf;
{
SCM *stkframe;
- ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+ ASRTER(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
s_frame2env);
- ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame2env);
+ ASRTER(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame2env);
if (!(stkframe = cont_frame(contin, INUM(nf))))
return BOOL_F;
return stkframe[2];
@@ -534,9 +534,9 @@ SCM scm_frame_eval(contin, nf, expr)
SCM contin, nf, expr;
{
SCM res, env, *stkframe;
- ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+ ASRTER(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
s_frame_eval);
- ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_eval);
+ ASRTER(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_eval);
if (!(stkframe = cont_frame(contin, INUM(nf))))
return BOOL_F;
env = stkframe[2];
diff --git a/dynl.c b/dynl.c
index d965840..a1a0c37 100644
--- a/dynl.c
+++ b/dynl.c
@@ -73,7 +73,7 @@ SCM l_dyn_link(fname)
SCM fname;
{
int status;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
DEFER_INTS;
status = dld_link(CHARS(fname));
ALLOW_INTS;
@@ -89,7 +89,7 @@ SCM l_dyn_call(symb, shl)
int i;
void (*func)() = 0;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
DEFER_INTS;
if ((i = dld_function_executable_p(CHARS(symb))))
func = (void (*) ()) dld_get_func(CHARS(symb));
@@ -113,7 +113,7 @@ SCM l_dyn_main_call(symb, shl, args)
int (*func)(int argc, char **argv) = 0;
char **argv;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
DEFER_INTS;
argv = makargvfrmstrs(args, s_main_call);
if ((i = dld_function_executable_p(CHARS(symb))))
@@ -141,7 +141,7 @@ SCM l_dyn_unlink(fname)
SCM fname;
{
int status;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_unlink);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_unlink);
DEFER_INTS;
status = dld_unlink_by_file(CHARS(fname), 1);
ALLOW_INTS;
@@ -194,7 +194,7 @@ SCM l_dyn_link(fname)
{
SCM z;
shl_t shl;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
shl = shl_load(CHARS(fname), BIND_DEFERRED , 0L);
@@ -214,8 +214,8 @@ SCM l_dyn_call(symb, shl)
void (*func)() = 0;
int i;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
if ((i = shl_findsym(P_SHL(shl),
CHARS(symb),
@@ -238,8 +238,8 @@ SCM l_dyn_main_call(symb, shl, args)
int (*func)P((int argc, char **argv)) = 0;
char **argv;
/* 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);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
if ((i = shl_findsym(P_SHL(shl),
CHARS(symb),
@@ -263,7 +263,7 @@ SCM l_dyn_unlink(shl)
SCM shl;
{
int status;
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
status = shl_unload(SHL(shl));
ALLOW_INTS;
@@ -318,9 +318,9 @@ SCM dynl(dir, symbol, fname)
struct dsc$descriptor fnamed, symbold, dird;
void (*fcn)();
long retval;
- ASSERT(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl);
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl);
- ASSERT(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl);
+ ASRTER(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl);
+ ASRTER(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl);
descriptorize(&fnamed, fname);
descriptorize(&symbold, symbol);
DEFER_INTS;
@@ -393,7 +393,7 @@ SCM l_dyn_link(fname)
SCM z;
void *handle;
if FALSEP(fname) return fname;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
handle = dlopen(CHARS(fname), DLOPEN_MODE);
@@ -421,8 +421,8 @@ SCM l_dyn_call(symb, shl)
{
void (*func)() = 0;
/* SCM oloadpath = *loc_loadpath; */
- ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
@@ -450,8 +450,8 @@ SCM l_dyn_main_call(symb, shl, args)
int (*func)P((int argc, char **argv)) = 0;
char **argv;
/* 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);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
@@ -481,7 +481,7 @@ SCM l_dyn_unlink(shl)
SCM shl;
{
int status;
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
status = dlclose(SHL(shl));
SETCHARS(shl, NULL);
@@ -549,7 +549,7 @@ SCM l_dyn_link(fname)
Str255 errMessage;
if FALSEP(fname) return fname;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
strcpy((char *)libName, CHARS(fname));
@@ -577,8 +577,8 @@ SCM l_dyn_call(symb, shl)
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);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
strcpy((char *)symName, CHARS(symb));
@@ -609,8 +609,8 @@ SCM l_dyn_main_call(symb, shl, args)
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);
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
strcpy((char *)symName, CHARS(symb));
c2pstr((char *)symName);
@@ -640,7 +640,7 @@ SCM l_dyn_unlink(shl)
OSErr status;
CFragConnectionID connID;
- ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
connID = (CFragConnectionID)SHL(shl);
status = CloseConnection(&connID);
@@ -665,3 +665,106 @@ void init_dynl()
}
}
#endif /* MACOS */
+
+#ifdef _WIN32
+# include <windows.h>
+# define SHL(obj) ((HINSTANCE)(CDR(obj)))
+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, free0, prinshl};
+
+static char s_link[] = "dyn:link";
+SCM scm_dyn_link(fname)
+ SCM fname;
+{
+ SCM z, shl = BOOL_F;
+ HINSTANCE hshl;
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ NEWCELL(z);
+ DEFER_INTS;
+ hshl = LoadLibrary(CHARS(fname));
+ if (hshl) {
+ SETCHARS(z, hshl);
+ CAR(z) = tc16_shl;
+ shl = z;
+ }
+ ALLOW_INTS;
+ return shl;
+}
+
+static char s_unlink[] = "dyn:unlink";
+SCM scm_dyn_unlink(shl)
+ SCM shl;
+{
+ BOOL status;
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ DEFER_INTS;
+ status = FreeLibrary(SHL(shl));
+ ALLOW_INTS;
+ return status ? BOOL_T : BOOL_F;
+}
+
+static char s_call[] = "dyn:call";
+SCM scm_dyn_call(symb, shl)
+ SCM symb, shl;
+{
+ FARPROC func;
+ int i;
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ DEFER_INTS;
+ func = GetProcAddress(SHL(shl), CHARS(symb));
+ ALLOW_INTS;
+ if (!func) return BOOL_F;
+ (*func) ();
+ return BOOL_T;
+}
+
+static char s_main_call[] = "dyn:main-call";
+SCM scm_dyn_main_call(symb, shl, args)
+ SCM symb, shl, args;
+{
+ int i;
+ FARPROC func;
+ char **argv;
+ ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+ DEFER_INTS;
+ func = GetProcAddress(SHL(shl), CHARS(symb));
+ if (!func) {
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ argv = makargvfrmstrs(args, s_main_call);
+ ALLOW_INTS;
+ i = (*func) ((int)ilength(args), argv);
+ DEFER_INTS;
+ must_free_argv(argv);
+ ALLOW_INTS;
+ return MAKINUM(0L+i);
+}
+
+static iproc subr1s[] = {
+ {s_link, scm_dyn_link},
+ {s_unlink, scm_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, scm_dyn_call);
+ make_subr(s_main_call, tc7_lsubr_2, scm_dyn_main_call);
+ add_feature("win32-dl");
+ }
+}
+#endif
diff --git a/edline.c b/edline.c
index d3a338a..e31207b 100644
--- a/edline.c
+++ b/edline.c
@@ -54,7 +54,7 @@ SCM lreadline(prompt)
{
SCM res;
char *s;
- ASSERT(NIMP(prompt) && STRINGP(prompt), prompt, ARG1, s_readline);
+ ASRTER(NIMP(prompt) && STRINGP(prompt), prompt, ARG1, s_readline);
s = readline(CHARS(prompt));
if (NULL == s) return EOF_VAL;
NEWCELL(res);
@@ -68,7 +68,7 @@ static char s_add_history[] = "add-history";
SCM ladd_history(line)
SCM line;
{
- ASSERT(NIMP(line) && STRINGP(line), line, ARG1, s_add_history);
+ ASRTER(NIMP(line) && STRINGP(line), line, ARG1, s_add_history);
add_history(CHARS(line));
return UNSPECIFIED;
}
diff --git a/eval.c b/eval.c
index 7b0e983..d5bba5f 100644
--- a/eval.c
+++ b/eval.c
@@ -45,8 +45,16 @@
#include "scm.h"
#include "setjump.h"
-#define I_SYM(x) (CAR((x)-1L))
-#define I_VAL(x) (CDR((x)-1L))
+#ifdef _M_ARM
+/* The Microsoft CLARM compiler has a bug in pointer arithmetic.
+ It doesn't always take into account that data acceses have to be
+ DWORD aligned. The MS_CLARM_dumy assignment resolves this problem. */
+# define I_SYM(x) (CAR((SCM)(MS_CLARM_dumy = (x)-1L)))
+# define I_VAL(x) (CDR((SCM)(MS_CLARM_dumy = (x)-1L)))
+#else
+# define I_SYM(x) (CAR((x)-1L))
+# define I_VAL(x) (CDR((x)-1L))
+#endif
#define ATOMP(x) (5==(5 & (int)CAR(x)))
#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x, 0):ceval_1(CAR(x)))
#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
@@ -103,7 +111,7 @@
#endif
#define EXTEND_ENV cons
-SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED;
+SCM scm_env, scm_env_tmp;
long tc16_env; /* Type code for environments passed to macro
transformers. */
@@ -221,8 +229,7 @@ static void debug_env_save P((char *fnam, int line));
#endif
#ifndef RECKLESS
-SCM scm_trace = BOOL_F;
-SCM scm_trace_env = EOL;
+SCM scm_trace, scm_trace_env;
#endif
#define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;}
#define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;}
@@ -250,8 +257,8 @@ long tc16_macro; /* Type code for macros */
#define MAC_MACRO 0x8L
#define MAC_MMACRO 0x2L
#define MAC_IDMACRO 0x6L
-/* uncomment this to experiment with inline procedures
- #define MAC_INLINE 0x10L */
+/* Uncomment this to experiment with inline procedures: */
+/* #define MAC_INLINE 0x10L */
#ifdef MACRO
long tc16_ident; /* synthetic macro identifier */
@@ -272,11 +279,16 @@ 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 ev = make_uve(sizeof(eval_cases)/sizeof(long),
+ MAKINUM(-8L*sizeof(long)));
+ SCM evo = make_uve(sizeof(eval_cases_other)/sizeof(long),
+ MAKINUM(-8L*sizeof(long)));
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);
+ MAKINUM(-8L*sizeof(long)),
+ EOL);
+ SCM evc = dims2ura(cons2(MAKINUM(5), MAKINUM(4), EOL),
+ MAKINUM(-8L*sizeof(long)),
+ EOL);
long *v = (long *)VELTS(ev);
int i;
for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++)
@@ -291,14 +303,14 @@ SCM scm_profile(resetp)
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;
+ 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));
}
@@ -540,7 +552,7 @@ static SCM *lookupcar(vloc)
#endif
else { /* global ref */
#ifdef MACRO
- ASSERT(SYMBOLP(addr), var, s_escaped, "");
+ ASRTER(SYMBOLP(addr), var, s_escaped, "");
#endif
val = sym2vcell(addr);
addr = val + tc3_cons_gloc;
@@ -549,7 +561,7 @@ static SCM *lookupcar(vloc)
ASRTGO(!KEYWORDP(*pv), badkey);
#endif
}
- ASSERT(!UNBNDP(*pv) && undefineds != *pv, var, s_unbnd, "");
+ ASRTER(!UNBNDP(*pv) && undefineds != *pv, var, s_unbnd, "");
CAR(vloc) = addr;
return pv;
}
@@ -576,13 +588,13 @@ static SCM scm_lookupval(vloc, memo)
}
else { /* global ref */
#ifdef MACRO
- ASSERT(SYMBOLP(addr), var, s_escaped, "");
+ ASRTER(SYMBOLP(addr), var, s_escaped, "");
#endif
addr = sym2vcell(addr);
val = CDR(addr);
addr += tc3_cons_gloc;
}
- ASSERT(!UNBNDP(val) && val != undefineds, var, s_unbnd, "");
+ ASRTER(!UNBNDP(val) && val != undefineds, var, s_unbnd, "");
if (memo && !KEYWORDP(val)) /* Don't memoize forms to be macroexpanded. */
CAR(vloc) = addr;
return val;
@@ -643,7 +655,7 @@ SCM scm_multi_set(syms, vals)
SCM res = EOL, *pres = &res;
SCM *loc;
do {
- ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set);
+ ASRTER(NIMP(vals) && CONSP(vals), vals, WNA, s_set);
switch (7 & (int)(CAR(syms))) {
case 0:
loc = lookupcar(syms);
@@ -661,7 +673,7 @@ SCM scm_multi_set(syms, vals)
syms = CDR(syms);
vals = CDR(vals);
} while (NIMP(syms));
- ASSERT(NULLP(vals) && NULLP(syms), vals, WNA, s_set);
+ ASRTER(NULLP(vals) && NULLP(syms), vals, WNA, s_set);
return res;
}
@@ -743,7 +755,7 @@ static SCM toplevel_define(xorig, env)
{
SCM x = CDR(xorig);
SCM name = CAR(x);
- ASSERT(scm_nullenv_p(env), xorig, s_placement, s_define);
+ ASRTER(scm_nullenv_p(env), xorig, s_placement, s_define);
ENV_PUSH;
x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL);
x = evalcar(x);
@@ -845,7 +857,7 @@ SCM scm_values(arg1, arg2, rest, what)
char *what;
{
DEFER_INTS_EGC;
- ASSERT(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what);
+ ASRTER(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what);
if (! UNBNDP(arg2))
scm_env_cons(arg2, rest);
return arg1;
@@ -1051,7 +1063,7 @@ SCM m_case(xorig, env, ctxt)
while(NIMP(x = CDR(x))) {
clause = CAR(x);
s = scm_check_linum(clause, 0L);
- ASSYNT(ilength(clause) >= 2, clause /* xorig */, s_clauses, s_case);
+ ASSYNT(ilength(s) >= 2, clause /* xorig */, s_clauses, s_case);
clause = s;
if (TOPDENOTE_EQ(i_else, CAR(clause), env)) {
ASSYNT(NULLP(CDR(x)), xorig, s_bad_else_clause, s_case);
@@ -1165,7 +1177,7 @@ SCM m_lambda(xorig, env, ctxt)
SCM name, linum;
#endif
int argc;
- ASSERT(ilength(x) > 1, x, s_body, s_lambda);
+ ASRTER(ilength(x) > 1, x, s_body, s_lambda);
formals = CAR(x);
argc = varcheck(formals, IM_LAMBDA, s_formals);
formals = scm_check_linum(formals, 0L);
@@ -1219,8 +1231,8 @@ SCM m_inline_lambda(xorig, env)
SCM x = CDR(xorig);
SCM typ = (SCM)(tc16_macro | (MAC_INLINE << 16));
int depth = env_depth();
- ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda);
- ASSERT(ilength(CAR(x)) >= 0, xorig, s_formals, s_lambda);
+ ASRTER(ilength(x) > 1, xorig, s_formals, s_lambda);
+ ASRTER(ilength(CAR(x)) >= 0, xorig, s_formals, s_lambda);
varcheck(CAR(x), IM_LAMBDA, s_formals);
x = cons2(typ, MAKINUM((long)depth),
cons(CAR(x), m_body(CDR(x), env)));
@@ -1235,13 +1247,13 @@ int scm_nullenv_p(env)
SCM fr, e;
if (IMP(env)) return !0;
for (e = env; NIMP(e); e = CDR(e)) {
- ASSERT(CONSP(e), e, s_badenv, s_nullenv_p);
+ ASRTER(CONSP(e), e, s_badenv, s_nullenv_p);
fr = CAR(e);
if (IMP(fr)) {
if (NULLP(fr)) return 0;
if (INUMP(fr)) { /* These frames are for meta-data, not bindings. */
e = CDR(e);
- ASSERT(NIMP(e), env, s_badenv, s_nullenv_p);
+ ASRTER(NIMP(e), env, s_badenv, s_nullenv_p);
}
} else return 0;
}
@@ -1314,7 +1326,6 @@ SCM m_do(xorig, env, ctxt)
x = CDR(x);
test = scm_check_linum(CAR(x), 0L);
ASSYNT(ilength(test) >= 1, CAR(x), s_test, s_do);
- test = m_seq(test, env, ctxt);
if (IMP(CDR(test))) test = cons(CAR(test), list_unspecified);
ASSYNT(ilength(CDR(x))>=0, xorig, s_expression, s_do);
varcheck(vars, IM_DO, s_variable);
@@ -1396,7 +1407,7 @@ static SCM m_iqq(form, depth, env, ctxt)
if (0==depth) tmp = IM_UNQUOTE;
label:
form = CDR(form);
- ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
+ ASRTER(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
form, ARG1, s_quasiquote);
if (0!=depth)
form = cons(m_iqq(CAR(form), depth, env, ctxt), EOL);
@@ -1444,6 +1455,11 @@ static int built_inp(name, x)
return 0;
}
+extern char s_redefining[];
+#ifndef RECKLESS
+char s_built_in_syntax[] = "built-in syntax ";
+# define s_syntax (&s_built_in_syntax[9])
+#endif
static void checked_define(name, val, what)
SCM name, val;
char *what;
@@ -1451,7 +1467,7 @@ static void checked_define(name, val, what)
SCM old, vcell;
#ifdef MACRO
while (M_IDENTP(name)) {
- ASSERT(IMP(IDENT_ENV(name)), name, s_escaped, what);
+ ASRTER(IMP(IDENT_ENV(name)), name, s_escaped, what);
name = IDENT_PARENT(name);
}
#endif
@@ -1459,17 +1475,17 @@ static void checked_define(name, val, what)
old = CDR(vcell);
#ifndef RECKLESS
if ('@'==CHARS(name)[0] && UNDEFINED != old)
- scm_warn("redefining internal name ", "", name);
+ scm_warn(s_redefining, "internal name ", name);
if (KEYWORDP(old)) {
if (1 <= verbose && built_inp(name, KEYWORD_MACRO(old)))
- scm_warn("redefining built-in syntax ", "", name);
+ scm_warn(s_redefining, s_built_in_syntax, name);
else if (3 <= verbose)
- scm_warn("redefining syntax ", "", name);
+ scm_warn(s_redefining, s_syntax, name);
}
else if (2 <= verbose && built_inp(name, old) && (old != val))
- scm_warn("redefining built-in ", "", name);
+ scm_warn(s_redefining, "built-in ", name);
else if (5 <= verbose && UNDEFINED != old)
- scm_warn("redefining ", "", name);
+ scm_warn(s_redefining, "", name);
#endif
CDR(vcell) = val;
}
@@ -1594,7 +1610,7 @@ static SCM m_body(xorig, env, ctxt)
SCM xorig, env, ctxt;
{
SCM form, denv = env, x = xorig, defs = EOL;
- char *what = ISYMCHARS(CAR(xorig)) + 2;
+ char *what = 0; /* Should this be passed in? */
ASRTSYNTAX(ilength(xorig) >= 1, s_expression);
while NIMP(x) {
form = scm_check_linum(CAR(x), 0L);
@@ -1627,9 +1643,9 @@ static SCM m_body(xorig, env, ctxt)
}
}
#ifdef CAUTIOUS
- ASSYNT(ilength(x) > 0, x, s_body, what);
+ ASSYNT(ilength(x) > 0, xorig, s_body, what);
#else
- ASSYNT(ilength(x) > 0, CDR(xorig), s_body, what);
+ ASSYNT(ilength(x) > 0, xorig, s_body, what);
#endif
if (IMP(defs)) return x;
return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL);
@@ -2019,11 +2035,26 @@ SCM scm_eval_values(x, env, valenv)
return res;
}
+#ifdef __GNUC__
+# define GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__)
+/* __GNUC_PATCHLEVEL__ */
+# if 302 == GCC_VERSION
+# ifdef sparc
+# define GCC_SPARC_BUG
+# endif
+# endif
+#endif
+
static SCM ceval_1(x)
SCM x;
{
- union {SCM *lloc; SCM arg1;} t;
- SCM proc, arg2, arg3;
+#ifdef GCC_SPARC_BUG
+ SCM arg1;
+#else
+ struct {SCM arg_1;} t;
+# define arg1 t.arg_1
+#endif
+ SCM arg2, arg3, proc;
int envpp = 0; /* 1 means an environment has been pushed in this
invocation of ceval_1, -1 means pushed and then popped. */
#ifdef CAUTIOUS
@@ -2044,19 +2075,19 @@ static SCM ceval_1(x)
goto retx;
case (127 & IM_AND):
x = CDR(x);
- t.arg1 = x;
- while(NNULLP(t.arg1 = CDR(t.arg1)))
+ arg1 = x;
+ while(NNULLP(arg1 = CDR(arg1)))
if (FALSEP(EVALCAR(x))) {x = BOOL_F; goto retx;}
- else x = t.arg1;
+ else x = arg1;
goto carloop;
cdrxbegin:
case (127 & IM_BEGIN):
x = CDR(x);
begin:
- t.arg1 = x;
- while(NNULLP(t.arg1 = CDR(t.arg1))) {
+ arg1 = x;
+ while(NNULLP(arg1 = CDR(arg1))) {
if (NIMP(CAR(x))) ceval_1(CAR(x));
- x = t.arg1;
+ x = arg1;
}
carloop: /* eval car of last form in list */
if NCELLP(CAR(x)) {
@@ -2080,11 +2111,11 @@ static SCM ceval_1(x)
case (127 & IM_COND):
while(NIMP(x = CDR(x))) {
proc = CAR(x);
- t.arg1 = EVALCAR(proc);
- if NFALSEP(t.arg1) {
+ arg1 = EVALCAR(proc);
+ if NFALSEP(arg1) {
x = CDR(proc);
if NULLP(x) {
- x = t.arg1;
+ x = arg1;
goto retx;
}
if (IM_ARROW != CAR(x)) goto begin;
@@ -2106,8 +2137,8 @@ static SCM ceval_1(x)
x = CDR(CDR(x));
while (proc = CAR(x), FALSEP(EVALCAR(proc))) {
for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
- t.arg1 = CAR(proc); /* body */
- SIDEVAL_1(t.arg1);
+ arg1 = CAR(proc); /* body */
+ SIDEVAL_1(arg1);
}
ecache_evalx(CDR(CDR(x))); /* steps */
scm_env = CDR(scm_env);
@@ -2125,13 +2156,13 @@ static SCM ceval_1(x)
ENV_MAY_PUSH(envpp);
TRACE(x);
#ifdef MAC_INLINE
- t.arg1 = CAR(x);
+ arg1 = CAR(x);
#endif
x = CDR(x);
ecache_evalx(CAR(CDR(x)));
#ifdef MAC_INLINE
- if (t.arg1 != IM_LET) /* inline call */
- env_tail(ISYMVAL(t.arg1));
+ if (arg1 != IM_LET) /* inline call */
+ env_tail(ISYMVAL(arg1));
#endif
STATIC_ENV = CAR(x);
EXTEND_VALENV;
@@ -2171,11 +2202,11 @@ static SCM ceval_1(x)
goto cdrxbegin;
case (127 & IM_OR):
x = CDR(x);
- t.arg1 = x;
- while(NNULLP(t.arg1 = CDR(t.arg1))) {
+ arg1 = x;
+ while(NNULLP(arg1 = CDR(arg1))) {
x = EVALCAR(x);
if NFALSEP(x) goto retx;
- x = t.arg1;
+ x = arg1;
}
goto carloop;
case (127 & IM_LAMBDA):
@@ -2226,18 +2257,18 @@ static SCM ceval_1(x)
x = CDR(x);
proc = evalcar(x);
ASRTGO(NIMP(proc), badfun);
- t.arg1 = evalcar(CDR(x));
+ arg1 = evalcar(CDR(x));
if (CLOSUREP(proc)) {
ENV_MAY_PUSH(envpp);
TRACE(x);
- scm_env_tmp = t.arg1;
+ scm_env_tmp = arg1;
#ifndef RECKLESS
goto clo_checked;
#else
goto clo_unchecked;
#endif
}
- x = apply(proc, t.arg1, EOL);
+ x = apply(proc, arg1, EOL);
goto retx;
case (ISYMNUM(IM_DELAY)):
x = makprom(closure(CDR(x), 0));
@@ -2338,13 +2369,13 @@ static SCM ceval_1(x)
#ifdef CAUTIOUS
if (0!=ARGC(proc)) {
clo_checked:
- t.arg1 = SCM_ENV_FORMALS(CAR(CODE(proc)));
+ arg1 = SCM_ENV_FORMALS(CAR(CODE(proc)));
DEFER_INTS_EGC;
arg2 = scm_env_tmp;
- while NIMP(t.arg1) {
- if NCONSP(t.arg1) goto clo_unchecked;
+ while NIMP(arg1) {
+ if NCONSP(arg1) goto clo_unchecked;
if IMP(arg2) goto umwrongnumargs;
- t.arg1 = CDR(t.arg1);
+ arg1 = CDR(arg1);
arg2 = CDR(arg2);
}
if NNULLP(arg2) goto umwrongnumargs;
@@ -2364,7 +2395,7 @@ static SCM ceval_1(x)
/* default: break; */
#ifdef CCLO
case tc16_cclo:
- t.arg1 = proc;
+ arg1 = proc;
proc = CCLO_SUBR(proc);
goto evap1;
#endif
@@ -2400,77 +2431,77 @@ static SCM ceval_1(x)
if (IMP(x))
goto wrongnumargs;
#endif
- t.arg1 = EVALCAR(x);
+ arg1 = EVALCAR(x);
x = CDR(x);
if NULLP(x) {
TOP_TRACE(xorig, STATIC_ENV);
evap1:
ENV_MAY_POP(envpp, CLOSUREP(proc));
ALLOW_INTS_EGC;
- switch TYP7(proc) { /* have one argument in t.arg1 */
+ switch TYP7(proc) { /* have one argument in arg1 */
case tc7_subr_2o:
- return SUBRF(proc)(t.arg1, UNDEFINED);
+ return SUBRF(proc)(arg1, UNDEFINED);
case tc7_subr_1:
case tc7_subr_1o:
- return SUBRF(proc)(t.arg1);
+ return SUBRF(proc)(arg1);
case tc7_cxr:
#ifdef FLOATS
if SUBRF(proc) {
- if INUMP(t.arg1)
- return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0);
- ASRTGO(NIMP(t.arg1), floerr);
- if REALP(t.arg1)
- return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0);
+ if INUMP(arg1)
+ return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
+ ASRTGO(NIMP(arg1), floerr);
+ if REALP(arg1)
+ return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
# ifdef BIGDIG
- if BIGP(t.arg1)
- return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0);
+ if BIGP(arg1)
+ return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
# endif
floerr:
- wta(t.arg1, (char *)ARG1, SNAME(proc));
+ wta(arg1, (char *)ARG1, SNAME(proc));
}
#endif
{
int op = CXR_OP(proc);
#ifndef RECKLESS
- x = t.arg1;
+ x = arg1;
#endif
while (op) {
- ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
+ ASRTER(NIMP(arg1) && CONSP(arg1),
x, ARG1, SNAME(proc));
- t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1));
+ arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
op >>= 2;
}
- return t.arg1;
+ return arg1;
}
case tc7_rpsubr:
return BOOL_T;
case tc7_asubr:
- return SUBRF(proc)(t.arg1, UNDEFINED);
+ return SUBRF(proc)(arg1, UNDEFINED);
case tc7_lsubr:
- return SUBRF(proc)(cons(t.arg1, EOL));
+ return SUBRF(proc)(cons(arg1, EOL));
case tcs_closures:
ENV_MAY_PUSH(envpp);
#ifdef SCM_PROFILE
eval_clo_cases[1][ARGC(proc)]++;
#endif
if (1==ARGC(proc)) {
- scm_env_cons(t.arg1, EOL);
+ scm_env_cons(arg1, EOL);
goto clo_unchecked;
}
else {
- scm_env_tmp = cons(t.arg1, EOL);
+ scm_env_tmp = cons(arg1, EOL);
goto clo_checked;
}
case tc7_contin:
- scm_dynthrow(proc, t.arg1);
+ scm_dynthrow(proc, arg1);
case tc7_specfun:
switch TYP16(proc) {
case tc16_call_cc:
- proc = t.arg1;
+ proc = arg1;
DEFER_INTS_EGC;
- t.arg1 = scm_make_cont();
- EGC_ROOT(t.arg1);
- x = setjump(CONT(t.arg1)->jmpbuf);
+ arg1 = scm_make_cont();
+ EGC_ROOT(arg1);
+ x = setjump(CONT(arg1)->jmpbuf);
if (x) {
#ifdef SHORT_INT
x = (SCM)thrown_value;
@@ -2484,22 +2515,22 @@ evap1:
goto evap1;
case tc16_eval:
ENV_MAY_PUSH(envpp);
- TRACE(t.arg1);
+ TRACE(arg1);
STATIC_ENV = eval_env;
scm_env = EOL;
- x = t.arg1;
+ x = arg1;
if (IMP(x)) goto retx;
goto loop;
#ifdef CCLO
case tc16_cclo:
arg2 = UNDEFINED;
goto cclon;
- /* arg2 = t.arg1;
- t.arg1 = proc;
+ /* arg2 = arg1;
+ arg1 = proc;
proc = CCLO_SUBR(proc);
goto evap2; */
#endif
- case tc16_values: return t.arg1;
+ case tc16_values: return arg1;
}
case tc7_subr_2:
case tc7_subr_0:
@@ -2524,25 +2555,25 @@ evap1:
switch TYP7(proc) {
case tc7_subr_2:
case tc7_subr_2o:
- return SUBRF(proc)(t.arg1, arg2);
+ return SUBRF(proc)(arg1, arg2);
case tc7_lsubr:
- return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
+ return SUBRF(proc)(cons2(arg1, arg2, EOL));
case tc7_lsubr_2:
- return SUBRF(proc)(t.arg1, arg2, EOL);
+ return SUBRF(proc)(arg1, arg2, EOL);
case tc7_rpsubr:
case tc7_asubr:
- return SUBRF(proc)(t.arg1, arg2);
+ return SUBRF(proc)(arg1, arg2);
case tc7_specfun:
switch TYP16(proc) {
case tc16_apply:
- proc = t.arg1;
+ proc = arg1;
ASRTGO(NIMP(proc), badfun);
if NULLP(arg2) goto evap0;
if (IMP(arg2) || NCONSP(arg2)) {
x = arg2;
badlst: wta(x, (char *)ARGn, s_apply);
}
- t.arg1 = CAR(arg2);
+ arg1 = CAR(arg2);
x = CDR(arg2);
apply3:
if NULLP(x) goto evap1;
@@ -2562,25 +2593,25 @@ evap1:
#ifdef CCLO
case tc16_cclo: cclon:
arg3 = arg2;
- arg2 = t.arg1;
- t.arg1 = proc;
+ arg2 = arg1;
+ arg1 = proc;
proc = CCLO_SUBR(proc);
if (UNBNDP(arg3)) goto evap2;
goto evap3;
/* return apply(CCLO_SUBR(proc),
- cons2(proc, t.arg1, cons(arg2, x)), EOL); */
+ cons2(proc, arg1, cons(arg2, x)), EOL); */
#endif
case tc16_values:
- return scm_values(t.arg1, arg2, EOL, s_values);
+ return scm_values(arg1, arg2, EOL, s_values);
case tc16_call_wv:
ENV_MAY_PUSH(envpp);
scm_env_tmp = IM_VALUES_TOKEN; /* Magic value recognized by VALUES */
- t.arg1 = apply(t.arg1, EOL, EOL);
+ arg1 = apply(arg1, EOL, EOL);
proc = arg2;
DEFER_INTS_EGC;
if (IM_VALUES_TOKEN==scm_env_tmp) {
scm_env_tmp = EOL;
- if (UNBNDP(t.arg1)) goto evap0;
+ if (UNBNDP(arg1)) goto evap0;
goto evap1;
}
arg2 = CAR(scm_env_tmp);
@@ -2604,14 +2635,14 @@ evap1:
#endif
switch ARGC(proc) {
case 2:
- scm_env_cons2(t.arg1, arg2, EOL);
+ scm_env_cons2(arg1, arg2, EOL);
goto clo_unchecked;
case 1:
- scm_env_cons(t.arg1, cons(arg2, EOL));
+ scm_env_cons(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);
+ scm_env_tmp = cons2(arg1, arg2, EOL);
goto clo_checked;
}
}
@@ -2623,7 +2654,7 @@ evap1:
if (CLOSUREP(proc) && 3==ARGC(proc)) {
ALLOW_INTS_EGC;
ENV_MAY_PUSH(envpp);
- if (ecache_eval_args(proc, t.arg1, arg2, arg3, x))
+ if (ecache_eval_args(proc, arg1, arg2, arg3, x))
goto clo_unchecked;
goto umwrongnumargs;
}
@@ -2636,15 +2667,15 @@ evap1:
switch TYP7(proc) {
case tc7_subr_3:
ASRTGO(NULLP(x), wrongnumargs);
- return SUBRF(proc)(t.arg1, arg2, arg3);
+ return SUBRF(proc)(arg1, arg2, arg3);
case tc7_asubr:
case tc7_rpsubr:
- return asubr_apply(proc, t.arg1, arg2, arg3, x);
- /* return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL); */
+ return asubr_apply(proc, arg1, arg2, arg3, x);
+ /* return apply(proc, cons2(arg1, arg2, cons(arg3, x)), EOL); */
case tc7_lsubr_2:
- return SUBRF(proc)(t.arg1, arg2, cons(arg3, x));
+ return SUBRF(proc)(arg1, arg2, cons(arg3, x));
case tc7_lsubr:
- return SUBRF(proc)(cons2(t.arg1, arg2, cons(arg3, x)));
+ return SUBRF(proc)(cons2(arg1, arg2, cons(arg3, x)));
case tcs_closures:
ENV_MAY_PUSH(envpp);
#ifdef SCM_PROFILE
@@ -2652,24 +2683,24 @@ evap1:
#endif
switch ARGC(proc) {
case 3:
- scm_env_cons3(t.arg1, arg2, arg3, x);
+ scm_env_cons3(arg1, arg2, arg3, x);
goto clo_checked;
case 2:
- scm_env_cons2(t.arg1, arg2, cons(arg3, x));
+ scm_env_cons2(arg1, arg2, cons(arg3, x));
goto clo_checked;
case 1:
- scm_env_cons(t.arg1, cons2(arg2, arg3, x));
+ scm_env_cons(arg1, cons2(arg2, arg3, x));
goto clo_checked;
case 0:
- scm_env_tmp = cons2(t.arg1, arg2, cons(arg3, x));
+ scm_env_tmp = cons2(arg1, arg2, cons(arg3, x));
goto clo_checked;
}
case tc7_specfun:
switch TYP16(proc) {
case tc16_apply:
- proc = t.arg1;
+ proc = arg1;
ASRTGO(NIMP(proc), badfun);
- t.arg1 = arg2;
+ arg1 = arg2;
if IMP(x) {
x = arg3;
goto apply3;
@@ -2688,7 +2719,7 @@ evap1:
goto cclon;
#endif
case tc16_values:
- return scm_values(t.arg1, arg2, cons(arg3, x), s_values);
+ return scm_values(arg1, arg2, cons(arg3, x), s_values);
}
case tc7_subr_2:
case tc7_subr_1o:
@@ -2703,6 +2734,7 @@ evap1:
}
}
}
+#undef arg1
}
SCM procedurep(obj)
@@ -2723,7 +2755,7 @@ SCM l_proc_doc(proc)
SCM proc;
{
SCM env;
- ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin,
+ ASRTER(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin,
proc, ARG1, s_proc_doc);
switch TYP7(proc) {
case tcs_closures:
@@ -2747,11 +2779,11 @@ SCM nconc2copy(lst)
{
SCM last, *lloc = &lst;
#ifdef CAUTIOUS
- ASSERT(ilength(lst) >= 1, lst, WNA, s_apply);
+ ASRTER(ilength(lst) >= 1, lst, WNA, s_apply);
#endif
while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc);
#ifdef CAUTIOUS
- ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply);
+ ASRTER(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply);
#endif
last = CAR(*lloc);
*lloc = EOL;
@@ -2846,7 +2878,7 @@ SCM apply(proc, arg1, args)
args = arg1;
#endif
while (op) {
- ASSERT(NIMP(arg1) && CONSP(arg1),
+ ASRTER(NIMP(arg1) && CONSP(arg1),
args, ARG1, SNAME(proc));
arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
op >>= 2;
@@ -2865,7 +2897,7 @@ SCM apply(proc, arg1, args)
case tc7_asubr:
if NULLP(args) return SUBRF(proc)(arg1, UNDEFINED);
while NIMP(args) {
- ASSERT(CONSP(args), args, ARG2, s_apply);
+ ASRTER(CONSP(args), args, ARG2, s_apply);
arg1 = SUBRF(proc)(arg1, CAR(args));
args = CDR(args);
}
@@ -2873,7 +2905,7 @@ SCM apply(proc, arg1, args)
case tc7_rpsubr:
if NULLP(args) return BOOL_T;
while NIMP(args) {
- ASSERT(CONSP(args), args, ARG2, s_apply);
+ ASRTER(CONSP(args), args, ARG2, s_apply);
if FALSEP(SUBRF(proc)(arg1, CAR(args))) return BOOL_F;
arg1 = CAR(args);
args = CDR(args);
@@ -2948,7 +2980,7 @@ SCM scm_cvapply(proc, n, argv)
int op = CXR_OP(proc);
res = argv[0];
while (op) {
- ASSERT(NIMP(res) && CONSP(res),
+ ASRTER(NIMP(res) && CONSP(res),
argv[0], ARG1, SNAME(proc));
res = (1 & op ? CAR(res) : CDR(res));
op >>= 2;
@@ -3024,7 +3056,7 @@ SCM map(proc, arg1, args)
#ifndef RECKLESS
scm_arity_check(proc, n, s_map);
#endif
- ASSERT(NIMP(arg1), arg1, ARG2, s_map);
+ ASRTER(NIMP(arg1), arg1, ARG2, s_map);
#ifdef CCLO
if (tc16_cclo==TYP16(proc)) {
args = cons(arg1, args);
@@ -3040,10 +3072,10 @@ SCM map(proc, arg1, args)
ave = &(ve[n]);
}
ve[0] = arg1;
- ASSERT(NIMP(ve[0]), arg1, ARG2, s_map);
+ ASRTER(NIMP(ve[0]), arg1, ARG2, s_map);
for (i = 1; i < n; i++) {
ve[i] = CAR(args);
- ASSERT(NIMP(ve[i]), ve[i], ARGn, s_map);
+ ASRTER(NIMP(ve[i]), ve[i], ARGn, s_map);
args = CDR(args);
}
while (1) {
@@ -3053,7 +3085,7 @@ SCM map(proc, arg1, args)
/* We could check for lists the same length here. */
return res;
}
- ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map);
+ ASRTER(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map);
ave[i] = CAR(ve[i]);
ve[i] = CDR(ve[i]);
}
@@ -3070,9 +3102,9 @@ SCM for_each(proc, arg1, args)
scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */
if NULLP(arg1) return UNSPECIFIED;
#ifndef RECKLESS
- scm_arity_check(proc, n, s_map);
+ scm_arity_check(proc, n, s_for_each);
#endif
- ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
+ ASRTER(NIMP(arg1), arg1, ARG2, s_for_each);
#ifdef CCLO
if (tc16_cclo==TYP16(proc)) {
args = cons(arg1, args);
@@ -3088,10 +3120,10 @@ SCM for_each(proc, arg1, args)
ave = &(ve[n]);
}
ve[0] = arg1;
- ASSERT(NIMP(ve[0]), arg1, ARG2, s_for_each);
+ ASRTER(NIMP(ve[0]), arg1, ARG2, s_for_each);
for (i = 1; i < n; i++) {
ve[i] = CAR(args);
- ASSERT(NIMP(ve[i]), args, ARGn, s_for_each);
+ ASRTER(NIMP(ve[i]), args, ARGn, s_for_each);
args = CDR(args);
}
while (1) {
@@ -3100,7 +3132,7 @@ SCM for_each(proc, arg1, args)
if IMP(ve[i]) {
return UNSPECIFIED;
}
- ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each);
+ ASRTER(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each);
ave[i] = CAR(ve[i]);
ve[i] = CDR(ve[i]);
}
@@ -3158,7 +3190,7 @@ static SCM makro(code, flags, what)
char *what;
{
register SCM z;
- ASSERT(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L),
+ ASRTER(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L),
(char *)0), code, ARG1, what);
NEWCELL(z);
CDR(z) = code;
@@ -3193,7 +3225,7 @@ SCM makidmacro(code)
/* Functions for smart expansion */
/* @MACROEXPAND1 returns:
- #F if its argument is not a macro invocation,
+ '#F' if its argument is not a macro invocation,
the argument if the argument is a primitive syntax invocation,
the result of expansion if the argument is a macro invocation
(BEGIN #F) will be returned instead of #F if #F is the result.
@@ -3394,7 +3426,7 @@ SCM ident2sym(id)
SCM id;
{
id = id2sym(id);
- ASSERT(NIMP(id) && SYMBOLP(id), id, ARG1, s_ident2sym);
+ ASRTER(NIMP(id) && SYMBOLP(id), id, ARG1, s_ident2sym);
return id;
}
@@ -3403,18 +3435,18 @@ SCM renamed_ident(id, env)
SCM id, env;
{
SCM z;
- ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
+ ASRTER(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
NEWCELL(z);
while (NIMP(env)) {
if (INUMP(CAR(env))) {
- ASSERT(NIMP(CDR(env)), env, s_badenv, s_renamed_ident);
+ ASRTER(NIMP(CDR(env)), env, s_badenv, s_renamed_ident);
env = CDR(CDR(env));
}
else if (SCM_LINUMP(CAR(env))) {
env = CDR(env);
}
else {
- ASSERT(NULLP(env) || (NIMP(env) && CONSP(env)),
+ ASRTER(NULLP(env) || (NIMP(env) && CONSP(env)),
env, s_badenv, s_renamed_ident);
break;
}
@@ -3587,6 +3619,12 @@ SCM make_specfun(name, typ, flags)
}
void init_eval()
{
+ scm_env = EOL;
+ scm_env_tmp = UNSPECIFIED;
+#ifndef RECKLESS
+ scm_trace = BOOL_F;
+ scm_trace_env = EOL;
+#endif
tc16_promise = newsmob(&promsmob);
tc16_macro = newsmob(&macrosmob);
tc16_env = newsmob(&envsmob);
@@ -3653,6 +3691,7 @@ void init_eval()
make_synt(s_letrec_syntax, MAC_MMACRO, m_letrec_syntax);
make_synt(s_the_macro, MAC_ACRO, m_the_macro);
+ add_feature("primitive-hygiene");
#endif
f_begin = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_begin))));
diff --git a/features.txi b/features.txi
new file mode 100644
index 0000000..96987b8
--- /dev/null
+++ b/features.txi
@@ -0,0 +1,200 @@
+@item array
+@cindex array
+Alias for ARRAYS
+
+@item array-for-each
+@cindex array-for-each
+array-map! and array-for-each (arrays must also be featured).
+
+@item arrays
+@cindex arrays
+Use if you want arrays, uniform-arrays and uniform-vectors.
+
+@item bignums
+@cindex bignums
+Large precision integers.
+
+@item byte
+@cindex byte
+Treating strings as byte-vectors.
+
+@item careful-interrupt-masking
+@cindex careful-interrupt-masking
+Define this for extra checking of interrupt masking and some simple
+checks for proper use of malloc and free. This is for debugging C
+code in @file{sys.c}, @file{eval.c}, @file{repl.c} and makes the
+interpreter several times slower than usual.
+
+@item cautious
+@cindex cautious
+Normally, the number of arguments arguments to interpreted closures
+(from LAMBDA) are checked if the function part of a form is not a
+symbol or only the first time the form is executed if the function
+part is a symbol. defining @samp{reckless} disables any checking.
+If you want to have SCM always check the number of arguments to
+interpreted closures define feature @samp{cautious}.
+
+@item cheap-continuations
+@cindex cheap-continuations
+If you only need straight stack continuations, executables compile with
+this feature will run faster and use less storage than not having it.
+Machines with unusual stacks @emph{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
+use this feature.
+
+@item compiled-closure
+@cindex compiled-closure
+Use if you want to use compiled closures.
+
+@item curses
+@cindex curses
+For the @dfn{curses} screen management package.
+
+@item debug
+@cindex debug
+Turns on the features @samp{cautious},
+@samp{careful-interrupt-masking}, and @samp{stack-limit}; uses
+@code{-g} flags for debugging SCM source code.
+
+@item dump
+@cindex dump
+Convert a running scheme program into an executable file.
+
+@item dynamic-linking
+@cindex dynamic-linking
+Be able to load compiled files while running.
+
+@item edit-line
+@cindex edit-line
+interface to the editline or GNU readline library.
+
+@item engineering-notation
+@cindex engineering-notation
+Use if you want floats to display in engineering notation (exponents
+always multiples of 3) instead of scientific notation.
+
+@item generalized-c-arguments
+@cindex generalized-c-arguments
+@code{make_gsubr} for arbitrary (< 11) arguments to C functions.
+
+@item i/o-extensions
+@cindex i/o-extensions
+Commonly available I/O extensions: @dfn{exec}, line I/O, file
+positioning, file delete and rename, and directory functions.
+
+@item inexact
+@cindex inexact
+Use if you want floating point numbers.
+
+@item lit
+@cindex lit
+Lightweight -- no features
+
+@item macro
+@cindex macro
+C level support for hygienic and referentially transparent macros
+(syntax-rules macros).
+
+@item mysql
+@cindex mysql
+Client connections to the mysql databases.
+
+@item no-heap-shrink
+@cindex no-heap-shrink
+Use if you want segments of unused heap to not be freed up after
+garbage collection. This may increase time in GC for *very* large
+working sets.
+
+@item none
+@cindex none
+No features
+
+@item posix
+@cindex posix
+Posix functions available on all @dfn{Unix-like} systems. fork and
+process functions, user and group IDs, file permissions, and
+@dfn{link}.
+
+@item reckless
+@cindex reckless
+If your scheme code runs without any errors you can disable almost
+all error checking by compiling all files with @samp{reckless}.
+
+@item record
+@cindex record
+The Record package provides a facility for user to define their own
+record data types. See SLIB for documentation.
+
+@item regex
+@cindex regex
+String regular expression matching.
+
+@item rev2-procedures
+@cindex rev2-procedures
+These procedures were specified in the @cite{Revised^2 Report on Scheme}
+but not in @cite{R4RS}.
+
+@item sicp
+@cindex sicp
+Use if you want to run code from:
+
+@cindex SICP
+Harold Abelson and Gerald Jay Sussman with Julie Sussman.
+@cite{Structure and Interpretation of Computer Programs.}
+The MIT Press, Cambridge, Massachusetts, USA, 1985.
+
+Differences from R5RS are:
+@itemize @bullet
+@item
+(eq? '() '#f)
+@item
+(define a 25) returns the symbol a.
+@item
+(set! a 36) returns 36.
+@end itemize
+
+@item single-precision-only
+@cindex single-precision-only
+Use if you want all inexact real numbers to be single precision. This
+only has an effect if SINGLES is also defined (which is the default).
+This does not affect complex numbers.
+
+@item socket
+@cindex socket
+BSD @dfn{socket} interface.
+
+@item stack-limit
+@cindex stack-limit
+Use to enable checking for stack overflow. Define value of the C
+preprocessor variable @var{STACK_LIMIT} to be the size to which SCM
+should allow the stack to grow. STACK_LIMIT should be less than the
+maximum size the hardware can support, as not every routine checks the
+stack.
+
+@item tick-interrupts
+@cindex tick-interrupts
+Use if you want the ticks and ticks-interrupt functions.
+
+@item turtlegr
+@cindex turtlegr
+@dfn{Turtle} graphics calls for both Borland-C and X11 from
+sjm@@ee.tut.fi.
+
+@item unix
+@cindex unix
+Those unix features which have not made it into the Posix specs:
+nice, acct, lstat, readlink, symlink, mknod and sync.
+
+@item windows
+@cindex windows
+Microsoft Windows executable.
+
+@item x
+@cindex x
+Alias for Xlib feature.
+
+@item xlib
+@cindex xlib
+Interface to Xlib graphics routines.
+
diff --git a/findexec.c b/findexec.c
index 4992775..9769ef5 100644
--- a/findexec.c
+++ b/findexec.c
@@ -16,13 +16,13 @@ Fri Sep 14 22:16:14 1990 Edgar Roeder (edgar at megamaster)
dld_find_executable so that users may specify a special path
for object modules.
-Thu Feb 3 01:46:16 1994 Aubrey Jaffer (jaffer@jacal)
+Thu Feb 3 01:46:16 1994 Aubrey Jaffer
* find_exec.c (dld_find_executable): added stat check for
linux so that it doesn't think directories with the same name
as the program are executable.
-Wed Feb 21 23:06:35 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+Wed Feb 21 23:06:35 1996 Aubrey Jaffer
* find_exec.c: extracted for general use. Generalized to
MS-DOS. */
@@ -83,6 +83,10 @@ Wed Feb 21 23:06:35 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
# include <sys/types.h>
# include <sys/stat.h>
# endif
+# ifdef __NetBSD__
+# include <stdlib.h>
+# include <unistd.h>
+# endif
# ifdef __OpenBSD__
/* This might be same for 44bsd derived system. */
# include <stdlib.h>
diff --git a/gsubr.c b/gsubr.c
index f7dd777..d3d7c82 100644
--- a/gsubr.c
+++ b/gsubr.c
@@ -73,7 +73,7 @@ SCM make_gsubr(name, req, opt, rst, fcn)
SCM symcell = sysintern(name, UNDEFINED);
SCM z = scm_maksubr(name, tc7_subr_0, fcn);
SCM cclo = makcclo(f_gsubr_apply, 3L);
- ASSERT(GSUBR_MAX >= req + opt + rst, MAKINUM(req + opt + rst),
+ ASRTER(GSUBR_MAX >= req + opt + rst, MAKINUM(req + opt + rst),
OUTOFRANGE, "make_gsubr");
GSUBR_PROC(cclo) = z;
GSUBR_TYPE(cclo) = MAKINUM(GSUBR_MAKTYPE(req, opt, rst));
@@ -127,6 +127,8 @@ SCM gsubr_apply(args)
}
}
+SCM_DLL_EXPORT void init_gsubr P((void));
+
void init_gsubr()
{
f_gsubr_apply = make_subr(s_gsubr_apply, tc7_lsubr, gsubr_apply);
diff --git a/hobbit.info b/hobbit.info
index 9e0c0a9..a9d8b9f 100644
--- a/hobbit.info
+++ b/hobbit.info
@@ -19,6 +19,7 @@ Tammet.
* Performance of Compiled Code::
* Principles of Compilation::
* About Hobbit::
+* Index::
Copyright (C) 1990-1999, 2002 Free Software Foundation
@@ -66,7 +67,7 @@ Hobbit (derived from hobbit5x) is now part of the SCM Scheme
implementation. The most recent information about SCM can be found on
SCM's "WWW" home page:
- <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
+ <http://swissnet.ai.mit.edu/~jaffer/SCM>
Hobbit4d has also been ported to the Guile Scheme implementation:
@@ -104,6 +105,9 @@ Compiling And Linking
instance, `.so'). NAME1.scm must be in the current directory;
NAME2.scm, ... may be in other directories.
+ If a file named `NAME1.opt' exists, then its options are passed to
+ the `build' invocation which compiles the `c' files.
+
cd ~/scm/
scm -rcompile -e'(compile-file "example.scm")'
@@ -134,7 +138,7 @@ Compiling And Linking
(lambda (fp)
(for-each
(lambda (string) (write-line string fp))
- '("#define IMPLINIT \"Init5d6.scm\""
+ '("#define IMPLINIT \"Init5d9.scm\""
"#define BIGNUMS"
"#define FLOATS"
"#define ARRAYS"
@@ -153,6 +157,9 @@ Compiling And Linking
... to a SCM executable named EXENAME. NAME1.scm must be in the
current directory; NAME2.scm, ... may be in other directories.
+ If a file named `EXENAME.opt' exists, then its options are passed
+ to the `build' invocation which compiles the `c' files.
+
cd ~/scm/
scm -rcompile -e'(compile->executable "exscm" "example.scm")'
@@ -183,7 +190,7 @@ Compiling And Linking
(lambda (fp)
(for-each
(lambda (string) (write-line string fp))
- '("#define IMPLINIT \"Init5d6.scm\""
+ '("#define IMPLINIT \"Init5d9.scm\""
"#define COMPILED_INITS init_example();"
"#define CCLO"
"#define FLOATS"))))
@@ -533,10 +540,8 @@ generic case, not immediate-integers-only and are thus much slower.
Notice that the procedures logsleft, logsright are NOT in the the
library file `logical.scm:' the universal procedure ash is instead.
Procedures ash, logcount, integer-length, integer-expt, bit-extract,
-ipow-by-squaring, logical:ash, logical:logcount, logical:integer-length,
-logical:integer-expt, logical:bit-extract, logical:ipow-by-squaring, in
-`logical.scm' are not primtives and they are all compiled into calls to
-interpreted code.
+ipow-by-squaring, in `logical.scm' are not primtives and they are all
+compiled into calls to interpreted code.
logsleft and logsright are defined for non-compiled use in the file
`scmhob.scm' included in the SCM distribution.
@@ -1271,13 +1276,13 @@ Expansion and Analysis
let*-s inside these chunks.
5. Normalization is performed. This converts a majority of scheme
- control procedures like cond, case, or, and into equivalent terms
- using a small set of primitives. New variables may be introduced
- in this phase.
+ control procedures like `cond', `case', `or', `and' into
+ equivalent terms using a small set of primitives. New variables
+ may be introduced in this phase.
- In case a procedure like or or and occurs in the place where its
- value is treated as a boolean (eg. first argument of if), it is
- converted into an analogous boolean-returning procedure, which
+ In case a procedure like `or' or `and' occurs in the place where
+ its value is treated as a boolean (eg. first argument of `if'), it
+ is converted into an analogous boolean-returning procedure, which
will finally be represented by an analogous C procedure (eg. || or
&&).
@@ -1616,7 +1621,7 @@ instead of the default:
(define *build-intermediate-files* #f).

-File: hobbit.info, Node: About Hobbit, Prev: Principles of Compilation, Up: Top
+File: hobbit.info, Node: About Hobbit, Next: Index, Prev: Principles of Compilation, Up: Top
About Hobbit
************
@@ -1674,7 +1679,7 @@ Author and Contributors
University of Go"teborg
S-41296 Go"teborg Sweden
-A. Jaffer (jaffer @ alum.mit.edu), the author of SCM, has been of major
+A. Jaffer (agj @ alum.mit.edu), the author of SCM, has been of major
help with a number of suggestions and hacks, especially concerning the
interface between compiled code and the SCM interpreter.
@@ -1750,10 +1755,10 @@ hobbit4c:
hobbit4b:
The following bugs have been fixed:
* Erroneous treatment of [ and ] inside symbols, reported by A.
- Jaffer (jaffer @ alum.mit.edu).
+ Jaffer (agj @ alum.mit.edu).
- * A bug in the liftability analysis, reported by A. Jaffer
- (jaffer @ alum.mit.edu).
+ * A bug in the liftability analysis, reported by A. Jaffer (agj
+ @ alum.mit.edu).
* A bug occurring in case arguments are evaluated right-to-left,
which happens with Hobbit compiled by gcc on Linux. Reported
@@ -1905,48 +1910,61 @@ hobbit1a1 (not public):
hobbit1:
the first release
+
+File: hobbit.info, Node: Index, Prev: About Hobbit, Up: Top
+
+Index
+*****
+
+* Menu:
+
+* compile->executable: Compiling And Linking.
+* compile-file: Compiling And Linking.
+* hobbit: Compiling And Linking.
+

Tag Table:
Node: Top199
-Node: Introduction1217
-Node: Compiling with Hobbit2533
-Node: Compiling And Linking2786
-Node: Error Detection7267
-Node: Hobbit Options8565
-Node: CC Optimizations15286
-Node: The Language Compiled16234
-Node: Macros16889
-Node: SCM Primitive Procedures17485
-Node: SLIB Logical Procedures18336
-Node: Fast Integer Calculations19616
-Node: Force and Delay20742
-Node: Suggestions for writing fast code21319
-Node: Performance of Compiled Code31510
-Node: Gain in Speed31766
-Node: Benchmarks33343
-Node: Benchmark Sources36435
-Node: Destruct36773
-Node: Recfib38348
-Node: div-iter and div-rec38591
-Node: Hanoi39665
-Node: Tak40234
-Node: Ctak40577
-Node: Takl41560
-Node: Cpstak42219
-Node: Pi42986
-Node: Principles of Compilation44103
-Node: Macro-Expansion and Analysis44525
-Node: Building Closures48308
-Node: Lambda-lifting51191
-Node: Statement-lifting53939
-Node: Higher-order Arglists55039
-Node: Typing and Constants56837
-Node: About Hobbit58093
-Node: The Aims of Developing Hobbit58335
-Node: Manifest59218
-Node: Author and Contributors59669
-Node: Future Improvements60719
-Node: Release History61476
+Node: Introduction1227
+Node: Compiling with Hobbit2540
+Node: Compiling And Linking2793
+Node: Error Detection7538
+Node: Hobbit Options8836
+Node: CC Optimizations15557
+Node: The Language Compiled16505
+Node: Macros17160
+Node: SCM Primitive Procedures17756
+Node: SLIB Logical Procedures18607
+Node: Fast Integer Calculations19763
+Node: Force and Delay20889
+Node: Suggestions for writing fast code21466
+Node: Performance of Compiled Code31657
+Node: Gain in Speed31913
+Node: Benchmarks33490
+Node: Benchmark Sources36582
+Node: Destruct36920
+Node: Recfib38495
+Node: div-iter and div-rec38738
+Node: Hanoi39812
+Node: Tak40381
+Node: Ctak40724
+Node: Takl41707
+Node: Cpstak42366
+Node: Pi43133
+Node: Principles of Compilation44250
+Node: Macro-Expansion and Analysis44672
+Node: Building Closures48469
+Node: Lambda-lifting51352
+Node: Statement-lifting54100
+Node: Higher-order Arglists55200
+Node: Typing and Constants56998
+Node: About Hobbit58254
+Node: The Aims of Developing Hobbit58510
+Node: Manifest59393
+Node: Author and Contributors59844
+Node: Future Improvements60891
+Node: Release History61648
+Node: Index68429

End Tag Table
diff --git a/hobbit.scm b/hobbit.scm
index 80d9d31..8f1d896 100644
--- a/hobbit.scm
+++ b/hobbit.scm
@@ -2,7 +2,7 @@
;
; HOBBIT: an optimizing scheme -> C compiler for SCM
;
-; scm5d6
+; scm5d9
; 2002-04-11
;
; Copyright (C) 1992-1997: Tanel Tammet
@@ -55,7 +55,12 @@
; - "copy-tree" and "acons" compilation introduced
; pre-april, 2002, Aubrey Jaffer:
; - numerous changes necessary for co-operation with SCM5d5
-;
+
+;;; Declare modules which might be needed:
+(require-if 'compiling 'pretty-print)
+(require-if 'compiling 'defmacroexpand)
+(require-if 'compiling 'pprint-file)
+
;=================================================================
;
; default compiler options
@@ -63,7 +68,6 @@
;
;=================================================================
-
;;; The following variable controls whether hobbit will do any
;;; macroexpansion. In that case (require 'defmacroexpand) must
;;; be able to load the macroexpander from the scheme library.
@@ -165,7 +169,7 @@
(for-each display lst)
(display #\newline)
(abort))
-
+;@
(define compile-allnumbers #t)
;=================================================================
@@ -365,13 +369,6 @@
(define *init-fun-prefix* "init_")
-;;; The following is a string which is prepended to the name of your
-;;; scheme file (without .scm) to form a C variable which is generated
-;;; as a new global to gc-protect the constant nonimmediate objects
-;;; in your file.
-
-(define *protect-variable* "protect_constants_")
-
;;; The following is a name of a variable which may be defined to
;;; the list of inlinable functions in your scheme file.
@@ -812,11 +809,7 @@
;
;=================================================================
-
-(define (Hobbit:compile file . files)
- (hobbit (cons file files)))
-
-
+;@ exported symbol hobbit.
(define (hobbit file . files)
(let* ((tmpname "hobbit.tmp"))
(if *build-intermediate-files*
@@ -824,8 +817,7 @@
(if *expand-macros-flag*
(begin (require 'defmacroexpand)
(require 'pprint-file)))
- (if (not (memq 'hobbit *features*))
- (set! *features* (cons 'hobbit *features*)))
+ (provide 'hobbit)
(if (or (member '"scmhob.scm" (cons file files))
(member '"scmhob" (cons file files)))
(report-error "The file scmhob.scm is not allowed to be compiled!"))
@@ -2384,9 +2376,6 @@
map for-each list call-with-input-file call-with-output-file
open-input-file open-output-file with-input-from-file
with-output-to-file string-append
- logical:logxor logical:lognot logical:logior logical:logand
- logical:ash logical:logcount logical:integer-length
- logical:bit-extract logical:integer-expt
defmacro:expand*
sin cos tan asin acos atan sinh cosh tanh asinh acosh
sin cos tan asin acos atan sinh cosh tanh asinh acosh
@@ -2561,7 +2550,7 @@
(vector->list "vector2list" 1)
(list->vector "vector" 1)
- (read "lread" 1)
+ (read "scm_read" 1)
(read-char "scm_read_char" 1)
(peek-char "peek_char" 1)
(eof-object? "eof_objectp" 1)
diff --git a/hobbit.texi b/hobbit.texi
index 3b448fb..f87c1b0 100644
--- a/hobbit.texi
+++ b/hobbit.texi
@@ -6,8 +6,6 @@
@setchapternewpage on
@c Choices for setchapternewpage are {on,off,odd}.
@paragraphindent 0
-@defcodeindex ft
-@syncodeindex ft cp
@c %**end of header
@dircategory The Algorithmic Language Scheme
@@ -68,6 +66,7 @@ Tammet.
* Performance of Compiled Code::
* Principles of Compilation::
* About Hobbit::
+* Index::
@end menu
Copyright (C) 1990-1999, 2002 Free Software Foundation
@@ -124,7 +123,7 @@ Hobbit (derived from hobbit5x) is now part of the SCM Scheme
implementation. The most recent information about SCM can be found on
SCM's @dfn{WWW} home page:
-@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM}
Hobbit4d has also been ported to the Guile Scheme implementation:
@@ -159,6 +158,10 @@ Compiles the HOBBIT translation of @var{name1}.scm, @var{name2}.scm,
suffix for your computer (for instance, @file{.so}). @var{name1}.scm
must be in the current directory; @var{name2}.scm, @dots{} may be in
other directories.
+
+If a file named @file{@var{name1}.opt} exists, then its options are
+passed to the @code{build} invocation which compiles the @code{c}
+files.
@end defun
@example
@@ -212,6 +215,10 @@ Compiles and links the HOBBIT translation of @var{name1}.scm,
@var{name2}.scm, @dots{} to a SCM executable named @var{exename}.
@var{name1}.scm must be in the current directory; @var{name2}.scm,
@dots{} may be in other directories.
+
+If a file named @file{@var{exename}.opt} exists, then its options are
+passed to the @code{build} invocation which compiles the @code{c}
+files.
@end defun
@example
@@ -663,13 +670,11 @@ The following alternative names @t{logical:logand}, @t{logical:logior},
generic case, not immediate-integers-only and are thus much slower.
Notice that the procedures @t{logsleft}, @t{logsright} are @b{NOT} in
-the the library file @file{logical.scm:} the universal procedure @t{ash}
-is instead. Procedures @t{ash}, @t{logcount}, @t{integer-length},
-@t{integer-expt}, @t{bit-extract}, @t{ipow-by-squaring},
-@t{logical:ash}, @t{logical:logcount}, @t{logical:integer-length},
-@t{logical:integer-expt}, @t{logical:bit-extract},
-@t{logical:ipow-by-squaring}, in @file{logical.scm} are not primtives
-and they are all compiled into calls to interpreted code.
+the the library file @file{logical.scm:} the universal procedure
+@t{ash} is instead. Procedures @t{ash}, @t{logcount},
+@t{integer-length}, @t{integer-expt}, @t{bit-extract},
+@t{ipow-by-squaring}, in @file{logical.scm} are not primtives and they
+are all compiled into calls to interpreted code.
@t{logsleft} and @t{logsright} are defined for non-compiled use in the
file @file{scmhob.scm} included in the SCM distribution.
@@ -1514,14 +1519,15 @@ passed variables. Wherever possible, @t{letrec}-s are replaced by
@item
Normalization is performed. This converts a majority of scheme
-control procedures like cond, case, or, and into equivalent
-terms using a small set of primitives. New variables may be
-introduced in this phase.
+control procedures like @code{cond}, @code{case}, @code{or},
+@code{and} into equivalent terms using a small set of primitives. New
+variables may be introduced in this phase.
-In case a procedure like or or and occurs in the place where its value
-is treated as a boolean (eg. first argument of if), it is converted
-into an analogous boolean-returning procedure, which will finally
-be represented by an analogous C procedure (eg. || or &&).
+In case a procedure like @code{or} or @code{and} occurs in the place
+where its value is treated as a boolean (eg. first argument of
+@code{if}), it is converted into an analogous boolean-returning
+procedure, which will finally be represented by an analogous C
+procedure (eg. || or &&).
Associative procedures are converted into structures of corresponding
nonassociative procedures. List is converted to a structure of cons-s.
@@ -1928,7 +1934,7 @@ instead of the default:
@end example
-@node About Hobbit, , Principles of Compilation, Top
+@node About Hobbit, Index, Principles of Compilation, Top
@chapter About Hobbit
@menu
@@ -1988,7 +1994,7 @@ University of Go"teborg@*
S-41296 Go"teborg Sweden
@end quotation
-A. Jaffer (jaffer @@ alum.mit.edu), the author of SCM, has been of major
+A. Jaffer (agj @@ alum.mit.edu), the author of SCM, has been of major
help with a number of suggestions and hacks, especially concerning the
interface between compiled code and the SCM interpreter.
@@ -2083,10 +2089,10 @@ The following bugs have been fixed:
@itemize @bullet
@item
Erroneous treatment of [ and ] inside symbols,
-reported by A. Jaffer (jaffer @@ alum.mit.edu).
+reported by A. Jaffer (agj @@ alum.mit.edu).
@item
A bug in the liftability analysis,
-reported by A. Jaffer (jaffer @@ alum.mit.edu).
+reported by A. Jaffer (agj @@ alum.mit.edu).
@item
A bug occurring in case arguments are evaluated right-to-left,
which happens with Hobbit compiled by gcc on Linux.
@@ -2269,5 +2275,10 @@ the first release
@end table
+@node Index, , About Hobbit, Top
+@unnumbered Index
+
+@printindex fn
+
@contents
@bye
diff --git a/inc2scm b/inc2scm
index 5037e2c..951104b 100755
--- a/inc2scm
+++ b/inc2scm
@@ -43,11 +43,13 @@
;;;; "inc2scm", Convert numeric C #defines to Scheme definitions.
;;; Author: Aubrey Jaffer.
-(define (go-script)
- (cond ((< 1 (- (length *argv*) *optind*))
- (apply inc2scm (list-tail *argv* *optind*)))
- (else
- (display "\
+(define (inc2scm.script args)
+ (cond ((< 1 (length args))
+ (apply scm<-usr/includes args))
+ (else (inc2scm.usage))))
+
+(define (inc2scm.usage)
+ (display "\
\
Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ...
\
@@ -57,9 +59,11 @@ Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ...
PRE: is prepended to those scheme names lacking a prefix.
/USR/INCLUDE/ defaults to /usr/include/.
+
+http://swissnet.ai.mit.edu/~jaffer/SCM
"
- (current-error-port))
- (exit #f))))
+ (current-error-port))
+ #f)
(require 'string-search)
(require 'printf)
@@ -172,7 +176,6 @@ Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ...
(apply scm<-includes scmname pre include-path filenames)
(delete-file "tmpprog.c")
(delete-file "tmpprog"))
-(define inc2scm scm<-usr/includes)
(define (scm<-h* scmname . filenames)
(define pre (let ((first (car filenames)))
@@ -183,8 +186,7 @@ Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ...
(delete-file "tmpprog"))
(define h2scm scm<-h*)
-(go-script)
-
;;; Local Variables:
;;; mode:scheme
;;; End:
+(exit (inc2scm.script (list-tail *argv* *optind*)))
diff --git a/ioext.c b/ioext.c
index 62ec8b2..6a8e6e1 100644
--- a/ioext.c
+++ b/ioext.c
@@ -70,6 +70,9 @@ SCM stat2scm P((struct stat *stat_temp));
#ifdef __FreeBSD__
# include <unistd.h>
#endif
+#ifdef __NetBSD__
+# include <unistd.h>
+#endif
#ifdef __OpenBSD__
# include <unistd.h>
#endif
@@ -134,7 +137,7 @@ SCM read_line(port)
SCM tok_buf = makstr((long) len);
register char *p = CHARS(tok_buf);
if UNBNDP(port) port = cur_inp;
- else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_line);
+ else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_line);
if (EOF==(c = lgetc(port))) return EOF_VAL;
while(1) {
switch (c) {
@@ -161,11 +164,11 @@ SCM read_line1(str, port)
register int j = 0;
register char *p;
sizet len;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_read_line1);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_read_line1);
p = CHARS(str);
len = LENGTH(str);
if UNBNDP(port) port = cur_inp;
- else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG2, s_read_line1);
+ else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG2, s_read_line1);
c = lgetc(port);
if (EOF==c) return EOF_VAL;
while(1) {
@@ -197,7 +200,7 @@ SCM file_position(port)
SCM port;
{
long ans;
- ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position);
+ ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position);
SYSCALL(ans = ftell(STREAM(port)););
if CRDYP(port) ans--;
return MAKINUM(ans);
@@ -206,7 +209,7 @@ SCM file_set_position(port, pos)
SCM port, pos;
{
SCM ans;
- ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos);
+ ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos);
#ifndef RECKLESS
if (TRACKED & SCM_PORTFLAGS(port)) {
if (INUM0==pos) {
@@ -226,7 +229,7 @@ SCM file_set_position(port, pos)
#ifdef HAVE_PIPE
# ifdef ESPIPE
if (!OPIOPORTP(port))
- ASSERT(ESPIPE != errno, port, ARG1, s_file_set_pos);
+ ASRTER(ESPIPE != errno, port, ARG1, s_file_set_pos);
# endif
#endif
return ans;
@@ -239,12 +242,12 @@ SCM reopen_file(filename, modes, port)
FILE *f;
char cmodes[4];
long flags;
- ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file);
- ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_reopen_file);
+ ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file);
+ ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_reopen_file);
flags = mode_bits(CHARS(modes), cmodes);
- ASSERT(flags, modes, ARG2, s_reopen_file);
+ ASRTER(flags, modes, ARG2, s_reopen_file);
DEFER_INTS;
- ASSERT(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file);
+ ASRTER(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file);
SCM_OPENCALL(f = freopen(CHARS(filename), cmodes, STREAM(port)));
if (!f) {
ALLOW_INTS;
@@ -272,10 +275,10 @@ SCM l_dup(oldpt, modes)
int tfd;
FILE *f;
SCM newpt;
- ASSERT(NIMP(oldpt) && OPFPORTP(oldpt), oldpt, ARG1, s_dup);
- ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_dup);
+ ASRTER(NIMP(oldpt) && OPFPORTP(oldpt), oldpt, ARG1, s_dup);
+ ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_dup);
flags = mode_bits(CHARS(modes), cmodes);
- ASSERT(flags, modes, ARG2, s_dup);
+ ASRTER(flags, modes, ARG2, s_dup);
NEWCELL(newpt);
DEFER_INTS;
SCM_OPENCALL(tfd = dup(fileno(STREAM(oldpt))));
@@ -303,8 +306,8 @@ SCM l_dup2(into_pt, from_pt)
{
int ans, oldfd, newfd;
DEFER_INTS;
- ASSERT(NIMP(into_pt) && OPFPORTP(into_pt), into_pt, ARG1, s_dup2);
- ASSERT(NIMP(from_pt) && OPFPORTP(from_pt), from_pt, ARG1, s_dup2);
+ ASRTER(NIMP(into_pt) && OPFPORTP(into_pt), into_pt, ARG1, s_dup2);
+ ASRTER(NIMP(from_pt) && OPFPORTP(from_pt), from_pt, ARG1, s_dup2);
oldfd = fileno(STREAM(into_pt));
newfd = fileno(STREAM(from_pt));
SCM_OPENCALL(ans = dup2(oldfd, newfd));
@@ -315,15 +318,18 @@ SCM l_dup2(into_pt, from_pt)
# endif
# ifndef vms
+static char s_opendir[]="opendir";
+static char s_readdir[]="readdir";
+static char s_rewinddir[]="rewinddir";
+static char s_closedir[]="closedir";
# ifndef _WIN32
# include <dirent.h>
-static char s_opendir[]="opendir";
SCM l_opendir(dirname)
SCM dirname;
{
DIR *ds;
SCM dir;
- ASSERT(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir);
+ ASRTER(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir);
NEWCELL(dir);
DEFER_INTS;
SCM_OPENCALL(ds = opendir(CHARS(dirname)));
@@ -333,33 +339,33 @@ SCM l_opendir(dirname)
ALLOW_INTS;
return dir;
}
-static char s_readdir[]="readdir";
+
SCM l_readdir(port)
SCM port;
{
struct dirent *rdent;
DEFER_INTS;
- ASSERT(OPDIRP(port), port, ARG1, s_readdir);
+ ASRTER(OPDIRP(port), port, ARG1, s_readdir);
SYSCALL(rdent = readdir((DIR *)CDR(port)););
if (!rdent) {ALLOW_INTS; return BOOL_F;}
ALLOW_INTS;
/* rdent could be overwritten by another readdir to the same handle */
return makfrom0str((char *)rdent->d_name);
}
-static char s_rewinddir[]="rewinddir";
+
SCM l_rewinddir(port)
SCM port;
{
- ASSERT(OPDIRP(port), port, ARG1, s_rewinddir);
+ ASRTER(OPDIRP(port), port, ARG1, s_rewinddir);
rewinddir((DIR *)CDR(port));
return UNSPECIFIED;
}
-static char s_closedir[]="closedir";
+
SCM l_closedir(port)
SCM port;
{
int sts;
- ASSERT(DIRP(port), port, ARG1, s_closedir);
+ ASRTER(DIRP(port), port, ARG1, s_closedir);
DEFER_INTS;
if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;}
SYSCALL(sts = closedir((DIR *)CDR(port)););
@@ -381,10 +387,117 @@ sizet dir_free(p)
if OPENP((SCM)p) closedir((DIR *)CDR((SCM)p));
return 0;
}
+# define dir_mark mark0
+# else /* _WIN32 */
+struct WDIR {
+ long handle; //-1 if at end of list.
+ struct _finddata_t info;
+ SCM fspec; //for rewind, needs gc protection.
+};
-long tc16_dir;
-static smobfuns dir_smob = {mark0, dir_free, dir_print, 0};
+SCM l_opendir(dirname)
+ SCM dirname;
+{
+ long handle;
+ SCM fspec, dir;
+ struct _finddata_t info;
+ struct WDIR *wdir;
+ int dlen;
+ ASRTER(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir);
+ dlen = LENGTH(dirname);
+ fspec = makstr(dlen + 2);
+ strcpy(CHARS(fspec), CHARS(dirname));
+ if ('/' != CHARS(fspec)[dlen - 1] && '\\' != CHARS(fspec)[dlen - 1])
+ CHARS(fspec)[dlen++] = '/';
+ CHARS(fspec)[dlen++] = '*';
+ CHARS(fspec)[dlen] = 0;
+ DEFER_INTS;
+ dir = must_malloc_cell(sizeof(struct WDIR)+0L, tc16_dir, s_opendir);
+ wdir = (struct WDIR*)CHARS(dir);
+ wdir->fspec = fspec;
+ SCM_OPENCALL(handle = _findfirst(CHARS(fspec), &(wdir->info)));
+ if (-1 == handle) {ALLOW_INTS; return BOOL_F;}
+ wdir->handle = handle;
+ CAR(dir) |= OPN;
+ ALLOW_INTS;
+ return dir;
+}
+
+SCM l_readdir(port)
+ SCM port;
+{
+ SCM fname;
+ struct WDIR *wdir;
+ int ret;
+ ASRTER(OPDIRP(port), port, ARG1, s_readdir);
+ wdir = (struct WDIR*)CHARS(port);
+ if (-1 == wdir->handle) return BOOL_F;
+ fname = makfrom0str(wdir->info.name);
+ DEFER_INTS;
+ SYSCALL(ret = _findnext(wdir->handle, &(wdir->info)););
+ if (0 != ret) {
+ SYSCALL(_findclose(wdir->handle););
+ wdir->handle = -1;
+ }
+ ALLOW_INTS;
+ return fname;
+}
+
+SCM l_rewinddir(port)
+ SCM port;
+{
+ struct WDIR *wdir;
+ ASRTER(OPDIRP(port), port, ARG1, s_rewinddir);
+ wdir = (struct WDIR*)CHARS(port);
+ DEFER_INTS;
+ if (-1 != wdir->handle)
+ SYSCALL(_findclose(wdir->handle););
+ SYSCALL(wdir->handle = _findfirst(CHARS(wdir->fspec), &(wdir->info)););
+ ALLOW_INTS;
+ return UNSPECIFIED;
+}
+
+SCM l_closedir(port)
+ SCM port;
+{
+ struct WDIR *wdir;
+ ASRTER(DIRP(port), port, ARG1, s_closedir);
+ wdir = (struct WDIR*)CHARS(port);
+ DEFER_INTS;
+ if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;}
+ if (-1 != wdir->handle) {
+ SYSCALL(_findclose(wdir->handle););
+ wdir->handle = -1;
+ }
+ CAR(port) = tc16_dir;
+ wdir->fspec = UNSPECIFIED;
+ ALLOW_INTS;
+ return BOOL_T;
+}
+
+int dir_print(sexp, port, writing)
+ SCM sexp; SCM port; int writing;
+{
+ prinport(sexp, port, "directory");
+ return !0;
+}
+sizet dir_free(p)
+ CELLPTR p;
+{
+ struct WDIR *wdir = (struct WDIR*)CHARS((SCM)p);
+ if (-1 != wdir->handle)
+ _findclose(wdir->handle);
+ must_free(CHARS((SCM)p), (sizet)sizeof(struct WDIR));
+ return 0;
+}
+SCM dir_mark(ptr)
+ SCM ptr;
+{
+ return ((struct WDIR*)CHARS(ptr))->fspec;
+}
# endif /* _WIN32 */
+long tc16_dir;
+static smobfuns dir_smob = {dir_mark, dir_free, dir_print, 0};
# endif /* vms */
static char s_mkdir[] = "mkdir";
@@ -392,8 +505,8 @@ SCM l_mkdir(path, mode)
SCM path, mode;
{
int val;
- ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_mkdir);
- ASSERT(INUMP(mode), mode, ARG2, s_mkdir);
+ ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_mkdir);
+ ASRTER(INUMP(mode), mode, ARG2, s_mkdir);
# ifdef _WIN32
SYSCALL(val = mkdir(CHARS(path)););
# else
@@ -410,7 +523,7 @@ SCM l_rmdir(path)
SCM path;
{
int val;
- ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_rmdir);
+ ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_rmdir);
# ifdef vms
return del_fil(st_append(cons2(path, s_dot_dir, EOL)));
# else
@@ -426,7 +539,7 @@ SCM lchdir(str)
SCM str;
{
int ans;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_chdir);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_chdir);
SYSCALL(ans = chdir(CHARS(str)););
return ans ? BOOL_F : BOOL_T;
}
@@ -453,8 +566,8 @@ SCM l_chmod(pathname, mode)
SCM pathname, mode;
{
int val;
- ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_chmod);
- ASSERT(INUMP(mode), mode, ARG2, s_chmod);
+ ASRTER(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_chmod);
+ ASRTER(INUMP(mode), mode, ARG2, s_chmod);
SYSCALL(val = chmod(CHARS(pathname), INUM(mode)););
return val ? BOOL_F : BOOL_T;
}
@@ -478,7 +591,7 @@ SCM l_utime(pathname, acctime, modtime)
struct utimbuf utm_tmp;
utm_tmp.actime = num2ulong(acctime, (char *)ARG2, s_utime);
utm_tmp.modtime = num2ulong(modtime, (char *)ARG3, s_utime);
- ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_utime);
+ ASRTER(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_utime);
SYSCALL(val = utime(CHARS(pathname), &utm_tmp););
return val ? BOOL_F : BOOL_T;
}
@@ -489,7 +602,7 @@ static char s_umask[] = "umask";
SCM l_umask(mode)
SCM mode;
{
- ASSERT(INUMP(mode), mode, ARG1, s_umask);
+ ASRTER(INUMP(mode), mode, ARG1, s_umask);
return MAKINUM(umask(INUM(mode)));
}
# endif
@@ -501,8 +614,8 @@ SCM ren_fil(oldname, newname)
SCM oldname, newname;
{
SCM ans;
- ASSERT(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil);
- ASSERT(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil);
+ ASRTER(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil);
+ ASRTER(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil);
#if 1 /* def STDC_HEADERS */
SYSCALL(ans = (rename(CHARS(oldname), CHARS(newname))) ? BOOL_F: BOOL_T;);
return ans;
@@ -522,7 +635,7 @@ static char s_fileno[] = "fileno";
SCM l_fileno(port)
SCM port;
{
- ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_fileno);
+ ASRTER(NIMP(port) && OPPORTP(port), port, ARG1, s_fileno);
if (tc16_fport != TYP16(port)) return BOOL_F;
return MAKINUM(fileno(STREAM(port)));
}
@@ -540,10 +653,10 @@ SCM l_access(pathname, mode)
{
int val;
int imodes;
- ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_access);
+ ASRTER(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_access);
if INUMP(mode) imodes = INUM(mode);
else {
- ASSERT(NIMP(mode) && STRINGP(mode), mode, ARG2, s_access);
+ ASRTER(NIMP(mode) && STRINGP(mode), mode, ARG2, s_access);
imodes = F_OK | (strchr(CHARS(mode), 'r') ? R_OK : 0)
| (strchr(CHARS(mode), 'w') ? W_OK : 0)
| (strchr(CHARS(mode), 'x') ? X_OK : 0);
@@ -630,8 +743,8 @@ SCM i_execv(modes, path, args)
{
char **execargv;
int i = ilength(args);
- ASSERT(i>0, args, WNA, s_execv);
- ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_execv);
+ ASRTER(i>0, args, WNA, s_execv);
+ ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_execv);
/* dowinds(EOL); */
args = cons(path, args);
DEFER_INTS;
@@ -667,7 +780,7 @@ static char s_putenv[] = "putenv";
SCM l_putenv(str)
SCM str;
{
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_putenv);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_putenv);
return putenv(CHARS(str)) ? BOOL_F : BOOL_T;
}
# endif
@@ -680,12 +793,10 @@ static iproc subr1s[] = {
{s_fileno, l_fileno},
#ifndef MCH_AMIGA
# ifndef vms
-# ifndef _WIN32
{s_opendir, l_opendir},
{s_readdir, l_readdir},
{s_rewinddir, l_rewinddir},
{s_closedir, l_closedir},
-# endif
# endif
{s_rmdir, l_rmdir},
#endif
@@ -734,11 +845,11 @@ SCM scm_try_create_file(fname, modes, perms)
# else
int cperms = 0666;
# endif
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_try_create_file);
- ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_try_create_file);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_try_create_file);
+ ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_try_create_file);
if (NNULLP(perms)) {
perms = CAR(perms);
- ASSERT(INUMP(perms), perms, ARG3, s_try_create_file);
+ ASRTER(INUMP(perms), perms, ARG3, s_try_create_file);
# ifdef S_IROTH
cperms = (mode_t)INUM(perms);
# else
@@ -746,7 +857,7 @@ SCM scm_try_create_file(fname, modes, perms)
# endif
}
flags = mode_bits(CHARS(modes), cmodes);
- ASSERT(flags, modes, ARG2, s_try_create_file);
+ ASRTER(flags, modes, ARG2, s_try_create_file);
fdflags |= (RDNG & flags) ? O_RDWR : O_WRONLY;
DEFER_INTS;
SCM_OPENCALL(fd = open(CHARS(fname), fdflags, cperms));
@@ -768,6 +879,8 @@ static iproc subr2os[] = {
{s_write_line, l_write_line},
{0, 0}};
+SCM_DLL_EXPORT void init_ioext P((void));
+
void init_ioext()
{
init_iprocs(subr1os, tc7_subr_1o);
@@ -787,8 +900,8 @@ void init_ioext()
# ifndef vms
# ifndef _WIN32
make_subr(s_utime, tc7_subr_3, l_utime);
- tc16_dir = newsmob(&dir_smob);
# endif
+ tc16_dir = newsmob(&dir_smob);
# endif
# endif
#endif
@@ -809,6 +922,11 @@ void init_ioext()
add_feature("line-i/o");
scm_ldstr("\n\
(define (file-exists? path) (access path \"r\"))\n\
+(define (make-directory path)\n\
+ (define umsk (umask 18))\n\
+ (umask umsk)\n\
+ (mkdir path (logxor #o777 umsk)))\n\
+(define current-directory getcwd)\n\
(define (directory-for-each proc dirname . args)\n\
(define dir (opendir (if (symbol? dirname)\n\
(symbol->string dirname)\n\
@@ -830,6 +948,17 @@ void init_ioext()
(do ((filename (readdir dir) (readdir dir)))\n\
((not filename) (closedir dir))\n\
(and (selector filename) (proc filename))))))\n\
+(define (system->line command . tmp)\n\
+ (require 'filename)\n\
+ (cond ((null? tmp)\n\
+ (call-with-tmpnam\n\
+ (lambda (tmp) (system->line command tmp))))\n\
+ (else\n\
+ (set! tmp (car tmp))\n\
+ (and (zero? (system (string-append command \" > \" tmp)))\n\
+ (file-exists? tmp)\n\
+ (let ((line (call-with-input-file tmp read-line)))\n\
+ (if (eof-object? line) \"\" line))))))\n\
");
- add_feature("directory-for-each");
+ add_feature("directory");
}
diff --git a/keysymdef.scm b/keysymdef.scm
index d35fcc7..1329c4b 100644
--- a/keysymdef.scm
+++ b/keysymdef.scm
@@ -226,6 +226,8 @@
(define XK:dead-voiced-sound 65118)
(define XK:dead-semivoiced-sound 65119)
(define XK:dead-belowdot 65120)
+(define XK:dead-hook 65121)
+(define XK:dead-horn 65122)
(define XK:First-Virtual-Screen 65232)
(define XK:Prev-Virtual-Screen 65233)
(define XK:Next-Virtual-Screen 65234)
@@ -427,6 +429,7 @@
(define XK:Odiaeresis 214)
(define XK:multiply 215)
(define XK:Ooblique 216)
+(define XK:Oslash 216)
(define XK:Ugrave 217)
(define XK:Uacute 218)
(define XK:Ucircumflex 219)
@@ -460,6 +463,7 @@
(define XK:odiaeresis 246)
(define XK:division 247)
(define XK:oslash 248)
+(define XK:ooblique 248)
(define XK:ugrave 249)
(define XK:uacute 250)
(define XK:ucircumflex 251)
@@ -582,13 +586,340 @@
(define XK:uogonek 1017)
(define XK:utilde 1021)
(define XK:umacron 1022)
+(define XK:Babovedot 4769)
+(define XK:babovedot 4770)
+(define XK:Dabovedot 4774)
+(define XK:Wgrave 4776)
+(define XK:Wacute 4778)
+(define XK:dabovedot 4779)
+(define XK:Ygrave 4780)
+(define XK:Fabovedot 4784)
+(define XK:fabovedot 4785)
+(define XK:Mabovedot 4788)
+(define XK:mabovedot 4789)
+(define XK:Pabovedot 4791)
+(define XK:wgrave 4792)
+(define XK:pabovedot 4793)
+(define XK:wacute 4794)
+(define XK:Sabovedot 4795)
+(define XK:ygrave 4796)
+(define XK:Wdiaeresis 4797)
+(define XK:wdiaeresis 4798)
+(define XK:sabovedot 4799)
+(define XK:Wcircumflex 4816)
+(define XK:Tabovedot 4823)
+(define XK:Ycircumflex 4830)
+(define XK:wcircumflex 4848)
+(define XK:tabovedot 4855)
+(define XK:ycircumflex 4862)
(define XK:OE 5052)
(define XK:oe 5053)
(define XK:Ydiaeresis 5054)
+(define XK:overline 1150)
+(define XK:kana-fullstop 1185)
+(define XK:kana-openingbracket 1186)
+(define XK:kana-closingbracket 1187)
+(define XK:kana-comma 1188)
+(define XK:kana-conjunctive 1189)
+(define XK:kana-middledot 1189)
+(define XK:kana-WO 1190)
+(define XK:kana-a 1191)
+(define XK:kana-i 1192)
+(define XK:kana-u 1193)
+(define XK:kana-e 1194)
+(define XK:kana-o 1195)
+(define XK:kana-ya 1196)
+(define XK:kana-yu 1197)
+(define XK:kana-yo 1198)
+(define XK:kana-tsu 1199)
+(define XK:kana-tu 1199)
+(define XK:prolongedsound 1200)
+(define XK:kana-A 1201)
+(define XK:kana-I 1202)
+(define XK:kana-U 1203)
+(define XK:kana-E 1204)
+(define XK:kana-O 1205)
+(define XK:kana-KA 1206)
+(define XK:kana-KI 1207)
+(define XK:kana-KU 1208)
+(define XK:kana-KE 1209)
+(define XK:kana-KO 1210)
+(define XK:kana-SA 1211)
+(define XK:kana-SHI 1212)
+(define XK:kana-SU 1213)
+(define XK:kana-SE 1214)
+(define XK:kana-SO 1215)
+(define XK:kana-TA 1216)
+(define XK:kana-CHI 1217)
+(define XK:kana-TI 1217)
+(define XK:kana-TSU 1218)
+(define XK:kana-TU 1218)
+(define XK:kana-TE 1219)
+(define XK:kana-TO 1220)
+(define XK:kana-NA 1221)
+(define XK:kana-NI 1222)
+(define XK:kana-NU 1223)
+(define XK:kana-NE 1224)
+(define XK:kana-NO 1225)
+(define XK:kana-HA 1226)
+(define XK:kana-HI 1227)
+(define XK:kana-FU 1228)
+(define XK:kana-HU 1228)
+(define XK:kana-HE 1229)
+(define XK:kana-HO 1230)
+(define XK:kana-MA 1231)
+(define XK:kana-MI 1232)
+(define XK:kana-MU 1233)
+(define XK:kana-ME 1234)
+(define XK:kana-MO 1235)
+(define XK:kana-YA 1236)
+(define XK:kana-YU 1237)
+(define XK:kana-YO 1238)
+(define XK:kana-RA 1239)
+(define XK:kana-RI 1240)
+(define XK:kana-RU 1241)
+(define XK:kana-RE 1242)
+(define XK:kana-RO 1243)
+(define XK:kana-WA 1244)
+(define XK:kana-N 1245)
+(define XK:voicedsound 1246)
+(define XK:semivoicedsound 1247)
+(define XK:kana-switch 65406)
+(define XK:Farsi-0 1424)
+(define XK:Farsi-1 1425)
+(define XK:Farsi-2 1426)
+(define XK:Farsi-3 1427)
+(define XK:Farsi-4 1428)
+(define XK:Farsi-5 1429)
+(define XK:Farsi-6 1430)
+(define XK:Farsi-7 1431)
+(define XK:Farsi-8 1432)
+(define XK:Farsi-9 1433)
+(define XK:Arabic-percent 1445)
+(define XK:Arabic-superscript-alef 1446)
+(define XK:Arabic-tteh 1447)
+(define XK:Arabic-peh 1448)
+(define XK:Arabic-tcheh 1449)
+(define XK:Arabic-ddal 1450)
+(define XK:Arabic-rreh 1451)
+(define XK:Arabic-comma 1452)
+(define XK:Arabic-fullstop 1454)
+(define XK:Arabic-0 1456)
+(define XK:Arabic-1 1457)
+(define XK:Arabic-2 1458)
+(define XK:Arabic-3 1459)
+(define XK:Arabic-4 1460)
+(define XK:Arabic-5 1461)
+(define XK:Arabic-6 1462)
+(define XK:Arabic-7 1463)
+(define XK:Arabic-8 1464)
+(define XK:Arabic-9 1465)
+(define XK:Arabic-semicolon 1467)
+(define XK:Arabic-question-mark 1471)
+(define XK:Arabic-hamza 1473)
+(define XK:Arabic-maddaonalef 1474)
+(define XK:Arabic-hamzaonalef 1475)
+(define XK:Arabic-hamzaonwaw 1476)
+(define XK:Arabic-hamzaunderalef 1477)
+(define XK:Arabic-hamzaonyeh 1478)
+(define XK:Arabic-alef 1479)
+(define XK:Arabic-beh 1480)
+(define XK:Arabic-tehmarbuta 1481)
+(define XK:Arabic-teh 1482)
+(define XK:Arabic-theh 1483)
+(define XK:Arabic-jeem 1484)
+(define XK:Arabic-hah 1485)
+(define XK:Arabic-khah 1486)
+(define XK:Arabic-dal 1487)
+(define XK:Arabic-thal 1488)
+(define XK:Arabic-ra 1489)
+(define XK:Arabic-zain 1490)
+(define XK:Arabic-seen 1491)
+(define XK:Arabic-sheen 1492)
+(define XK:Arabic-sad 1493)
+(define XK:Arabic-dad 1494)
+(define XK:Arabic-tah 1495)
+(define XK:Arabic-zah 1496)
+(define XK:Arabic-ain 1497)
+(define XK:Arabic-ghain 1498)
+(define XK:Arabic-tatweel 1504)
+(define XK:Arabic-feh 1505)
+(define XK:Arabic-qaf 1506)
+(define XK:Arabic-kaf 1507)
+(define XK:Arabic-lam 1508)
+(define XK:Arabic-meem 1509)
+(define XK:Arabic-noon 1510)
+(define XK:Arabic-ha 1511)
+(define XK:Arabic-heh 1511)
+(define XK:Arabic-waw 1512)
+(define XK:Arabic-alefmaksura 1513)
+(define XK:Arabic-yeh 1514)
+(define XK:Arabic-fathatan 1515)
+(define XK:Arabic-dammatan 1516)
+(define XK:Arabic-kasratan 1517)
+(define XK:Arabic-fatha 1518)
+(define XK:Arabic-damma 1519)
+(define XK:Arabic-kasra 1520)
+(define XK:Arabic-shadda 1521)
+(define XK:Arabic-sukun 1522)
+(define XK:Arabic-madda-above 1523)
+(define XK:Arabic-hamza-above 1524)
+(define XK:Arabic-hamza-below 1525)
+(define XK:Arabic-jeh 1526)
+(define XK:Arabic-veh 1527)
+(define XK:Arabic-keheh 1528)
+(define XK:Arabic-gaf 1529)
+(define XK:Arabic-noon-ghunna 1530)
+(define XK:Arabic-heh-doachashmee 1531)
+(define XK:Farsi-yeh 1532)
+(define XK:Arabic-farsi-yeh 1532)
+(define XK:Arabic-yeh-baree 1533)
+(define XK:Arabic-heh-goal 1534)
+(define XK:Arabic-switch 65406)
+(define XK:Cyrillic-GHE-bar 1664)
+(define XK:Cyrillic-ghe-bar 1680)
+(define XK:Cyrillic-ZHE-descender 1665)
+(define XK:Cyrillic-zhe-descender 1681)
+(define XK:Cyrillic-KA-descender 1666)
+(define XK:Cyrillic-ka-descender 1682)
+(define XK:Cyrillic-KA-vertstroke 1667)
+(define XK:Cyrillic-ka-vertstroke 1683)
+(define XK:Cyrillic-EN-descender 1668)
+(define XK:Cyrillic-en-descender 1684)
+(define XK:Cyrillic-U-straight 1669)
+(define XK:Cyrillic-u-straight 1685)
+(define XK:Cyrillic-U-straight-bar 1670)
+(define XK:Cyrillic-u-straight-bar 1686)
+(define XK:Cyrillic-HA-descender 1671)
+(define XK:Cyrillic-ha-descender 1687)
+(define XK:Cyrillic-CHE-descender 1672)
+(define XK:Cyrillic-che-descender 1688)
+(define XK:Cyrillic-CHE-vertstroke 1673)
+(define XK:Cyrillic-che-vertstroke 1689)
+(define XK:Cyrillic-SHHA 1674)
+(define XK:Cyrillic-shha 1690)
+(define XK:Cyrillic-SCHWA 1676)
+(define XK:Cyrillic-schwa 1692)
+(define XK:Cyrillic-I-macron 1677)
+(define XK:Cyrillic-i-macron 1693)
+(define XK:Cyrillic-O-bar 1678)
+(define XK:Cyrillic-o-bar 1694)
+(define XK:Cyrillic-U-macron 1679)
+(define XK:Cyrillic-u-macron 1695)
+(define XK:Serbian-dje 1697)
+(define XK:Macedonia-gje 1698)
+(define XK:Cyrillic-io 1699)
+(define XK:Ukrainian-ie 1700)
+(define XK:Ukranian-je 1700)
+(define XK:Macedonia-dse 1701)
+(define XK:Ukrainian-i 1702)
+(define XK:Ukranian-i 1702)
+(define XK:Ukrainian-yi 1703)
+(define XK:Ukranian-yi 1703)
+(define XK:Cyrillic-je 1704)
+(define XK:Serbian-je 1704)
+(define XK:Cyrillic-lje 1705)
+(define XK:Serbian-lje 1705)
+(define XK:Cyrillic-nje 1706)
+(define XK:Serbian-nje 1706)
+(define XK:Serbian-tshe 1707)
+(define XK:Macedonia-kje 1708)
+(define XK:Ukrainian-ghe-with-upturn 1709)
+(define XK:Byelorussian-shortu 1710)
+(define XK:Cyrillic-dzhe 1711)
+(define XK:Serbian-dze 1711)
+(define XK:numerosign 1712)
+(define XK:Serbian-DJE 1713)
+(define XK:Macedonia-GJE 1714)
+(define XK:Cyrillic-IO 1715)
+(define XK:Ukrainian-IE 1716)
+(define XK:Ukranian-JE 1716)
+(define XK:Macedonia-DSE 1717)
+(define XK:Ukrainian-I 1718)
+(define XK:Ukranian-I 1718)
+(define XK:Ukrainian-YI 1719)
+(define XK:Ukranian-YI 1719)
+(define XK:Cyrillic-JE 1720)
+(define XK:Serbian-JE 1720)
+(define XK:Cyrillic-LJE 1721)
+(define XK:Serbian-LJE 1721)
+(define XK:Cyrillic-NJE 1722)
+(define XK:Serbian-NJE 1722)
+(define XK:Serbian-TSHE 1723)
+(define XK:Macedonia-KJE 1724)
+(define XK:Ukrainian-GHE-WITH-UPTURN 1725)
+(define XK:Byelorussian-SHORTU 1726)
+(define XK:Cyrillic-DZHE 1727)
+(define XK:Serbian-DZE 1727)
+(define XK:Cyrillic-yu 1728)
+(define XK:Cyrillic-a 1729)
+(define XK:Cyrillic-be 1730)
+(define XK:Cyrillic-tse 1731)
+(define XK:Cyrillic-de 1732)
+(define XK:Cyrillic-ie 1733)
+(define XK:Cyrillic-ef 1734)
+(define XK:Cyrillic-ghe 1735)
+(define XK:Cyrillic-ha 1736)
+(define XK:Cyrillic-i 1737)
+(define XK:Cyrillic-shorti 1738)
+(define XK:Cyrillic-ka 1739)
+(define XK:Cyrillic-el 1740)
+(define XK:Cyrillic-em 1741)
+(define XK:Cyrillic-en 1742)
+(define XK:Cyrillic-o 1743)
+(define XK:Cyrillic-pe 1744)
+(define XK:Cyrillic-ya 1745)
+(define XK:Cyrillic-er 1746)
+(define XK:Cyrillic-es 1747)
+(define XK:Cyrillic-te 1748)
+(define XK:Cyrillic-u 1749)
+(define XK:Cyrillic-zhe 1750)
+(define XK:Cyrillic-ve 1751)
+(define XK:Cyrillic-softsign 1752)
+(define XK:Cyrillic-yeru 1753)
+(define XK:Cyrillic-ze 1754)
+(define XK:Cyrillic-sha 1755)
+(define XK:Cyrillic-e 1756)
+(define XK:Cyrillic-shcha 1757)
+(define XK:Cyrillic-che 1758)
+(define XK:Cyrillic-hardsign 1759)
+(define XK:Cyrillic-YU 1760)
+(define XK:Cyrillic-A 1761)
+(define XK:Cyrillic-BE 1762)
+(define XK:Cyrillic-TSE 1763)
+(define XK:Cyrillic-DE 1764)
+(define XK:Cyrillic-IE 1765)
+(define XK:Cyrillic-EF 1766)
+(define XK:Cyrillic-GHE 1767)
+(define XK:Cyrillic-HA 1768)
+(define XK:Cyrillic-I 1769)
+(define XK:Cyrillic-SHORTI 1770)
+(define XK:Cyrillic-KA 1771)
+(define XK:Cyrillic-EL 1772)
+(define XK:Cyrillic-EM 1773)
+(define XK:Cyrillic-EN 1774)
+(define XK:Cyrillic-O 1775)
+(define XK:Cyrillic-PE 1776)
+(define XK:Cyrillic-YA 1777)
+(define XK:Cyrillic-ER 1778)
+(define XK:Cyrillic-ES 1779)
+(define XK:Cyrillic-TE 1780)
+(define XK:Cyrillic-U 1781)
+(define XK:Cyrillic-ZHE 1782)
+(define XK:Cyrillic-VE 1783)
+(define XK:Cyrillic-SOFTSIGN 1784)
+(define XK:Cyrillic-YERU 1785)
+(define XK:Cyrillic-ZE 1786)
+(define XK:Cyrillic-SHA 1787)
+(define XK:Cyrillic-E 1788)
+(define XK:Cyrillic-SHCHA 1789)
+(define XK:Cyrillic-CHE 1790)
+(define XK:Cyrillic-HARDSIGN 1791)
(define XK:Greek-ALPHAaccent 1953)
(define XK:Greek-EPSILONaccent 1954)
(define XK:Greek-ETAaccent 1955)
(define XK:Greek-IOTAaccent 1956)
+(define XK:Greek-IOTAdieresis 1957)
(define XK:Greek-IOTAdiaeresis 1957)
(define XK:Greek-OMICRONaccent 1959)
(define XK:Greek-UPSILONaccent 1960)
@@ -659,6 +990,503 @@
(define XK:Greek-psi 2040)
(define XK:Greek-omega 2041)
(define XK:Greek-switch 65406)
+(define XK:hebrew-doublelowline 3295)
+(define XK:hebrew-aleph 3296)
+(define XK:hebrew-bet 3297)
+(define XK:hebrew-beth 3297)
+(define XK:hebrew-gimel 3298)
+(define XK:hebrew-gimmel 3298)
+(define XK:hebrew-dalet 3299)
+(define XK:hebrew-daleth 3299)
+(define XK:hebrew-he 3300)
+(define XK:hebrew-waw 3301)
+(define XK:hebrew-zain 3302)
+(define XK:hebrew-zayin 3302)
+(define XK:hebrew-chet 3303)
+(define XK:hebrew-het 3303)
+(define XK:hebrew-tet 3304)
+(define XK:hebrew-teth 3304)
+(define XK:hebrew-yod 3305)
+(define XK:hebrew-finalkaph 3306)
+(define XK:hebrew-kaph 3307)
+(define XK:hebrew-lamed 3308)
+(define XK:hebrew-finalmem 3309)
+(define XK:hebrew-mem 3310)
+(define XK:hebrew-finalnun 3311)
+(define XK:hebrew-nun 3312)
+(define XK:hebrew-samech 3313)
+(define XK:hebrew-samekh 3313)
+(define XK:hebrew-ayin 3314)
+(define XK:hebrew-finalpe 3315)
+(define XK:hebrew-pe 3316)
+(define XK:hebrew-finalzade 3317)
+(define XK:hebrew-finalzadi 3317)
+(define XK:hebrew-zade 3318)
+(define XK:hebrew-zadi 3318)
+(define XK:hebrew-qoph 3319)
+(define XK:hebrew-kuf 3319)
+(define XK:hebrew-resh 3320)
+(define XK:hebrew-shin 3321)
+(define XK:hebrew-taw 3322)
+(define XK:hebrew-taf 3322)
+(define XK:Hebrew-switch 65406)
+(define XK:Thai-kokai 3489)
+(define XK:Thai-khokhai 3490)
+(define XK:Thai-khokhuat 3491)
+(define XK:Thai-khokhwai 3492)
+(define XK:Thai-khokhon 3493)
+(define XK:Thai-khorakhang 3494)
+(define XK:Thai-ngongu 3495)
+(define XK:Thai-chochan 3496)
+(define XK:Thai-choching 3497)
+(define XK:Thai-chochang 3498)
+(define XK:Thai-soso 3499)
+(define XK:Thai-chochoe 3500)
+(define XK:Thai-yoying 3501)
+(define XK:Thai-dochada 3502)
+(define XK:Thai-topatak 3503)
+(define XK:Thai-thothan 3504)
+(define XK:Thai-thonangmontho 3505)
+(define XK:Thai-thophuthao 3506)
+(define XK:Thai-nonen 3507)
+(define XK:Thai-dodek 3508)
+(define XK:Thai-totao 3509)
+(define XK:Thai-thothung 3510)
+(define XK:Thai-thothahan 3511)
+(define XK:Thai-thothong 3512)
+(define XK:Thai-nonu 3513)
+(define XK:Thai-bobaimai 3514)
+(define XK:Thai-popla 3515)
+(define XK:Thai-phophung 3516)
+(define XK:Thai-fofa 3517)
+(define XK:Thai-phophan 3518)
+(define XK:Thai-fofan 3519)
+(define XK:Thai-phosamphao 3520)
+(define XK:Thai-moma 3521)
+(define XK:Thai-yoyak 3522)
+(define XK:Thai-rorua 3523)
+(define XK:Thai-ru 3524)
+(define XK:Thai-loling 3525)
+(define XK:Thai-lu 3526)
+(define XK:Thai-wowaen 3527)
+(define XK:Thai-sosala 3528)
+(define XK:Thai-sorusi 3529)
+(define XK:Thai-sosua 3530)
+(define XK:Thai-hohip 3531)
+(define XK:Thai-lochula 3532)
+(define XK:Thai-oang 3533)
+(define XK:Thai-honokhuk 3534)
+(define XK:Thai-paiyannoi 3535)
+(define XK:Thai-saraa 3536)
+(define XK:Thai-maihanakat 3537)
+(define XK:Thai-saraaa 3538)
+(define XK:Thai-saraam 3539)
+(define XK:Thai-sarai 3540)
+(define XK:Thai-saraii 3541)
+(define XK:Thai-saraue 3542)
+(define XK:Thai-sarauee 3543)
+(define XK:Thai-sarau 3544)
+(define XK:Thai-sarauu 3545)
+(define XK:Thai-phinthu 3546)
+(define XK:Thai-maihanakat-maitho 3550)
+(define XK:Thai-baht 3551)
+(define XK:Thai-sarae 3552)
+(define XK:Thai-saraae 3553)
+(define XK:Thai-sarao 3554)
+(define XK:Thai-saraaimaimuan 3555)
+(define XK:Thai-saraaimaimalai 3556)
+(define XK:Thai-lakkhangyao 3557)
+(define XK:Thai-maiyamok 3558)
+(define XK:Thai-maitaikhu 3559)
+(define XK:Thai-maiek 3560)
+(define XK:Thai-maitho 3561)
+(define XK:Thai-maitri 3562)
+(define XK:Thai-maichattawa 3563)
+(define XK:Thai-thanthakhat 3564)
+(define XK:Thai-nikhahit 3565)
+(define XK:Thai-leksun 3568)
+(define XK:Thai-leknung 3569)
+(define XK:Thai-leksong 3570)
+(define XK:Thai-leksam 3571)
+(define XK:Thai-leksi 3572)
+(define XK:Thai-lekha 3573)
+(define XK:Thai-lekhok 3574)
+(define XK:Thai-lekchet 3575)
+(define XK:Thai-lekpaet 3576)
+(define XK:Thai-lekkao 3577)
+(define XK:Hangul 65329)
+(define XK:Hangul-Start 65330)
+(define XK:Hangul-End 65331)
+(define XK:Hangul-Hanja 65332)
+(define XK:Hangul-Jamo 65333)
+(define XK:Hangul-Romaja 65334)
+(define XK:Hangul-Codeinput 65335)
+(define XK:Hangul-Jeonja 65336)
+(define XK:Hangul-Banja 65337)
+(define XK:Hangul-PreHanja 65338)
+(define XK:Hangul-PostHanja 65339)
+(define XK:Hangul-SingleCandidate 65340)
+(define XK:Hangul-MultipleCandidate 65341)
+(define XK:Hangul-PreviousCandidate 65342)
+(define XK:Hangul-Special 65343)
+(define XK:Hangul-switch 65406)
+(define XK:Hangul-Kiyeog 3745)
+(define XK:Hangul-SsangKiyeog 3746)
+(define XK:Hangul-KiyeogSios 3747)
+(define XK:Hangul-Nieun 3748)
+(define XK:Hangul-NieunJieuj 3749)
+(define XK:Hangul-NieunHieuh 3750)
+(define XK:Hangul-Dikeud 3751)
+(define XK:Hangul-SsangDikeud 3752)
+(define XK:Hangul-Rieul 3753)
+(define XK:Hangul-RieulKiyeog 3754)
+(define XK:Hangul-RieulMieum 3755)
+(define XK:Hangul-RieulPieub 3756)
+(define XK:Hangul-RieulSios 3757)
+(define XK:Hangul-RieulTieut 3758)
+(define XK:Hangul-RieulPhieuf 3759)
+(define XK:Hangul-RieulHieuh 3760)
+(define XK:Hangul-Mieum 3761)
+(define XK:Hangul-Pieub 3762)
+(define XK:Hangul-SsangPieub 3763)
+(define XK:Hangul-PieubSios 3764)
+(define XK:Hangul-Sios 3765)
+(define XK:Hangul-SsangSios 3766)
+(define XK:Hangul-Ieung 3767)
+(define XK:Hangul-Jieuj 3768)
+(define XK:Hangul-SsangJieuj 3769)
+(define XK:Hangul-Cieuc 3770)
+(define XK:Hangul-Khieuq 3771)
+(define XK:Hangul-Tieut 3772)
+(define XK:Hangul-Phieuf 3773)
+(define XK:Hangul-Hieuh 3774)
+(define XK:Hangul-A 3775)
+(define XK:Hangul-AE 3776)
+(define XK:Hangul-YA 3777)
+(define XK:Hangul-YAE 3778)
+(define XK:Hangul-EO 3779)
+(define XK:Hangul-E 3780)
+(define XK:Hangul-YEO 3781)
+(define XK:Hangul-YE 3782)
+(define XK:Hangul-O 3783)
+(define XK:Hangul-WA 3784)
+(define XK:Hangul-WAE 3785)
+(define XK:Hangul-OE 3786)
+(define XK:Hangul-YO 3787)
+(define XK:Hangul-U 3788)
+(define XK:Hangul-WEO 3789)
+(define XK:Hangul-WE 3790)
+(define XK:Hangul-WI 3791)
+(define XK:Hangul-YU 3792)
+(define XK:Hangul-EU 3793)
+(define XK:Hangul-YI 3794)
+(define XK:Hangul-I 3795)
+(define XK:Hangul-J-Kiyeog 3796)
+(define XK:Hangul-J-SsangKiyeog 3797)
+(define XK:Hangul-J-KiyeogSios 3798)
+(define XK:Hangul-J-Nieun 3799)
+(define XK:Hangul-J-NieunJieuj 3800)
+(define XK:Hangul-J-NieunHieuh 3801)
+(define XK:Hangul-J-Dikeud 3802)
+(define XK:Hangul-J-Rieul 3803)
+(define XK:Hangul-J-RieulKiyeog 3804)
+(define XK:Hangul-J-RieulMieum 3805)
+(define XK:Hangul-J-RieulPieub 3806)
+(define XK:Hangul-J-RieulSios 3807)
+(define XK:Hangul-J-RieulTieut 3808)
+(define XK:Hangul-J-RieulPhieuf 3809)
+(define XK:Hangul-J-RieulHieuh 3810)
+(define XK:Hangul-J-Mieum 3811)
+(define XK:Hangul-J-Pieub 3812)
+(define XK:Hangul-J-PieubSios 3813)
+(define XK:Hangul-J-Sios 3814)
+(define XK:Hangul-J-SsangSios 3815)
+(define XK:Hangul-J-Ieung 3816)
+(define XK:Hangul-J-Jieuj 3817)
+(define XK:Hangul-J-Cieuc 3818)
+(define XK:Hangul-J-Khieuq 3819)
+(define XK:Hangul-J-Tieut 3820)
+(define XK:Hangul-J-Phieuf 3821)
+(define XK:Hangul-J-Hieuh 3822)
+(define XK:Hangul-RieulYeorinHieuh 3823)
+(define XK:Hangul-SunkyeongeumMieum 3824)
+(define XK:Hangul-SunkyeongeumPieub 3825)
+(define XK:Hangul-PanSios 3826)
+(define XK:Hangul-KkogjiDalrinIeung 3827)
+(define XK:Hangul-SunkyeongeumPhieuf 3828)
+(define XK:Hangul-YeorinHieuh 3829)
+(define XK:Hangul-AraeA 3830)
+(define XK:Hangul-AraeAE 3831)
+(define XK:Hangul-J-PanSios 3832)
+(define XK:Hangul-J-KkogjiDalrinIeung 3833)
+(define XK:Hangul-J-YeorinHieuh 3834)
+(define XK:Korean-Won 3839)
+(define XK:Armenian-eternity 5281)
+(define XK:Armenian-ligature-ew 5282)
+(define XK:Armenian-full-stop 5283)
+(define XK:Armenian-verjaket 5283)
+(define XK:Armenian-parenright 5284)
+(define XK:Armenian-parenleft 5285)
+(define XK:Armenian-guillemotright 5286)
+(define XK:Armenian-guillemotleft 5287)
+(define XK:Armenian-em-dash 5288)
+(define XK:Armenian-dot 5289)
+(define XK:Armenian-mijaket 5289)
+(define XK:Armenian-separation-mark 5290)
+(define XK:Armenian-but 5290)
+(define XK:Armenian-comma 5291)
+(define XK:Armenian-en-dash 5292)
+(define XK:Armenian-hyphen 5293)
+(define XK:Armenian-yentamna 5293)
+(define XK:Armenian-ellipsis 5294)
+(define XK:Armenian-exclam 5295)
+(define XK:Armenian-amanak 5295)
+(define XK:Armenian-accent 5296)
+(define XK:Armenian-shesht 5296)
+(define XK:Armenian-question 5297)
+(define XK:Armenian-paruyk 5297)
+(define XK:Armenian-AYB 5298)
+(define XK:Armenian-ayb 5299)
+(define XK:Armenian-BEN 5300)
+(define XK:Armenian-ben 5301)
+(define XK:Armenian-GIM 5302)
+(define XK:Armenian-gim 5303)
+(define XK:Armenian-DA 5304)
+(define XK:Armenian-da 5305)
+(define XK:Armenian-YECH 5306)
+(define XK:Armenian-yech 5307)
+(define XK:Armenian-ZA 5308)
+(define XK:Armenian-za 5309)
+(define XK:Armenian-E 5310)
+(define XK:Armenian-e 5311)
+(define XK:Armenian-AT 5312)
+(define XK:Armenian-at 5313)
+(define XK:Armenian-TO 5314)
+(define XK:Armenian-to 5315)
+(define XK:Armenian-ZHE 5316)
+(define XK:Armenian-zhe 5317)
+(define XK:Armenian-INI 5318)
+(define XK:Armenian-ini 5319)
+(define XK:Armenian-LYUN 5320)
+(define XK:Armenian-lyun 5321)
+(define XK:Armenian-KHE 5322)
+(define XK:Armenian-khe 5323)
+(define XK:Armenian-TSA 5324)
+(define XK:Armenian-tsa 5325)
+(define XK:Armenian-KEN 5326)
+(define XK:Armenian-ken 5327)
+(define XK:Armenian-HO 5328)
+(define XK:Armenian-ho 5329)
+(define XK:Armenian-DZA 5330)
+(define XK:Armenian-dza 5331)
+(define XK:Armenian-GHAT 5332)
+(define XK:Armenian-ghat 5333)
+(define XK:Armenian-TCHE 5334)
+(define XK:Armenian-tche 5335)
+(define XK:Armenian-MEN 5336)
+(define XK:Armenian-men 5337)
+(define XK:Armenian-HI 5338)
+(define XK:Armenian-hi 5339)
+(define XK:Armenian-NU 5340)
+(define XK:Armenian-nu 5341)
+(define XK:Armenian-SHA 5342)
+(define XK:Armenian-sha 5343)
+(define XK:Armenian-VO 5344)
+(define XK:Armenian-vo 5345)
+(define XK:Armenian-CHA 5346)
+(define XK:Armenian-cha 5347)
+(define XK:Armenian-PE 5348)
+(define XK:Armenian-pe 5349)
+(define XK:Armenian-JE 5350)
+(define XK:Armenian-je 5351)
+(define XK:Armenian-RA 5352)
+(define XK:Armenian-ra 5353)
+(define XK:Armenian-SE 5354)
+(define XK:Armenian-se 5355)
+(define XK:Armenian-VEV 5356)
+(define XK:Armenian-vev 5357)
+(define XK:Armenian-TYUN 5358)
+(define XK:Armenian-tyun 5359)
+(define XK:Armenian-RE 5360)
+(define XK:Armenian-re 5361)
+(define XK:Armenian-TSO 5362)
+(define XK:Armenian-tso 5363)
+(define XK:Armenian-VYUN 5364)
+(define XK:Armenian-vyun 5365)
+(define XK:Armenian-PYUR 5366)
+(define XK:Armenian-pyur 5367)
+(define XK:Armenian-KE 5368)
+(define XK:Armenian-ke 5369)
+(define XK:Armenian-O 5370)
+(define XK:Armenian-o 5371)
+(define XK:Armenian-FE 5372)
+(define XK:Armenian-fe 5373)
+(define XK:Armenian-apostrophe 5374)
+(define XK:Armenian-section-sign 5375)
+(define XK:Georgian-an 5584)
+(define XK:Georgian-ban 5585)
+(define XK:Georgian-gan 5586)
+(define XK:Georgian-don 5587)
+(define XK:Georgian-en 5588)
+(define XK:Georgian-vin 5589)
+(define XK:Georgian-zen 5590)
+(define XK:Georgian-tan 5591)
+(define XK:Georgian-in 5592)
+(define XK:Georgian-kan 5593)
+(define XK:Georgian-las 5594)
+(define XK:Georgian-man 5595)
+(define XK:Georgian-nar 5596)
+(define XK:Georgian-on 5597)
+(define XK:Georgian-par 5598)
+(define XK:Georgian-zhar 5599)
+(define XK:Georgian-rae 5600)
+(define XK:Georgian-san 5601)
+(define XK:Georgian-tar 5602)
+(define XK:Georgian-un 5603)
+(define XK:Georgian-phar 5604)
+(define XK:Georgian-khar 5605)
+(define XK:Georgian-ghan 5606)
+(define XK:Georgian-qar 5607)
+(define XK:Georgian-shin 5608)
+(define XK:Georgian-chin 5609)
+(define XK:Georgian-can 5610)
+(define XK:Georgian-jil 5611)
+(define XK:Georgian-cil 5612)
+(define XK:Georgian-char 5613)
+(define XK:Georgian-xan 5614)
+(define XK:Georgian-jhan 5615)
+(define XK:Georgian-hae 5616)
+(define XK:Georgian-he 5617)
+(define XK:Georgian-hie 5618)
+(define XK:Georgian-we 5619)
+(define XK:Georgian-har 5620)
+(define XK:Georgian-hoe 5621)
+(define XK:Georgian-fi 5622)
+(define XK:Ccedillaabovedot 5794)
+(define XK:Xabovedot 5795)
+(define XK:Qabovedot 5797)
+(define XK:Ibreve 5798)
+(define XK:IE 5799)
+(define XK:UO 5800)
+(define XK:Zstroke 5801)
+(define XK:Gcaron 5802)
+(define XK:Obarred 5807)
+(define XK:ccedillaabovedot 5810)
+(define XK:xabovedot 5811)
+(define XK:Ocaron 5812)
+(define XK:qabovedot 5813)
+(define XK:ibreve 5814)
+(define XK:ie 5815)
+(define XK:uo 5816)
+(define XK:zstroke 5817)
+(define XK:gcaron 5818)
+(define XK:ocaron 5821)
+(define XK:obarred 5823)
+(define XK:SCHWA 5830)
+(define XK:schwa 5878)
+(define XK:Lbelowdot 5841)
+(define XK:Lstrokebelowdot 5842)
+(define XK:lbelowdot 5857)
+(define XK:lstrokebelowdot 5858)
+(define XK:Gtilde 5843)
+(define XK:gtilde 5859)
+(define XK:Abelowdot 7840)
+(define XK:abelowdot 7841)
+(define XK:Ahook 7842)
+(define XK:ahook 7843)
+(define XK:Acircumflexacute 7844)
+(define XK:acircumflexacute 7845)
+(define XK:Acircumflexgrave 7846)
+(define XK:acircumflexgrave 7847)
+(define XK:Acircumflexhook 7848)
+(define XK:acircumflexhook 7849)
+(define XK:Acircumflextilde 7850)
+(define XK:acircumflextilde 7851)
+(define XK:Acircumflexbelowdot 7852)
+(define XK:acircumflexbelowdot 7853)
+(define XK:Abreveacute 7854)
+(define XK:abreveacute 7855)
+(define XK:Abrevegrave 7856)
+(define XK:abrevegrave 7857)
+(define XK:Abrevehook 7858)
+(define XK:abrevehook 7859)
+(define XK:Abrevetilde 7860)
+(define XK:abrevetilde 7861)
+(define XK:Abrevebelowdot 7862)
+(define XK:abrevebelowdot 7863)
+(define XK:Ebelowdot 7864)
+(define XK:ebelowdot 7865)
+(define XK:Ehook 7866)
+(define XK:ehook 7867)
+(define XK:Etilde 7868)
+(define XK:etilde 7869)
+(define XK:Ecircumflexacute 7870)
+(define XK:ecircumflexacute 7871)
+(define XK:Ecircumflexgrave 7872)
+(define XK:ecircumflexgrave 7873)
+(define XK:Ecircumflexhook 7874)
+(define XK:ecircumflexhook 7875)
+(define XK:Ecircumflextilde 7876)
+(define XK:ecircumflextilde 7877)
+(define XK:Ecircumflexbelowdot 7878)
+(define XK:ecircumflexbelowdot 7879)
+(define XK:Ihook 7880)
+(define XK:ihook 7881)
+(define XK:Ibelowdot 7882)
+(define XK:ibelowdot 7883)
+(define XK:Obelowdot 7884)
+(define XK:obelowdot 7885)
+(define XK:Ohook 7886)
+(define XK:ohook 7887)
+(define XK:Ocircumflexacute 7888)
+(define XK:ocircumflexacute 7889)
+(define XK:Ocircumflexgrave 7890)
+(define XK:ocircumflexgrave 7891)
+(define XK:Ocircumflexhook 7892)
+(define XK:ocircumflexhook 7893)
+(define XK:Ocircumflextilde 7894)
+(define XK:ocircumflextilde 7895)
+(define XK:Ocircumflexbelowdot 7896)
+(define XK:ocircumflexbelowdot 7897)
+(define XK:Ohornacute 7898)
+(define XK:ohornacute 7899)
+(define XK:Ohorngrave 7900)
+(define XK:ohorngrave 7901)
+(define XK:Ohornhook 7902)
+(define XK:ohornhook 7903)
+(define XK:Ohorntilde 7904)
+(define XK:ohorntilde 7905)
+(define XK:Ohornbelowdot 7906)
+(define XK:ohornbelowdot 7907)
+(define XK:Ubelowdot 7908)
+(define XK:ubelowdot 7909)
+(define XK:Uhook 7910)
+(define XK:uhook 7911)
+(define XK:Uhornacute 7912)
+(define XK:uhornacute 7913)
+(define XK:Uhorngrave 7914)
+(define XK:uhorngrave 7915)
+(define XK:Uhornhook 7916)
+(define XK:uhornhook 7917)
+(define XK:Uhorntilde 7918)
+(define XK:uhorntilde 7919)
+(define XK:Uhornbelowdot 7920)
+(define XK:uhornbelowdot 7921)
+(define XK:Ybelowdot 7924)
+(define XK:ybelowdot 7925)
+(define XK:Yhook 7926)
+(define XK:yhook 7927)
+(define XK:Ytilde 7928)
+(define XK:ytilde 7929)
+(define XK:Ohorn 7930)
+(define XK:ohorn 7931)
+(define XK:Uhorn 7932)
+(define XK:uhorn 7933)
+(define XK:combining-tilde 7839)
+(define XK:combining-grave 7922)
+(define XK:combining-acute 7923)
+(define XK:combining-hook 7934)
+(define XK:combining-belowdot 7935)
(define XK:EcuSign 8352)
(define XK:ColonSign 8353)
(define XK:CruzeiroSign 8354)
diff --git a/mkimpcat.scm b/mkimpcat.scm
index f94f949..8f5929a 100644
--- a/mkimpcat.scm
+++ b/mkimpcat.scm
@@ -82,11 +82,15 @@
(in-implementation-vicinity "ioext" link:able-suffix)
(usr:lib "c"))
(add-alias 'directory-for-each 'i/o-extensions)
+ (add-alias 'directory 'i/o-extensions)
(add-alias 'line-i/o 'i/o-extensions)
(add-alias 'pipe 'i/o-extensions)))
(cond ((add-link 'rev2-procedures
(in-implementation-vicinity "sc2"
link:able-suffix))))
+ (cond ((add-link 'byte
+ (in-implementation-vicinity "byte"
+ link:able-suffix))))
(cond ((or
(add-link 'db
(in-wb-vicinity "db.so"))
@@ -104,6 +108,8 @@
(usr:lib "c")))
(add-source 'wb-table
(in-wb-vicinity "wbtab"))
+ (add-source 'rwb-isam
+ (in-wb-vicinity "rwb-isam"))
(add-alias 'wb 'db)))
(cond ((add-link 'mysql
(in-implementation-vicinity "database"
@@ -194,15 +200,10 @@
(display* ")")
)
- (begin
- ;; Messy because this trait has no C-installed feature name
- (display* "#.(if (defined? renamed-identifier)")
- (display* " '(")
- (display " " op)
- (add-source 'macro (in-implementation-vicinity "Macro"))
- (display* " )")
- (display* " '())")
- )
+ (display* "#+" 'primitive-hygiene)
+ (display* "(")
+ (add-source 'macro (in-implementation-vicinity "Macro"))
+ (display* ")")
(add-links 'dld
(lambda (lib) (string-append "/usr/lib/lib" lib ".a"))
@@ -229,4 +230,8 @@
(lambda (lib) #f)
(lambda (lib) #f)
".so")
+ (add-links 'win32-dl
+ (lambda (lib) #f)
+ (lambda (lib) #f)
+ ".dll")
)))
diff --git a/patchlvl.h b/patchlvl.h
index 7dc9724..cd637d3 100644
--- a/patchlvl.h
+++ b/patchlvl.h
@@ -4,11 +4,11 @@
# for alpha release, "b" for beta release, "c", and so on), and the
# trailing number is the patchlevel. */
# /* This next line sets VERSION when included from the Makefile */
-VERSION=5d6
+VERSION=5d9
#endif
#ifndef SCMVERSION
-# define SCMVERSION "5d6"
+# define SCMVERSION "5d9"
#endif
#ifdef nosve
# define INIT_FILE_NAME "Init"SCMVERSION"_scm";
diff --git a/platform.txi b/platform.txi
new file mode 100644
index 0000000..d7b3d13
--- /dev/null
+++ b/platform.txi
@@ -0,0 +1,47 @@
+Table: platform
+name processor operating-system compiler
+#f processor-family operating-system #f
+symbol processor-family operating-system symbol
+symbol symbol symbol symbol
+================= ================= ================= =================
+*unknown* *unknown* unix cc
+acorn-unixlib acorn *unknown* cc
+aix powerpc aix cc
+alpha-elf alpha unix cc
+alpha-linux alpha linux gcc
+amiga-aztec m68000 amiga cc
+amiga-dice-c m68000 amiga dcc
+amiga-gcc m68000 amiga gcc
+amiga-sas m68000 amiga lc
+atari-st-gcc m68000 atari.st gcc
+atari-st-turbo-c m68000 atari.st tcc
+borland-c i8086 ms-dos bcc
+darwin powerpc unix cc
+djgpp i386 ms-dos gcc
+freebsd i386 unix cc
+gcc *unknown* unix gcc
+gnu-win32 i386 unix gcc
+highc i386 ms-dos hc386
+hp-ux hp-risc hp-ux cc
+irix mips irix gcc
+linux i386 linux gcc
+linux-aout i386 linux gcc
+microsoft-c i8086 ms-dos cl
+microsoft-c-nt i386 ms-dos cl
+microsoft-quick-c i8086 ms-dos qcl
+ms-dos i8086 ms-dos cc
+netbsd *unknown* unix gcc
+openbsd *unknown* unix gcc
+os/2-cset i386 os/2 icc
+os/2-emx i386 os/2 gcc
+osf1 alpha unix cc
+plan9-8 i386 plan9 8c
+sunos sparc sunos cc
+svr4 *unknown* unix cc
+svr4-gcc-sun-ld sparc sunos gcc
+turbo-c i8086 ms-dos tcc
+unicos cray unicos cc
+unix *unknown* unix cc
+vms vax vms cc
+vms-gcc vax vms gcc
+watcom-9.0 i386 ms-dos wcc386p
diff --git a/posix.c b/posix.c
index 8af5c0b..229384a 100644
--- a/posix.c
+++ b/posix.c
@@ -57,14 +57,15 @@
#else /* added by Denys Duchier */
# ifdef SVR4
# include <unistd.h>
-# else
-# ifdef linux
-# include <unistd.h>
-# else
-# ifdef __OpenBSD__
-# include <unistd.h>
-# endif
-# endif
+# endif
+# ifdef linux
+# include <unistd.h>
+# endif
+# ifdef __OpenBSD__
+# include <unistd.h>
+# endif
+# ifdef __NetBSD__
+# include <unistd.h>
# endif
#endif
@@ -73,9 +74,9 @@ SCM l_chown(path, owner, group)
SCM path, owner, group;
{
int val;
- ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_chown);
- ASSERT(INUMP(owner), owner, ARG2, s_chown);
- ASSERT(INUMP(group), group, ARG3, s_chown);
+ ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_chown);
+ ASRTER(INUMP(owner), owner, ARG2, s_chown);
+ ASRTER(INUMP(group), group, ARG3, s_chown);
SYSCALL(val = chown(CHARS(path), INUM(owner), INUM(group)););
return val ? BOOL_F : BOOL_T;
}
@@ -85,8 +86,8 @@ SCM l_link(oldpath, newpath)
SCM oldpath, newpath;
{
int val;
- ASSERT(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_link);
- ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_link);
+ ASRTER(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_link);
+ ASRTER(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_link);
SYSCALL(val = link(CHARS(oldpath), CHARS(newpath)););
return val ? BOOL_F : BOOL_T;
}
@@ -124,8 +125,8 @@ SCM open_pipe(pipestr, modes)
{
FILE *f;
register SCM z;
- ASSERT(NIMP(pipestr) && STRINGP(pipestr), pipestr, ARG1, s_op_pipe);
- ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_op_pipe);
+ ASRTER(NIMP(pipestr) && STRINGP(pipestr), pipestr, ARG1, s_op_pipe);
+ ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_op_pipe);
NEWCELL(z);
/* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/
DEFER_INTS;
@@ -180,7 +181,7 @@ SCM l_pwinfo(user)
if UNBNDP(user) SYSCALL(entry = getpwent(););
else if INUMP(user) SYSCALL(entry = getpwuid(INUM(user)););
else {
- ASSERT(NIMP(user) && STRINGP(user), user, ARG1, s_pwinfo);
+ ASRTER(NIMP(user) && STRINGP(user), user, ARG1, s_pwinfo);
SYSCALL(entry = getpwnam(CHARS(user)););
}
ALLOW_INTS;
@@ -206,7 +207,7 @@ SCM l_grinfo(name)
if UNBNDP(name) SYSCALL(entry = getgrent(););
else if INUMP(name) SYSCALL(entry = getgrgid(INUM(name)););
else {
- ASSERT(NIMP(name) && STRINGP(name), name, ARG1, s_grinfo);
+ ASRTER(NIMP(name) && STRINGP(name), name, ARG1, s_grinfo);
SYSCALL(entry = getgrnam(CHARS(name)););
}
ALLOW_INTS;
@@ -237,8 +238,8 @@ SCM l_kill(pid, sig)
SCM pid, sig;
{
int i;
- ASSERT(INUMP(pid), pid, ARG1, s_kill);
- ASSERT(INUMP(sig), sig, ARG2, s_kill);
+ ASRTER(INUMP(pid), pid, ARG1, s_kill);
+ ASRTER(INUMP(sig), sig, ARG2, s_kill);
SYSCALL(i = kill((int)INUM(pid), (int)INUM(sig)););
return MAKINUM(0L+i);
}
@@ -247,8 +248,8 @@ SCM l_waitpid(pid, options)
SCM pid, options;
{
int i, status;
- ASSERT(INUMP(pid), pid, ARG1, s_waitpid);
- ASSERT(INUMP(options), options, ARG2, s_waitpid);
+ ASRTER(INUMP(pid), pid, ARG1, s_waitpid);
+ ASRTER(INUMP(options), options, ARG2, s_waitpid);
SYSCALL(i = waitpid(INUM(pid), &status, INUM(options)););
return i < 0 ? BOOL_F : MAKINUM(0L+status);
}
@@ -258,10 +259,6 @@ SCM l_getppid()
return MAKINUM(0L+getppid());
}
-SCM scm_getlogin()
-{
- return makfrom0str(getlogin());
-}
SCM l_getuid()
{
return MAKINUM(0L+getuid());
@@ -285,14 +282,14 @@ static char s_setuid[] = "setuid";
SCM l_setuid(id)
SCM id;
{
- ASSERT(INUMP(id), id, ARG1, s_setuid);
+ ASRTER(INUMP(id), id, ARG1, s_setuid);
return setuid(INUM(id)) ? BOOL_F : BOOL_T;
}
static char s_setgid[] = "setgid";
SCM l_setgid(id)
SCM id;
{
- ASSERT(INUMP(id), id, ARG1, s_setgid);
+ ASRTER(INUMP(id), id, ARG1, s_setgid);
return setgid(INUM(id)) ? BOOL_F : BOOL_T;
}
@@ -301,14 +298,14 @@ static char s_seteuid[] = "seteuid";
SCM l_seteuid(id)
SCM id;
{
- ASSERT(INUMP(id), id, ARG1, s_seteuid);
+ ASRTER(INUMP(id), id, ARG1, s_seteuid);
return seteuid(INUM(id)) ? BOOL_F : BOOL_T;
}
static char s_setegid[] = "setegid";
SCM l_setegid(id)
SCM id;
{
- ASSERT(INUMP(id), id, ARG1, s_setegid);
+ ASRTER(INUMP(id), id, ARG1, s_setegid);
return setegid(INUM(id)) ? BOOL_F : BOOL_T;
}
#endif
@@ -318,7 +315,7 @@ SCM l_ttyname(port)
SCM port;
{
char *ans;
- ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_ttyname);
+ ASRTER(NIMP(port) && OPPORTP(port), port, ARG1, s_ttyname);
if (tc16_fport != TYP16(port)) return BOOL_F;
SYSCALL(ans = ttyname(fileno(STREAM(port))););
/* ans could be overwritten by another call to ttyname */
@@ -351,7 +348,6 @@ static iproc subr0s[] = {
{"pipe", l_pipe},
{scm_s_getgroups, scm_getgroups},
{"getppid", l_getppid},
- {"getlogin", scm_getlogin},
{"getuid", l_getuid},
{"getgid", l_getgid},
#ifndef LACK_E_IDs
@@ -405,8 +401,11 @@ void init_posix()
scm_ldstr("\n\
(define (open-input-pipe cmd) (open-pipe cmd \"r\"))\n\
(define (open-output-pipe cmd) (open-pipe cmd \"w\"))\n\
-(define getlogin\n\
- (let ((getlogin getlogin))\n\
- (lambda () (or (getlogin) (getenv \"USER\") (getenv \"LOGNAME\")))))\n\
+(define (system->line command . tmp)\n\
+ (define line\n\
+ (call-with-open-ports\n\
+ read-line\n\
+ (open-input-pipe command)))\n\
+ (if (eof-object? line) \"\" line))\n\
");
}
diff --git a/r4rstest.scm b/r4rstest.scm
index 3683f0d..f6f3ae0 100644
--- a/r4rstest.scm
+++ b/r4rstest.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003 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
@@ -30,16 +30,16 @@
;;; There are three optional tests:
;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
-;;;
+;;;
;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
-;;;
+;;;
;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
;;; either standard.
;;; If you are testing a R3RS version which does not have `list?' do:
;;; (define list? #f)
-;;; send corrections or additions to jaffer @ai.mit.edu
+;;; send corrections or additions to agj @ alum.mit.edu
(define cur-section '())(define errs '())
(define SECTION (lambda args
@@ -224,7 +224,7 @@
`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
;;; sqt is defined here because not all implementations are required to
-;;; support it.
+;;; support it.
(define (sqt x)
(do ((i 0 (+ i 1)))
((> (* i i) x) (- i 1))))
@@ -557,6 +557,21 @@
(test 288 lcm 32 -36)
(test 1 lcm)
+(SECTION 6 5 5)
+;;; Implementations which don't allow division by 0 can have fragile
+;;; string->number.
+(define (test-string->number str)
+ (define ans (string->number str))
+ (cond ((not ans) #t) ((number? ans) #t) (else ans)))
+(for-each (lambda (str) (test #t test-string->number str))
+ '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
+ "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
+ "#i" "#e" "#" "#i0/0"))
+(cond ((number? (string->number "1+1i")) ;More kawa bait
+ (test #t number? (string->number "#i-i"))
+ (test #t number? (string->number "#i+i"))
+ (test #t number? (string->number "#i2+i"))))
+
;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
;;; Modified by jaffer.
(define (test-inexact)
@@ -574,11 +589,17 @@
(newline)
(display ";testing inexact numbers; ")
(newline)
+ (SECTION 6 2)
+ (test #f eqv? 1 f1.0)
+ (test #f eqv? 0 f0.0)
(SECTION 6 5 5)
(test #t inexact? f3.9)
- (test #t 'inexact? (inexact? (max f3.9 4)))
- (test f4.0 'max (max f3.9 4))
- (test f4.0 'exact->inexact (exact->inexact 4))
+ (test #t 'max (inexact? (max f3.9 4)))
+ (test f4.0 max f3.9 4)
+ (test f4.0 exact->inexact 4)
+ (test f4.0 exact->inexact 4.0)
+ (test 4 inexact->exact 4)
+ (test 4 inexact->exact 4.0)
(test (- f4.0) round (- f4.5))
(test (- f4.0) round (- f3.5))
(test (- f4.0) round (- f3.9))
@@ -618,14 +639,14 @@
(define log2
(let ((l2 (log 2)))
(lambda (x) (/ (log x) l2))))
-
+
(define (slow-frexp x)
(if (zero? x)
(list f0.0 0)
(let* ((l2 (log2 x))
(e (floor (log2 x)))
(e (if (= l2 e)
- (inexact->exact e)
+ (inexact->exact e)
(+ (inexact->exact e) 1)))
(f (/ x (expt 2 e))))
(list f e))))
@@ -649,7 +670,7 @@
minval
eps)))
(slow-frexp x)))))
-
+
(define (float-print-test x)
(define (testit number)
(eqv? number (string->number (number->string number))))
@@ -671,7 +692,7 @@
(define (mult-float-print-test x)
(let ((res #t))
- (for-each
+ (for-each
(lambda (mult)
(or (float-print-test (* mult x)) (set! res #f)))
(map string->number
@@ -682,7 +703,7 @@
(SECTION 6 5 6)
(test #t 'float-print-test (float-print-test f0.0))
(test #t 'mult-float-print-test (mult-float-print-test f1.0))
- (test #t 'mult-float-print-test (mult-float-print-test
+ (test #t 'mult-float-print-test (mult-float-print-test
(string->number "3.0")))
(test #t 'mult-float-print-test (mult-float-print-test
(string->number "7.0")))
@@ -1023,15 +1044,15 @@
(test '(1 2 3) map * '(1 2 3))
(test '(-1 -2 -3) map - '(1 2 3))
(test '#(0 1 4 9 16) 'for-each
- (let ((v (make-vector 5)))
- (for-each (lambda (i) (vector-set! v i (* i i)))
- '(0 1 2 3 4))
- v))
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
(test -3 call-with-current-continuation
- (lambda (exit)
- (for-each (lambda (x) (if (negative? x) (exit x)))
- '(54 0 37 -3 245 19))
- #t))
+ (lambda (exit)
+ (for-each (lambda (x) (if (negative? x) (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
(define list-length
(lambda (obj)
(call-with-current-continuation
@@ -1049,7 +1070,7 @@
;;; other than escape procedures. I am indebted to
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
-;;; trees constructed of conses.
+;;; trees constructed of conses.
(define (next-leaf-generator obj eot)
(letrec ((return #f)
(cont (lambda (x)
@@ -1191,7 +1212,7 @@
(report-errs))
(report-errs)
-(let ((have-inexacts?
+(let ((have-inexacts?
(and (string->number "0.0") (inexact? (string->number "0.0"))))
(have-bignums?
(let ((n (string->number "281474976710655325431")))
diff --git a/ramap.c b/ramap.c
index 08ba177..42181ee 100644
--- a/ramap.c
+++ b/ramap.c
@@ -44,6 +44,8 @@
#include "scm.h"
+SCM sc2array P((SCM s, SCM ra, SCM prot));
+
typedef struct {
char *name;
SCM sproc;
@@ -206,7 +208,7 @@ int ramapc(cproc, data, ra0, lra, what)
long *indv = &auto_indv[0];
if (ARRAY_NDIM(ra0) >= 5) {
scm_protect_temp(&hp_indv);
- hp_indv = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-1L));
+ hp_indv = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-32L));
indv = (long *)VELTS(hp_indv);
}
vra0 = make_ra(1);
@@ -278,7 +280,6 @@ int ramapc(cproc, data, ra0, lra, what)
}
}
-static char s_array_fill[] = "array-fill!";
SCM array_fill(ra, fill)
SCM ra, fill;
{
@@ -444,7 +445,7 @@ SCM array_copy(src, dst)
{
#ifndef RECKLESS
if (INUM0==array_rank(dst))
- ASSERT(NIMP(dst) && ARRAYP(dst) && INUM0==array_rank(src),
+ ASRTER(NIMP(dst) && ARRAYP(dst) && INUM0==array_rank(src),
dst, ARG2, s_array_copy);
#endif
ramapc(racp, UNDEFINED, src, cons(dst, EOL), s_array_copy);
@@ -512,7 +513,7 @@ SCM sc2array(s, ra, prot)
SCM s, ra, prot;
{
SCM res;
- ASSERT(NIMP(ra), ra, ARG2, s_sc2array);
+ ASRTER(NIMP(ra), ra, ARG2, s_sc2array);
if ARRAYP(ra) {
int k = ARRAY_NDIM(ra);
res = make_ra(k);
@@ -524,7 +525,7 @@ SCM sc2array(s, ra, prot)
ra = ARRAY_V(ra);
}
else {
- ASSERT(BOOL_T==arrayp(ra, UNDEFINED), ra, ARG2, s_sc2array);
+ ASRTER(BOOL_T==arrayp(ra, UNDEFINED), ra, ARG2, s_sc2array);
res = make_ra(1);
ARRAY_DIMS(res)->ubnd = LENGTH(ra) - 1;
ARRAY_DIMS(res)->lbnd = 0;
@@ -1433,7 +1434,7 @@ SCM array_imap(ra, proc)
long auto_indv[5];
long *indv = &auto_indv[0];
sizet i;
- ASSERT(NIMP(ra), ra, ARG1, s_array_imap);
+ ASRTER(NIMP(ra), ra, ARG1, s_array_imap);
i = INUM(array_rank(ra));
#ifndef RECKLESS
scm_arity_check(proc, i+0L, s_array_imap);
@@ -1443,7 +1444,7 @@ SCM array_imap(ra, proc)
scm_protect_temp(&hp_indv);
hp_av = make_vector(MAKINUM(i), BOOL_F);
av = VELTS(hp_av);
- hp_indv = make_uve(i+0L, MAKINUM(-1L));
+ hp_indv = make_uve(i+0L, MAKINUM(-32L));
indv = (long *)VELTS(hp_indv);
}
switch TYP7(ra) {
@@ -1662,6 +1663,8 @@ static void init_raprocs(subra)
subra->sproc = CDR(sysintern(subra->name, UNDEFINED));
}
+SCM_DLL_EXPORT void init_ramap P((void));
+
void init_ramap()
{
init_raprocs(ra_rpsubrs);
@@ -1677,5 +1680,9 @@ scm_ldstr("\n\
(let ((ra0 (apply create-array '#() (array-shape ra))))\n\
(array-index-map! ra0 list)\n\
ra0))\n\
+(define (array-map prototype proc ra1 . ras)\n\
+ (define nra (apply create-array prototype (array-shape ra1)))\n\
+ (apply array-map! nra proc ra1 ras)\n\
+ nra)\n\
");
}
diff --git a/record.c b/record.c
index 6811575..5370daf 100644
--- a/record.c
+++ b/record.c
@@ -68,7 +68,7 @@ static SCM the_rtd_rtd;
arrays will be available when the dll is loaded */
#ifdef ARRAYS
# ifndef DLL
-# define MAKE_REC_INDS(n) make_uve((long)n, MAKINUM(1))
+# define MAKE_REC_INDS(n) make_uve((long)n, MAKINUM(32L))
# define REC_IND_REF(x, i) VELTS(x)[(i)]
# define REC_IND_SET(x, i, val) VELTS(x)[(i)] = (val)
# endif
@@ -99,7 +99,7 @@ SCM rec_pred(rtd)
SCM rtd;
{
SCM cclo = makcclo(f_rec_pred1, 2L);
- ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_pred);
+ ASRTER(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_pred);
RCLO_RTD(cclo) = rtd;
return cclo;
}
@@ -121,7 +121,7 @@ SCM rec_constr(rtd, flds)
SCM cclo = makcclo(f_rec_constr1, 4L);
SCM indices;
sizet i, j;
- ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_constr);
+ ASRTER(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_constr);
RCLO_RTD(cclo) = rtd;
i = ilength(RTD_FIELDS(rtd));
RCONSTR_SIZE(cclo) = MAKINUM(i);
@@ -131,14 +131,14 @@ SCM rec_constr(rtd, flds)
}
else {
i = ilength(flds);
- ASSERT(i>=0, flds, ARG2, s_rec_constr);
+ ASRTER(i>=0, flds, ARG2, s_rec_constr);
indices = MAKE_REC_INDS(i);
for(i = 0; NIMP(flds); i++, flds = CDR(flds)) {
fld = CAR(flds);
- ASSERT(NIMP(fld) && SYMBOLP(fld), fld, ARG2, s_rec_constr);
+ ASRTER(NIMP(fld) && SYMBOLP(fld), fld, ARG2, s_rec_constr);
flst = RTD_FIELDS(rtd);
for (j = 0; ; j++, flst = CDR(flst)) {
- ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr);
+ ASRTER(NNULLP(flst), fld, ARG2, s_rec_constr);
if (fld==CAR(flst)) {
REC_IND_SET(indices, i, j+1);
break;
@@ -204,12 +204,12 @@ static SCM makrecclo(proc, rtd, field, what)
SCM flst;
SCM cclo = makcclo(proc, 3L);
int i;
- ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, what);
- ASSERT(NIMP(field) && SYMBOLP(field), field, ARG2, what);
+ ASRTER(NIMP(rtd) && RTDP(rtd), rtd, ARG1, what);
+ ASRTER(NIMP(field) && SYMBOLP(field), field, ARG2, what);
RCLO_RTD(cclo) = rtd;
flst = RTD_FIELDS(rtd);
for (i = 1; ; i++) {
- ASSERT(NNULLP(flst), field, ARG2, what);
+ ASRTER(NNULLP(flst), field, ARG2, what);
if (CAR(flst)==field) break;
flst = CDR(flst);
}
@@ -274,8 +274,8 @@ static char s_rec_prinset[] = "record-printer-set!";
SCM rec_prinset(rtd, printer)
SCM rtd, printer;
{
- ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_prinset);
- ASSERT(BOOL_F==printer || scm_arity_check(printer, 3L, (char *)0),
+ ASRTER(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_prinset);
+ ASRTER(BOOL_F==printer || scm_arity_check(printer, 3L, (char *)0),
printer, ARG2, s_rec_prinset);
RTD_PRINTER(rtd) = printer;
return UNSPECIFIED;
@@ -385,6 +385,9 @@ static iproc subr2s[] = {
{s_makrectyp, makrectyp},
{s_rec_prinset, rec_prinset},
{0, 0}};
+
+SCM_DLL_EXPORT void init_record P((void));
+
void init_record()
{
SCM i_name = CAR(sysintern("name", UNDEFINED));
diff --git a/repl.c b/repl.c
index ae7642f..07b357c 100644
--- a/repl.c
+++ b/repl.c
@@ -53,6 +53,11 @@ void scm_fill_freelist P((void));
# include <sys/types.h>
#endif
+#ifdef __NetBSD__
+# include <ctype.h>
+# include <unistd.h>
+#endif
+
#ifdef __OpenBSD__
# include <ctype.h>
# include <unistd.h>
@@ -143,17 +148,17 @@ char *isymnames[] = {
};
static char s_read_char[] = "read-char", s_peek_char[] = "peek-char";
-char s_read[] = "read", s_write[] = "write", s_newline[] = "newline";
+char s_write[] = "write", s_newline[] = "newline";
static char s_display[] = "display", s_write_char[] = "write-char";
static char s_freshline[] = "freshline";
static char s_eofin[] = "end of file in ";
static char s_unknown_sharp[] = "unknown # object";
-static SCM lread1 P((SCM port, int nump, char *what));
-static SCM lreadr P((SCM tok_buf, SCM port, int nump));
-static SCM lreadpr P((SCM tok_buf, SCM port, int nump));
-static SCM lreadparen P((SCM tok_buf, SCM port, int nump, char *name));
+static SCM lread1 P((SCM port, int flgs, char *what));
+static SCM lreadr P((SCM tok_buf, SCM port, int flgs));
+static SCM lreadpr P((SCM tok_buf, SCM port, int flgs));
+static SCM lreadparen P((SCM tok_buf, SCM port, int flgs, char *name));
static SCM lread_rec P((SCM tok_buf, SCM port));
static sizet read_token P((int ic, SCM tok_buf, SCM port));
static void err_head P((char *str));
@@ -256,7 +261,12 @@ taloop:
break;
}
lputs("#@", port);
+#ifdef _M_ARM
+ /* MS CLARM compiler workaround */
+ exp = CAR(MS_CLARM_dumy = exp - 1);
+#else
exp = CAR(exp-1);
+#endif
goto taloop;
default:
idef:
@@ -427,7 +437,7 @@ static int input_waiting(f)
tv.tv_usec = 0;
SYSCALL(ret = select((fileno(f) + 1), &ifds, (fd_set *) NULL,
(fd_set *) NULL, &tv););
- ASSERT(ret>=0, MAKINUM(ret), "select error", s_char_readyp);
+ ASRTER(ret>=0, MAKINUM(ret), "select error", s_char_readyp);
return FD_ISSET(fileno(f), &ifds);
# else
# ifdef FIONREAD
@@ -446,7 +456,7 @@ SCM char_readyp(port)
SCM port;
{
if UNBNDP(port) port = cur_inp;
- ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp);
+ ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp);
if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T;
return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F;
}
@@ -472,7 +482,7 @@ SCM wait_for_input(args)
{
SCM how_long, port1, port, ports, ans = EOL;
int timeout, pos = ARG2;
- ASSERT(!NULLP(args), INUM0, WNA, s_wfi);
+ ASRTER(!NULLP(args), INUM0, WNA, s_wfi);
how_long = CAR(args);
args = CDR(args);
if NULLP(args) port1 = cur_inp;
@@ -481,11 +491,11 @@ SCM wait_for_input(args)
args = CDR(args);
}
timeout = num2long(how_long, (char *)ARG1, s_wfi);
- ASSERT(timeout >= 0, how_long, ARG1, s_wfi);
+ ASRTER(timeout >= 0, how_long, ARG1, s_wfi);
port = port1;
ports = args;
while (1) {
- ASSERT(NIMP(port) && OPINPORTP(port) && (BUF0 & SCM_PORTFLAGS(port)),
+ ASRTER(NIMP(port) && OPINPORTP(port) && (BUF0 & SCM_PORTFLAGS(port)),
port, pos, s_wfi);
if (CRDYP(port) || feof(STREAM(port))) timeout = 0;
if (NULLP(ports)) break;
@@ -516,7 +526,7 @@ SCM wait_for_input(args)
ports = CDR(ports);
}
SYSCALL(ret = select(fd_max + 1, &ifds, (fd_set *)0L, (fd_set *)0L, &tv););
- ASSERT(ret>=0, MAKINUM(ret), "select error", s_wfi);
+ ASRTER(ret>=0, MAKINUM(ret), "select error", s_wfi);
port = port1;
ports = args;
@@ -538,17 +548,21 @@ SCM wait_for_input(args)
FILE *f = STREAM(port);
if (feof(f)) ans = cons(port, ans);
else {
-# ifdef FIONREAD
- long remir;
- ioctl(fileno(f), FIONREAD, &remir);
- if (remir) ans = cons(port, ans);
+# ifdef _WIN32
+ if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin))) && kbhit())
+ ans = cons(port, ans);
# else
- if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin))) && kbhit())
- ans = cons(port, ans);
+# ifdef FIONREAD
+ long remir;
+ ioctl(fileno(f), FIONREAD, &remir);
+ if (remir) ans = cons(port, ans);
+# else
+ /* If we get here this is not going to work */
+# endif
# endif
- if (NULLP(ports)) break;
- port = CAR(ports);
- ports = CDR(ports);
+ if (NULLP(ports)) break;
+ port = CAR(ports);
+ ports = CDR(ports);
}
} while (time((timet*)0L) < start);
#endif
@@ -608,7 +622,7 @@ SCM lflush(port) /* user accessible as force-output */
SCM port;
{
if UNBNDP(port) port = cur_outp;
- else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush);
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush);
{
sizet i = PTOBNUM(port);
while ((ptobs[i].fflush)(STREAM(port)) &&
@@ -622,7 +636,7 @@ SCM lwrite(obj, port)
SCM obj, port;
{
if UNBNDP(port) port = cur_outp;
- else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write);
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write);
iprin1(obj, port, 1);
return UNSPECIFIED;
}
@@ -630,7 +644,7 @@ SCM display(obj, port)
SCM obj, port;
{
if UNBNDP(port) port = cur_outp;
- else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display);
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display);
iprin1(obj, port, 0);
return UNSPECIFIED;
}
@@ -638,7 +652,7 @@ SCM newline(port)
SCM port;
{
if UNBNDP(port) port = cur_outp;
- else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline);
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline);
lputc('\n', port);
if (port==cur_outp) lfflush(port);
return UNSPECIFIED;
@@ -647,8 +661,8 @@ SCM write_char(chr, port)
SCM chr, port;
{
if UNBNDP(port) port = cur_outp;
- else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char);
- ASSERT(ICHRP(chr), chr, ARG1, s_write_char);
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char);
+ ASRTER(ICHRP(chr), chr, ARG1, s_write_char);
lputc((int)ICHR(chr), port);
return UNSPECIFIED;
}
@@ -656,7 +670,7 @@ SCM scm_freshline(port)
SCM port;
{
if UNBNDP(port) port = cur_outp;
- else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline);
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline);
if (INUM0==scm_port_col(port)) return UNSPECIFIED;
lputc('\n', port);
if (port==cur_outp) lfflush(port);
@@ -688,7 +702,7 @@ void lputs(s, port)
SCM port;
{
sizet i = PTOBNUM(port);
- ASSERT(s, INUM0, ARG1, "lputs");
+ ASRTER(s, INUM0, ARG1, "lputs");
while (EOF==(ptobs[i].fputs)(s, STREAM(port)) &&
scm_io_error(port, "fputs"))
;
@@ -775,7 +789,7 @@ void lungetc(c, port)
SCM port;
{
int i = PTOBNUM(port);
-/* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/
+/* ASRTER(!CRDYP(port), port, ARG2, "too many lungetc");*/
if (ptobs[i].ungetc)
(ptobs[i].ungetc)(c, port);
else {
@@ -789,7 +803,7 @@ SCM scm_read_char(port)
{
int c;
if UNBNDP(port) port = cur_inp;
- ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char);
+ ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char);
c = lgetc(port);
if (EOF==c) return EOF_VAL;
return MAKICHR(c);
@@ -799,7 +813,7 @@ SCM peek_char(port)
{
int c;
if UNBNDP(port) port = cur_inp;
- else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char);
+ else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char);
c = lgetc(port);
if (EOF==c) return EOF_VAL;
lungetc(c, port);
@@ -832,187 +846,209 @@ static int flush_ws(port)
return c;
}
}
-SCM lread(port)
+
+/* Top-level readers */
+static SCM p_read_numbered, p_read_for_load, p_read;
+static char s_read[] = "read";
+static char s_read_for_load[] = "read-for-load";
+static char s_read_numbered[] = "read-numbered";
+SCM scm_read(port)
SCM port;
{
return lread1(port, 0, s_read);
}
-static SCM lread1(port, nump, what)
+
+SCM scm_read_for_load(port)
+ SCM port;
+{
+ return lread1(port, 4, s_read_for_load);
+}
+
+SCM scm_read_numbered(port)
+ SCM port;
+{
+ return lread1(port, 6, s_read_numbered);
+}
+
+static SCM lread1(port, flgs, what)
SCM port;
- int nump;
+ int flgs;
char *what;
{
int c;
SCM tok_buf;
if UNBNDP(port) port = cur_inp;
- ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, what);
+ ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, what);
do {
c = flush_ws(port);
if (EOF==c) return EOF_VAL;
lungetc(c, port);
tok_buf = makstr(30L);
- } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port, nump)));
+ } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port, flgs)));
return tok_buf;
}
-static SCM *loc_readsharp = 0, *loc_readsharpc = 0;
-static SCM lreadpr(tok_buf, port, nump)
+static SCM *loc_loadsharp = 0, *loc_readsharp = 0, *loc_charsharp = 0;
+static SCM lreadpr(tok_buf, port, flgs)
SCM tok_buf;
SCM port;
- int nump;
+ int flgs;
{
- int c;
- sizet j;
- SCM p;
- if (2==nump)
- return lread_rec(tok_buf, port);
-tryagain:
- c = flush_ws(port);
- switch (c) {
- case EOF: return EOF_VAL;
+ int c;
+ sizet j;
+ SCM p;
+ if (2==(3&flgs)) return lread_rec(tok_buf, port);
+ tryagain:
+ c = flush_ws(port);
+ switch (c) {
+ case EOF: return EOF_VAL;
#ifdef BRACKETS_AS_PARENS
- case '[':
+ case '[':
#endif
- case '(':
- return lreadparen(tok_buf, port, nump, s_list);
+ case '(': return lreadparen(tok_buf, port, flgs, s_list);
#ifdef BRACKETS_AS_PARENS
- case ']':
+ case ']':
#endif
- case ')': return UNDEFINED; /* goto tryagain; */
- case '\'': return cons2(i_quote,
- lreadr(tok_buf, port, nump), EOL);
- case '`': return cons2(i_quasiquote,
- lreadr(tok_buf, port, nump), EOL);
- case ',':
- c = lgetc(port);
- if ('@'==c) p = i_uq_splicing;
- else {
- lungetc(c, port);
- p = i_unquote;
- }
- return cons2(p, lreadr(tok_buf, port, nump), EOL);
- case '#':
- c = lgetc(port);
- switch (c) {
+ case ')': return UNDEFINED; /* goto tryagain; */
+ case '\'': return cons2(i_quote,
+ lreadr(tok_buf, port, flgs), EOL);
+ case '`': return cons2(i_quasiquote,
+ lreadr(tok_buf, port, flgs), EOL);
+ case ',':
+ c = lgetc(port);
+ if ('@'==c) p = i_uq_splicing;
+ else {
+ lungetc(c, port);
+ p = i_unquote;
+ }
+ return cons2(p, lreadr(tok_buf, port, flgs), EOL);
+ case '#':
+ c = lgetc(port);
+ switch (c) {
#ifdef BRACKETS_AS_PARENS
- case '[':
+ case '[':
#endif
- case '(':
- p = lreadparen(tok_buf, port, nump, s_vector);
- return NULLP(p) ? nullvect : vector(p);
- case 't': case 'T': return BOOL_T;
- case 'f': case 'F': return BOOL_F;
- case 'b': case 'B': case 'o': case 'O':
- case 'd': case 'D': case 'x': case 'X':
- case 'i': case 'I': case 'e': case 'E':
- lungetc(c, port);
- c = '#';
- goto num;
- case '*':
- j = read_token(c, tok_buf, port);
- p = istr2bve(CHARS(tok_buf)+1, (long)(j-1));
- if (NFALSEP(p)) return p;
- else goto unkshrp;
- case '\\':
- c = lgetc(port);
- j = read_token(c, tok_buf, port);
- if (j==1) return MAKICHR(c);
- if (c >= '0' && c < '8') {
- p = istr2int(CHARS(tok_buf), (long)j, 8);
- if (NFALSEP(p)) return MAKICHR(INUM(p));
- }
- for (c = 0;c<sizeof charnames/sizeof(char *);c++)
- if (charnames[c]
- && (0==strcmp(charnames[c], CHARS(tok_buf))))
- return MAKICHR(charnums[c]);
- if (loc_readsharpc && NIMP(*loc_readsharpc)) {
- resizuve(tok_buf, MAKINUM(j));
- p = apply(*loc_readsharpc, tok_buf, listofnull);
- if ICHRP(p) return p;
- }
- wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf));
- case '|':
- j = 1; /* here j is the comment nesting depth */
-lp: c = lgetc(port);
-lpc: switch (c) {
- case EOF:
- wta(UNDEFINED, s_eofin, "balanced comment");
- case LINE_INCREMENTORS:
- default:
- goto lp;
- case '|':
- if ('#' != (c = lgetc(port))) goto lpc;
- if (--j) goto lp;
- break;
- case '#':
- if ('|' != (c = lgetc(port))) goto lpc;
- ++j; goto lp;
- }
- goto tryagain;
- default: callshrp:
- if (loc_readsharp && NIMP(*loc_readsharp)) {
- p = apply(*loc_readsharp, cons2(MAKICHR(c), port, EOL), EOL);
- if (UNSPECIFIED==p) goto tryagain;
- return p;
- }
- unkshrp: wta((SCM)MAKICHR(c), s_unknown_sharp, "");
- }
- case '\"':
- j = 0;
- while ('\"' != (c = lgetc(port))) {
- ASSERT(EOF != c, UNDEFINED, s_eofin, s_string);
- if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf);
- switch (c) {
- case LINE_INCREMENTORS: break;
- case '\\':
- switch (c = lgetc(port)) {
- case LINE_INCREMENTORS: continue;
- case '0': c = '\0'; break;
- case 'f': c = '\f'; break;
- case 'n': c = '\n'; break;
- case 'r': c = '\r'; break;
- case 't': c = '\t'; break;
- case 'a': c = '\007'; break;
- case 'v': c = '\v'; break;
- }
- }
- CHARS(tok_buf)[j] = c;
- ++j;
- }
- if (j==0) return nullstr;
- CHARS(tok_buf)[j] = 0;
- return makfromstr(CHARS(tok_buf), j);
- case DIGITS:
- case '.': case '-': case '+':
-num:
- j = read_token(c, tok_buf, port);
- p = istring2number(CHARS(tok_buf), (long)j, 10L);
- if NFALSEP(p) return p;
- if (c=='#') {
- if ((j==2) && (lgetc(port)=='(')) {
- lungetc('(', port);
- c = CHARS(tok_buf)[1];
- goto callshrp;
- }
- wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf));
- }
- goto tok;
- default:
- j = read_token(c, tok_buf, port);
-tok:
- p = intern(CHARS(tok_buf), j);
- return CAR(p);
+ case '(':
+ p = lreadparen(tok_buf, port, flgs, s_vector);
+ return NULLP(p) ? nullvect : vector(p);
+ case 't': case 'T': return BOOL_T;
+ case 'f': case 'F': return BOOL_F;
+ case 'b': case 'B': case 'o': case 'O':
+ case 'd': case 'D': case 'x': case 'X':
+ case 'i': case 'I': case 'e': case 'E':
+ lungetc(c, port);
+ c = '#';
+ goto num;
+ case '*':
+ j = read_token(c, tok_buf, port);
+ p = istr2bve(CHARS(tok_buf)+1, (long)(j-1));
+ if (NFALSEP(p)) return p;
+ else goto unkshrp;
+ case '\\':
+ c = lgetc(port);
+ j = read_token(c, tok_buf, port);
+ if (j==1) return MAKICHR(c);
+ for (c = 0;c<sizeof charnames/sizeof(char *);c++)
+ if (charnames[c]
+ && (0==strcmp(charnames[c], CHARS(tok_buf))))
+ return MAKICHR(charnums[c]);
+ if (loc_charsharp && NIMP(*loc_charsharp)) {
+ resizuve(tok_buf, MAKINUM(j));
+ p = apply(*loc_charsharp, tok_buf, listofnull);
+ if ICHRP(p) return p;
+ }
+ wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf));
+ case '|':
+ j = 1; /* here j is the comment nesting depth */
+ lp: c = lgetc(port);
+ lpc:
+ switch (c) {
+ case EOF: wta(UNDEFINED, s_eofin, "balanced comment");
+ case LINE_INCREMENTORS:
+ default:
+ goto lp;
+ case '|':
+ if ('#' != (c = lgetc(port))) goto lpc;
+ if (--j) goto lp;
+ break;
+ case '#':
+ if ('|' != (c = lgetc(port))) goto lpc;
+ ++j; goto lp;
+ }
+ goto tryagain;
+ default: callshrp:
+ {
+ SCM reader = (3&flgs) ? p_read_numbered :
+ ((4&flgs) ? p_read_for_load : p_read);
+ SCM args = cons2(MAKICHR(c), port, cons(reader, EOL));
+ if ((4&flgs) && loc_loadsharp && NIMP(*loc_loadsharp)) {
+ p = apply(*loc_loadsharp, args, EOL);
+ if (UNSPECIFIED==p) goto tryagain;
+ return p;
+ } else if (loc_readsharp && NIMP(*loc_readsharp)) {
+ p = apply(*loc_readsharp, args, EOL);
+ if (UNSPECIFIED==p) goto tryagain;
+ return p;
}
+ }
+ unkshrp: wta((SCM)MAKICHR(c), s_unknown_sharp, "");
+ }
+ case '\"':
+ j = 0;
+ while ('\"' != (c = lgetc(port))) {
+ ASRTER(EOF != c, UNDEFINED, s_eofin, s_string);
+ if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf);
+ switch (c) {
+ case LINE_INCREMENTORS: break;
+ case '\\':
+ switch (c = lgetc(port)) {
+ case LINE_INCREMENTORS: continue;
+ case '0': c = '\0'; break;
+ case 'f': c = '\f'; break;
+ case 'n': c = '\n'; break;
+ case 'r': c = '\r'; break;
+ case 't': c = '\t'; break;
+ case 'a': c = '\007'; break;
+ case 'v': c = '\v'; break;
+ }
+ }
+ CHARS(tok_buf)[j] = c;
+ ++j;
+ }
+ if (j==0) return nullstr;
+ CHARS(tok_buf)[j] = 0;
+ return makfromstr(CHARS(tok_buf), j);
+ case DIGITS:
+ case '.': case '-': case '+':
+ num:
+ j = read_token(c, tok_buf, port);
+ p = istring2number(CHARS(tok_buf), (long)j, 10L);
+ if NFALSEP(p) return p;
+ if (c=='#') {
+ if ((j==2) && (lgetc(port)=='(')) {
+ lungetc('(', port);
+ c = CHARS(tok_buf)[1];
+ goto callshrp;
+ }
+ wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf));
+ }
+ goto tok;
+ default:
+ j = read_token(c, tok_buf, port);
+ tok:
+ p = intern(CHARS(tok_buf), j);
+ return CAR(p);
+ }
}
-static SCM lreadr(tok_buf, port, nump)
+static SCM lreadr(tok_buf, port, flgs)
SCM tok_buf;
SCM port;
- int nump;
+ int flgs;
{
- SCM ans = lreadpr(tok_buf, port, nump);
+ SCM ans = lreadpr(tok_buf, port, flgs);
switch (ans) {
case UNDEFINED:
scm_warn("unexpected \")\"", "", port);
- return lreadpr(tok_buf, port, nump);
+ return lreadpr(tok_buf, port, flgs);
}
return ans;
}
@@ -1026,8 +1062,8 @@ static SCM lread_rec(tok_buf, port)
default:
lungetc(c, port);
line = scm_port_line(port);
- form = lreadpr(tok_buf, port, 1);
- if (NFALSEP(line) && NIMP(form) &&
+ form = lreadpr(tok_buf, port, 5);
+ if (NFALSEP(line) && NIMP(form) &&
(CONSP(form) || VECTORP(form))) {
return cons(SCM_MAKE_LINUM(INUM(line)), form);
}
@@ -1076,26 +1112,37 @@ static sizet read_token(ic, tok_buf, port)
_Pragma("opt"); /* # pragma _CRI opt */
#endif
-static SCM lreadparen(tok_buf, port, nump, name)
+/* flgs was originally an argument to determine whether a read was */
+/* top-level or recursve. It has been overloaded to determine also */
+/* what to do in the case of a recursive read. */
+/* It distinguishes four states: */
+/* 0 - not adding line-numbers - never changes. Uses READ:SHARP */
+/* 4 - not adding line-numbers - never changes. Uses LOAD:SHARP */
+/* 5 - top level read when adding line-numbers. Uses LOAD:SHARP */
+/* 6 - recursive read when adding line-numbers. Uses LOAD:SHARP */
+
+static SCM lreadparen(tok_buf, port, flgs, name)
SCM tok_buf;
SCM port;
- int nump;
+ int flgs;
char *name;
{
- SCM lst, fst, tmp = lreadpr(tok_buf, port, nump ? 2 : 0);
+ SCM lst, fst,
+ tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0));
if (UNDEFINED==tmp) return EOL;
if (i_dot==tmp) {
- fst = lreadr(tok_buf, port, nump ? 1 : 0);
+ fst = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0));
closeit:
tmp = lreadpr(tok_buf, port, 0);
if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name);
return fst;
}
fst = lst = cons(tmp, EOL);
- while (UNDEFINED != (tmp = lreadpr(tok_buf, port, nump ? 2 : 0))) {
+ while (UNDEFINED !=
+ (tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0)))) {
if (EOF_VAL==tmp) wta(lst, s_eofin, s_list);
if (i_dot==tmp) {
- CDR(lst) = lreadr(tok_buf, port, nump ? 1 : 0);
+ CDR(lst) = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0));
goto closeit;
}
lst = (CDR(lst) = cons(tmp, EOL));
@@ -1111,7 +1158,7 @@ SCM swapcar(pair, value)
SCM pair, value;
{
SCM ret;
- ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar);
+ ASRTER(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar);
DEFER_INTS;
ret = CAR(pair);
CAR(pair) = value;
@@ -1124,7 +1171,7 @@ long tc16_arbiter;
SCM tryarb(arb)
SCM arb;
{
- ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb);
+ ASRTER((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb);
DEFER_INTS;
if (CAR(arb) & (1L<<16))
arb = BOOL_F;
@@ -1138,7 +1185,7 @@ SCM tryarb(arb)
SCM relarb(arb)
SCM arb;
{
- ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb);
+ ASRTER((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb);
if (!(CAR(arb) & (1L<<16))) return BOOL_F;
CAR(arb) = tc16_arbiter;
return BOOL_T;
@@ -1226,7 +1273,7 @@ int handle_it(i)
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
@@ -1254,40 +1301,6 @@ int handle_it(i)
}
return errmsgs[i-WNA].parent_err;
}
-static char s_eval_string[] = "eval-string";
-static char s_load_string[] = "load-string";
-static SCM i_eval_string = 0;
-SCM scm_eval_string(str)
- SCM str;
-{
- SCM env = EOL;
-#ifdef SCM_ENV_FILENAME
- if (i_eval_string)
- env = scm_env_addprop(SCM_ENV_FILENAME, i_eval_string, env);
-#endif
- str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
- str = lread(str);
- return EVAL(str, env, EOL);
-}
-static SCM i_load_string = 0;
-SCM scm_load_string(str)
- SCM str;
-{
- SCM env = EOL;
-#ifdef SCM_ENV_FILENAME
- if (i_load_string)
- env = scm_env_addprop(SCM_ENV_FILENAME, i_load_string, env);
-#endif
- ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1,
- s_load_string);
- str = mkstrport(INUM0, str, OPN | RDNG, s_load_string);
- while(1) {
- SCM form = lread(str);
- if (EOF_VAL==form) break;
- SIDEVAL(form, env, EOL);
- }
- return BOOL_T;
-}
SCM exitval = MAKINUM(EXIT_FAILURE); /* INUM return value */
extern char s_unexec[];
@@ -1423,7 +1436,7 @@ SCM scm_port_line(port)
SCM port;
{
sizet lnum;
- ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_line);
+ ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_line);
if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F;
lnum = scm_port_table[SCM_PORTNUM(port)].line;
switch (CGETUN(port)) {
@@ -1441,7 +1454,7 @@ SCM scm_port_col(port)
SCM port;
{
long col;
- ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_col);
+ ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_col);
if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F;
col = scm_port_table[SCM_PORTNUM(port)].col;
switch (CGETUN(port)) {
@@ -1461,7 +1474,7 @@ SCM scm_port_filename(port)
SCM port;
{
SCM x;
- ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_filename);
+ ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_filename);
x = SCM_PORTDATA(port);
if (NIMP(x) && STRINGP(x))
return SCM_PORTDATA(port);
@@ -1672,7 +1685,7 @@ SCM repl()
scm_env_work = scm_ecache_index - scm_ecache_len;
scm_egcs = scm_clo_moved = scm_stk_moved = 0;
lmallocated = mallocated;
- x = lread(cur_inp);
+ x = scm_read_for_load(cur_inp);
rt = INUM(my_time());
scm_gcs = 0;
gc_time_taken = 0;
@@ -1732,7 +1745,7 @@ SCM abrt()
char s_restart[] = "restart";
SCM restart()
{
- /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */
+ /* ASRTER(!dumped, UNDEFINED, "dumped can't", s_restart); */
longjump(CONT(rootcont)->jmpbuf, COOKIE(-3));
}
@@ -1741,8 +1754,8 @@ char s_unexec[] = "unexec";
SCM scm_unexec(newpath)
SCM newpath;
{
- ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec);
- ASSERT(execpath, UNSPECIFIED, s_no_execpath, s_unexec);
+ ASRTER(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec);
+ ASRTER(execpath, UNSPECIFIED, s_no_execpath, s_unexec);
*loc_errobj = newpath;
longjump(CONT(rootcont)->jmpbuf, COOKIE(-4));
}
@@ -1796,20 +1809,10 @@ void ints_warn(str1, str2, fname, linum)
}
#endif
-#ifdef CAUTIOUS
-static SCM f_read_numbered;
-static char s_read_numbered[] = "read-numbered";
-SCM scm_read_numbered(port)
- SCM port;
-{
- return lread1(port, 2, s_read_numbered);
-}
-#endif
-
SCM tryload(filename, reader)
SCM filename, reader;
{
- ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load);
+ ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load);
if (FALSEP(reader)) reader = UNDEFINED;
#ifndef RECKLESS
if (!UNBNDP(reader)) scm_arity_check(reader, 1L, s_load);
@@ -1828,7 +1831,7 @@ SCM tryload(filename, reader)
#endif
while(1) {
if (UNBNDP(reader))
- form = lread(port);
+ form = scm_read_for_load(port);
else
form = scm_cvapply(reader, 1L, &port);
if (EOF_VAL==form) break;
@@ -1840,6 +1843,40 @@ SCM tryload(filename, reader)
}
return BOOL_T;
}
+static char s_eval_string[] = "eval-string";
+static char s_load_string[] = "load-string";
+static SCM i_eval_string = 0;
+SCM scm_eval_string(str)
+ SCM str;
+{
+ SCM env = EOL;
+#ifdef SCM_ENV_FILENAME
+ if (i_eval_string)
+ env = scm_env_addprop(SCM_ENV_FILENAME, i_eval_string, env);
+#endif
+ str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
+ str = scm_read(str);
+ return EVAL(str, env, EOL);
+}
+static SCM i_load_string = 0;
+SCM scm_load_string(str)
+ SCM str;
+{
+ SCM env = EOL;
+#ifdef SCM_ENV_FILENAME
+ if (i_load_string)
+ env = scm_env_addprop(SCM_ENV_FILENAME, i_load_string, env);
+#endif
+ ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1,
+ s_load_string);
+ str = mkstrport(INUM0, str, OPN | RDNG, s_load_string);
+ while(1) {
+ SCM form = scm_read_for_load(str);
+ if (EOF_VAL==form) break;
+ SIDEVAL(form, env, EOL);
+ }
+ return BOOL_T;
+}
void scm_line_msg(file, linum, port)
SCM file, linum, port;
@@ -1925,7 +1962,7 @@ static char s_perror[] = "perror";
SCM lperror(arg)
SCM arg;
{
- ASSERT(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror);
+ ASRTER(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror);
err_head(CHARS(arg));
return UNSPECIFIED;
}
@@ -1984,9 +2021,10 @@ static void def_err_response()
err_pos = 0;
if (!UNBNDP(obj))
if (reset_safeport(sys_safep, 55, cur_errp))
- if (0==setjmp(SAFEP_JMPBUF(sys_safep)))
+ if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
if (codep) scm_princode(obj, EOL, sys_safep, writing);
else iprin1(obj, sys_safep, writing);
+ }
if UNBNDP(err_exp) goto getout;
if NIMP(err_exp) {
if (reset_safeport(sys_safep, 55, cur_errp))
@@ -2079,7 +2117,7 @@ SCM set_inp(port)
SCM port;
{
SCM oinp;
- ASSERT(NIMP(port) && INPORTP(port), port, ARG1, s_cur_inp);
+ ASRTER(NIMP(port) && INPORTP(port), port, ARG1, s_cur_inp);
DEFER_INTS;
oinp = cur_inp;
cur_inp = port;
@@ -2090,7 +2128,7 @@ SCM set_outp(port)
SCM port;
{
SCM ooutp;
- ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_outp);
+ ASRTER(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_outp);
DEFER_INTS;
ooutp = cur_outp;
cur_outp = port;
@@ -2101,7 +2139,7 @@ SCM set_errp(port)
SCM port;
{
SCM oerrp;
- ASSERT(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_errp);
+ ASRTER(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_errp);
DEFER_INTS;
oerrp = cur_errp;
cur_errp = port;
@@ -2112,7 +2150,7 @@ static char s_isatty[] = "isatty?";
SCM l_isatty(port)
SCM port;
{
- ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty);
+ ASRTER(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty);
if (tc16_fport != TYP16(port)) return BOOL_F;
return isatty(fileno(STREAM(port)))?BOOL_T:BOOL_F;
}
@@ -2144,7 +2182,6 @@ static iproc subr1s[] = {
{0, 0}};
static iproc subr1os[] = {
- {s_read, lread},
{s_read_char, scm_read_char},
{s_peek_char, peek_char},
{s_newline, newline},
@@ -2177,21 +2214,24 @@ void init_repl( iverbose )
i_repl = CAR(sysintern("repl", UNDEFINED));
loc_errobj = &CDR(sysintern("errobj", UNDEFINED));
loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F));
+ loc_loadsharp = &CDR(sysintern("load:sharp", UNDEFINED));
loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED));
- loc_readsharpc = &CDR(sysintern("read:sharp-char", UNDEFINED));
+ loc_charsharp = &CDR(sysintern("char:sharp", UNDEFINED));
loc_broken_pipe = &CDR(sysintern("broken-pipe", UNDEFINED));
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);
-#ifdef CAUTIOUS
- f_read_numbered =
- make_subr(s_read_numbered, tc7_subr_1, scm_read_numbered);
-#endif
add_feature(s_char_readyp);
make_subr(s_swapcar, tc7_subr_2, swapcar);
make_subr(s_wfi, tc7_lsubr, wait_for_input);
+ p_read_numbered =
+ make_subr(s_read_numbered, tc7_subr_1, scm_read_numbered);
+ p_read_for_load =
+ make_subr(s_read_for_load, tc7_subr_1, scm_read_for_load);
+ p_read =
+ make_subr(s_read, tc7_subr_1o, scm_read);
i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED));
i_load_string = CAR(sysintern(s_load_string, UNDEFINED));
#ifdef CAN_DUMP
@@ -2214,6 +2254,7 @@ void init_repl( iverbose )
}
void final_repl()
{
+ i_eval_string = i_load_string = 0;
loc_errobj = (SCM *)&tmp_errobj;
loc_loadpath = (SCM *)&tmp_loadpath;
loadports = EOL;
diff --git a/requires.scm b/requires.scm
index 97d7cdd..cad8db0 100644
--- a/requires.scm
+++ b/requires.scm
@@ -1,6 +1,6 @@
;;; "require.scm" Trampoline to slib/require.scm
-(set! library-vicinity
+(define library-vicinity
(let* ((vl (case (software-type)
((AMIGA) '(#\: #\/))
((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/))
@@ -19,4 +19,3 @@
(string-append (substring iv 0 (+ 1 pos)) "slib" vs))
(else (loop (- pos 1)))))))
(lambda () lv)))
-(load (in-vicinity (library-vicinity) "require"))
diff --git a/rgx.c b/rgx.c
index 0c1c377..1f3b4f0 100644
--- a/rgx.c
+++ b/rgx.c
@@ -55,7 +55,7 @@
#endif
static char rcsid[] =
- "$Id: rgx.c,v 1.15 2002/04/13 20:41:02 jaffer Exp $";
+ "$Id: rgx.c,v 1.16 2002/11/25 20:34:31 jaffer Exp $";
#ifdef HAVE_ALLOCA
# include <alloca.h>
@@ -161,7 +161,7 @@ SCM lregerror(scode)
int len;
#endif
SCM str;
- ASSERT(INUMP(scode), scode, ARG1, s_regerror);
+ ASRTER(INUMP(scode), scode, ARG1, s_regerror);
code = INUM(scode);
if (code < 0)
return makfromstr("Invalid code", sizeof("Invalid code")-1);
@@ -192,8 +192,8 @@ SCM lregcomp(pattern, flags)
char *err_msg;
#endif
- ASSERT(NIMP(pattern) && STRINGP(pattern), pattern, ARG1, s_regcomp);
- ASSERT(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)),
+ ASRTER(NIMP(pattern) && STRINGP(pattern), pattern, ARG1, s_regcomp);
+ ASRTER(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)),
flags, ARG2, s_regcomp);
DEFER_INTS;
z = must_malloc_cell((long)sizeof(regex_info), (SCM)tc16_rgx, s_regex);
@@ -302,8 +302,8 @@ SCM lregexec(prog, str)
ALLOCA_PROTECT;
FIXUP_REGEXP(prog);
- ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regexec);
- ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regexec);
+ ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regexec);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_regexec);
#ifdef _GNU_SOURCE
return lregsearchv(prog, str, EOL);
@@ -334,8 +334,8 @@ SCM lregmatp(prog, str)
SCM prog, str;
{
FIXUP_REGEXP(prog);
- ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regmatp);
- ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regmatp);
+ ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regmatp);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_regmatp);
#ifdef _GNU_SOURCE
return (lregsearch(prog, str, EOL)==BOOL_F)?BOOL_F:BOOL_T;
@@ -367,11 +367,11 @@ SCM lregsearchmatch(prog, str, args, search, vector)
ALLOCA_PROTECT;
FIXUP_REGEXP(prog);
- ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regsearch);
- ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regsearch);
- ASSERT(len<=2, args, WNA, s_regsearch);
- ASSERT((len<1)||(INUMP(CAR(args))), CAR(args), ARG3, s_regsearch);
- ASSERT((len<2)||(INUMP(CAR(CDR(args)))), CAR(CDR(args)), ARG4, s_regsearch);
+ ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regsearch);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_regsearch);
+ ASRTER(len<=2, args, WNA, s_regsearch);
+ ASRTER((len<1)||(INUMP(CAR(args))), CAR(args), ARG3, s_regsearch);
+ ASRTER((len<2)||(INUMP(CAR(CDR(args)))), CAR(CDR(args)), ARG4, s_regsearch);
start = (len>=1)?(INUM(CAR(args))):0;
size = (len>=2)?(INUM(CAR(CDR(args)))):LENGTH(str);
@@ -503,8 +503,8 @@ SCM stringsplitutil(prog, str, vector)
SCM st_start, st_end;
FIXUP_REGEXP(prog);
- ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringsplit);
- ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_stringsplit);
+ ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringsplit);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_stringsplit);
substrings = EOL;
anchor = 0;
@@ -599,16 +599,16 @@ SCM lstringedit(prog, editspec, args)
args_len = ilength(args);
FIXUP_REGEXP(prog);
- ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringedit);
- ASSERT(NIMP(editspec) && STRINGP(editspec), editspec, ARG2, s_stringedit);
- ASSERT((args_len==1)||(args_len==2), args, WNA, s_stringedit);
+ ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringedit);
+ ASRTER(NIMP(editspec) && STRINGP(editspec), editspec, ARG2, s_stringedit);
+ ASRTER((args_len==1)||(args_len==2), args, WNA, s_stringedit);
str = CAR(args);
- ASSERT(NIMP(str)&&STRINGP(str), str, ARG3, s_stringedit);
+ ASRTER(NIMP(str)&&STRINGP(str), str, ARG3, s_stringedit);
if (args_len==2) {
count = CAR(CDR(args));
- ASSERT(INUMP(count)||(count==BOOL_T), count, ARG4, s_stringedit);
+ ASRTER(INUMP(count)||(count==BOOL_T), count, ARG4, s_stringedit);
} else
count = MAKINUM(1);
diff --git a/rope.c b/rope.c
index af62c41..b4ca0d4 100644
--- a/rope.c
+++ b/rope.c
@@ -85,7 +85,7 @@ unsigned char num2uchar(num, pos, s_caller)
char *pos, *s_caller;
{
unsigned long res = INUM(num);
- ASSERT(INUMP(num) && (255L >= res), num, pos, s_caller);
+ ASRTER(INUMP(num) && (255L >= res), num, pos, s_caller);
return (unsigned char) res;
}
unsigned short num2ushort(num, pos, s_caller)
@@ -93,7 +93,7 @@ unsigned short num2ushort(num, pos, s_caller)
char *pos, *s_caller;
{
unsigned long res = INUM(num);
- ASSERT(INUMP(num) && (65535L >= res), num, pos, s_caller);
+ ASRTER(INUMP(num) && (65535L >= res), num, pos, s_caller);
return (unsigned short) res;
}
unsigned long num2ulong(num, pos, s_caller)
@@ -223,7 +223,7 @@ char **makargvfrmstrs(args, s_name)
int argc = ilength(args);
argv = (char **)must_malloc((1L+argc)*sizeof(char *), s_vector);
for(argc = 0; NNULLP(args); args=CDR(args), ++argc) {
- ASSERT(NIMP(CAR(args)) && STRINGP(CAR(args)), CAR(args), ARG2, s_name);
+ ASRTER(NIMP(CAR(args)) && STRINGP(CAR(args)), CAR(args), ARG2, s_name);
{
sizet len = 1 + LENGTH(CAR(args));
char *dst = (char *)must_malloc((long)len, s_string);
@@ -300,13 +300,13 @@ unsigned long scm_addr(args, s_name)
}
else {
if NIMP(args) {
- ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_name);
+ ASRTER(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_name);
pos = INUM(CAR(args));
ASRTGO(NULLP(CDR(args)), wna);
}
else if NULLP(args) pos = 0;
else {
- ASSERT(INUMP(args), args, ARG2, s_name);
+ ASRTER(INUMP(args), args, ARG2, s_name);
pos = INUM(args);
}
ASRTGO(pos >= 0 && pos < LENGTH(v), outrng);
@@ -418,8 +418,11 @@ SCM scm_gc_protect(obj)
SCM obj;
{
long len;
- ASSERT(NIMP(scm_uprotects), MAKINUM(20), NALLOC, "protects");
+ ASRTER(NIMP(scm_uprotects), MAKINUM(20), NALLOC, "protects");
if IMP(obj) return obj;
+ for (len = LENGTH(scm_uprotects);len--;) {
+ if (obj==VELTS(scm_uprotects)[len]) return obj;
+ }
len = LENGTH(scm_uprotects);
if (scm_protidx >= len) resizuve(scm_uprotects, MAKINUM(len + (len>>2)));
VELTS(scm_uprotects)[scm_protidx++] = obj;
@@ -428,5 +431,6 @@ SCM scm_gc_protect(obj)
void init_rope()
{
+ scm_protidx = 0;
scm_uprotects = make_vector(MAKINUM(20), UNDEFINED);
}
diff --git a/sc2.c b/sc2.c
index 3df2f1a..5749b63 100644
--- a/sc2.c
+++ b/sc2.c
@@ -50,7 +50,7 @@ SCM last_pair(sx)
{
register SCM res = sx;
register SCM x;
- ASSERT(NIMP(res) && CONSP(res), res, ARG1, s_last_pair);
+ ASRTER(NIMP(res) && CONSP(res), res, ARG1, s_last_pair);
while (!0) {
x = CDR(res);
if (IMP(x) || NCONSP(x)) return res;
@@ -59,7 +59,7 @@ SCM last_pair(sx)
if (IMP(x) || NCONSP(x)) return res;
res = x;
sx = CDR(sx);
- ASSERT(x != sx, sx, ARG1, s_last_pair);
+ ASRTER(x != sx, sx, ARG1, s_last_pair);
}
}
@@ -69,20 +69,20 @@ SCM subml(str1, start1, args)
{
SCM end1, str2, start2;
long i, j, e;
- ASSERT(3==ilength(args), args, WNA, s_subml);
+ ASRTER(3==ilength(args), args, WNA, s_subml);
end1 = CAR(args); args = CDR(args);
str2 = CAR(args); args = CDR(args);
start2 = CAR(args);
- ASSERT(NIMP(str1) && STRINGP(str1), str1, ARG1, s_subml);
- ASSERT(INUMP(start1), start1, ARG2, s_subml);
- ASSERT(INUMP(end1), end1, ARG3, s_subml);
- ASSERT(NIMP(str2) && STRINGP(str2), str2, ARG4, s_subml);
- ASSERT(INUMP(start2), start2, ARG5, s_subml);
+ ASRTER(NIMP(str1) && STRINGP(str1), str1, ARG1, s_subml);
+ ASRTER(INUMP(start1), start1, ARG2, s_subml);
+ ASRTER(INUMP(end1), end1, ARG3, s_subml);
+ ASRTER(NIMP(str2) && STRINGP(str2), str2, ARG4, s_subml);
+ ASRTER(INUMP(start2), start2, ARG5, s_subml);
i = INUM(start1), j = INUM(start2), e = INUM(end1);
- ASSERT(i <= LENGTH(str1) && i >= 0, start1, OUTOFRANGE, s_subml);
- ASSERT(j <= LENGTH(str2) && j >= 0, start2, OUTOFRANGE, s_subml);
- ASSERT(e <= LENGTH(str1) && e >= 0, end1, OUTOFRANGE, s_subml);
- ASSERT(e-i+j <= LENGTH(str2), start2, OUTOFRANGE, s_subml);
+ ASRTER(i <= LENGTH(str1) && i >= 0, start1, OUTOFRANGE, s_subml);
+ ASRTER(j <= LENGTH(str2) && j >= 0, start2, OUTOFRANGE, s_subml);
+ ASRTER(e <= LENGTH(str1) && e >= 0, end1, OUTOFRANGE, s_subml);
+ ASRTER(e-i+j <= LENGTH(str2), start2, OUTOFRANGE, s_subml);
while(i<e) CHARS(str2)[j++] = CHARS(str1)[i++];
return UNSPECIFIED;
}
@@ -92,20 +92,20 @@ SCM submr(str1, start1, args)
{
SCM end1, str2, start2;
long i, j, e;
- ASSERT(3==ilength(args), args, WNA, s_submr);
+ ASRTER(3==ilength(args), args, WNA, s_submr);
end1 = CAR(args); args = CDR(args);
str2 = CAR(args); args = CDR(args);
start2 = CAR(args);
- ASSERT(NIMP(str1) && STRINGP(str1), str1, ARG1, s_submr);
- ASSERT(INUMP(start1), start1, ARG2, s_submr);
- ASSERT(INUMP(end1), end1, ARG3, s_submr);
- ASSERT(NIMP(str2) && STRINGP(str2), str2, ARG4, s_submr);
- ASSERT(INUMP(start2), start2, ARG5, s_submr);
+ ASRTER(NIMP(str1) && STRINGP(str1), str1, ARG1, s_submr);
+ ASRTER(INUMP(start1), start1, ARG2, s_submr);
+ ASRTER(INUMP(end1), end1, ARG3, s_submr);
+ ASRTER(NIMP(str2) && STRINGP(str2), str2, ARG4, s_submr);
+ ASRTER(INUMP(start2), start2, ARG5, s_submr);
i = INUM(start1), j = INUM(start2), e = INUM(end1);
- ASSERT(i <= LENGTH(str1) && i >= 0, start1, OUTOFRANGE, s_submr);
- ASSERT(j <= LENGTH(str2) && j >= 0, start2, OUTOFRANGE, s_submr);
- ASSERT(e <= LENGTH(str1) && e >= 0, end1, OUTOFRANGE, s_submr);
- ASSERT((j = e-i+j) <= LENGTH(str2), start2, OUTOFRANGE, s_submr);
+ ASRTER(i <= LENGTH(str1) && i >= 0, start1, OUTOFRANGE, s_submr);
+ ASRTER(j <= LENGTH(str2) && j >= 0, start2, OUTOFRANGE, s_submr);
+ ASRTER(e <= LENGTH(str1) && e >= 0, end1, OUTOFRANGE, s_submr);
+ ASRTER((j = e-i+j) <= LENGTH(str2), start2, OUTOFRANGE, s_submr);
while(i<e) CHARS(str2)[--j] = CHARS(str1)[--e];
return UNSPECIFIED;
}
@@ -116,16 +116,16 @@ SCM subfl(str, start, args)
SCM end, fill;
long i, e;
char c;
- ASSERT(2==ilength(args), args, WNA, s_subfl);
+ ASRTER(2==ilength(args), args, WNA, s_subfl);
end = CAR(args); args = CDR(args);
fill = CAR(args);
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_subfl);
- ASSERT(INUMP(start), start, ARG2, s_subfl);
- ASSERT(INUMP(end), end, ARG3, s_subfl);
- ASSERT(ICHRP(fill), fill, ARG4, s_subfl);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_subfl);
+ ASRTER(INUMP(start), start, ARG2, s_subfl);
+ ASRTER(INUMP(end), end, ARG3, s_subfl);
+ ASRTER(ICHRP(fill), fill, ARG4, s_subfl);
i = INUM(start), e = INUM(end);c = ICHR(fill);
- ASSERT(i <= LENGTH(str) && i >= 0, start, OUTOFRANGE, s_subfl);
- ASSERT(e <= LENGTH(str) && e >= 0, end, OUTOFRANGE, s_subfl);
+ ASRTER(i <= LENGTH(str) && i >= 0, start, OUTOFRANGE, s_subfl);
+ ASRTER(e <= LENGTH(str) && e >= 0, end, OUTOFRANGE, s_subfl);
while(i<e) CHARS(str)[i++] = c;
return UNSPECIFIED;
}
@@ -134,7 +134,7 @@ static char s_strnullp[] = "string-null?";
SCM strnullp(str)
SCM str;
{
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_strnullp);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_strnullp);
if LENGTH(str) return BOOL_F;
else return BOOL_T;
}
@@ -150,7 +150,7 @@ SCM appendb(args)
args = CDR(args);
if NULLP(args) return arg;
if NULLP(arg) goto tail;
- ASSERT(NIMP(arg) && CONSP(arg), arg, ARG1, s_appendb);
+ ASRTER(NIMP(arg) && CONSP(arg), arg, ARG1, s_appendb);
CDR(last_pair(arg)) = appendb(args);
return arg;
}
@@ -161,6 +161,8 @@ static iproc lsubr2s[] = {
{s_subfl, subfl},
{0, 0}};
+SCM_DLL_EXPORT void init_sc2 P((void));
+
void init_sc2()
{
make_subr(s_last_pair, tc7_subr_1, last_pair);
diff --git a/scl.c b/scl.c
index 57d020e..13f6023 100644
--- a/scl.c
+++ b/scl.c
@@ -74,8 +74,9 @@ sizet num_protects = NUM_PROTECTS;
char s_inexactp[] = "inexact?";
static char s_zerop[] = "zero?",
s_positivep[] = "positive?", s_negativep[] = "negative?";
-static char s_eqp[] = "=", s_lessp[] = "<", s_grp[] = ">";
+static char s_lessp[] = "<", s_grp[] = ">";
static char s_leqp[] = "<=", s_greqp[] = ">=";
+#define s_eqp (&s_leqp[1])
static char s_max[] = "max", s_min[] = "min";
char s_sum[] = "+", s_difference[] = "-", s_product[] = "*",
s_divide[] = "/";
@@ -91,9 +92,6 @@ static char s_intexpt[] = "integer-expt";
/*** NUMBERS -> STRINGS ***/
#ifdef FLOATS
-# ifndef DBL_MANT_DIG
-# define DBL_MANT_DIG dbl_mant_dig
-# endif
static int dbl_mant_dig = 0;
static double max_dbl_int; /* Integers less than or equal to max_dbl_int
are representable exactly as doubles. */
@@ -105,10 +103,10 @@ double dbl_prec(x)
double frac = frexp(x, &expt);
# ifdef DBL_MIN_EXP
if (0.0==x || expt < DBL_MIN_EXP) /* gradual underflow */
- return ldexp(1.0, -DBL_MANT_DIG) * ldexp(1.0, DBL_MIN_EXP);
+ return ldexp(1.0, - dbl_mant_dig) * ldexp(1.0, DBL_MIN_EXP);
# endif
- if (1.0==frac) return ldexp(1.0, expt - DBL_MANT_DIG + 1);
- return ldexp(1.0, expt - DBL_MANT_DIG);
+ if (1.0==frac) return ldexp(1.0, expt - dbl_mant_dig + 1);
+ return ldexp(1.0, expt - dbl_mant_dig);
}
static double llog2 = 0.3010299956639812; /* log10(2) */
@@ -142,6 +140,17 @@ static double lpow10(x, n)
return x/p10[-n];
}
+int NaN2str(f, a)
+ double f;
+ char *a;
+{
+ sizet ch = 0;
+ if (f < 0.0) a[ch++] = '-';
+ a[ch++] = IS_INF(f)?'1':'0';
+ a[ch++] = '/'; a[ch++] = '0';
+ return ch;
+}
+
/* DBL2STR_FUZZ is a somewhat arbitrary guard against
round off error in scaling f and fprec. */
# define DBL2STR_FUZZ 0.9
@@ -155,13 +164,10 @@ static sizet idbl2str(f, a)
sizet ch = 0;
if (f==0.0) {exp = 0; goto zero;} /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
+ if IS_INF(f) return NaN2str(f, a);
if (f < 0.0) {f = -f;a[ch++]='-';}
else if (f > 0.0) ;
- else goto funny;
- if IS_INF(f) {
- if (ch==0) a[ch++]='+';
- funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch;
- }
+ else return NaN2str(f, a);
exp = apx_log10(f);
f = lpow10(f, -exp);
fprec = lpow10(fprec, -exp);
@@ -171,12 +177,13 @@ static sizet idbl2str(f, a)
while (f < 1.0) {
f *= 10.0;
fprec *= 10.0;
- if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) goto funny;
+ if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) return NaN2str(f, a);
}
while (f > 10.0) {
f /= 10.0;
fprec /= 10.0;
- if (exp++ > DBL_MAX_10_EXP) goto funny;}
+ if (exp++ > DBL_MAX_10_EXP) return NaN2str(f, a);
+ }
# else
while (f < 1.0) {f *= 10.0; fprec *= 10.0; exp--;}
while (f > 10.0) {f /= 10.0; fprec /= 10.0; exp++;}
@@ -258,8 +265,7 @@ static sizet iflo2str(flt, str)
# endif
i = idbl2str(REAL(flt), str);
if CPLXP(flt) {
- if(0 <= IMAG(flt)) /* jeh */
- str[i++] = '+'; /* jeh */
+ if (!(0 > IMAG(flt))) str[i++] = '+';
i += idbl2str(IMAG(flt), &str[i]);
str[i++] = 'i';
}
@@ -340,7 +346,7 @@ SCM number2string(x, radix)
SCM x, radix;
{
if UNBNDP(radix) radix=MAKINUM(10L);
- else ASSERT(INUMP(radix), radix, ARG2, s_number2string);
+ else ASRTER(INUMP(radix), radix, ARG2, s_number2string);
#ifdef FLOATS
if NINUMP(x) {
char num_buf[FLOBUFLEN];
@@ -352,18 +358,18 @@ SCM number2string(x, radix)
badx: wta(x, (char *)ARG1, s_number2string);
# endif
# else
- ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_number2string);
+ ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_number2string);
# endif
return makfromstr(num_buf, iflo2str(x, num_buf));
}
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_number2string);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_number2string);
return big2str(x, (unsigned int)INUM(radix));
}
# else
- ASSERT(INUMP(x), x, ARG1, s_number2string);
+ ASRTER(INUMP(x), x, ARG1, s_number2string);
# endif
#endif
{
@@ -451,7 +457,7 @@ SCM istr2int(str, len, radix)
ds[k++] = BIGLO(t2);
t2 = BIGDN(t2);
}
- ASSERT(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum");
+ ASRTER(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum");
if (t2) {blen++; goto moretodo;}
break;
default:
@@ -630,7 +636,7 @@ SCM istr2flo(str, len, radix)
}
}
out2:
- if (tmp==0.0) return BOOL_F; /* `slash zero' not allowed */
+/* if (tmp==0.0) return BOOL_F; /\* `slash zero' not allowed *\/ */
if (i < len)
while (str[i]=='#') { /* optional sharps */
tmp *= radix;
@@ -679,9 +685,9 @@ SCM istr2flo(str, len, radix)
switch (c = str[i]) {
case DIGITS:
expon = expon*10 + c-'0';
- if (expon > MAXEXP)
- if (1==expsgn || expon > (MAXEXP + dblprec + 1))
- return BOOL_F; /* exponent too large */
+/* if (expon > MAXEXP) */
+/* if (1==expsgn || expon > (MAXEXP + dblprec + 1)) */
+/* return BOOL_F; /\* exponent too large *\/ */
break;
default:
goto out4;
@@ -786,8 +792,8 @@ SCM string2number(str, radix)
SCM str, radix;
{
if UNBNDP(radix) radix=MAKINUM(10L);
- else ASSERT(INUMP(radix), radix, ARG2, s_str2number);
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2number);
+ else ASRTER(INUMP(radix), radix, ARG2, s_str2number);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_str2number);
return istring2number(CHARS(str), LENGTH(str), INUM(radix));
}
/*** END strs->nums ***/
@@ -840,9 +846,7 @@ SCM eqv(x, y)
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;
+ return floequal(x, y);
# endif
}
return BOOL_F;
@@ -882,10 +886,10 @@ SCM list_tail(lst, k)
SCM lst, k;
{
register long i;
- ASSERT(INUMP(k), k, ARG2, s_list_tail);
+ ASRTER(INUMP(k), k, ARG2, s_list_tail);
i = INUM(k);
while (i-- > 0) {
- ASSERT(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
+ ASRTER(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
lst = CDR(lst);
}
return lst;
@@ -897,7 +901,7 @@ SCM string2list(str)
long i;
SCM res = EOL;
unsigned char *src;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2list);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_str2list);
src = UCHARS(str);
for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKICHR(src[i]), res);
return res;
@@ -905,7 +909,7 @@ SCM string2list(str)
SCM string_copy(str)
SCM str;
{
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy);
return makfromstr(CHARS(str), (sizet)LENGTH(str));
}
SCM string_fill(str, chr)
@@ -913,8 +917,8 @@ SCM string_fill(str, chr)
{
register char *dst, c;
register long k;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_fill);
- ASSERT(ICHRP(chr), chr, ARG2, s_st_fill);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_fill);
+ ASRTER(ICHRP(chr), chr, ARG2, s_st_fill);
c = ICHR(chr);
dst = CHARS(str);
for(k = LENGTH(str)-1;k >= 0;k--) dst[k] = c;
@@ -926,7 +930,7 @@ SCM vector2list(v)
SCM res = EOL;
long i;
SCM *data;
- ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list);
+ ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list);
data = VELTS(v);
for(i = LENGTH(v)-1;i >= 0;i--) res = cons(data[i], res);
return res;
@@ -936,7 +940,7 @@ SCM vector_fill(v, fill)
{
register long i;
register SCM *data;
- ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill);
+ ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill);
data = VELTS(v);
for(i = LENGTH(v)-1;i >= 0;i--) data[i] = fill;
return UNSPECIFIED;
@@ -958,12 +962,14 @@ SCM bigequal(x, y)
}
#endif
#ifdef FLOATS
+# define REALLY_UNEQUAL(x,y) ((x) != (y) && !((x)!=(x) && (y)!=(y)))
SCM floequal(x, y)
SCM x, y;
{
- if (REALPART(x) != REALPART(y)) return BOOL_F;
- if (!(CPLXP(x) && (IMAG(x) != IMAG(y)))) return BOOL_T;
- return BOOL_F;
+ if (REALLY_UNEQUAL(REALPART(x), REALPART(y))) return BOOL_F;
+ if (CPLXP(x))
+ return (CPLXP(y) && !REALLY_UNEQUAL(IMAG(x), IMAG(y))) ? BOOL_T : BOOL_F;
+ return CPLXP(y) ? BOOL_F : BOOL_T;
}
#endif
SCM equal(x, y)
@@ -1030,7 +1036,7 @@ int scm_bigdblcomp(b, d)
blen = INUM(scm_intlength(b));
if (blen > dlen) return dneg ? 1 : -1;
if (blen < dlen) return dneg ? -1 : 1;
- if ((blen <= DBL_MANT_DIG) || (blen - scm_twos_power(b)) <= DBL_MANT_DIG) {
+ if ((blen <= dbl_mant_dig) || (blen - scm_twos_power(b)) <= dbl_mant_dig) {
double bd = big2dbl(b);
if (bd > d) return -1;
if (bd < d) return 1;
@@ -1075,6 +1081,7 @@ SCM inexactp(x)
#endif
return BOOL_F;
}
+
SCM eqp(x, y)
SCM x, y;
{
@@ -1097,7 +1104,7 @@ SCM eqp(x, y)
}
ASRTGO(INEXP(x), badx);
# else
- ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_eqp);
+ ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_eqp);
# endif
if INUMP(y) {t = x; x = y; y = t; goto realint;}
# ifdef BIGDIG
@@ -1107,10 +1114,8 @@ SCM eqp(x, y)
# else
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
- if (REALPART(x) != REALPART(y)) return BOOL_F;
- if CPLXP(x)
- return (CPLXP(y) && (IMAG(x)==IMAG(y))) ? BOOL_T : BOOL_F;
- return CPLXP(y) ? BOOL_F : BOOL_T;
+ if (x==y) return BOOL_T;
+ return floequal(x, y);
}
if NINUMP(y) {
# ifdef BIGDIG
@@ -1132,7 +1137,7 @@ SCM eqp(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_eqp);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_eqp);
if INUMP(y) return BOOL_F;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
@@ -1145,8 +1150,8 @@ SCM eqp(x, y)
return BOOL_F;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_eqp);
- ASSERT(INUMP(y), y, ARG2, s_eqp);
+ ASRTER(INUMP(x), x, ARG1, s_eqp);
+ ASRTER(INUMP(y), y, ARG2, s_eqp);
# endif
#endif
return ((long)x==(long)y) ? BOOL_T : BOOL_F;
@@ -1170,7 +1175,7 @@ SCM lessp(x, y)
}
ASRTGO(REALP(x), badx);
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_lessp);
+ ASRTER(NIMP(x) && REALP(x), x, ARG1, s_lessp);
# endif
if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F;
# ifdef BIGDIG
@@ -1201,7 +1206,7 @@ SCM lessp(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_lessp);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_lessp);
if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F;
@@ -1214,8 +1219,8 @@ SCM lessp(x, y)
return BIGSIGN(y) ? BOOL_F : BOOL_T;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_lessp);
- ASSERT(INUMP(y), y, ARG2, s_lessp);
+ ASRTER(INUMP(x), x, ARG1, s_lessp);
+ ASRTER(INUMP(y), y, ARG2, s_lessp);
# endif
#endif
return ((long)x < (long)y) ? BOOL_T : BOOL_F;
@@ -1248,18 +1253,18 @@ SCM zerop(z)
badz: wta(z, (char *)ARG1, s_zerop);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_zerop);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_zerop);
# endif
return (z==flo0) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if NINUMP(z) {
- ASSERT(NIMP(z) && BIGP(z), z, ARG1, s_zerop);
+ ASRTER(NIMP(z) && BIGP(z), z, ARG1, s_zerop);
return BOOL_F;
}
# else
- ASSERT(INUMP(z), z, ARG1, s_zerop);
+ ASRTER(INUMP(z), z, ARG1, s_zerop);
# endif
#endif
return (z==INUM0) ? BOOL_T: BOOL_F;
@@ -1277,18 +1282,18 @@ SCM positivep(x)
badx: wta(x, (char *)ARG1, s_positivep);
# endif
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_positivep);
+ ASRTER(NIMP(x) && REALP(x), x, ARG1, s_positivep);
# endif
return (REALPART(x) > 0.0) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_positivep);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_positivep);
return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_positivep);
+ ASRTER(INUMP(x), x, ARG1, s_positivep);
# endif
#endif
return (x > INUM0) ? BOOL_T : BOOL_F;
@@ -1306,18 +1311,18 @@ SCM negativep(x)
badx: wta(x, (char *)ARG1, s_negativep);
# endif
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_negativep);
+ ASRTER(NIMP(x) && REALP(x), x, ARG1, s_negativep);
# endif
return (REALPART(x) < 0.0) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_negativep);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_negativep);
return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_negativep);
+ ASRTER(INUMP(x), x, ARG1, s_negativep);
# endif
#endif
return (x < INUM0) ? BOOL_T : BOOL_F;
@@ -1350,12 +1355,12 @@ SCM lmax(x, y)
big_dbl:
if (-1 != scm_bigdblcomp(x, REALPART(y))) return y;
z = big2dbl(x);
- ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_max);
+ ASRTER(0==scm_bigdblcomp(x, z), x, s_exactprob, s_max);
return makdbl(z, 0.0);
}
ASRTGO(REALP(x), badx);
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_max);
+ ASRTER(NIMP(x) && REALP(x), x, ARG1, s_max);
# endif
if INUMP(y) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x;
# ifdef BIGDIG
@@ -1388,7 +1393,7 @@ SCM lmax(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_max);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_max);
if INUMP(y) return BIGSIGN(x) ? y : x;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (1==bigcomp(x, y)) ? y : x;
@@ -1401,8 +1406,8 @@ SCM lmax(x, y)
return BIGSIGN(y) ? x : y;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_max);
- ASSERT(INUMP(y), y, ARG2, s_max);
+ ASRTER(INUMP(x), x, ARG1, s_max);
+ ASRTER(INUMP(y), y, ARG2, s_max);
# endif
#endif
return ((long)x < (long)y) ? y : x;
@@ -1434,12 +1439,12 @@ SCM lmin(x, y)
big_dbl:
if (1 != scm_bigdblcomp(x, REALPART(y))) return y;
z = big2dbl(x);
- ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_min);
+ ASRTER(0==scm_bigdblcomp(x, z), x, s_exactprob, s_min);
return makdbl(z, 0.0);
}
ASRTGO(REALP(x), badx);
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_min);
+ ASRTER(NIMP(x) && REALP(x), x, ARG1, s_min);
# endif
if INUMP(y) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x;
# ifdef BIGDIG
@@ -1472,7 +1477,7 @@ SCM lmin(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_min);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_min);
if INUMP(y) return BIGSIGN(x) ? x : y;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (-1==bigcomp(x, y)) ? y : x;
@@ -1485,8 +1490,8 @@ SCM lmin(x, y)
return BIGSIGN(y) ? y : x;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_min);
- ASSERT(INUMP(y), y, ARG2, s_min);
+ ASRTER(INUMP(x), x, ARG1, s_min);
+ ASRTER(INUMP(y), y, ARG2, s_min);
# endif
#endif
return ((long)x > (long)y) ? y : x;
@@ -1589,7 +1594,7 @@ SCM sum(x, y)
}
# else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_sum);
+ ASRTER(INUMP(y), y, ARG2, s_sum);
# endif
#endif
x = INUM(x)+INUM(y);
@@ -1642,11 +1647,12 @@ SCM difference(x, y)
ASRTGO(INEXP(x), badx);
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
- if CPLXP(x)
+ if CPLXP(x) {
if CPLXP(y)
return makdbl(REAL(x)-REAL(y), IMAG(x)-IMAG(y));
else
return makdbl(REAL(x)-REALPART(y), IMAG(x));
+ }
return makdbl(REALPART(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
}
if UNBNDP(y) {x = -INUM(x); goto checkx;}
@@ -1678,7 +1684,7 @@ SCM difference(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_difference);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_difference);
if UNBNDP(y) {
x = copybig(x, !BIGSIGN(x));
return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
@@ -1717,9 +1723,9 @@ SCM difference(x, y)
}
}
# else
- ASSERT(INUMP(x), x, ARG1, s_difference);
+ ASRTER(INUMP(x), x, ARG1, s_difference);
if UNBNDP(y) {x = -INUM(x); goto checkx;}
- ASSERT(INUMP(y), y, ARG2, s_difference);
+ ASRTER(INUMP(y), y, ARG2, s_difference);
# endif
#endif
x = INUM(x)-INUM(y);
@@ -1779,12 +1785,13 @@ SCM product(x, y)
bady: wta(y, (char *)ARG2, s_product);
# endif
# endif
- if CPLXP(x)
+ if CPLXP(x) {
if CPLXP(y)
return makdbl(REAL(x)*REAL(y)-IMAG(x)*IMAG(y),
REAL(x)*IMAG(y)+IMAG(x)*REAL(y));
else
return makdbl(REAL(x)*REALPART(y), IMAG(x)*REALPART(y));
+ }
return makdbl(REALPART(x)*REALPART(y),
CPLXP(y)?REALPART(x)*IMAG(y):0.0);
}
@@ -1842,7 +1849,7 @@ SCM product(x, y)
}
# else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_product);
+ ASRTER(INUMP(y), y, ARG2, s_product);
# endif
#endif
{
@@ -1902,7 +1909,7 @@ SCM divide(x, y)
SCM z;
if INUMP(y) {
z = INUM(y);
- ASSERT(z, y, OVFLOW, s_divide);
+ ASRTER(z, y, OVFLOW, s_divide);
if (1==z) return x;
if (z < 0) z = -z;
if (z < BIGRAD) {
@@ -1978,7 +1985,7 @@ SCM divide(x, y)
# ifdef BIGDIG
if NINUMP(x) {
SCM z;
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_divide);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_divide);
if UNBNDP(y) goto ov;
if INUMP(y) {
z = INUM(y);
@@ -2020,12 +2027,12 @@ SCM divide(x, y)
goto ov;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_divide);
+ ASRTER(INUMP(x), x, ARG1, s_divide);
if UNBNDP(y) {
if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
goto ov;
}
- ASSERT(INUMP(y), y, ARG2, s_divide);
+ ASRTER(INUMP(y), y, ARG2, s_divide);
# endif
#endif
{
@@ -2056,7 +2063,7 @@ SCM scm_intexpt(z1, z2)
if (INUM0==z1 || acc==z1) return z1;
else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc;
#endif
- ASSERT(INUMP(z2), z2, ARG2, s_intexpt);
+ ASRTER(INUMP(z2), z2, ARG2, s_intexpt);
z2 = INUM(z2);
if (z2 < 0) {
z2 = -z2;
@@ -2101,7 +2108,7 @@ SCM scm_intexpt(z1, z2)
#endif
goto ret;
}
- ASSERT(NIMP(z1), z1, ARG1, s_intexpt);
+ ASRTER(NIMP(z1), z1, ARG1, s_intexpt);
#ifdef FLOATS
if REALP(z1) {
dz1 = REALPART(z1);
@@ -2183,7 +2190,7 @@ void two_doubles(z1, z2, sstring, xy)
# endif
xy->x = REALPART(z1);}
# else
- {ASSERT(NIMP(z1) && REALP(z1), z1, ARG1, sstring);
+ {ASRTER(NIMP(z1) && REALP(z1), z1, ARG1, sstring);
xy->x = REALPART(z1);}
# endif
}
@@ -2199,7 +2206,7 @@ void two_doubles(z1, z2, sstring, xy)
# endif
xy->y = REALPART(z2);}
# else
- {ASSERT(NIMP(z2) && REALP(z2), z2, ARG2, sstring);
+ {ASRTER(NIMP(z2) && REALP(z2), z2, ARG2, sstring);
xy->y = REALPART(z2);}
# endif
}
@@ -2246,7 +2253,7 @@ SCM real_part(z)
badz: wta(z, (char *)ARG1, s_real_part);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_real_part);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_real_part);
# endif
if CPLXP(z) return makdbl(REAL(z), 0.0);
}
@@ -2264,7 +2271,7 @@ SCM imag_part(z)
badz: wta(z, (char *)ARG1, s_imag_part);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_imag_part);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_imag_part);
# endif
if CPLXP(z) return makdbl(IMAG(z), 0.0);
return flo0;
@@ -2281,7 +2288,7 @@ SCM magnitude(z)
badz: wta(z, (char *)ARG1, s_magnitude);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_magnitude);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_magnitude);
# endif
if CPLXP(z)
{
@@ -2304,7 +2311,7 @@ SCM angle(z)
badz: wta(z, (char *)ARG1, s_angle);}
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_angle);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_angle);
# endif
if REALP(z) {x = REALPART(z); goto do_angle;}
x = REAL(z); y = IMAG(z);
@@ -2336,7 +2343,7 @@ SCM in2ex(z)
badz: wta(z, (char *)ARG1, s_in2ex);
# endif
# else
- ASSERT(NIMP(z) && REALP(z), z, ARG1, s_in2ex);
+ ASRTER(NIMP(z) && REALP(z), z, ARG1, s_in2ex);
# endif
# ifdef BIGDIG
{
@@ -2349,7 +2356,7 @@ SCM in2ex(z)
SCM ans = MAKINUM((long)u);
if (INUM(ans)==(long)u) return ans;
}
- ASRTGO(!IS_INF(u), badz); /* problem? */
+ ASRTGO(!(IS_INF(u) || (u)!=(u)), badz); /* problem? */
return dbl2big(u);
}
# else
@@ -2361,7 +2368,7 @@ static char s_trunc[] = "truncate";
SCM numident(x)
SCM x;
{
- ASSERT(INUMP(x), x, ARG1, s_trunc);
+ ASRTER(INUMP(x), x, ARG1, s_trunc);
return x;
}
#endif /* FLOATS */
@@ -2385,7 +2392,7 @@ SCM dbl2big(d)
u -= c;
digits[i] = c;
}
- ASSERT(0==u, INUM0, OVFLOW, "dbl2big");
+ ASRTER(0==u, INUM0, OVFLOW, "dbl2big");
return ans;
}
double big2dbl(b)
@@ -2480,7 +2487,7 @@ static char s_dfloat_parts[] = "double-float-parts";
SCM scm_dfloat_parts(f)
SCM f;
{
- int expt, ndig = DBL_MANT_DIG;
+ int expt, ndig = dbl_mant_dig;
double mant = frexp(num2dbl(f, (char *)ARG1, s_dfloat_parts), &expt);
# ifdef DBL_MIN_EXP
if (expt < DBL_MIN_EXP)
@@ -2496,8 +2503,8 @@ SCM scm_make_dfloat(mant, expt)
{
double dmant = num2dbl(mant, (char *)ARG1, s_make_dfloat);
int e = INUM(expt);
- ASSERT(INUMP(expt), expt, ARG2, s_make_dfloat);
- ASSERT((dmant < 0 ? -dmant : dmant)<=max_dbl_int, mant,
+ ASRTER(INUMP(expt), expt, ARG2, s_make_dfloat);
+ ASRTER((dmant < 0 ? -dmant : dmant)<=max_dbl_int, mant,
OUTOFRANGE, s_make_dfloat);
return makdbl(ldexp(dmant, e), 0.0);
}
@@ -2515,7 +2522,7 @@ SCM scm_next_dfloat(f1, f2)
if (e < DBL_MIN_EXP)
eps = ldexp(eps, DBL_MIN_EXP - e);
else if (0.0==d)
- eps = ldexp(1.0, DBL_MIN_EXP - DBL_MANT_DIG);
+ eps = ldexp(1.0, DBL_MIN_EXP - dbl_mant_dig);
# endif
d = ldexp(d + eps, e);
}
@@ -2524,7 +2531,7 @@ SCM scm_next_dfloat(f1, f2)
if (e < DBL_MIN_EXP)
eps = ldexp(eps, DBL_MIN_EXP - e);
else if (0.0==d)
- eps = ldexp(-1.0, DBL_MIN_EXP - DBL_MANT_DIG);
+ eps = ldexp(-1.0, DBL_MIN_EXP - dbl_mant_dig);
# endif
if (0.5==d) eps *= 0.5;
d = ldexp(d - eps, e);
@@ -2616,7 +2623,7 @@ SCM hash(obj, n)
SCM obj;
SCM n;
{
- ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hash);
+ ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hash);
return MAKINUM(hasher(obj, INUM(n), 10));
}
@@ -2624,7 +2631,7 @@ SCM hashv(obj, n)
SCM obj;
SCM n;
{
- ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashv);
+ ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hashv);
if ICHRP(obj) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n));
if (NIMP(obj) && NUMP(obj)) return MAKINUM(hasher(obj, INUM(n), 10));
else return MAKINUM(obj % INUM(n));
@@ -2634,7 +2641,7 @@ SCM hashq(obj, n)
SCM obj;
SCM n;
{
- ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashq);
+ ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hashq);
return MAKINUM((((unsigned) obj) >> 1) % INUM(n));
}
@@ -2755,13 +2762,11 @@ static dblproc cxrs[] = {
#endif
#ifdef FLOATS
-/* # ifndef DBL_DIG -- also needed for ifndef DBL_MANT_DIG */
static void add1(f, fsum)
double f, *fsum;
{
*fsum = f + 1.0;
}
-/* #endif */
#endif
void init_scl()
@@ -2803,7 +2808,7 @@ void init_scl()
# ifdef DBL_MANT_DIG
dbl_mant_dig = DBL_MANT_DIG;
# else
- if (!DBL_MANT_DIG) { /* means we #defined it. */
+ { /* means we #defined it. */
double fsum = 0.0, eps = 1.0;
int i = 0;
while (fsum != 1.0) {
@@ -2816,7 +2821,7 @@ void init_scl()
# endif /* DBL_MANT_DIG */
max_dbl_int = pow(2.0, dbl_mant_dig - 1.0);
max_dbl_int = max_dbl_int + (max_dbl_int - 1.0);
- dbl_eps = ldexp(1.0, -dbl_mant_dig);
- sysintern("double-float-mantissa-length", MAKINUM(DBL_MANT_DIG));
+ dbl_eps = ldexp(1.0, - dbl_mant_dig);
+ sysintern("double-float-mantissa-length", MAKINUM(dbl_mant_dig));
#endif
}
diff --git a/scm.c b/scm.c
index b939b6b..d4506e8 100644
--- a/scm.c
+++ b/scm.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990-1999 Free Software Foundation, Inc.
+/* Copyright (C) 1990-2002 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -50,6 +50,10 @@
#include "scm.h"
#include "patchlvl.h"
+#ifdef _WIN32
+#include <io.h>
+#endif
+
#ifdef __IBMC__
# include <io.h>
#endif
@@ -66,6 +70,9 @@
# ifdef SVR4
# include <unistd.h>
# endif
+# ifdef __NetBSD__
+# include <unistd.h>
+# endif
# ifdef __OpenBSD__
# include <unistd.h>
# endif
@@ -104,7 +111,7 @@ void final_repl P((void));
void init_banner()
{
- fputs("SCM version "SCMVERSION", Copyright (C) 1990-1999 \
+ fputs("SCM version "SCMVERSION", Copyright (C) 1990-2002 \
Free Software Foundation.\n\
SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\
This is free software, and you are welcome to redistribute it\n\
@@ -119,6 +126,8 @@ void scm_init_INITS()
#endif
}
}
+
+void (*init_user_scm) P((void));
SCM scm_init_extensions()
{
#ifdef COMPILED_INITS
@@ -195,6 +204,71 @@ void process_signals()
}
deferred_proc = 0;
}
+
+
+#ifdef WINSIGNALS
+SCM_EXPORT HANDLE scm_hMainThread;
+HANDLE scm_hMainThread;
+static SIGRETTYPE scmable_signal(int sig);
+# ifdef __MINGW32__
+static void sigintstub();
+__asm(".globl _sigintstub");
+__asm("_sigintstub:");
+__asm(" pushl $2");
+__asm(" call _scmable_signal");
+__asm(" addl $4, %esp");
+__asm(" popal");
+__asm(" popfl");
+__asm(" ret");
+# else /* works for Microsoft VC++ */
+static __declspec(naked) void sigintstub()
+{
+ scmable_signal(SIGINT);
+ __asm popad;
+ __asm popfd;
+ __asm ret;
+}
+# endif /* def __MINGW32__ */
+
+/* control-c signal handler */
+SIGRETTYPE win32_sigint(int sig)
+{
+ CONTEXT ctx;
+ DWORD *Stack;
+
+ if(-1 == SuspendThread(scm_hMainThread))
+ return;
+
+ ctx.ContextFlags = CONTEXT_FULL;
+ if(0 == GetThreadContext(scm_hMainThread, &ctx))
+ {
+ ResumeThread(scm_hMainThread);
+ return;
+ }
+
+ Stack = (DWORD *)ctx.Esp;
+
+ *--Stack = ctx.Eip;
+ *--Stack = ctx.EFlags;
+ *--Stack = ctx.Eax;
+ *--Stack = ctx.Ecx;
+ *--Stack = ctx.Edx;
+ *--Stack = ctx.Ebx;
+ *--Stack = ctx.Esp;
+ *--Stack = ctx.Ebp;
+ *--Stack = ctx.Esi;
+ *--Stack = ctx.Edi;
+ ctx.Esp = (DWORD)Stack;
+
+ ctx.Eip = (DWORD)sigintstub;
+
+ SetThreadContext(scm_hMainThread, &ctx);
+ ResumeThread(scm_hMainThread);
+}
+
+#endif /*def WINSIGNALS*/
+
+
static char s_unksig[] = "unknown signal";
static SIGRETTYPE err_signal(sig)
int sig;
@@ -205,6 +279,7 @@ static SIGRETTYPE err_signal(sig)
if (sig == sigdesc[i].signo) break;
wta(MAKINUM(sig), (i < 0 ? s_unksig : (char *)(i + SIGNAL_BASE)), "");
}
+
static SIGRETTYPE scmable_signal(sig)
int sig;
{
@@ -212,7 +287,12 @@ static SIGRETTYPE scmable_signal(sig)
int i = NUM_SIGNALS;
while (i--)
if (sig == sigdesc[i].signo) break;
- ASSERT(i >= 0, MAKINUM(sig), s_unksig, "");
+ ASRTER(i >= 0, MAKINUM(sig), s_unksig, "");
+#ifdef WINSIGNALS
+ if(SIGINT == sig)
+ signal(sig, win32_sigint);
+ else
+#endif
signal(sig, scmable_signal);
if (ints_disabled) {
deferred_proc = process_signals;
@@ -235,6 +315,8 @@ static SIGRETTYPE scmable_signal(sig)
errno = oerr;
}
+
+
/* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */
#ifndef SIGFPE
@@ -259,7 +341,7 @@ SCM lalarm(i)
SCM i;
{
unsigned int j;
- ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_alarm);
+ ASRTER(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_alarm);
SYSCALL(j = alarm(INUM(i)););
return MAKINUM(j);
}
@@ -282,9 +364,9 @@ SCM scm_setitimer(which, value, interval)
SYSCALL(w = getitimer(w, &oval););
else {
if (BOOL_F==value) value = INUM0;
- ASSERT(INUMP(value), value, ARG2, s_setitimer);
+ ASRTER(INUMP(value), value, ARG2, s_setitimer);
if (BOOL_F==interval) interval = INUM0;
- ASSERT(INUMP(interval), interval, ARG3, s_setitimer);
+ ASRTER(INUMP(interval), interval, ARG3, s_setitimer);
tval.it_value.tv_sec = INUM(value) / 1000;
tval.it_value.tv_usec = (INUM(value) % 1000)*1000;
tval.it_interval.tv_sec = INUM(interval) / 1000;
@@ -326,7 +408,7 @@ SCM l_sleep(i)
SCM i;
{
unsigned int j = 0;
- ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_sleep);
+ ASRTER(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_sleep);
# ifdef __HIGHC__
SYSCALL(sleep(INUM(i)););
# else
@@ -387,7 +469,7 @@ static char s_raise[] = "raise";
SCM l_raise(sig)
SCM sig;
{
- ASSERT(INUMP(sig), sig, ARG1, s_raise);
+ ASRTER(INUMP(sig), sig, ARG1, s_raise);
#ifdef LACK_RAISE
# ifdef vms
return MAKINUM(gsignal((int)INUM(sig)));
@@ -472,15 +554,19 @@ static void init_sig1(scm_err, signo, handler)
SIGRETTYPE (*handler)();
{
int i = scm_err - SIGNAL_BASE;
- ASSERT(i < NUM_SIGNALS, MAKINUM(i), OUTOFRANGE, "init_sig1");
+ ASRTER(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()
{
-#ifdef SIGINT
+#ifdef WINSIGNALS
+ init_sig1(INT_SIGNAL, SIGINT, win32_sigint);
+#else
+# ifdef SIGINT
init_sig1(INT_SIGNAL, SIGINT, scmable_signal);
+# endif
#endif
#ifdef SIGHUP
init_sig1(HUP_SIGNAL, SIGHUP, scmable_signal);
@@ -707,6 +793,10 @@ void final_scm(freeall)
# define SYSTNAME "amiga"
# define DIRSEP "/"
#endif
+#ifdef __NetBSD__
+# define SYSTNAME "unix"
+# define DIRSEP "/"
+#endif
const char dirsep[] = DIRSEP;
SCM softtype()
@@ -766,9 +856,9 @@ int init_buf0(inport)
# endif
# endif
# endif
+#endif
return !0; /* stdin gets marked BUF0 in init_scm() */
}
-#endif
return 0;
}
@@ -786,10 +876,10 @@ SCM scm_execpath(newpath)
execpath = 0;
return retval;
}
- ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath);
+ ASRTER(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath);
if (execpath) free(execpath);
execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1));
- ASSERT(execpath, newpath, NALLOC, s_execpath);
+ ASRTER(execpath, newpath, NALLOC, s_execpath);
strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1);
return retval;
}
@@ -836,7 +926,7 @@ char s_system[] = "system";
SCM lsystem(cmd)
SCM cmd;
{
- ASSERT(NIMP(cmd) && STRINGP(cmd), cmd, ARG1, s_system);
+ ASRTER(NIMP(cmd) && STRINGP(cmd), cmd, ARG1, s_system);
ignore_signals();
# ifdef AZTEC_C
cmd = MAKINUM(Execute(CHARS(cmd), 0, 0));
@@ -854,7 +944,7 @@ SCM lgetenv(nam)
SCM nam;
{
char *val;
- ASSERT(NIMP(nam) && STRINGP(nam), nam, ARG1, s_getenv);
+ ASRTER(NIMP(nam) && STRINGP(nam), nam, ARG1, s_getenv);
val = getenv(CHARS(nam));
if (!val) return BOOL_F;
return makfrom0str(val);
@@ -868,7 +958,7 @@ SCM ed(fname)
SCM fname;
{
struct dsc$descriptor_s d;
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_ed);
+ ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_ed);
d.dsc$b_dtype = DSC$K_DTYPE_T;
d.dsc$b_class = DSC$K_CLASS_S;
d.dsc$w_length = LENGTH(fname);
diff --git a/scm.h b/scm.h
index 81b6232..504f849 100644
--- a/scm.h
+++ b/scm.h
@@ -45,6 +45,14 @@
extern "C" {
#endif
+#ifdef _WIN32
+# include <windows.h>
+#endif
+
+#ifdef _WIN32_WCE
+# include <windows.h>
+#endif
+
#ifdef hpux
# ifndef __GNUC__
# define const /**/
@@ -71,6 +79,27 @@ typedef struct {const char *name;} subr_info;
#include <stdio.h>
#include "scmfig.h"
+#ifdef _WIN32
+# ifdef DLLSCM
+# define SCM_DLL_EXPORT __declspec(dllexport)
+# define SCM_DLL_IMPORT __declspec(dllimport)
+# ifdef SCM_DLL
+# define SCM_EXPORT SCM_DLL_EXPORT
+# else
+# define SCM_EXPORT SCM_DLL_IMPORT
+# endif
+# else
+# define SCM_DLL_EXPORT /**/
+# define SCM_DLL_IMPORT extern
+# define SCM_EXPORT extern
+# endif
+#else
+# define SCM_DLL_EXPORT /**/
+# define SCM_DLL_IMPORT extern
+# define SCM_EXPORT extern
+#endif
+
+
typedef struct {
sizet eltsize;
sizet len;
@@ -178,7 +207,7 @@ typedef struct {SCM type;double *real;} dbl;
as in backtraces, make a little more sense. */
#define MAKSPCSYM2(work, look) ((127L & (work)) | ((127L<<9) & (look)))
-extern char *isymnames[];
+SCM_EXPORT char *isymnames[];
#define NUM_ISPCSYM 14
#define IM_AND MAKSPCSYM(0)
#define IM_BEGIN MAKSPCSYM(1)
@@ -213,7 +242,7 @@ extern char *isymnames[];
#define s_quasiquote (ISYMCHARS(IM_QUASIQUOTE)+2)
#define s_let_syntax (ISYMCHARS(IM_LET_SYNTAX)+2)
-extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
+SCM_EXPORT SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
#define s_apply (ISYMCHARS(IM_APPLY)+2)
/* each symbol defined here must have a unique number which
@@ -301,8 +330,14 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
#define GCCDR(x) (~1L & CDR(x))
#define SETCDR(x, v) CDR(x) = (SCM)(v)
+#ifdef _M_ARM
+/* MS CLARM compiler bug workaround. */
+volatile SCM MS_CLARM_dumy;
+# define CODE(x) (MS_CLARM_dumy = (CAR(x)-tc3_closure))
+#else
+# define CODE(x) (CAR(x)-tc3_closure)
+#endif
#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) ((~7L & CDR(x)) ? (~7L & CDR(x)) : EOL)
#define GCENV ENV
@@ -316,7 +351,7 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
#define SCM_ESTK_PARENT(v) (VELTS(v)[0])
#define SCM_ESTK_PARENT_WRITABLEP(v) (VELTS(v)[1])
#define SCM_ESTK_PARENT_INDEX(v) (VELTS(v)[2])
-extern long tc16_env, tc16_ident;
+SCM_EXPORT long tc16_env, tc16_ident;
#define ENVP(x) (tc16_env==TYP16(x))
#define SCM_ENV_FORMALS CAR
#ifdef MACRO
@@ -360,8 +395,6 @@ extern long tc16_env, tc16_ident;
#define SETSTREAM SETCDR
#define CRDYP(port) ((CAR(port) & CRDY) && (EOF != CGETUN(port)))
#define CLRDY(port) (CAR(port) &= (SCM_PORTFLAGS(port) | (~0xf0000)))
- /* #define CRDYP(port) (CAR(port) & CRDY)
- #define CLRDY(port) (CAR(port) &= (~CRDY)) */
#define CGETUN(port) (scm_port_table[SCM_PORTNUM(port)].unread)
#define tc_socket (tc7_port | OPN)
@@ -427,7 +460,7 @@ extern long tc16_env, tc16_ident;
#define SETCHARS SETCDR
#define SETVELTS SETCDR
-extern long tc16_array;
+SCM_EXPORT long tc16_array;
#define ARRAYP(a) (tc16_array==TYP16(a))
#define ARRAY_V(a) (((array *)CDR(a))->v)
/*#define ARRAY_NDIM(x) NUMDIGS(x)*/
@@ -567,28 +600,28 @@ extern long tc16_array;
#define EXCLUSIVE (128L<<16)
/* LSB is used for gc mark */
-extern scm_gra subrs_gra;
+SCM_EXPORT scm_gra subrs_gra;
#define subrs ((subr_info *)(subrs_gra.elts))
-/* extern sizet numsmob, numptob;
- extern smobfuns *smobs;
- extern ptobfuns *ptobs;
- extern ptobfuns pipob; */
-extern scm_gra smobs_gra;
+/* SCM_EXPORT sizet numsmob, numptob;
+ SCM_EXPORT smobfuns *smobs;
+ SCM_EXPORT ptobfuns *ptobs;
+ SCM_EXPORT ptobfuns pipob; */
+SCM_EXPORT scm_gra smobs_gra;
#define numsmob (smobs_gra.len)
#define smobs ((smobfuns *)(smobs_gra.elts))
-extern scm_gra ptobs_gra;
+SCM_EXPORT scm_gra ptobs_gra;
#define numptob (ptobs_gra.len)
#define ptobs ((ptobfuns *)(ptobs_gra.elts))
-extern port_info *scm_port_table;
+SCM_EXPORT port_info *scm_port_table;
#define tc16_fport (tc7_port + 0*256L)
#define tc16_pipe (tc7_port + 1*256L)
#define tc16_strport (tc7_port + 2*256L)
#define tc16_sfport (tc7_port + 3*256L)
-extern long tc16_dir;
-extern long tc16_clport;
+SCM_EXPORT long tc16_dir;
+SCM_EXPORT long tc16_clport;
-extern SCM sys_protects[];
+SCM_EXPORT SCM sys_protects[];
#define cur_inp sys_protects[0]
#define cur_outp sys_protects[1]
#define cur_errp sys_protects[2]
@@ -615,484 +648,476 @@ extern SCM sys_protects[];
/* now for connects between source files */
-/* extern sizet num_finals;
- extern void (**finals)P((void));
- extern sizet num_finals; */
-extern scm_gra finals_gra;
+/* SCM_EXPORT sizet num_finals;
+ SCM_EXPORT void (**finals)P((void));
+ SCM_EXPORT sizet num_finals; */
+SCM_EXPORT scm_gra finals_gra;
#define num_finals (finals_gra.len)
#define finals ((void (**)())(finals_gra.elts))
-extern unsigned char upcase[], downcase[];
-extern SCM symhash;
-extern int symhash_dim;
-extern long heap_cells;
-extern CELLPTR heap_org;
-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;
-extern long mtrigger;
-extern SCM *loc_loadpath;
-extern SCM *loc_errobj;
-extern SCM loadport;
-extern char *errjmp_bad;
-extern int ints_disabled, output_deferred, gc_hook_pending, gc_hook_active;
-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 char s_no_execpath[];
-extern int scm_verbose;
+SCM_EXPORT unsigned char upcase[], downcase[];
+SCM_EXPORT SCM symhash;
+SCM_EXPORT int symhash_dim;
+SCM_EXPORT long heap_cells;
+SCM_EXPORT CELLPTR heap_org;
+SCM_EXPORT VOLATILE SCM freelist;
+SCM_EXPORT long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
+SCM_EXPORT long gc_syms_collected;
+SCM_EXPORT long cells_allocated, lcells_allocated, mallocated, lmallocated;
+SCM_EXPORT long mtrigger;
+SCM_EXPORT SCM *loc_loadpath;
+SCM_EXPORT SCM *loc_errobj;
+SCM_EXPORT SCM loadport;
+SCM_EXPORT char *errjmp_bad;
+SCM_EXPORT int ints_disabled, output_deferred, gc_hook_pending, gc_hook_active;
+SCM_EXPORT unsigned long SIG_deferred;
+SCM_EXPORT SCM exitval;
+SCM_EXPORT int cursinit;
+SCM_EXPORT unsigned int poll_count, tick_count;
+SCM_EXPORT int dumped;
+SCM_EXPORT char *execpath;
+SCM_EXPORT char s_no_execpath[];
+SCM_EXPORT int scm_verbose;
#define verbose (scm_verbose+0)
-extern const char dirsep[];
+SCM_EXPORT const char dirsep[];
/* strings used in several source files */
-extern char s_read[], s_write[], s_newline[], s_system[];
-extern char s_make_string[], s_make_vector[], s_list[], s_op_pipe[];
+SCM_EXPORT char s_read[], s_write[], s_newline[], s_system[];
+SCM_EXPORT char s_make_string[], s_make_vector[], s_list[], s_op_pipe[];
#define s_string (s_make_string+5)
#define s_vector (s_make_vector+5)
#define s_pipe (s_op_pipe+5)
-extern char s_make_sh_array[];
+SCM_EXPORT char s_make_sh_array[];
+SCM_EXPORT char s_array_fill[];
#define s_array (s_make_sh_array+12)
-extern char s_ccl[];
+SCM_EXPORT char s_ccl[];
#define s_limit (s_ccl+10)
-extern char s_close_port[];
+SCM_EXPORT char s_close_port[];
#define s_port_type (s_close_port+6)
-extern char s_call_cc[];
+SCM_EXPORT char s_call_cc[];
#define s_cont (s_call_cc+18)
-extern char s_try_create_file[];
-extern char s_badenv[];
+SCM_EXPORT char s_try_create_file[];
+SCM_EXPORT char s_badenv[];
+
+SCM_EXPORT void (*init_user_scm) P((void));
/* function prototypes */
-extern void (* deferred_proc) P((void));
-void process_signals P((void));
-int handle_it P((int i));
-SCM must_malloc_cell P((long len, SCM c, 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, 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));
-SCM hashq P((SCM obj, SCM n));
-SCM obhash P((SCM obj));
-SCM obunhash P((SCM obj));
-unsigned long strhash P((unsigned char *str, sizet len, unsigned long n));
-unsigned long hasher P((SCM obj, unsigned long n, sizet d));
-SCM lroom P((SCM args));
-SCM lflush P((SCM port));
-void scm_init_gra P((scm_gra *gra, sizet eltsize, sizet len,
+SCM_EXPORT void (* deferred_proc) P((void));
+SCM_EXPORT void process_signals P((void));
+SCM_EXPORT int handle_it P((int i));
+SCM_EXPORT SCM must_malloc_cell P((long len, SCM c, char *what));
+SCM_EXPORT void must_realloc_cell P((SCM z, long olen, long len, char *what));
+SCM_EXPORT char *must_malloc P((long len, char *what));
+SCM_EXPORT char *must_realloc P((char *where, long olen, long len, char *what));
+SCM_EXPORT void must_free P((char *obj, sizet len));
+SCM_EXPORT void scm_protect_temp P((SCM *ptr));
+SCM_EXPORT long ilength P((SCM sx));
+SCM_EXPORT SCM hash P((SCM obj, SCM n));
+SCM_EXPORT SCM hashv P((SCM obj, SCM n));
+SCM_EXPORT SCM hashq P((SCM obj, SCM n));
+SCM_EXPORT SCM obhash P((SCM obj));
+SCM_EXPORT SCM obunhash P((SCM obj));
+SCM_EXPORT unsigned long strhash P((unsigned char *str, sizet len, unsigned long n));
+SCM_EXPORT unsigned long hasher P((SCM obj, unsigned long n, sizet d));
+SCM_EXPORT SCM lroom P((SCM args));
+SCM_EXPORT SCM lflush P((SCM port));
+SCM_EXPORT void scm_init_gra P((scm_gra *gra, sizet eltsize, sizet len,
sizet maxlen, char *what));
-int scm_grow_gra P((scm_gra *gra, char *elt));
-void scm_trim_gra P((scm_gra *gra));
-void scm_free_gra P((scm_gra *gra));
-long newsmob P((smobfuns *smob));
-long newptob P((ptobfuns *ptob));
-SCM scm_port_entry P((FILE *stream, long ptype, long flags));
-SCM scm_open_ports P((void));
-void prinport P((SCM exp, SCM port, char *type));
-SCM repl P((void));
-void repl_report P((void));
-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_gc_hook P((void));
-SCM scm_gc_protect P((SCM obj));
-SCM scm_add_finalizer P((SCM value, SCM finalizer));
-void scm_run_finalizers P((int exiting));
-void scm_egc_start P((void));
-void scm_egc_end P((void));
-void heap_report P((void));
-void gra_report P((void));
-void exit_report P((void));
-void stack_report P((void));
-SCM scm_stack_trace P((SCM contin));
-SCM scm_scope_trace P((SCM env));
-SCM scm_frame_trace P((SCM contin, SCM nf));
-SCM scm_frame2env P((SCM contin, SCM nf));
-SCM scm_frame_eval P((SCM contin, SCM nf, SCM expr));
-void iprin1 P((SCM exp, SCM port, int writing));
-void intprint P((long n, int radix, SCM port));
-void iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing));
-SCM scm_env_lookup P((SCM var, SCM stenv));
-SCM scm_env_rlookup P((SCM addr, SCM stenv, char *what));
-SCM scm_env_getprop P((SCM prop, SCM env));
-SCM scm_env_addprop P((SCM prop, SCM val, SCM env));
-long num_frames P((SCM estk, int i));
-SCM *estk_frame P((SCM estk, int i, int nf));
-SCM *cont_frame P((SCM contin, int nf));
-SCM stacktrace1 P((SCM estk, int i));
-void scm_princode P((SCM code, SCM env, SCM port, int writing));
-void scm_princlosure P((SCM proc, SCM port, int writing));
-void lputc P((int c, SCM port));
-void lputs P((char *s, SCM port));
-sizet lfwrite P((char *ptr, sizet size, sizet nitems, SCM port));
-int lgetc P((SCM port));
-void lungetc P((int c, SCM port));
-char *grow_tok_buf P((SCM tok_buf));
-long mode_bits P((char *modes, char *cmodes));
-long time_in_msec P((long x));
-SCM my_time P((void));
-SCM your_time P((void));
-void init_iprocs P((iproc *subra, int type));
-
-void final_scm P((int));
-void init_sbrk P((void));
-int init_buf0 P((FILE *inport));
-void scm_init_from_argv P((int argc, char **argv, char *script_arg,
+SCM_EXPORT int scm_grow_gra P((scm_gra *gra, char *elt));
+SCM_EXPORT void scm_trim_gra P((scm_gra *gra));
+SCM_EXPORT void scm_free_gra P((scm_gra *gra));
+SCM_EXPORT long newsmob P((smobfuns *smob));
+SCM_EXPORT long newptob P((ptobfuns *ptob));
+SCM_EXPORT SCM scm_port_entry P((FILE *stream, long ptype, long flags));
+SCM_EXPORT SCM scm_open_ports P((void));
+SCM_EXPORT void prinport P((SCM exp, SCM port, char *type));
+SCM_EXPORT SCM repl P((void));
+SCM_EXPORT void repl_report P((void));
+SCM_EXPORT void growth_mon P((char *obj, long size, char *units, int grewp));
+SCM_EXPORT void gc_start P((char *what));
+SCM_EXPORT void gc_end P((void));
+SCM_EXPORT void gc_mark P((SCM p));
+SCM_EXPORT void scm_gc_hook P((void));
+SCM_EXPORT SCM scm_gc_protect P((SCM obj));
+SCM_EXPORT SCM scm_add_finalizer P((SCM value, SCM finalizer));
+SCM_EXPORT void scm_run_finalizers P((int exiting));
+SCM_EXPORT void scm_egc_start P((void));
+SCM_EXPORT void scm_egc_end P((void));
+SCM_EXPORT void heap_report P((void));
+SCM_EXPORT void gra_report P((void));
+SCM_EXPORT void exit_report P((void));
+SCM_EXPORT void stack_report P((void));
+SCM_EXPORT SCM scm_stack_trace P((SCM contin));
+SCM_EXPORT SCM scm_scope_trace P((SCM env));
+SCM_EXPORT SCM scm_frame_trace P((SCM contin, SCM nf));
+SCM_EXPORT SCM scm_frame2env P((SCM contin, SCM nf));
+SCM_EXPORT SCM scm_frame_eval P((SCM contin, SCM nf, SCM expr));
+SCM_EXPORT void iprin1 P((SCM exp, SCM port, int writing));
+SCM_EXPORT void intprint P((long n, int radix, SCM port));
+SCM_EXPORT void iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing));
+SCM_EXPORT SCM scm_env_lookup P((SCM var, SCM stenv));
+SCM_EXPORT SCM scm_env_rlookup P((SCM addr, SCM stenv, char *what));
+SCM_EXPORT SCM scm_env_getprop P((SCM prop, SCM env));
+SCM_EXPORT SCM scm_env_addprop P((SCM prop, SCM val, SCM env));
+SCM_EXPORT long num_frames P((SCM estk, int i));
+SCM_EXPORT SCM *estk_frame P((SCM estk, int i, int nf));
+SCM_EXPORT SCM *cont_frame P((SCM contin, int nf));
+SCM_EXPORT SCM stacktrace1 P((SCM estk, int i));
+SCM_EXPORT void scm_princode P((SCM code, SCM env, SCM port, int writing));
+SCM_EXPORT void scm_princlosure P((SCM proc, SCM port, int writing));
+SCM_EXPORT void lputc P((int c, SCM port));
+SCM_EXPORT void lputs P((char *s, SCM port));
+SCM_EXPORT sizet lfwrite P((char *ptr, sizet size, sizet nitems, SCM port));
+SCM_EXPORT int lgetc P((SCM port));
+SCM_EXPORT void lungetc P((int c, SCM port));
+SCM_EXPORT char *grow_tok_buf P((SCM tok_buf));
+SCM_EXPORT long mode_bits P((char *modes, char *cmodes));
+SCM_EXPORT long time_in_msec P((long x));
+SCM_EXPORT SCM my_time P((void));
+SCM_EXPORT SCM your_time P((void));
+SCM_EXPORT void init_iprocs P((iproc *subra, int type));
+
+SCM_EXPORT void final_scm P((int));
+SCM_EXPORT void init_sbrk P((void));
+SCM_EXPORT int init_buf0 P((FILE *inport));
+SCM_EXPORT void scm_init_from_argv P((int argc, char **argv, char *script_arg,
int iverbose, int buf0stdin));
-void init_signals P((void));
-SCM scm_top_level P((char *initpath, SCM (*toplvl_fun)()));
-void restore_signals P((void));
-void free_storage P((void));
-char *dld_find_executable P((const char* command));
-char *scm_find_execpath P((int argc, char **argv, char *script_arg));
-void init_scm P((int iverbose, int buf0stdin, long init_heap_size));
-void scm_init_INITS P((void));
-SCM scm_init_extensions P((void));
-void init_user_scm P((void));
-void ignore_signals P((void));
-void unignore_signals P((void));
-
-void add_feature P((char *str));
-int raprin1 P((SCM exp, SCM port, int writing));
-SCM markcdr P((SCM ptr));
+SCM_EXPORT void init_signals P((void));
+SCM_EXPORT SCM scm_top_level P((char *initpath, SCM (*toplvl_fun)()));
+SCM_EXPORT void restore_signals P((void));
+SCM_EXPORT void free_storage P((void));
+SCM_EXPORT char *dld_find_executable P((const char* command));
+SCM_EXPORT char *scm_find_execpath P((int argc, char **argv, char *script_arg));
+SCM_EXPORT void init_scm P((int iverbose, int buf0stdin, long init_heap_size));
+SCM_EXPORT void scm_init_INITS P((void));
+SCM_EXPORT SCM scm_init_extensions P((void));
+SCM_EXPORT void ignore_signals P((void));
+SCM_EXPORT void unignore_signals P((void));
+
+SCM_EXPORT void add_feature P((char *str));
+SCM_EXPORT int raprin1 P((SCM exp, SCM port, int writing));
+SCM_EXPORT SCM markcdr P((SCM ptr));
#define mark0 (0) /*SCM mark0 P((SCM ptr)); */
-SCM equal0 P((SCM ptr1, SCM ptr2));
-sizet free0 P((CELLPTR ptr));
-void scm_warn P((char *str1, char *str2, SCM obj));
-void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr, int codep));
-void wta P((SCM arg, char *pos, char *s_subr));
-void scm_experr P((SCM arg, char *pos, char *s_subr));
-SCM intern P((char *name, sizet len));
-SCM sysintern P((const char *name, SCM val));
-SCM sym2vcell P((SCM sym));
-SCM makstr P((long len));
-SCM scm_maksubr P((const char *name, int type, SCM (*fcn)()));
-SCM make_subr P((const char *name, int type, SCM (*fcn)()));
-SCM make_synt P((const char *name, long flags, SCM (*fcn)()));
-SCM make_gsubr P((const char *name, int req, int opt, int rst,
+SCM_EXPORT SCM equal0 P((SCM ptr1, SCM ptr2));
+SCM_EXPORT sizet free0 P((CELLPTR ptr));
+SCM_EXPORT void scm_warn P((char *str1, char *str2, SCM obj));
+SCM_EXPORT void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr, int codep));
+SCM_EXPORT void wta P((SCM arg, char *pos, char *s_subr));
+SCM_EXPORT void scm_experr P((SCM arg, char *pos, char *s_subr));
+SCM_EXPORT SCM intern P((char *name, sizet len));
+SCM_EXPORT SCM sysintern P((const char *name, SCM val));
+SCM_EXPORT SCM sym2vcell P((SCM sym));
+SCM_EXPORT SCM makstr P((long len));
+SCM_EXPORT SCM scm_maksubr P((const char *name, int type, SCM (*fcn)()));
+SCM_EXPORT SCM make_subr P((const char *name, int type, SCM (*fcn)()));
+SCM_EXPORT SCM make_synt P((const char *name, long flags, SCM (*fcn)()));
+SCM_EXPORT SCM make_gsubr P((const char *name, int req, int opt, int rst,
SCM (*fcn)()));
-SCM closure P((SCM code, int nargs));
-SCM makprom P((SCM code));
-SCM force P((SCM x));
-SCM makarb P((SCM name));
-SCM tryarb P((SCM arb));
-SCM relarb P((SCM arb));
-SCM ceval P((SCM x, SCM static_env, SCM env));
-SCM scm_wrapcode P((SCM code, SCM env));
-SCM scm_current_env P((void));
-SCM prolixity P((SCM arg));
-SCM gc_for_newcell P((void));
-void gc_for_open_files P((void));
-SCM gc P((SCM arg));
-SCM tryload P((SCM filename, SCM reader));
-SCM acons P((SCM w, SCM x, SCM y));
-SCM cons2 P((SCM w, SCM x, SCM y));
-SCM resizuve P((SCM vect, SCM len));
-SCM lnot P((SCM x));
-SCM booleanp P((SCM obj));
-SCM eq P((SCM x, SCM y));
-SCM equal P((SCM x, SCM y));
-SCM consp P((SCM x));
-SCM cons P((SCM x, SCM y));
-SCM nullp P((SCM x));
-SCM setcar P((SCM pair, SCM value));
-SCM setcdr P((SCM pair, SCM value));
-SCM listp P((SCM x));
-SCM list P((SCM objs));
-SCM length P((SCM x));
-SCM append P((SCM args));
-SCM reverse P((SCM lst));
-SCM list_ref P((SCM lst, SCM k));
-SCM memq P((SCM x, SCM lst));
-SCM member P((SCM x, SCM lst));
-SCM memv P((SCM x, SCM lst));
-SCM assq P((SCM x, SCM alist));
-SCM assoc P((SCM x, SCM alist));
-SCM symbolp P((SCM x));
-SCM symbol2string P((SCM s));
-SCM string2symbol P((SCM s));
-SCM numberp P((SCM x));
-SCM exactp P((SCM x));
-SCM inexactp P((SCM x));
-SCM eqp P((SCM x, SCM y));
-SCM lessp P((SCM x, SCM y));
-SCM greaterp P((SCM x, SCM y));
-SCM leqp P((SCM x, SCM y));
-SCM greqp P((SCM x, SCM y));
-SCM zerop P((SCM z));
-SCM positivep P((SCM x));
-SCM negativep P((SCM x));
-SCM oddp P((SCM n));
-SCM evenp P((SCM n));
-SCM lmax P((SCM x, SCM y));
-SCM lmin P((SCM x, SCM y));
-SCM sum P((SCM x, SCM y));
-SCM difference P((SCM x, SCM y));
-SCM product P((SCM x, SCM y));
-SCM divide P((SCM x, SCM y));
-SCM lquotient P((SCM x, SCM y));
-SCM absval P((SCM x));
-SCM lremainder P((SCM x, SCM y));
-SCM modulo P((SCM x, SCM y));
-SCM lgcd P((SCM x, SCM y));
-SCM llcm P((SCM n1, SCM n2));
-SCM number2string P((SCM x, SCM radix));
-SCM istring2number P((char *str, long len, long radix));
-SCM string2number P((SCM str, SCM radix));
-SCM istr2flo P((char *str, long len, long radix));
-SCM mkbig P((sizet nlen, int sign));
-SCM mkstrport P((SCM pos, SCM str, long modes, char *caller));
-SCM mksafeport P((int maxlen, SCM port));
-int reset_safeport P((SCM sfp, int maxlen, SCM port));
-SCM long2big P((long n));
-SCM ulong2big P((unsigned long n));
-SCM big2inum P((SCM b, sizet l));
-sizet iint2str P((long num, int rad, char *p));
-SCM floequal P((SCM x, SCM y));
-SCM uve_equal P((SCM u, SCM v));
-SCM raequal P((SCM ra0, SCM ra1));
-SCM array_equal P((SCM u, SCM v));
-SCM array_rank P((SCM ra));
-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));
-SCM istr2bve P((char *str, long len));
-void ipruk P((char *hdr, SCM ptr, SCM port));
-SCM charp P((SCM x));
-SCM char_lessp P((SCM x, SCM y));
-SCM chci_eq P((SCM x, SCM y));
-SCM chci_lessp P((SCM x, SCM y));
-SCM char_alphap P((SCM chr));
-SCM char_nump P((SCM chr));
-SCM char_whitep P((SCM chr));
-SCM char_upperp P((SCM chr));
-SCM char_lowerp P((SCM chr));
-SCM char2int P((SCM chr));
-SCM int2char P((SCM n));
-SCM char_upcase P((SCM chr));
-SCM char_downcase P((SCM chr));
-SCM stringp P((SCM x));
-SCM string P((SCM chrs));
-SCM make_string P((SCM k, SCM chr));
-SCM string2list P((SCM str));
-SCM st_length P((SCM str));
-SCM st_ref P((SCM str, SCM k));
-SCM st_set P((SCM str, SCM k, SCM chr));
-SCM st_equal P((SCM s1, SCM s2));
-SCM stci_equal P((SCM s1, SCM s2));
-SCM st_lessp P((SCM s1, SCM s2));
-SCM stci_lessp P((SCM s1, SCM s2));
-SCM substring P((SCM str, SCM start, SCM end));
-SCM st_append P((SCM args));
-SCM vectorp P((SCM x));
-SCM vector_length P((SCM v));
-SCM vector P((SCM l));
-SCM vector_ref P((SCM v, SCM k));
-SCM vector_set P((SCM v, SCM k, SCM obj));
-SCM make_vector P((SCM k, SCM fill));
-SCM vector2list P((SCM v));
-SCM for_each P((SCM proc, SCM arg1, SCM args));
-SCM procedurep P((SCM obj));
-SCM apply P((SCM proc, SCM arg1, SCM args));
-SCM scm_cvapply P((SCM proc, long n, SCM *argv));
-int scm_arity_check P((SCM proc, long argc, char *what));
-SCM map P((SCM proc, SCM arg1, SCM args));
-SCM scm_make_cont P((void));
-SCM copytree P((SCM obj));
-SCM eval P((SCM obj));
-SCM scm_values P((SCM arg1, SCM arg2, SCM rest, char *what));
-SCM scm_eval_values P((SCM x, SCM static_env, SCM env));
-SCM identp P((SCM obj));
-SCM ident2sym P((SCM id));
-SCM ident_eqp P((SCM id1, SCM id2, SCM env));
-int scm_nullenv_p P((SCM env));
-SCM env2tree P((SCM env));
-SCM renamed_ident P((SCM id, SCM env));
-SCM scm_check_linum P((SCM x, SCM *linum));
-SCM scm_add_linum P((SCM linum, SCM x));
-SCM input_portp P((SCM x));
-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));
-SCM lread P((SCM port));
-SCM scm_read_char P((SCM port));
-SCM peek_char P((SCM port));
-SCM eof_objectp P((SCM x));
-int scm_io_error P((SCM port, char *what));
-SCM lwrite P((SCM obj, SCM port));
-SCM display P((SCM obj, SCM port));
-SCM newline P((SCM port));
-SCM write_char P((SCM chr, SCM port));
-SCM file_position P((SCM port));
-SCM file_set_position P((SCM port, SCM pos));
-SCM scm_port_line P((SCM port));
-SCM scm_port_col P((SCM port));
-void scm_line_msg P((SCM file, SCM linum, SCM port));
-void scm_err_line P((char *what, SCM file, SCM linum, SCM port));
-SCM lgetenv P((SCM nam));
-SCM prog_args P((void));
-SCM makacro P((SCM code));
-SCM makmacro P((SCM code));
-SCM makmmacro P((SCM code));
-SCM makidmacro P((SCM code));
-void poll_routine P((void));
-void tick_signal P((void));
-void stack_check P((void));
-SCM list2ura P((SCM ndim, SCM prot, SCM lst));
-SCM make_ra P((int ndim));
-SCM makflo P((float x));
-SCM arrayp P((SCM v, SCM prot));
-SCM array_contents P((SCM ra, SCM strict));
-SCM uve_read P((SCM v, SCM port));
-SCM uve_write P((SCM v, SCM port));
-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));
+SCM_EXPORT SCM closure P((SCM code, int nargs));
+SCM_EXPORT SCM makprom P((SCM code));
+SCM_EXPORT SCM force P((SCM x));
+SCM_EXPORT SCM makarb P((SCM name));
+SCM_EXPORT SCM tryarb P((SCM arb));
+SCM_EXPORT SCM relarb P((SCM arb));
+SCM_EXPORT SCM ceval P((SCM x, SCM static_env, SCM env));
+SCM_EXPORT SCM scm_wrapcode P((SCM code, SCM env));
+SCM_EXPORT SCM scm_current_env P((void));
+SCM_EXPORT SCM prolixity P((SCM arg));
+SCM_EXPORT SCM gc_for_newcell P((void));
+SCM_EXPORT void gc_for_open_files P((void));
+SCM_EXPORT SCM gc P((SCM arg));
+SCM_EXPORT SCM tryload P((SCM filename, SCM reader));
+SCM_EXPORT SCM acons P((SCM w, SCM x, SCM y));
+SCM_EXPORT SCM cons2 P((SCM w, SCM x, SCM y));
+SCM_EXPORT SCM resizuve P((SCM vect, SCM len));
+SCM_EXPORT SCM lnot P((SCM x));
+SCM_EXPORT SCM booleanp P((SCM obj));
+SCM_EXPORT SCM eq P((SCM x, SCM y));
+SCM_EXPORT SCM equal P((SCM x, SCM y));
+SCM_EXPORT SCM consp P((SCM x));
+SCM_EXPORT SCM cons P((SCM x, SCM y));
+SCM_EXPORT SCM nullp P((SCM x));
+SCM_EXPORT SCM setcar P((SCM pair, SCM value));
+SCM_EXPORT SCM setcdr P((SCM pair, SCM value));
+SCM_EXPORT SCM listp P((SCM x));
+SCM_EXPORT SCM list P((SCM objs));
+SCM_EXPORT SCM length P((SCM x));
+SCM_EXPORT SCM append P((SCM args));
+SCM_EXPORT SCM reverse P((SCM lst));
+SCM_EXPORT SCM list_ref P((SCM lst, SCM k));
+SCM_EXPORT SCM memq P((SCM x, SCM lst));
+SCM_EXPORT SCM member P((SCM x, SCM lst));
+SCM_EXPORT SCM memv P((SCM x, SCM lst));
+SCM_EXPORT SCM assq P((SCM x, SCM alist));
+SCM_EXPORT SCM assoc P((SCM x, SCM alist));
+SCM_EXPORT SCM symbolp P((SCM x));
+SCM_EXPORT SCM symbol2string P((SCM s));
+SCM_EXPORT SCM string2symbol P((SCM s));
+SCM_EXPORT SCM numberp P((SCM x));
+SCM_EXPORT SCM exactp P((SCM x));
+SCM_EXPORT SCM inexactp P((SCM x));
+SCM_EXPORT SCM eqp P((SCM x, SCM y));
+SCM_EXPORT SCM lessp P((SCM x, SCM y));
+SCM_EXPORT SCM greaterp P((SCM x, SCM y));
+SCM_EXPORT SCM leqp P((SCM x, SCM y));
+SCM_EXPORT SCM greqp P((SCM x, SCM y));
+SCM_EXPORT SCM zerop P((SCM z));
+SCM_EXPORT SCM positivep P((SCM x));
+SCM_EXPORT SCM negativep P((SCM x));
+SCM_EXPORT SCM oddp P((SCM n));
+SCM_EXPORT SCM evenp P((SCM n));
+SCM_EXPORT SCM lmax P((SCM x, SCM y));
+SCM_EXPORT SCM lmin P((SCM x, SCM y));
+SCM_EXPORT SCM sum P((SCM x, SCM y));
+SCM_EXPORT SCM difference P((SCM x, SCM y));
+SCM_EXPORT SCM product P((SCM x, SCM y));
+SCM_EXPORT SCM divide P((SCM x, SCM y));
+SCM_EXPORT SCM lquotient P((SCM x, SCM y));
+SCM_EXPORT SCM absval P((SCM x));
+SCM_EXPORT SCM lremainder P((SCM x, SCM y));
+SCM_EXPORT SCM modulo P((SCM x, SCM y));
+SCM_EXPORT SCM lgcd P((SCM x, SCM y));
+SCM_EXPORT SCM llcm P((SCM n1, SCM n2));
+SCM_EXPORT SCM number2string P((SCM x, SCM radix));
+SCM_EXPORT SCM istring2number P((char *str, long len, long radix));
+SCM_EXPORT SCM string2number P((SCM str, SCM radix));
+SCM_EXPORT SCM istr2flo P((char *str, long len, long radix));
+SCM_EXPORT SCM mkbig P((sizet nlen, int sign));
+SCM_EXPORT SCM mkstrport P((SCM pos, SCM str, long modes, char *caller));
+SCM_EXPORT SCM mksafeport P((int maxlen, SCM port));
+SCM_EXPORT int reset_safeport P((SCM sfp, int maxlen, SCM port));
+SCM_EXPORT SCM long2big P((long n));
+SCM_EXPORT SCM ulong2big P((unsigned long n));
+SCM_EXPORT SCM big2inum P((SCM b, sizet l));
+SCM_EXPORT sizet iint2str P((long num, int rad, char *p));
+SCM_EXPORT SCM floequal P((SCM x, SCM y));
+SCM_EXPORT SCM uve_equal P((SCM u, SCM v));
+SCM_EXPORT SCM uve_read P((SCM v, SCM port));
+SCM_EXPORT SCM uve_write P((SCM v, SCM port));
+SCM_EXPORT SCM raequal P((SCM ra0, SCM ra1));
+SCM_EXPORT SCM array_equal P((SCM u, SCM v));
+SCM_EXPORT SCM array_rank P((SCM ra));
+SCM_EXPORT int rafill P((SCM ra, SCM fill, SCM ignore));
+SCM_EXPORT SCM uve_fill P((SCM uve, SCM fill));
+SCM_EXPORT SCM array_fill P((SCM ra, SCM fill));
+SCM_EXPORT SCM array_prot P((SCM ra));
+SCM_EXPORT SCM array_rank P((SCM ra));
+SCM_EXPORT SCM array_contents P((SCM ra, SCM strict));
+SCM_EXPORT int bigprint P((SCM exp, SCM port, int writing));
+SCM_EXPORT int floprint P((SCM sexp, SCM port, int writing));
+SCM_EXPORT SCM istr2int P((char *str, long len, long radix));
+SCM_EXPORT SCM istr2bve P((char *str, long len));
+SCM_EXPORT void ipruk P((char *hdr, SCM ptr, SCM port));
+SCM_EXPORT SCM charp P((SCM x));
+SCM_EXPORT SCM char_lessp P((SCM x, SCM y));
+SCM_EXPORT SCM chci_eq P((SCM x, SCM y));
+SCM_EXPORT SCM chci_lessp P((SCM x, SCM y));
+SCM_EXPORT SCM char_alphap P((SCM chr));
+SCM_EXPORT SCM char_nump P((SCM chr));
+SCM_EXPORT SCM char_whitep P((SCM chr));
+SCM_EXPORT SCM char_upperp P((SCM chr));
+SCM_EXPORT SCM char_lowerp P((SCM chr));
+SCM_EXPORT SCM char2int P((SCM chr));
+SCM_EXPORT SCM int2char P((SCM n));
+SCM_EXPORT SCM char_upcase P((SCM chr));
+SCM_EXPORT SCM char_downcase P((SCM chr));
+SCM_EXPORT SCM stringp P((SCM x));
+SCM_EXPORT SCM string P((SCM chrs));
+SCM_EXPORT SCM make_string P((SCM k, SCM chr));
+SCM_EXPORT SCM string2list P((SCM str));
+SCM_EXPORT SCM st_length P((SCM str));
+SCM_EXPORT SCM st_ref P((SCM str, SCM k));
+SCM_EXPORT SCM st_set P((SCM str, SCM k, SCM chr));
+SCM_EXPORT SCM st_equal P((SCM s1, SCM s2));
+SCM_EXPORT SCM stci_equal P((SCM s1, SCM s2));
+SCM_EXPORT SCM st_lessp P((SCM s1, SCM s2));
+SCM_EXPORT SCM stci_lessp P((SCM s1, SCM s2));
+SCM_EXPORT SCM substring P((SCM str, SCM start, SCM end));
+SCM_EXPORT SCM st_append P((SCM args));
+SCM_EXPORT SCM vectorp P((SCM x));
+SCM_EXPORT SCM vector_length P((SCM v));
+SCM_EXPORT SCM vector P((SCM l));
+SCM_EXPORT SCM vector_ref P((SCM v, SCM k));
+SCM_EXPORT SCM vector_set P((SCM v, SCM k, SCM obj));
+SCM_EXPORT SCM make_vector P((SCM k, SCM fill));
+SCM_EXPORT SCM vector2list P((SCM v));
+SCM_EXPORT SCM for_each P((SCM proc, SCM arg1, SCM args));
+SCM_EXPORT SCM procedurep P((SCM obj));
+SCM_EXPORT SCM apply P((SCM proc, SCM arg1, SCM args));
+SCM_EXPORT SCM scm_cvapply P((SCM proc, long n, SCM *argv));
+SCM_EXPORT int scm_arity_check P((SCM proc, long argc, char *what));
+SCM_EXPORT SCM map P((SCM proc, SCM arg1, SCM args));
+SCM_EXPORT SCM scm_make_cont P((void));
+SCM_EXPORT SCM copytree P((SCM obj));
+SCM_EXPORT SCM eval P((SCM obj));
+SCM_EXPORT SCM scm_values P((SCM arg1, SCM arg2, SCM rest, char *what));
+SCM_EXPORT SCM scm_eval_values P((SCM x, SCM static_env, SCM env));
+SCM_EXPORT SCM identp P((SCM obj));
+SCM_EXPORT SCM ident2sym P((SCM id));
+SCM_EXPORT SCM ident_eqp P((SCM id1, SCM id2, SCM env));
+SCM_EXPORT int scm_nullenv_p P((SCM env));
+SCM_EXPORT SCM env2tree P((SCM env));
+SCM_EXPORT SCM renamed_ident P((SCM id, SCM env));
+SCM_EXPORT SCM scm_check_linum P((SCM x, SCM *linum));
+SCM_EXPORT SCM scm_add_linum P((SCM linum, SCM x));
+SCM_EXPORT SCM input_portp P((SCM x));
+SCM_EXPORT SCM output_portp P((SCM x));
+SCM_EXPORT SCM cur_input_port P((void));
+SCM_EXPORT SCM cur_output_port P((void));
+SCM_EXPORT SCM i_setbuf0 P((SCM port));
+SCM_EXPORT SCM try_open_file P((SCM filename, SCM modes));
+SCM_EXPORT SCM open_file P((SCM filename, SCM modes));
+SCM_EXPORT SCM open_pipe P((SCM pipestr, SCM modes));
+SCM_EXPORT SCM close_port P((SCM port));
+SCM_EXPORT SCM scm_read P((SCM port));
+SCM_EXPORT SCM scm_read_char P((SCM port));
+SCM_EXPORT SCM peek_char P((SCM port));
+SCM_EXPORT SCM eof_objectp P((SCM x));
+SCM_EXPORT int scm_io_error P((SCM port, char *what));
+SCM_EXPORT SCM lwrite P((SCM obj, SCM port));
+SCM_EXPORT SCM display P((SCM obj, SCM port));
+SCM_EXPORT SCM newline P((SCM port));
+SCM_EXPORT SCM write_char P((SCM chr, SCM port));
+SCM_EXPORT SCM scm_port_line P((SCM port));
+SCM_EXPORT SCM scm_port_col P((SCM port));
+SCM_EXPORT void scm_line_msg P((SCM file, SCM linum, SCM port));
+SCM_EXPORT void scm_err_line P((char *what, SCM file, SCM linum, SCM port));
+SCM_EXPORT SCM lgetenv P((SCM nam));
+SCM_EXPORT SCM prog_args P((void));
+SCM_EXPORT SCM makacro P((SCM code));
+SCM_EXPORT SCM makmacro P((SCM code));
+SCM_EXPORT SCM makmmacro P((SCM code));
+SCM_EXPORT SCM makidmacro P((SCM code));
+SCM_EXPORT void poll_routine P((void));
+SCM_EXPORT void tick_signal P((void));
+SCM_EXPORT void stack_check P((void));
+SCM_EXPORT SCM list2ura P((SCM ndim, SCM prot, SCM lst));
+SCM_EXPORT SCM make_ra P((int ndim));
+SCM_EXPORT SCM makflo P((float x));
+SCM_EXPORT SCM arrayp P((SCM v, SCM prot));
+SCM_EXPORT SCM aset P((SCM v, SCM obj, SCM args));
+SCM_EXPORT SCM aref P((SCM v, SCM args));
+SCM_EXPORT SCM scm_array_ref P((SCM args));
+SCM_EXPORT SCM cvref P((SCM v, sizet pos, SCM last));
+SCM_EXPORT SCM quit P((SCM n));
#ifdef CAREFUL_INTS
-void ints_viol P((ints_infot *info, int sense));
-void ints_warn P((char *s1, char* s2, char *fname, int linum));
+SCM_EXPORT void ints_viol P((ints_infot *info, int sense));
+SCM_EXPORT void ints_warn P((char *s1, char* s2, char *fname, int linum));
#endif
-void add_final P((void (*final)(void)));
-SCM makcclo P((SCM proc, long len));
-SCM make_uve P((long k, SCM prot));
-long scm_prot2type P((SCM prot));
-SCM ra2contig P((SCM ra, int copy));
-SCM sc2array P((SCM s, SCM ra, SCM prot));
-SCM array_copy P((SCM src, SCM dst));
-long aind P((SCM ra, SCM args, char *what));
-SCM scm_eval_string P((SCM str));
-SCM scm_load_string P((SCM str));
-void scm_print_stack P((SCM stk));
-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));
+SCM_EXPORT void add_final P((void (*final)(void)));
+SCM_EXPORT SCM makcclo P((SCM proc, long len));
+SCM_EXPORT SCM make_uve P((long k, SCM prot));
+SCM_EXPORT long scm_prot2type P((SCM prot));
+SCM_EXPORT long aind P((SCM ra, SCM args, char *what));
+SCM_EXPORT SCM scm_eval_string P((SCM str));
+SCM_EXPORT SCM scm_load_string P((SCM str));
+SCM_EXPORT SCM scm_unexec P((const SCM pathname));
+SCM_EXPORT SCM scm_logbitp P((SCM index, SCM j1));
+SCM_EXPORT SCM scm_logtest P((SCM x, SCM y));
+SCM_EXPORT SCM scm_logxor P((SCM x, SCM y));
+SCM_EXPORT SCM scm_logand P((SCM x, SCM y));
+SCM_EXPORT SCM scm_logior P((SCM x, SCM y));
+SCM_EXPORT SCM scm_lognot P((SCM n));
+SCM_EXPORT SCM scm_intexpt P((SCM z1, SCM z2));
+SCM_EXPORT SCM scm_ash P((SCM n, SCM cnt));
+SCM_EXPORT SCM scm_bitfield P((SCM n, SCM start, SCM end));
+SCM_EXPORT SCM scm_logcount P((SCM n));
+SCM_EXPORT SCM scm_intlength P((SCM n));
+SCM_EXPORT SCM scm_copybit P((SCM index, SCM j1, SCM bit));
+SCM_EXPORT SCM scm_bitif P((SCM mask, SCM n0, SCM n1));
+SCM_EXPORT SCM scm_copybitfield P((SCM to, SCM start, SCM rest));
/* Defined in "rope.c" */
-SCM long2num P((long n));
-SCM ulong2num P((unsigned long n));
-unsigned char num2uchar P((SCM num, char *pos, char *s_caller));
-unsigned short num2ushort P((SCM num, char *pos, char *s_caller));
-unsigned long num2ulong P((SCM num, char *pos, char *s_caller));
- long num2long P((SCM num, char *pos, char *s_caller));
- short num2short P((SCM num, char *pos, char *s_caller));
- double num2dbl P((SCM num, char *pos, char *s_caller));
-SCM makfromstr P((char *src, sizet len));
-SCM makfromstrs P((int argc, char **argv));
-SCM makfrom0str P((char *scr));
-char **makargvfrmstrs P((SCM args, char *s_v));
-void must_free_argv P((char **argv));
-SCM scm_evstr P((char *str));
-void scm_ldstr P((char *str));
-int scm_ldfile P((char *path));
-int scm_ldprog P((char *path));
-unsigned long scm_addr P((SCM args, char *name));
-unsigned long scm_base_addr P((SCM v, char *name));
-int scm_cell_p P((SCM x));
+SCM_EXPORT SCM long2num P((long n));
+SCM_EXPORT SCM ulong2num P((unsigned long n));
+SCM_EXPORT unsigned char num2uchar P((SCM num, char *pos, char *s_caller));
+SCM_EXPORT unsigned short num2ushort P((SCM num, char *pos, char *s_caller));
+SCM_EXPORT unsigned long num2ulong P((SCM num, char *pos, char *s_caller));
+SCM_EXPORT long num2long P((SCM num, char *pos, char *s_caller));
+SCM_EXPORT short num2short P((SCM num, char *pos, char *s_caller));
+SCM_EXPORT double num2dbl P((SCM num, char *pos, char *s_caller));
+SCM_EXPORT SCM makfromstr P((char *src, sizet len));
+SCM_EXPORT SCM makfromstrs P((int argc, char **argv));
+SCM_EXPORT SCM makfrom0str P((char *scr));
+SCM_EXPORT char **makargvfrmstrs P((SCM args, char *s_v));
+SCM_EXPORT void must_free_argv P((char **argv));
+SCM_EXPORT SCM scm_evstr P((char *str));
+SCM_EXPORT void scm_ldstr P((char *str));
+SCM_EXPORT int scm_ldfile P((char *path));
+SCM_EXPORT int scm_ldprog P((char *path));
+SCM_EXPORT unsigned long scm_addr P((SCM args, char *name));
+SCM_EXPORT unsigned long scm_base_addr P((SCM v, char *name));
+SCM_EXPORT int scm_cell_p P((SCM x));
#ifdef FLOATS
-SCM makdbl P((double x, double y));
-SCM dbl2big P((double d));
-double big2dbl P((SCM b));
-double lasinh P((double x));
-double lacosh P((double x));
-double latanh P((double x));
-double ltrunc P((double x));
-double scm_round P((double x));
-double floident P((double x));
+SCM_EXPORT SCM makdbl P((double x, double y));
+SCM_EXPORT SCM dbl2big P((double d));
+SCM_EXPORT double big2dbl P((SCM b));
+SCM_EXPORT double lasinh P((double x));
+SCM_EXPORT double lacosh P((double x));
+SCM_EXPORT double latanh P((double x));
+SCM_EXPORT double ltrunc P((double x));
+SCM_EXPORT double scm_round P((double x));
+SCM_EXPORT double floident P((double x));
#endif
#ifdef BIGDIG
-void longdigs P((long x, BIGDIG digs[DIGSPERLONG]));
-SCM adjbig P((SCM b, sizet nlen));
-SCM normbig P((SCM b));
-SCM copybig P((SCM b, int sign));
-SCM addbig P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int sgny));
-SCM mulbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn));
-unsigned int divbigdig P((BIGDIG *ds, sizet h, BIGDIG div));
-SCM divbigint P((SCM x, long z, int sgn, int mode));
-SCM divbigbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn,
+SCM_EXPORT void longdigs P((long x, BIGDIG digs[DIGSPERLONG]));
+SCM_EXPORT SCM adjbig P((SCM b, sizet nlen));
+SCM_EXPORT SCM normbig P((SCM b));
+SCM_EXPORT SCM copybig P((SCM b, int sign));
+SCM_EXPORT SCM addbig P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int sgny));
+SCM_EXPORT SCM mulbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn));
+SCM_EXPORT unsigned int divbigdig P((BIGDIG *ds, sizet h, BIGDIG div));
+SCM_EXPORT SCM divbigint P((SCM x, long z, int sgn, int mode));
+SCM_EXPORT SCM divbigbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn,
int modes));
-long pseudolong P((long x));
+SCM_EXPORT long pseudolong P((long x));
#endif
-int bigcomp P((SCM x, SCM y));
-SCM bigequal P((SCM x, SCM y));
-int scm_bigdblcomp P((SCM b, double d));
+SCM_EXPORT int bigcomp P((SCM x, SCM y));
+SCM_EXPORT SCM bigequal P((SCM x, SCM y));
+SCM_EXPORT int scm_bigdblcomp P((SCM b, double d));
/* "script.c" functions */
-char * scm_cat_path P((char *str1, const char *str2, long n));
-char * scm_try_path P((char *path));
-char * script_find_executable P((const char *command));
-char ** script_process_argv P((int argc, char **argv));
-int script_count_argv P((char **argv));
-char * find_impl_file P((char *exec_path, const char *generic_name,
+SCM_EXPORT char * scm_cat_path P((char *str1, const char *str2, long n));
+SCM_EXPORT char * scm_try_path P((char *path));
+SCM_EXPORT char * script_find_executable P((const char *command));
+SCM_EXPORT char ** script_process_argv P((int argc, char **argv));
+SCM_EXPORT int script_count_argv P((char **argv));
+SCM_EXPORT char * find_impl_file P((char *exec_path, const char *generic_name,
const char *initname, const char *sep));
/* environment cache functions */
-void scm_ecache_report P((void));
-void scm_estk_reset P((sizet size));
-void scm_env_cons P((SCM x, SCM y));
-void scm_env_cons2 P((SCM w, SCM x, SCM y));
-void scm_env_cons3 P((SCM v, SCM w, SCM x, SCM y));
-void scm_env_v2lst P((long argc, SCM *argv));
-void scm_extend_env P((void));
-void scm_egc P((void));
+SCM_EXPORT void scm_ecache_report P((void));
+SCM_EXPORT void scm_estk_reset P((sizet size));
+SCM_EXPORT void scm_env_cons P((SCM x, SCM y));
+SCM_EXPORT void scm_env_cons2 P((SCM w, SCM x, SCM y));
+SCM_EXPORT void scm_env_cons3 P((SCM v, SCM w, SCM x, SCM y));
+SCM_EXPORT void scm_env_v2lst P((long argc, SCM *argv));
+SCM_EXPORT void scm_extend_env P((void));
+SCM_EXPORT 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 VOLATILE long scm_egc_root_index;
-extern SCM scm_estk;
-extern SCM *scm_estk_v, *scm_estk_ptr;
-extern long scm_estk_size;
+SCM_EXPORT CELLPTR scm_ecache;
+SCM_EXPORT VOLATILE long scm_ecache_index, scm_ecache_len;
+SCM_EXPORT SCM scm_env, scm_env_tmp;
+SCM_EXPORT SCM scm_egc_roots[];
+SCM_EXPORT VOLATILE long scm_egc_root_index;
+SCM_EXPORT SCM scm_estk;
+SCM_EXPORT SCM *scm_estk_v, *scm_estk_ptr;
+SCM_EXPORT long scm_estk_size;
#ifndef RECKLESS
-extern SCM scm_trace, scm_trace_env;
+SCM_EXPORT SCM scm_trace, scm_trace_env;
#endif
#ifdef RECKLESS
-# define ASSERT(_cond, _arg, _pos, _subr) ;
+# define ASRTER(_cond, _arg, _pos, _subr) ;
# define ASRTGO(_cond, _label) ;
#else
-# define ASSERT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)(_pos), _subr);
+# define ASRTER(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)(_pos), _subr);
# define ASRTGO(_cond, _label) if(!(_cond)) goto _label;
#endif
diff --git a/scm.info b/scm.info
index b0dbf1b..c7f80bd 100644
--- a/scm.info
+++ b/scm.info
@@ -1,4 +1,4 @@
-This is scm.info, produced by makeinfo version 4.0 from scm.texi.
+This is scm.info, produced by makeinfo version 4.0 from scm.texi. |
INFO-DIR-SECTION The Algorithmic Language Scheme
START-INFO-DIR-ENTRY
@@ -9,10 +9,10 @@ END-INFO-DIR-ENTRY
File: scm.info, Node: Top, Next: Overview, Prev: (dir), Up: (dir)
This manual documents the SCM Scheme implementation. SCM version
-5d6 was released April 2002. The most recent information about SCM can |
-be found on SCM's "WWW" home page: |
+5d9 was released November 2003. The most recent information about SCM |
+can be found on SCM's "WWW" home page:
- <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
+ <http://swissnet.ai.mit.edu/~jaffer/SCM>
Copyright (C) 1990-1999 Free Software Foundation
@@ -33,7 +33,7 @@ approved by the author.
* Menu:
* Overview::
-* Installing SCM::
+* Installing SCM:: How to
* Operational Features::
* The Language:: Reference.
* Packages:: Optional Capabilities.
@@ -112,7 +112,7 @@ File: scm.info, Node: SCM Authors, Next: Copying, Prev: SCM Features, Up: Ov
Authors
=======
-Aubrey Jaffer (jaffer @ alum.mit.edu) |
+Aubrey Jaffer (agj @ alum.mit.edu)
Most of SCM.
Radey Shouman
@@ -332,22 +332,21 @@ SLIB is not _neccessary_ to run SCM, I strongly suggest you obtain and
install it. Bug reports about running SCM without SLIB have very low
priority. SLIB is available from the same sites as SCM:
- * swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz |
+ * swissnet.ai.mit.edu:/pub/scm/slib3a1.tar.gz |
- * ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz |
+ * ftp.gnu.org:/pub/gnu/jacal/slib3a1.tar.gz |
- * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz |
+ * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a1.tar.gz |
-Unpack SLIB (`tar xzf slib2d4.tar.gz' or `unzip -ao slib2d4.zip') in an |
+Unpack SLIB (`tar xzf slib3a1.tar.gz' or `unzip -ao slib3a1.zip') in an |
appropriate directory for your system; both `tar' and `unzip' will
create the directory `slib'.
Then create a file `require.scm' in the SCM "implementation-vicinity"
-(this is the same directory as where the file `Init5d6.scm' is |
+(this is the same directory as where the file `Init5d9.scm' is |
installed). `require.scm' should have the contents:
(define (library-vicinity) "/usr/local/lib/slib/")
- (load (in-vicinity (library-vicinity) "require"))
where the pathname string `/usr/local/lib/slib/' is to be replaced by
the pathname into which you installed SLIB. Absolute pathnames are
@@ -359,7 +358,6 @@ implementation-vicinity, which is absolute:
(define library-vicinity
(let ((lv (string-append (implementation-vicinity) "../slib/")))
(lambda () lv)))
- (load (in-vicinity (library-vicinity) "require"))
Alternatively, you can set the (shell) environment variable
`SCHEME_LIBRARY_PATH' to the pathname of the SLIB directory (*note
@@ -413,33 +411,33 @@ script with the `arrays', `inexact', and `bignums' options as defaults.
bash$ ./build
-|
#! /bin/sh
- # unix (linux) script created by SLIB/batch |
- # ================ Write file with C defines |
+ # unix (linux) script created by SLIB/batch
+ # ================ Write file with C defines
rm -f scmflags.h
- echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h |
+ echo '#define IMPLINIT "Init5d9.scm"'>>scmflags.h |
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
- # ================ Compile C source files |
+ # ================ Compile C source files
gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
- # ================ Link C object files |
+ # ================ Link C object files
gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc
To cross compile for another platform, invoke build with the `-p' or
`--platform=' option. This will create a script for the platform named
in the `-p' or `--platform=' option.
- bash$ ./build -o scmlit -p darwin -F lit |
+ bash$ ./build -o scmlit -p darwin -F lit
-|
- #! /bin/sh |
- # unix (darwin) script created by SLIB/batch |
- # ================ Write file with C defines |
- rm -f scmflags.h |
- echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h |
- # ================ Compile C source files |
+ #! /bin/sh
+ # unix (darwin) script created by SLIB/batch
+ # ================ Write file with C defines
+ rm -f scmflags.h
+ echo '#define IMPLINIT "Init5d9.scm"'>>scmflags.h |
+ # ================ Compile C source files
cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
- # ================ Link C object files |
- mv -f scmlit scmlit~ |
+ # ================ Link C object files
+ mv -f scmlit scmlit~
cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o

@@ -465,12 +463,11 @@ the SCM command line options.
name processor operating-system compiler |
#f processor-family operating-system #f |
symbol processor-family operating-system symbol |
- symbol atom symbol symbol |
+ symbol symbol symbol symbol |
================= ================= ================= ================= |
*unknown* *unknown* unix cc |
acorn-unixlib acorn *unknown* cc |
aix powerpc aix cc |
- alpha alpha osf1 cc |
alpha-elf alpha unix cc |
alpha-linux alpha linux gcc |
amiga-aztec m68000 amiga cc |
@@ -479,35 +476,65 @@ the SCM command line options.
amiga-sas m68000 amiga lc |
atari-st-gcc m68000 atari.st gcc |
atari-st-turbo-c m68000 atari.st tcc |
- borland-c 8086 ms-dos bcc |
- cygwin32 i386 unix gcc |
+ borland-c i8086 ms-dos bcc |
darwin powerpc unix cc |
djgpp i386 ms-dos gcc |
freebsd i386 unix cc |
gcc *unknown* unix gcc |
+ gnu-win32 i386 unix gcc |
highc i386 ms-dos hc386 |
hp-ux hp-risc hp-ux cc |
irix mips irix gcc |
linux i386 linux gcc |
linux-aout i386 linux gcc |
- microsoft-c 8086 ms-dos cl |
+ microsoft-c i8086 ms-dos cl |
microsoft-c-nt i386 ms-dos cl |
- microsoft-quick-c 8086 ms-dos qcl |
- ms-dos 8086 ms-dos cc |
+ microsoft-quick-c i8086 ms-dos qcl |
+ ms-dos i8086 ms-dos cc |
+ netbsd *unknown* unix gcc |
openbsd *unknown* unix gcc |
os/2-cset i386 os/2 icc |
os/2-emx i386 os/2 gcc |
+ osf1 alpha unix cc |
plan9-8 i386 plan9 8c |
sunos sparc sunos cc |
svr4 *unknown* unix cc |
svr4-gcc-sun-ld sparc sunos gcc |
- turbo-c 8086 ms-dos tcc |
+ turbo-c i8086 ms-dos tcc |
unicos cray unicos cc |
unix *unknown* unix cc |
vms vax vms cc |
vms-gcc vax vms gcc |
watcom-9.0 i386 ms-dos wcc386p |
+ - Build Option: -f PATHNAME
+ specifies that the build options contained in PATHNAME be spliced
+ into the argument list at this point. The use of option files can |
+ separate functional features from platform-specific ones. |
+ |
+ The `Makefile' calls out builds with the options in `.opt' files: |
+ |
+ `dlls.opt' |
+ Options for Makefile targets mydlls, myturtle, and x.so. |
+ |
+ `gdb.opt' |
+ Options for udgdbscm and gdbscm. |
+ |
+ `libscm.opt' |
+ Options for libscm.a. |
+ |
+ `pg.opt' |
+ Options for pgscm, which instruments C functions. |
+ |
+ `udscm4.opt' |
+ Options for targets udscm4 and myscm4 (scm). |
+ |
+ `udscm5.opt' |
+ Options for targets udscm5 and myscm5 (scm). |
+ |
+ The Makefile creates options files it depends on only if they do |
+ not already exist. |
+
- Build Option: -o FILENAME
- Build Option: --outname=FILENAME
specifies that the compilation should produce an executable or
@@ -539,7 +566,7 @@ the SCM command line options.
- Build Option: -s PATHNAME
- Build Option: --scheme-initial=PATHNAME
specifies that PATHNAME should be the default location of the SCM
- initialization file `Init5d6.scm'. SCM tries several likely |
+ initialization file `Init5d9.scm'. SCM tries several likely |
locations before resorting to PATHNAME (*note File-System
Habitat::). If not specified, the current directory (where build
is building) is used.
@@ -586,7 +613,7 @@ the SCM command line options.
* vms
- * amigaos (was amigados) |
+ * amigaos (was amigados)
* system
@@ -619,6 +646,9 @@ the SCM command line options.
"bignums"
Large precision integers.
+ "byte" |
+ Treating strings as byte-vectors. |
+ |
"careful-interrupt-masking"
Define this for extra checking of interrupt masking and some
simple checks for proper use of malloc and free. This is for
@@ -786,11 +816,11 @@ Suppose a C file "foo.c" has functions you wish to add to SCM. To
compile and link your file at compile time, use the `-c' and `-i'
options to build:
- bash$ build -c foo.c -i init_foo
+ bash$ ./build -c foo.c -i init_foo
-|
#! /bin/sh
rm -f scmflags.h
- echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h |
+ echo '#define IMPLINIT "/home/jaffer/scm/Init5d9.scm"'>>scmflags.h |
echo '#define COMPILED_INITS init_foo();'>>scmflags.h
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
@@ -802,11 +832,11 @@ options to build:
To make a dynamically loadable object file use the `-t dll' option:
- bash$ build -t dll -c foo.c
+ bash$ ./build -t dll -c foo.c
-|
#! /bin/sh
rm -f scmflags.h
- echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h |
+ echo '#define IMPLINIT "/home/jaffer/scm/Init5d9.scm"'>>scmflags.h |
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
@@ -830,7 +860,7 @@ in the BSD family (a.out binary format) can usually be ported to "DLD".
The "dl" library (`#define SUN_DL' for SCM) was a proposed POSIX
standard and may be available on other machines with "COFF" binary
format. For notes about porting to MS-Windows and finishing the port
-to VMS *Note Finishing Dynamic Linking::.
+to VMS *Note VMS Dynamic Linking::.
"DLD" is a library package of C functions that performs "dynamic link
editing" on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0),
@@ -962,9 +992,9 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
__ZTC__ Zortech C
_AIX AIX operating system
- __APPLE__ Apple Darwin |
+ __APPLE__ Apple Darwin
AMIGA SAS/C 5.10 or Dice C on AMIGA
- __amigaos__ Gnu CC on AMIGA |
+ __amigaos__ Gnu CC on AMIGA
atarist ATARI-ST under Gnu CC
__FreeBSD__ FreeBSD
GNUDOS DJGPP (obsolete in version 1.08)
@@ -973,9 +1003,11 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
linux Linux
macintosh Macintosh (THINK_C and __MWERKS__ define)
MCH_AMIGA Aztec_c 5.2a on AMIGA
- __MACH__ Apple Darwin |
+ __MACH__ Apple Darwin
MSDOS Microsoft C 5.10 and 6.00A
+ _MSDOS Microsoft CLARM and CLTHUMB compilers.
__MSDOS__ Turbo C, Borland C, and DJGPP
+ __NetBSD__ NetBSD
nosve Control Data NOS/VE
SVR2 System V Revision 2.
__SVR4 SunOS
@@ -990,16 +1022,22 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
VAX11 VAX C compiler
_Windows Borland C 3.1 compiling for Windows
_WIN32 MS VisualC++ 4.2 and Cygwin (Win32 API)
+ _WIN32_WCE MS Windows CE
vms (and VMS) VAX-11 C under VMS.
__alpha DEC Alpha processor
__alpha__ DEC Alpha processor
hp9000s800 HP RISC processor
+ __ia64 GCC on IA64 |
+ __ia64__ GCC on IA64 |
+ _LONGLONG GCC on IA64 |
__i386__ DJGPP
i386 DJGPP
+ _M_ARM Microsoft CLARM compiler defines as 4 for ARM.
+ _M_ARMT Microsoft CLTHUMB compiler defines as 4 for Thumb.
MULTIMAX Encore computer
- ppc PowerPC |
- __ppc__ PowerPC |
+ ppc PowerPC
+ __ppc__ PowerPC
pyr Pyramid 9810 processor
__sgi__ Silicon Graphics Inc.
sparc SPARC processor
@@ -1072,17 +1110,17 @@ remove <FLAG> in scmfig.h and Do so and recompile files.
recompile scm.
add <FLAG> in scmfig.h and
recompile scm.
-ERROR: Init5d6.scm not found. Assign correct IMPLINIT in makefile |
+ERROR: Init5d9.scm not found. Assign correct IMPLINIT in makefile |
or scmfig.h.
Define environment variable
SCM_INIT_PATH to be the full
- pathname of Init5d6.scm. |
+ pathname of Init5d9.scm. |
WARNING: require.scm not found. Define environment variable
SCHEME_LIBRARY_PATH to be the full
pathname of the scheme library
[SLIB].
Change library-vicinity in
- Init5d6.scm to point to library or |
+ Init5d9.scm to point to library or |
remove.
Make sure the value of
(library-vicinity) has a trailing
@@ -1114,13 +1152,13 @@ of pi.
> (load "pi")
;loading "pi"
;done loading "pi.scm"
- ;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B other |
+ ;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B other
#<unspecified>
> (pi 100 5)
00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
70679
- ;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other |
+ ;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other
#<unspecified>
Loading `bench.scm' will compute and display performance statistics of
@@ -1142,7 +1180,7 @@ Some symbol names print incorrectly. Change memory model option to C
than HEAP_SEG_SIZE).
ERROR: Rogue pointer in Heap. See above under machine crashes.
Newlines don't appear correctly in Check file mode (define OPEN_... in
-output files. `Init5d6.scm'). |
+output files. `Init5d9.scm'). |
Spaces or control characters appear Check character defines in
in symbol names. `scmfig.h'.
Negative numbers turn positive. Check SRS in `scmfig.h'.
@@ -1167,8 +1205,8 @@ Reporting Problems
Reported problems and solutions are grouped under Compiling, Linking,
Running, and Testing. If you don't find your problem listed there, you
-can send a bug report to `jaffer @ alum.mit.edu'. The bug report |
-should include: |
+can send a bug report to `agj @ alum.mit.edu'. The bug report should
+include:
1. The version of SCM (printed when SCM is invoked with no arguments).
@@ -1223,7 +1261,7 @@ variable SCM_INIT_PATH.
If SCM_INIT_PATH is not defined or if the file it names is not present,
`scm' tries to find the directory containing the executable file. If
it is able to locate the executable, `scm' looks for the initialization
-file (usually `Init5d6.scm') in platform-dependent directories relative |
+file (usually `Init5d9.scm') in platform-dependent directories relative |
to this directory. See *Note File-System Habitat:: for a blow-by-blow
description.
@@ -1232,19 +1270,19 @@ compile parameter IMPLINIT (defined in the makefile or `scmfig.h') is
tried.
Unless the option `-no-init-file' or `--no-init-file' occurs in the
-command line, `Init5d6.scm' checks to see if there is file |
+command line, `Init5d9.scm' checks to see if there is file |
`ScmInit.scm' in the path specified by the environment variable HOME
(or in the current directory if HOME is undefined). If it finds such a
file it is loaded.
-`Init5d6.scm' then looks for command input from one of three sources: |
+`Init5d9.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.
This explanation applies to SCMLIT or other builds of SCM.
Scheme-code files can also invoke SCM and its variants. *Note #!:
-Syntax Extensions.
+Lexical Conventions.

File: scm.info, Node: SCM Options, Next: Invocation Examples, Prev: Invoking SCM, Up: Operational Features
@@ -1254,8 +1292,8 @@ Options
The options are processed in the order specified on the command line.
- - Command Option: -a k |
- specifies that `scm' should allocate an initial heapsize of K |
+ - Command Option: -a k
+ specifies that `scm' should allocate an initial heapsize of K
kilobytes. This option, if present, must be the first on the
command line. If not specified, the default is `INIT_HEAP_SIZE'
in source file `setjump.h' which the distribution sets at
@@ -1273,10 +1311,10 @@ The options are processed in the order specified on the command line.
- Command Option: -r feature
requires FEATURE. This will load a file from [SLIB] if that
- FEATURE is not already provided. If FEATURE is 2, 2rs, r2rs, 3, |
- 3rs, r3rs, 4, 4rs, r4rs, 5, 5rs, or r5rs; `scm' will require the |
- features neccessary to support [R2RS], [R3RS], [R4RS], or [R5RS], |
- respectively. |
+ FEATURE is not already provided. If FEATURE is 2, 2rs, or r2rs; |
+ 3, 3rs, or r3rs; 4, 4rs, or r4rs; 5, 5rs, or r5rs; `scm' will |
+ require the features neccessary to support [R2RS]; [R3RS]; [R4RS]; |
+ or [R5RS], respectively. |
- Command Option: -h feature
provides FEATURE.
@@ -1284,11 +1322,11 @@ The options are processed in the order specified on the command line.
- Command Option: -l filename
- Command Option: -f filename
loads FILENAME. `Scm' will load the first (unoptioned) file named
- on the command line if no `-c', `-e', `-f', `-l', or `-s' option
+ on the command line if no `-c', `-e', `-f', `-l', or `-s' option
preceeds it.
- Command Option: -d filename
- Loads SLIB `databases' feature and opens FILENAME as a database. |
+ Loads SLIB `databases' feature and opens FILENAME as a database.
- Command Option: -e expression
- Command Option: -c expression
@@ -1349,12 +1387,14 @@ The options are processed in the order specified on the command line.
are errors.
- Command Option: -s
- specifies, by analogy with `sh', that further options are to be
- treated as program aguments.
+ specifies, by analogy with `sh', that `scm' should run
+ interactively and that further options are to be treated as program
+ aguments.
- Command Option: -
- Command Option: --
- specifies that there are no more options on the command line.
+ specifies that further options are to be treated as program
+ aguments.

File: scm.info, Node: Invocation Examples, Next: SCM Variables, Prev: SCM Options, Up: Operational Features
@@ -1396,13 +1436,13 @@ Environment Variables
- Environment Variable: SCM_INIT_PATH
is the pathname where `scm' will look for its initialization code.
- The default is the file `Init5d6.scm' in the source directory. |
+ The default is the file `Init5d9.scm' in the source directory. |
- Environment Variable: SCHEME_LIBRARY_PATH
is the [SLIB] Scheme library directory.
- Environment Variable: HOME
- is the directory where `Init5d6.scm' will look for the user |
+ is the directory where `Init5d9.scm' will look for the user |
initialization file `ScmInit.scm'.
- Environment Variable: EDITOR
@@ -1417,7 +1457,7 @@ Scheme Variables
during argument processing. This list is suitable for use as an
argument to [SLIB] `getopt'.
- - Variable: *syntax-rules* |
+ - Variable: *syntax-rules*
controls whether loading and interaction support syntax-rules
macros. Define this in `ScmInit.scm' or files specified on the
command line. This can be overridden by subsequent `-m' and `-u'
@@ -1452,14 +1492,19 @@ SCM Session
SCM can also tail-call another program. *Note execp:
I/O-Extensions.
- - Callback procedure: boot-tail dumped? |
- `boot-tail' is called by `scm_top_level' just before entering |
- interactive top-level. If `boot-tail' calls `quit', then |
- interactive top-level is not entered. |
- |
+ - Callback procedure: boot-tail dumped?
+ `boot-tail' is called by `scm_top_level' just before entering
+ interactive top-level. If `boot-tail' calls `quit', then
+ interactive top-level is not entered.
+
- Function: program-arguments
Returns a list of strings of the arguments scm was called with.
+ - Function: getlogin
+ Returns the (login) name of the user logged in on the controlling
+ terminal of the process, or #f if this information cannot be
+ determined.
+
For documentation of the procedures `getenv' and `system' *Note System
Interface: (slib)System Interface.
@@ -1483,14 +1528,11 @@ Editing Scheme Code
Gnu Emacs:
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:
-
- <http://simtel.coast.net/SimTel/gnu/demacs.html>
+ files ending in .scm are automatically put into scheme-mode. |
- If your Emacs can run a process in a buffer you can use the Emacs
- command `M-x run-scheme' with SCM. Otherwise, use the emacs
- command `M-x suspend-emacs'; or see "other systems" below.
+ If your Emacs can run a process in a buffer you can use the Emacs |
+ command `M-x run-scheme' with SCM. Otherwise, use the emacs |
+ command `M-x suspend-emacs'; or see "other systems" below. |
Epsilon (MS-DOS):
There is lisp (and scheme) mode available by use of the package
@@ -1716,13 +1758,13 @@ warnings and errors.
- Function: warn arg1 arg2 arg3 ...
Alias for *Note slib:warn: (slib)System. Outputs an error message
- containing the arguments. `warn' is defined in `Init5d6.scm'. |
+ containing the arguments. `warn' is defined in `Init5d9.scm'. |
- Function: error arg1 arg2 arg3 ...
Alias for *Note slib:error: (slib)System. Outputs an error
message containing the arguments, aborts evaluation of the current
form and resumes the top level read-eval-print loop. `Error' is
- defined in `Init5d6.scm'. |
+ defined in `Init5d9.scm'. |
If SCM is built with the `CAUTIOUS' flag, then when an error occurs, a
"stack trace" of certain pending calls are printed as part of the
@@ -1740,7 +1782,7 @@ with Lisp systems.
- Function: stack-trace
Prints information describing the stack of partially evaluated
expressions. `stack-trace' returns `#t' if any lines were printed
- and `#f' otherwise. See `Init5d6.scm' for an example of the use |
+ and `#f' otherwise. See `Init5d9.scm' for an example of the use |
of `stack-trace'.

@@ -1765,7 +1807,7 @@ a convenient aid to locating bugs and untested expressions.
* The names of identifiers which are not lexiallly bound but defined
at top-level have #@ prepended.
-For instance, `open-input-file' is defined as follows in `Init5d6.scm': |
+For instance, `open-input-file' is defined as follows in `Init5d9.scm': |
(define (open-input-file str)
(or (open-file str OPEN_READ)
@@ -1814,7 +1856,7 @@ Internal State
*INTERACTIVE* is controlled directly by the command-line options
`-b', `-i', and `-s' (*note Invoking SCM::). If none of these
options are specified, the rules to determine interactivity are
- more complicated; see `Init5d6.scm' for details. |
+ more complicated; see `Init5d9.scm' for details. |
- Function: abort
Resumes the top level Read-Eval-Print loop.
@@ -1844,19 +1886,19 @@ Internal State
a prompt is printed.
>= 2
- messages bracketing file loading are printed. |
+ messages bracketing file loading are printed.
>= 3
- the CPU time is printed after each top level form evaluated; |
- notifications of heap growth printed. |
+ the CPU time is printed after each top level form evaluated;
+ notifications of heap growth printed.
>= 4
- a garbage collection summary is printed after each top level |
- form evaluated; |
+ a garbage collection summary is printed after each top level
+ form evaluated;
>= 5
- a message for each GC (*note Garbage Collection::) is printed; |
- warnings issued for top-level symbols redefined. |
+ a message for each GC (*note Garbage Collection::) is printed;
+ warnings issued for top-level symbols redefined.
- Function: gc
Scans all of SCM objects and reclaims for further use those that
@@ -1868,7 +1910,7 @@ Internal State
#t)' also gives the hexadecimal heap segment and stack bounds.
- Constant: *scm-version*
- Contains the version string (e.g. `5d6') of SCM. |
+ Contains the version string (e.g. `5d9') of SCM. |
Executable path
---------------
@@ -1923,9 +1965,9 @@ file has (different) meanings to SCM and the operating system
When executing a shell-script, the operating system invokes
INTERPRETER with a single argument encapsulating the rest of the
- first line's contents (if if not just whitespace), the pathname of
- the Scheme Script file, and then any arguments which the
- shell-script was invoked with.
+ first line's contents (if not just whitespace), the pathname of the
+ Scheme Script file, and then any arguments which the shell-script
+ was invoked with.
Put one space character between `#!' and the first character of
INTERPRETER (`/'). The INTERPRETER name is followed by ` \'; SCM
@@ -1957,25 +1999,25 @@ The following Scheme-Script prints factorial of its argument:
#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
- !#
- ; -*-scheme-*-
- (define (go-script)
- (cond ((not *script*))
- ((and (= 1 (- (length *argv*) *optind*))
- (string->number (list-ref *argv* *optind*)))
- => (lambda (n) (print (fact n))))
- (else
- (print *argv*)
- (display "\
- Usage: fact n
- Returns the factorial of N.
- http://swissnet.ai.mit.edu/~jaffer/SLIB.html
+ (define (fact.script args)
+ (cond ((and (= 1 (length args))
+ (string->number (car args)))
+ => (lambda (n) (print (fact n)) #t))
+ (else (fact.usage))))
+
+ (define (fact.usage)
+ (print *argv*)
+ (display "\
+ Usage: fact N
+ Returns the factorial of N.
"
- (current-error-port))
- (exit #f))))
+ (current-error-port))
+ #f)
(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n)))))
- (go-script)
+
+ (if *script* (exit (fact.script (list-tail *argv* *optind*))))
./fact 32
=>
@@ -1987,10 +2029,8 @@ usage information.
./fact 3 2
-|
("./fact" "3" "2")
- Usage: fact n
+ Usage: fact N
Returns the factorial of N.
-
- http://swissnet.ai.mit.edu/~jaffer/SLIB.html

File: scm.info, Node: MS-DOS Compatible Scripts, Next: Unix Shell Scripts, Prev: Unix Scheme Scripts, Up: Scripting
@@ -2000,7 +2040,8 @@ MS-DOS Compatible Scripts
It turns out that we can create scheme-scripts which run both under unix
and MS-DOS. To implement this, I have written the MS-DOS programs:
-`#!.bat' and `!#.exe'.
+`#!.bat' and `!#.exe', which are available from: |
+<http://swissnet.ai.mit.edu/ftpdir/scm/sharpbang.zip> |
With these two programs installed in a `PATH' directory, we have the
following syntax for <PROGRAM>.BAT files.
@@ -2022,9 +2063,9 @@ following syntax for <PROGRAM>.BAT files.
`#!' tries all directories named by environment variable `PATH'.
Once the INTERPRETER executable path is found, arguments are
- processed in the manner of scheme-shell, with the all the text
- after the `\' taken as part of the meta-argument. More precisely,
- `#!' calls INTERPRETER with any options on the second line of the
+ processed in the manner of scheme-shell, with all the text after |
+ the `\' taken as part of the meta-argument. More precisely, `#!' |
+ calls INTERPRETER with any options on the second line of the |
Scheme-Script up to `!#', the name of the Scheme-Script file, and
then any of at most 8 arguments given on the command line invoking
this Scheme-Script.
@@ -2070,25 +2111,24 @@ example.
#! /bin/sh
:;exec scm -e"(set! *script* \"$0\")" -l$0 $*
- (define (go-script)
- (cond ((not *script*))
- ((and (= 1 (- (length *argv*) *optind*))
- (string->number (list-ref *argv* *optind*)))
- => (lambda (n) (print (fact n))))
- (else
- (print *argv*)
- (display "\
- Usage: fact n
- Returns the factorial of N.
+ (define (fact.script args)
+ (cond ((and (= 1 (length args))
+ (string->number (car args)))
+ => (lambda (n) (print (fact n)) #t))
+ (else (fact.usage))))
- http://swissnet.ai.mit.edu/~jaffer/SLIB.html
+ (define (fact.usage)
+ (print *argv*)
+ (display "\
+ Usage: fact N
+ Returns the factorial of N.
"
- (current-error-port))
- (exit #f))))
+ (current-error-port))
+ #f)
(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n)))))
- (go-script)
+ (if *script* (exit (fact.script (list-tail *argv* *optind*))))
./fact 6
=> 720
@@ -2102,19 +2142,17 @@ The Language
* Menu:
* Standards Compliance:: Links to sections in [R5RS] and [SLIB]
-* Miscellaneous Procedures::
+* Storage:: Finalizers, GC-hook, vector-set-length!
* Time:: Both real time and processor time
* Interrupts:: and exceptions
* Process Synchronization:: Because interrupts are preemptive
* Files and Ports::
-* Line Numbers:: |
-* Soft Ports:: Emulate I/O devices
-* Syntax Extensions::
-* Low Level Syntactic Hooks::
-* Syntactic Hooks for Hygienic Macros::
+* Eval and Load:: and line-numbers
+* Lexical Conventions:: Also called read-syntax
+* Syntax:: Macros

-File: scm.info, Node: Standards Compliance, Next: Miscellaneous Procedures, Prev: The Language, Up: The Language
+File: scm.info, Node: Standards Compliance, Next: Storage, Prev: The Language, Up: The Language
Standards Compliance
====================
@@ -2234,52 +2272,10 @@ Optionals of [R5RS] not Supported by SCM
*Note Require: (slib)Require.

-File: scm.info, Node: Miscellaneous Procedures, Next: Time, Prev: Standards Compliance, Up: The Language
-
-Miscellaneous Procedures
-========================
-
- - Function: try-load filename
- If the string FILENAME names an existing file, the try-load
- procedure reads Scheme source code expressions and definitions
- from the file and evaluates them sequentially and returns `#t'.
- If not, try-load returns `#f'. The try-load procedure does not
- affect the values returned by `current-input-port' and
- `current-output-port'.
+File: scm.info, Node: Storage, Next: Time, Prev: Standards Compliance, Up: The Language
- - Variable: *load-pathname*
- Is set to the pathname given as argument to `load', `try-load',
- and `dyn:link' (*note Compiling And Linking: (hobbit)Compiling And |
- Linking.). `*load-pathname*' is used to compute the value of |
- *Note program-vicinity: (slib)Vicinity. |
-
- - Function: line-number
- Returns the current line number of the file currently being loaded.
-
- - Function: port-filename port
- Returns the filename PORT was opened with. If PORT is not open to
- a file the result is unspecified.
-
- - Function: port-line port
- - Function: port-column port
- If PORT is a tracked port, return the current line (column) number,
- otherwise return `#f'. Line and column numbers begin with 1. The
- column number applies to the next character to be read; if that
- character is a newline, then the column number will be one more
- than the length of the line.
-
- - Function: eval obj
- Alias for *Note eval: (slib)System.
-
- - Function: eval-string str
- Returns the result of reading an expression from STR and
- evaluating it. `eval-string' does not change `*load-pathname*' or
- `line-number'.
-
- - Function: load-string str
- Reads and evaluates all the expressions from STR. As with `load',
- the value returned is unspecified. `load-string' does not change
- `*load-pathname*' or `line-number'.
+Storage
+=======
- Function: vector-set-length! object length
Change the length of string, vector, bit-vector, or uniform-array
@@ -2296,22 +2292,45 @@ Miscellaneous Procedures
on this feature; `copy-tree' could get redefined.
- Function: acons obj1 obj2 obj3
- Returns (cons (cons obj1 obj2) obj3). The expression (set! a-list
- (acons key datum a-list)) adds a new association to a-list.
+ Returns (cons (cons obj1 obj2) obj3).
- - Function: terms
- This command displays the GNU General Public License.
+ (set! a-list (acons key datum a-list))
- - Function: list-file filename
- Displays the text contents of FILENAME.
+ Adds a new association to a-list.
- - Procedure: print arg1 ...
- `Print' writes all its arguments, separated by spaces. `Print'
- outputs a `newline' at the end and returns the value of the last
- argument.
+ - Callback procedure: gc-hook ...
+ Allows a Scheme procedure to be run shortly after each garbage
+ collection. This procedure will not be run recursively. If it
+ runs long enough to cause a garbage collection before returning a
+ warning will be printed.
+
+ To remove the gc-hook, `(set! gc-hook #f)'.
+
+ - Function: add-finalizer object finalizer
+ OBJECT may be any garbage collected object, that is, any object
+ other than an immediate integer, character, or special token such
+ as `#f' or `#t', *Note Immediates::. FINALIZER is a thunk, or
+ procedure taking no arguments.
+
+ FINALIZER will be invoked asynchronously exactly once some time
+ after OBJECT becomes eligible for garbage collection. A reference
+ to OBJECT in the environment of FINALIZER will not prevent
+ finalization, but will delay the reclamation of OBJECT at least
+ until the next garbage collection. A reference to OBJECT in some
+ other object's finalizer will necessarily prevent finalization
+ until both objects are eligible for garbage collection.
+
+ Finalizers are not run in any predictable order. All finalizers
+ will be run by the time the program ends.
+
+ This facility was based on the paper by Simon Peyton Jones, et al,
+ "Stretching the storage manager: weak pointers and stable names in
+ Haskell", Proc. 11th International Workshop on the Implementation
+ of Functional Languages, The Netherlands, September 7-10 1999,
+ Springer-Verlag LNCS.

-File: scm.info, Node: Time, Next: Interrupts, Prev: Miscellaneous Procedures, Up: The Language
+File: scm.info, Node: Time, Next: Interrupts, Prev: Storage, Up: The Language
Time
====
@@ -2417,70 +2436,40 @@ Interrupts
To unestablish a response for an error set the handler symbol to
`#f'. For instance, `(set! could-not-open #f)'.
- - Callback procedure: gc-hook ... |
- Allows a Scheme procedure to be run shortly after each garbage |
- collection. This procedure will not be run recursively. If it |
- runs long enough to cause a garbage collection before returning a |
- warning will be printed. |
- |
- - Function: add-finalizer object finalizer |
- OBJECT may be any garbage collected object, that is, any object |
- other than an immediate integer, character, or special token such |
- as `#f' or `#t', *Note Immediates::. FINALIZER is a thunk, or |
- procedure taking no arguments. |
- |
- FINALIZER will be invoked asynchronously exactly once some time |
- after OBJECT becomes eligible for garbage collection. A reference |
- to OBJECT in the environment of FINALIZER will not prevent |
- finalization, but will delay the reclamation of OBJECT at least |
- until the next garbage collection. A reference to OBJECT in some |
- other object's finalizer will necessarily prevent finalization |
- until both objects are eligible for garbage collection. |
- |
- Finalizers are not run in any predictable order. All finalizers |
- will be run by the time the program ends. |
- |
- This facility was based on the paper by Simon Peyton Jones, et al, |
- "Stretching the storage manager: weak pointers and stable names in |
- Haskell", Proc. 11th International Workshop on the Implementation |
- of Functional Languages, The Netherlands, September 7-10 1999, |
- Springer-Verlag LNCS. |
- |
- |

File: scm.info, Node: Process Synchronization, Next: Files and Ports, Prev: Interrupts, Up: The Language
Process Synchronization
=======================
-An "exchanger" is a procedure of one argument regulating mutually |
-exclusive access to a resource. When a exchanger is called, its current |
-content is returned, while being replaced by its argument in an atomic |
-operation. |
- |
- - Function: make-exchanger obj |
- Returns a new exchanger with the argument OBJ as its initial |
- content. |
- |
- (define queue (make-exchanger (list a))) |
- |
- A queue implemented as an exchanger holding a list can be |
- protected from reentrant execution thus: |
- |
- (define (pop queue) |
- (let ((lst #f)) |
- (dynamic-wind |
- (lambda () (set! lst (queue #f))) |
- (lambda () (and lst (not (null? lst)) |
- (let ((ret (car lst))) |
- (set! lst (cdr lst)) |
- ret))) |
- (lambda () (and lst (queue lst)))))) |
- |
- (pop queue) => a |
- |
- (pop queue) => #f |
- |
+An "exchanger" is a procedure of one argument regulating mutually
+exclusive access to a resource. When a exchanger is called, its current
+content is returned, while being replaced by its argument in an atomic
+operation.
+
+ - Function: make-exchanger obj
+ Returns a new exchanger with the argument OBJ as its initial
+ content.
+
+ (define queue (make-exchanger (list a)))
+
+ A queue implemented as an exchanger holding a list can be
+ protected from reentrant execution thus:
+
+ (define (pop queue)
+ (let ((lst #f))
+ (dynamic-wind
+ (lambda () (set! lst (queue #f)))
+ (lambda () (and lst (not (null? lst))
+ (let ((ret (car lst)))
+ (set! lst (cdr lst))
+ ret)))
+ (lambda () (and lst (queue lst))))))
+
+ (pop queue) => a
+
+ (pop queue) => #f
+
- Function: make-arbiter name
Returns an object of type arbiter and name NAME. Its state is
initially unlocked.
@@ -2494,14 +2483,27 @@ operation. |
Otherwise, returns `#f'.

-File: scm.info, Node: Files and Ports, Next: Line Numbers, Prev: Process Synchronization, Up: The Language
- |
+File: scm.info, Node: Files and Ports, Next: Eval and Load, Prev: Process Synchronization, Up: The Language
+
Files and Ports
===============
These procedures generalize and extend the standard capabilities in
*Note Ports: (r5rs)Ports.
+* Menu:
+
+* Opening and Closing::
+* Port Properties::
+* Port Redirection::
+* Soft Ports::
+
+
+File: scm.info, Node: Opening and Closing, Next: Port Properties, Prev: Files and Ports, Up: Files and Ports
+
+Opening and Closing
+-------------------
+
- Function: open-file string modes
- Function: try-open-file string modes
Returns a port capable of receiving or delivering characters as
@@ -2519,15 +2521,15 @@ These procedures generalize and extend the standard capabilities in
Contain modes strings specifying that a file is to be opened for
reading, writing, and both reading and writing respectively.
- Both input and output functions can be used with io-ports. An end |
- of file must be read or a file-set-position done on the port |
- between a read operation and a write operation or vice-versa. |
- |
+ Both input and output functions can be used with io-ports. An end
+ of file must be read or a file-set-position done on the port
+ between a read operation and a write operation or vice-versa.
+
- Function: _ionbf modestr
Returns a version of MODESTR which when `open-file' is called with
- it as the second argument will return an unbuffered port. An |
- input-port must be unbuffered in order for `char-ready?' and |
- `wait-for-input' to work correctly on it. The initial value of |
+ it as the second argument will return an unbuffered port. An
+ input-port must be unbuffered in order for `char-ready?' and
+ `wait-for-input' to work correctly on it. The initial value of
`(current-input-port)' is unbuffered if the platform supports it.
- Function: _tracked modestr
@@ -2536,49 +2538,58 @@ These procedures generalize and extend the standard capabilities in
port maintains current line and column numbers, which may be
queried with `port-line' and `port-column'.
- - Function: _exclusive modestr |
- Returns a version of MODESTR which when `open-file' is called with |
- it as the second argument will return a port only if the named file |
- does not already exist. This functionality is provided by calling |
- `try-create-file' *Note I/O-Extensions::, which is not available |
- for all platforms. |
- |
- - Function: port-closed? port |
- Returns #t if PORT is closed. |
- |
- - Function: port-type obj |
- If OBJ is not a port returns false, otherwise returns a symbol |
- describing the port type, for example string or pipe. |
- |
+ - Function: _exclusive modestr
+ Returns a version of MODESTR which when `open-file' is called with
+ it as the second argument will return a port only if the named file
+ does not already exist. This functionality is provided by calling
+ `try-create-file' *Note I/O-Extensions::, which is not available
+ for all platforms.
+
+ - Function: open-ports
+ Returns a list of all currently open ports, excluding string ports,
+ see *Note String Ports: (slib)String Ports. This may be useful
+ after a fork *Note Posix Extensions::, or for debugging. Bear in
+ mind that ports that would be closed by gc will be kept open by a
+ reference to this list.
+
- Function: close-port port
Closes PORT. The same as close-input-port and close-output-port.
- |
- - Function: current-error-port
- Returns the current port to which diagnostic output is directed.
- - Function: with-error-to-file string thunk
- THUNK must be a procedure of no arguments, and string must be a
- string naming a file. The file is opened for output, an output
- port connected to it is made the default value returned by
- current-error-port, and the THUNK is called with no arguments.
- When the thunk returns, the port is closed and the previous
- default is restored. With-error-to-file returns the value yielded
- by THUNK.
+
+File: scm.info, Node: Port Properties, Next: Port Redirection, Prev: Opening and Closing, Up: Files and Ports
- - Function: with-input-from-port port thunk
- - Function: with-output-to-port port thunk
- - Function: with-error-to-port port thunk
- These routines differ from with-input-from-file,
- with-output-to-file, and with-error-to-file in that the first
- argument is a port, rather than a string naming a file.
+Port Properties
+---------------
- - Function: call-with-outputs thunk proc
- Calls the THUNK procedure while the current-output-port and
- current-error-port are directed to string-ports. If THUNK
- returns, the PROC procedure is called with the output-string, the
- error-string, and the value returned by THUNK. If THUNK does not
- return a value (perhaps because of error), PROC is called with
- just the output-string and the error-string as arguments.
+ - Function: port-closed? port
+ Returns #t if PORT is closed.
+
+ - Function: port-type obj
+ If OBJ is not a port returns false, otherwise returns a symbol
+ describing the port type, for example string or pipe.
+
+ - Function: port-filename port
+ Returns the filename PORT was opened with. If PORT is not open to
+ a file the result is unspecified.
+
+ - Function: port-line port
+ - Function: port-column port
+ If PORT is a tracked port, return the current line (column) number,
+ otherwise return `#f'. Line and column numbers begin with 1. The
+ column number applies to the next character to be read; if that
+ character is a newline, then the column number will be one more
+ than the length of the line.
+
+ - Function: freshline port
+ Outputs a newline to optional argument PORT unless the current
+ output column number of PORT is known to be zero, ie output will
+ start at the beginning of a new line. PORT defaults to
+ `current-output-port'. If PORT is not a tracked port `freshline'
+ is equivalent to `newline'.
+
+ - Function: isatty? port
+ Returns `#t' if PORT is input or output to a serial non-file
+ device.
- procedure: char-ready?
- procedure: char-ready? port
@@ -2606,81 +2617,44 @@ These procedures generalize and extend the standard capabilities in
omitted, in which case they default to the list of the value
returned by `current-input-port'.
- - Function: isatty? port
- Returns `#t' if PORT is input or output to a serial non-file
- device.
+
+File: scm.info, Node: Port Redirection, Next: Soft Ports, Prev: Port Properties, Up: Files and Ports
- - Function: freshline port
- Outputs a newline to optional argument PORT unless the current
- output column number of PORT is known to be zero, ie output will
- start at the beginning of a new line. PORT defaults to
- `current-output-port'. If PORT is not a tracked port `freshline'
- is equivalent to `newline'.
+Port Redirection
+----------------
+
+ - Function: current-error-port
+ Returns the current port to which diagnostic output is directed.
+
+ - Function: with-error-to-file string thunk
+ THUNK must be a procedure of no arguments, and string must be a
+ string naming a file. The file is opened for output, an output
+ port connected to it is made the default value returned by
+ current-error-port, and the THUNK is called with no arguments.
+ When the thunk returns, the port is closed and the previous
+ default is restored. With-error-to-file returns the value yielded
+ by THUNK.
+
+ - Function: with-input-from-port port thunk
+ - Function: with-output-to-port port thunk
+ - Function: with-error-to-port port thunk
+ These routines differ from with-input-from-file,
+ with-output-to-file, and with-error-to-file in that the first
+ argument is a port, rather than a string naming a file.
+
+ - Function: call-with-outputs thunk proc
+ Calls the THUNK procedure while the current-output-port and
+ current-error-port are directed to string-ports. If THUNK
+ returns, the PROC procedure is called with the output-string, the
+ error-string, and the value returned by THUNK. If THUNK does not
+ return a value (perhaps because of error), PROC is called with
+ just the output-string and the error-string as arguments.
- - Function: open-ports |
- Returns a list of all currently open ports, excluding string ports, |
- see *Note String Ports: (slib)String Ports. This may be useful |
- after a fork *Note Posix Extensions::, or for debugging. Bear in |
- mind that ports that would be closed by gc will be kept open by a |
- reference to this list. |
- |
-
-File: scm.info, Node: Line Numbers, Next: Soft Ports, Prev: Files and Ports, Up: The Language
- |
-Line Numbers |
-============ |
- |
-Scheme code define by load may optionally contain line number |
-information. Currently this information is used only for reporting |
-expansion time errors, but in the future run-time error messages may |
-also include line number information. |
- |
- - Function: try-load pathname reader |
- This is the primitive for loading, PATHNAME is the name of a file |
- containing Scheme code, and optional argument READER is a function |
- of one argument, a port. READER should read and return Scheme |
- code as list structure. The default value is `read', which is |
- used if READER is not supplied or is false. |
- |
-Line number objects are disjoint from integers or other Scheme types. |
-When evaluated or loaded as Scheme code, an s-expression containing a |
-line-number in the car is equivalent to the cdr of the s-expression. A |
-pair consisting of a line-number in the car and a vector in the cdr is |
-equivalent to the vector. The meaning of s-expressions with |
-line-numbers in other positions is undefined. |
- |
- - Function: read-numbered port |
- Behaves like `read', except that every s-expression read will be |
- replaced with a cons of a line-number object and the sexp actually |
- read. This replacement is done only if PORT is a tracked port See |
- *Note Files and Ports::. |
- |
- - Function: integer->line-number int |
- Returns a line-number object with value INT. INT should be an |
- exact non-negative integer. |
- |
- - Function: line-number->integer linum |
- Returns the value of line-number object LINUM as an integer. |
- |
- - Function: line-number? obj |
- Returns true if and only if OBJ is a line-number object. |
- |
- - Variable: *load-reader* |
- - Variable: *slib-load-reader* |
- The value of `*load-reader*' should be a value acceptable as the |
- second argument to `try-load' (note that #f is acceptable). This |
- value will be used to read code during calls to `scm:load'. The |
- value of `*slib-load-reader*' will similarly be used during calls |
- to `slib:load' and `require'. |
- |
- In order to disable all line-numbering, it is sufficient to set! |
- `*load-reader*' and `*slib-load-reader*' to #f. |
- |

-File: scm.info, Node: Soft Ports, Next: Syntax Extensions, Prev: Line Numbers, Up: The Language
- |
+File: scm.info, Node: Soft Ports, Prev: Port Redirection, Up: Files and Ports
+
Soft Ports
-==========
+----------
A "soft-port" is a port based on a vector of procedures capable of
accepting or delivering characters. It allows emulation of I/O ports.
@@ -2710,9 +2684,9 @@ accepting or delivering characters. It allows emulation of I/O ports.
(r5rs)Input.) it indicates that the port has reached end-of-file.
For example:
- If it is necessary to explicitly close the port when it is garbage |
- collected, (*note add-finalizer: Interrupts.). |
- |
+ If it is necessary to explicitly close the port when it is garbage
+ collected, (*note add-finalizer: Interrupts.).
+
(define stdout (current-output-port))
(define p (make-soft-port
(vector
@@ -2726,10 +2700,194 @@ accepting or delivering characters. It allows emulation of I/O ports.
(write p p) => #<input-output-soft#\space45d10#\>

-File: scm.info, Node: Syntax Extensions, Next: Low Level Syntactic Hooks, Prev: Soft Ports, Up: The Language
+File: scm.info, Node: Eval and Load, Next: Lexical Conventions, Prev: Files and Ports, Up: The Language
+
+Eval and Load
+=============
+
+ - Function: try-load filename
+ If the string FILENAME names an existing file, the try-load
+ procedure reads Scheme source code expressions and definitions
+ from the file and evaluates them sequentially and returns `#t'.
+ If not, try-load returns `#f'. The try-load procedure does not
+ affect the values returned by `current-input-port' and
+ `current-output-port'.
+
+ - Variable: *load-pathname*
+ Is set to the pathname given as argument to `load', `try-load',
+ and `dyn:link' (*note Compiling And Linking: (hobbit)Compiling And
+ Linking.). `*load-pathname*' is used to compute the value of
+ *Note program-vicinity: (slib)Vicinity.
+
+ - Function: eval obj
+ Alias for *Note eval: (slib)System.
+
+ - Function: eval-string str
+ Returns the result of reading an expression from STR and
+ evaluating it. `eval-string' does not change `*load-pathname*' or
+ `line-number'.
+
+ - Function: load-string str
+ Reads and evaluates all the expressions from STR. As with `load',
+ the value returned is unspecified. `load-string' does not change
+ `*load-pathname*' or `line-number'.
+
+ - Function: line-number
+ Returns the current line number of the file currently being loaded.
+
+* Menu:
+
+* Line Numbers::
+
+
+File: scm.info, Node: Line Numbers, Prev: Eval and Load, Up: Eval and Load
+
+Line Numbers
+------------
+
+Scheme code defined by load may optionally contain line number
+information. Currently this information is used only for reporting
+expansion time errors, but in the future run-time error messages may
+also include line number information.
+
+ - Function: try-load pathname reader
+ This is the primitive for loading, PATHNAME is the name of a file
+ containing Scheme code, and optional argument READER is a function
+ of one argument, a port. READER should read and return Scheme
+ code as list structure. The default value is `read', which is
+ used if READER is not supplied or is false.
+
+Line number objects are disjoint from integers or other Scheme types.
+When evaluated or loaded as Scheme code, an s-expression containing a
+line-number in the car is equivalent to the cdr of the s-expression. A
+pair consisting of a line-number in the car and a vector in the cdr is
+equivalent to the vector. The meaning of s-expressions with
+line-numbers in other positions is undefined.
+
+ - Function: read-numbered port
+ Behaves like `read', except that |
+ |
+ bullet Load (read) sytnaxes are enabled. |
+ |
+ bullet every s-expression read will be replaced with a cons of |
+ a line-number object and the sexp actually read. This |
+ replacement is done only if PORT is a tracked port See *Note |
+ Files and Ports::. |
+ |
+
+ - Function: integer->line-number int
+ Returns a line-number object with value INT. INT should be an
+ exact non-negative integer.
+
+ - Function: line-number->integer linum
+ Returns the value of line-number object LINUM as an integer.
+
+ - Function: line-number? obj
+ Returns true if and only if OBJ is a line-number object.
+
+ - Function: read-for-load port |
+ Behaves like `read', except that load syntaxes are enabled. |
+ |
+ - Variable: *load-reader*
+ - Variable: *slib-load-reader*
+ The value of `*load-reader*' should be a value acceptable as the
+ second argument to `try-load' (note that #f is acceptable). This
+ value will be used to read code during calls to `scm:load'. The
+ value of `*slib-load-reader*' will similarly be used during calls
+ to `slib:load' and `require'.
+
+ In order to disable all line-numbering, it is sufficient to set!
+ `*load-reader*' and `*slib-load-reader*' to #f.
+
+
+File: scm.info, Node: Lexical Conventions, Next: Syntax, Prev: Eval and Load, Up: The Language
+
+Lexical Conventions
+===================
+
+* Menu:
+
+* Common-Lisp Read Syntax::
+* Load Syntax:: |
+* Documentation and Comments::
+* Modifying Read Syntax::
+
+
+File: scm.info, Node: Common-Lisp Read Syntax, Next: Load Syntax, Prev: Lexical Conventions, Up: Lexical Conventions
+ |
+Common-Lisp Read Syntax
+-----------------------
+
+ - Read syntax: #\token |
+ If TOKEN is a sequence of two or more digits, then this syntax is |
+ equivalent to `#.(integer->char (string->number token 8))'. |
+
+ If TOKEN is `C-', `c-', or `^' followed by a character, then this |
+ syntax is read as a control character. If TOKEN is `M-' or `m-' |
+ followed by a character, then a meta character is read. `c-' and |
+ `m-' prefixes may be combined. |
+
+ - Read syntax: #+ feature form
+ If feature is `provided?' (by `*features*') then FORM is read as a
+ scheme expression. If not, then FORM is treated as whitespace.
+
+ Feature is a boolean expression composed of symbols and `and',
+ `or', and `not' of boolean expressions.
+
+ For more information on `provided?' and `*features*', *Note
+ Require: (slib)Require.
-Syntax Extensions
-=================
+ - Read syntax: #- feature form
+ is equivalent to `#+(not feature) expression'.
+ |
+ - Read syntax: #| any thing |#
+ Is a balanced comment. Everything up to the matching `|#' is
+ ignored by the `read'. Nested `#|...|#' can occur inside ANY
+ THING.
+
+"Load sytax" is Read syntax enabled for `read' only when that `read' is |
+part of loading a file or string. This distinction was made so that |
+reading from a datafile would not be able to corrupt a scheme program |
+using `#.'. |
+
+ - Load syntax: #. expression |
+ Is read as the object resulting from the evaluation of EXPRESSION. |
+ This substitution occurs even inside quoted structure. |
+
+ In order to allow compiled code to work with `#.' it is good |
+ practice to define those symbols used inside of EXPRESSION with |
+ `#.(define ...)'. For example: |
+ |
+ #.(define foo 9) => #<unspecified> |
+ '(#.foo #.(+ foo foo)) => (9 18) |
+ |
+ - Load syntax: #' form |
+ is equivalent to FORM (for compatibility with common-lisp). |
+
+
+File: scm.info, Node: Load Syntax, Next: Documentation and Comments, Prev: Common-Lisp Read Syntax, Up: Lexical Conventions
+ |
+Load Syntax |
+----------- |
+ |
+"#!" is the unix mechanism for executing scripts. See *Note Unix
+Scheme Scripts:: for the full description of how this comment supports |
+scripting. |
+ |
+ - Load syntax: #?line |
+ - Load syntax: #?column |
+ Return integers for the current line and column being read during a |
+ load. |
+ |
+ - Load syntax: #?file |
+ Returns the string naming the file currently being loaded. This |
+ path is the string passed to `load', possibly with `.scm' appended. |
+ |
+
+File: scm.info, Node: Documentation and Comments, Next: Modifying Read Syntax, Prev: Load Syntax, Up: Lexical Conventions
+ |
+Documentation and Comments
+--------------------------
- procedure: procedure-documentation proc
Returns the documentation string of PROC if it exists, or `#f' if
@@ -2755,52 +2913,83 @@ Syntax Extensions
Returns the (appended) strings given as arguments to previous calls
`comment' and empties the current string collection.
- - Read syntax: #;text-till-end-of-line
+ - Load syntax: #;text-till-end-of-line |
Behaves as `(comment "TEXT-TILL-END-OF-LINE")'.
- - Read syntax: #. expression
- Is read as the object resulting from the evaluation of EXPRESSION.
- This substitution occurs even inside quoted structure.
+
+File: scm.info, Node: Modifying Read Syntax, Prev: Documentation and Comments, Up: Lexical Conventions
- In order to allow compiled code to work with `#.' it is good
- practice to define those symbols used inside of EXPRESSION with
- `#.(define ...)'. For example:
+Modifying Read Syntax
+---------------------
- #.(define foo 9) => #<unspecified>
- '(#.foo #.(+ foo foo)) => (9 18)
+ - Callback procedure: read:sharp c port
+ If a <#> followed by a character (for a non-standard syntax) is
+ encountered by `read', `read' will call the value of the symbol
+ `read:sharp' with arguments the character and the port being read
+ from. The value returned by this function will be the value of
+ `read' for this expression unless the function returns
+ `#<unspecified>' in which case the expression will be treated as
+ whitespace. `#<unspecified>' is the value returned by the
+ expression `(if #f #f)'.
- - Read syntax: #+ feature form
- If feature is `provided?' (by `*features*') then FORM is read as a
- scheme expression. If not, then FORM is treated as whitespace.
+ - Callback procedure: load:sharp c port |
+ Dispatches like `read:sharp', but only during `load's. The |
+ read-syntaxes handled by `load:sharp' are a superset of those |
+ handled by `read:sharp'. `load:sharp' calls `read:sharp' if none |
+ of its syntaxes match C. |
+ |
+ - Callback procedure: char:sharp token |
+ If the sequence <#\> followed by a non-standard character name is
+ encountered by `read', `read' will call the value of the symbol
+ `char:sharp' with the token (a string of length at least two) as |
+ argument. If the value returned is a character, then that will be |
+ the value of `read' for this expression, otherwise an error will |
+ be signaled. |
- Feature is a boolean expression composed of symbols and `and',
- `or', and `not' of boolean expressions.
+_Note:_ When adding new <#> syntaxes, have your code save the previous
+value of `load:sharp', `read:sharp', or `char:sharp' when defining it. |
+Call this saved value if an invocation's syntax is not recognized. |
+This will allow `#+', `#-', and *Note Uniform Array::s to still be |
+supported (as they dispatch from `read:sharp'). |
- For more information on `provided?' and `*features*', *Note
- Require: (slib)Require.
+
+File: scm.info, Node: Syntax, Prev: Lexical Conventions, Up: The Language
- - Read syntax: #- feature form
- is equivalent to `#+(not feature) expression'.
+Syntax
+======
- - Read syntax: #' form
- is equivalent to FORM (for compatibility with common-lisp).
+SCM provides a native implementation of "defmacro". *Note Defmacro:
+(slib)Defmacro.
- - Read syntax: #| any thing |#
- Is a balanced comment. Everything up to the matching `|#' is
- ignored by the `read'. Nested `#|...|#' can occur inside ANY
- THING.
+When built with `-F macro' build option (*note Build Options::) and
+`*syntax-rules*' is non-false, SCM also supports [R5RS] `syntax-rules'
+macros. *Note Macros: (r5rs)Macros.
+
+Other Scheme Syntax Extension Packages from SLIB can be employed through
+the use of `macro:eval' and `macro:load'; Or by using the SLIB
+read-eval-print-loop:
-A similar read syntax "#!" (exclamation rather than vertical bar) is
-supported for Posix shell-scripts (*note Scripting::).
+ (require 'repl)
+ (repl:top-level macro:eval)
- - Read syntax: #\token
- If TOKEN is a sequence of two or more digits, then this syntax is
- equivalent to `#.(integer->char (string->number token 8))'.
+With the appropriate catalog entries (*note Library Catalogs:
+(slib)Library Catalogs.), files using macro packages will automatically
+use the correct macro loader when `require'd.
- If TOKEN is `C-', `c-', or `^' followed by a character, then this
- syntax is read as a control character. If TOKEN is `M-' or `m-'
- followed by a character, then a meta character is read. `c-' and
- `m-' prefixes may be combined.
+* Menu:
+
+* Define and Set::
+* Defmacro::
+* Syntax-Rules::
+* Macro Primitives::
+* Environment Frames::
+* Syntactic Hooks for Hygienic Macros::
+
+
+File: scm.info, Node: Define and Set, Next: Defmacro, Prev: Syntax, Up: Syntax
+
+Define and Set
+--------------
- Special Form: defined? symbol
Equivalent to `#t' if SYMBOL is a syntactic keyword (such as `if')
@@ -2814,7 +3003,7 @@ supported for Posix shell-scripts (*note Scripting::).
INITIAL-VALUE as if the `defvar' form were instead the form
`(define identifier initial-value)' . If IDENTIFIER already has a
value, then INITIAL-VALUE is _not_ evaluated and IDENTIFIER's
- value is not changed. `defconst' is valid only when used at
+ value is not changed. `defvar' is valid only when used at |
top-level.
- Special Form: defconst identifier value
@@ -2840,9 +3029,9 @@ supported for Posix shell-scripts (*note Scripting::).
(set! (x y) (list 4 5)) => _unspecified_
(+ x y) => 9
- - Special Form: qase key clause1 clause2 ... |
- `qase' is an extension of standard Scheme `case': Each CLAUSE of a |
- `qase' statement must have as first element a list containing |
+ - Special Form: qase key clause1 clause2 ...
+ `qase' is an extension of standard Scheme `case': Each CLAUSE of a
+ `qase' statement must have as first element a list containing
elements which are:
* literal datums, or
@@ -2852,7 +3041,7 @@ supported for Posix shell-scripts (*note Scripting::).
* a comma followed by an at-sign (@) followed by the name of a
symbolic constant whose value is a list.
- A `qase' statement is equivalent to a `case' statement in which |
+ A `qase' statement is equivalent to a `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
@@ -2861,27 +3050,32 @@ supported for Posix shell-scripts (*note Scripting::).
unquoted expressions must be "symbolic constants".
Symbolic constants are defined using `defconst', their values are
- substituted in the head of each `qase' clause during macro |
+ substituted in the head of each `qase' clause during macro
expansion. `defconst' constants should be defined before use.
- `qase' can be substituted for any correct use of `case'. |
+ `qase' can be substituted for any correct use of `case'.
(defconst unit '1)
(defconst semivowels '(w y))
- (qase (* 2 3) |
+ (qase (* 2 3)
((2 3 5 7) 'prime)
((,unit 4 6 8 9) 'composite)) ==> composite
- (qase (car '(c d)) |
+ (qase (car '(c d))
((a) 'a)
((b) 'b)) ==> _unspecified_
- (qase (car '(c d)) |
+ (qase (car '(c d))
((a e i o u) 'vowel)
((,@semivowels) 'semivowel)
(else 'consonant)) ==> consonant
+
+File: scm.info, Node: Defmacro, Next: Syntax-Rules, Prev: Define and Set, Up: Syntax
+
+Defmacro
+--------
-SCM also supports the following constructs from Common Lisp:
-`defmacro', `macroexpand', `macroexpand-1', and `gentemp'. *Note
-Defmacro: (slib)Defmacro.
+SCM supports the following constructs from Common Lisp: `defmacro',
+`macroexpand', `macroexpand-1', and `gentemp'. *Note Defmacro:
+(slib)Defmacro.
SCM `defmacro' is extended over that described for SLIB:
@@ -2907,13 +3101,19 @@ For example:
(let1 not legal syntax) error--> not "does not match" ((name value))
+
+File: scm.info, Node: Syntax-Rules, Next: Macro Primitives, Prev: Defmacro, Up: Syntax
+
+Syntax-Rules
+------------
+
SCM supports [R5RS] `syntax-rules' macros *Note Macros: (r5rs)Macros.
-The pattern language is extended by the syntax `(... <obj>)', which is |
-identical to `<obj>' except that ellipses in `<obj>' are treated as |
-ordinary identifiers in a template, or as literals in a pattern. In |
-particular, `(... ...)' quotes the ellipsis token `...' in a pattern or |
-template. |
+The pattern language is extended by the syntax `(... <obj>)', which is
+identical to `<obj>' except that ellipses in `<obj>' are treated as
+ordinary identifiers in a template, or as literals in a pattern. In
+particular, `(... ...)' quotes the ellipsis token `...' in a pattern or
+template.
For example:
(define-syntax check-tree
@@ -2956,34 +3156,10 @@ For example:
(set! eight 9) => ERROR

-File: scm.info, Node: Low Level Syntactic Hooks, Next: Syntactic Hooks for Hygienic Macros, Prev: Syntax Extensions, Up: The Language
-
-Low Level Syntactic Hooks
-=========================
+File: scm.info, Node: Macro Primitives, Next: Environment Frames, Prev: Syntax-Rules, Up: Syntax
- - Callback procedure: read:sharp c port
- If a <#> followed by a character (for a non-standard syntax) is
- encountered by `read', `read' will call the value of the symbol
- `read:sharp' with arguments the character and the port being read
- from. The value returned by this function will be the value of
- `read' for this expression unless the function returns
- `#<unspecified>' in which case the expression will be treated as
- whitespace. `#<unspecified>' is the value returned by the
- expression `(if #f #f)'.
-
- - Callback procedure: read:sharp-char token
- If the sequence <#\> followed by a non-standard character name is
- encountered by `read', `read' will call the value of the symbol
- `read:sharp-char' with the token (a string of length at least two)
- as argument. If the value returned is a character, then that will
- be the value of `read' for this expression, otherwise an error
- will be signaled.
-
-_Note:_ When adding new <#> syntaxes, have your code save the previous
-value of `read:sharp' or `read:sharp-char' when defining it. Call this
-saved value if an invocation's syntax is not recognized. This will
-allow `#+', `#-', `#!', and *Note Uniform Array::s to still be
-supported (as they use `read:sharp').
+Macro Primitives
+----------------
- Function: procedure->syntax proc
Returns a "macro" which, when a symbol defined to this value
@@ -3000,7 +3176,7 @@ supported (as they use `read:sharp').
`PROCEDURE->MEMOIZING-MACRO' replaces the form passed to PROC.
For example:
- (defsyntax trace |
+ (defsyntax trace
(procedure->macro
(lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))
@@ -3014,56 +3190,62 @@ supported (as they use `read:sharp').
identifier.
- - Special Form: defsyntax name expr |
- Defines NAME as a macro keyword bound to the result of evaluating |
- EXPR, which should be a macro. Using `define' for this purpose |
- may not result in NAME being interpreted as a macro keyword. |
- |
-An "environment" is a list of frames representing lexical bindings. |
-Only the names and scope of the bindings are included in environments |
-passed to macro expanders - run-time values are not included. |
- |
-There are several types of environment frames: |
+ - Special Form: defsyntax name expr
+ Defines NAME as a macro keyword bound to the result of evaluating
+ EXPR, which should be a macro. Using `define' for this purpose
+ may not result in NAME being interpreted as a macro keyword.
+
+
+File: scm.info, Node: Environment Frames, Next: Syntactic Hooks for Hygienic Macros, Prev: Macro Primitives, Up: Syntax
+
+Environment Frames
+------------------
+
+An "environment" is a list of frames representing lexical bindings.
+Only the names and scope of the bindings are included in environments
+passed to macro expanders - run-time values are not included.
+
+There are several types of environment frames:
`((lambda (variable1 ...) ...) value1 ...)'
`(let ((variable1 value1) (variable2 value2) ...) ...)'
`(letrec ((variable1 value1) ...) ...)'
result in a single enviroment frame:
- |
- (variable1 variable2 ...) |
+
+ (variable1 variable2 ...)
`(let ((variable1 value1)) ...)'
`(let* ((variable1 value1) ...) ...)'
result in an environment frame for each variable:
- |
- variable1 variable2 ... |
- |
-`(let-syntax ((key1 macro1) (key2 macro2)) ...)' |
-`(letrec-syntax ((key1 value1) (key2 value2)) ...)' |
- Lexically bound macros result in environment frames consisting of |
- a marker and an alist of keywords and macro objects: |
- |
- (<env-syntax-marker> (key1 . value1) (key2 . value2)) |
- Currently <env-syntax-marker> is the integer 6. |
- |
-`line numbers' |
- Line numbers (*note Line Numbers::) may be included in the |
- environment as frame entries to indicate the line number on which |
- a function is defined. They are ignored for variable lookup. |
- |
- #<line 8> |
- |
-`miscellaneous' |
- Debugging information is stored in environments in a plist format: |
- Any exact integer stored as an environment frame may be followed |
- by any value. The two frame entries are ignored when doing |
- variable lookup. Load file names, procedure names, and closure |
- documentation strings are stored in this format. |
- |
- <env-filename-marker> "foo.scm" <env-procedure-name-marker> foo ... |
- |
- Currently <env-filename-marker> is the integer 1 and |
- <env-procedure-name-marker> the integer 2. |
+
+ variable1 variable2 ...
+
+`(let-syntax ((key1 macro1) (key2 macro2)) ...)'
+`(letrec-syntax ((key1 value1) (key2 value2)) ...)'
+ Lexically bound macros result in environment frames consisting of
+ a marker and an alist of keywords and macro objects:
+
+ (<env-syntax-marker> (key1 . value1) (key2 . value2))
+ Currently <env-syntax-marker> is the integer 6.
+
+`line numbers'
+ Line numbers (*note Line Numbers::) may be included in the
+ environment as frame entries to indicate the line number on which
+ a function is defined. They are ignored for variable lookup.
+
+ #<line 8>
+
+`miscellaneous'
+ Debugging information is stored in environments in a plist format:
+ Any exact integer stored as an environment frame may be followed
+ by any value. The two frame entries are ignored when doing
+ variable lookup. Load file names, procedure names, and closure
+ documentation strings are stored in this format.
+
+ <env-filename-marker> "foo.scm" <env-procedure-name-marker> foo ...
+
+ Currently <env-filename-marker> is the integer 1 and
+ <env-procedure-name-marker> the integer 2.
- Special Form: @apply procedure argument-list
Returns the result of applying PROCEDURE to ARGUMENT-LIST.
@@ -3078,10 +3260,10 @@ There are several types of environment frames: |
bindings.

-File: scm.info, Node: Syntactic Hooks for Hygienic Macros, Prev: Low Level Syntactic Hooks, Up: The Language
+File: scm.info, Node: Syntactic Hooks for Hygienic Macros, Prev: Environment Frames, Up: Syntax
Syntactic Hooks for Hygienic Macros
-===================================
+-----------------------------------
SCM provides a synthetic identifier type for efficient implementation of
hygienic macros (for example, `syntax-rules' *note Macros:
@@ -3117,7 +3299,7 @@ will be repeatedly replaced by its parent, until a symbol is obtained.
Returns the symbol obtained by recursively extracting the parent of
ID, which must be an identifier.
-Use of synthetic identifiers
+Use of Synthetic Identifiers
----------------------------
`renamed-identifier' may be used as a replacement for `gentemp':
@@ -3156,10 +3338,10 @@ lexical scope of its environment.
There is another restriction imposed for implementation convenience:
Macros passing their lexical environments to `renamed-identifier' may
-be lexically bound only by the special forms `let-syntax' or |
-`letrec-syntax'. No error is signaled if this restriction is not met, |
+be lexically bound only by the special forms `let-syntax' or
+`letrec-syntax'. No error is signaled if this restriction is not met,
but synthetic identifier lookup will not work properly.
- |
+
In order to maintain referential transparency it is necessary to
determine whether two identifiers have the same denotation. With
synthetic identifiers it is not necessary that two identifiers be `eq?'
@@ -3238,15 +3420,15 @@ Packages
********
* Menu:
- |
+
* Dynamic Linking::
* Dump:: Create Fast-Booting Executables
* Numeric:: Numeric Language Extensions
* Arrays:: As in APL
-* Records:: Define new aggregate data types |
+* Records:: Define new aggregate data types
* I/O-Extensions:: i/o-extensions
* Posix Extensions:: posix
-* Unix Extensions:: non-posix unix |
+* Unix Extensions:: non-posix unix
* Regular Expression Pattern Matching:: regex
* Line Editing:: edit-line
* Curses:: Screen Control
@@ -3255,11 +3437,11 @@ Packages
* Menu:
* Xlib: (Xlibscm). X Window Graphics.
-* Hobbit: (hobbit). Scheme-to-C Compiler. |
+* Hobbit: (hobbit). Scheme-to-C Compiler.

File: scm.info, Node: Dynamic Linking, Next: Dump, Prev: Packages, Up: Packages
- |
+
Dynamic Linking
===============
@@ -3405,8 +3587,8 @@ There are constraints on which sessions are savable using `dump'
* Creates an executable program named NEWPATH which continues
the state of the current SCM session when invoked. The
optional argument THUNK, if provided, should be a procedure
- of no arguments; BOOT-TAIL will be set to this procedure, |
- causing it to be called in the restored executable. |
+ of no arguments; BOOT-TAIL will be set to this procedure,
+ causing it to be called in the restored executable.
If the optional argument is missing or a boolean, SCM's
standard command line processing will be called in the
@@ -3434,7 +3616,7 @@ The procedure `program-arguments' returns the command line arguments
for the curent invocation. More specifically, `program-arguments' for
the restored session are _not_ saved from the dumping session. Command
line processing is done on the value of the identifier `*argv*'.
- |
+
The following example shows how to create `rscm', which is like regular
scm, but which loads faster and has the `random' package alreadly
provided.
@@ -3531,73 +3713,39 @@ operations: (r5rs)Numerical operations.

File: scm.info, Node: Arrays, Next: Records, Prev: Numeric, Up: Packages
- |
+
Arrays
======
* Menu:
* Conventional Arrays::
-* Array Mapping:: array-for-each
* Uniform Array::
* Bit Vectors::
+* Array Mapping:: array-for-each

-File: scm.info, Node: Conventional Arrays, Next: Array Mapping, Prev: Arrays, Up: Arrays
+File: scm.info, Node: Conventional Arrays, Next: Uniform Array, Prev: Arrays, Up: Arrays
Conventional Arrays
-------------------
+The following syntax and procedures are SCM extensions to feature
+`array' in *Note Arrays: (slib)Arrays.
+
"Arrays" read and write as a `#' followed by the "rank" (number of
dimensions) followed by the character #\a or #\A and what appear as
lists (of lists) of elements. The lists must be nested to the depth of
the rank. For each depth, all lists must be the same length.
- (make-array 'ho 3 3) =>
- #2A((ho ho ho) (ho ho ho) (ho ho ho))
+ (create-array '#(ho) 4 3) => |
+ #2A((ho ho ho) (ho ho ho) (ho ho ho) (ho ho ho)) |
The rank may be elided, in which case it is read as one.
'#A(a b c) == '#(a b c)
-Unshared conventional (not uniform) 0-based arrays of rank 1 (dimension)
-are equivalent to (and can't be distinguished from) vectors.
- (make-array 'ho 3) => #(ho ho ho)
-
-When constructing an array, BOUND is either an inclusive range of
-indices expressed as a two element list, or an upper bound expressed as
-a single integer. So
- (make-array 'foo 3 3) == (make-array 'foo '(0 2) '(0 2))
-
- - Function: array? obj
- Returns `#t' if the OBJ is an array, and `#f' if not.
-
- - Function: make-array initial-value bound1 bound2 ...
- Creates and returns an array that has as many dimensions as there
- are BOUNDs and fills it with INITIAL-VALUE.
-
- - Function: array-ref array index1 index2 ...
- Returns the INDEX1, INDEX2, ...'th element of ARRAY.
-
- - Function: array-in-bounds? array index1 index2 ...
- Returns `#t' if its arguments would be acceptable to ARRAY-REF.
-
- - Function: array-set! array new-value index1 index2 ...
- Sets the INDEX1, INDEX2, ...'th element of ARRAY to NEW-VALUE.
- The value returned by `array-set!' is unspecified.
-
- - Function: make-shared-array array mapper bound1 bound2 ...
- `make-shared-array' can be used to create shared subarrays of other
- arrays. The MAPPER is a function that translates coordinates in
- the new array into coordinates in the old array. A MAPPER must be
- linear, and its range must stay within the bounds of the old
- array, but it can be otherwise arbitrary. A simple example:
- (define fred (make-array #f 8 8))
- (define freds-diagonal
- (make-shared-array fred (lambda (i) (list i i)) 8))
- (array-set! freds-diagonal 'foo 3)
- (array-ref fred 3 3) => foo
- (define freds-center
- (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))
- (array-ref freds-center 0 0) => foo
+Unshared, conventional (not uniform) 0-based arrays of rank 1 are
+equivalent to (and can't be distinguished from) scheme vectors.
+ (create-array '#(ho) 3) => #(ho ho ho)
- Function: transpose-array array dim0 dim1 ...
Returns an array sharing contents with ARRAY, but with dimensions
@@ -3638,110 +3786,24 @@ a single integer. So
(enclose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) =>
#<enclosed-array #2A((a 1) (d 4)) #2A((b 2) (e 5)) #2A((c 3) (f 6))>
- - Function: array-shape array
- Returns a list of inclusive bounds of integers.
- (array-shape (make-array 'foo '(-1 3) 5)) => ((-1 3) (0 4))
-
- - Function: array-dimensions array
- `Array-dimensions' is similar to `array-shape' but replaces
- elements with a `0' minimum with one greater than the maximum. So:
- (array-dimensions (make-array 'foo '(-1 3) 5)) => ((-1 3) 5)
-
- - Function: array-rank obj
- Returns the number of dimensions of OBJ. If OBJ is not an array,
- `0' is returned.
-
- Function: array->list array
Returns a list consisting of all the elements, in order, of ARRAY.
In the case of a rank-0 array, returns the single element.
- - Function: array-copy! source destination
- Copies every element from vector or array SOURCE to the
- corresponding element of DESTINATION. DESTINATION must have the
- same rank as SOURCE, and be at least as large in each dimension.
- The order of copying is unspecified.
-
- - Function: serial-array-copy! source destination
- Same as `array-copy!' but guaranteed to copy in row-major order.
-
- - Function: array-fill! array fill
- Stores FILL in every element of ARRAY. The value returned is
- unspecified.
-
- - Function: array-equal? array0 array1 ...
- Returns `#t' iff all arguments are arrays with the same shape, the
- same type, and have corresponding elements which are either
- `equal?' or `array-equal?'. This function differs from `equal?'
- in that a one dimensional shared array may be ARRAY-EQUAL? but not
- EQUAL? to a vector or uniform vector.
-
- Function: array-contents array
- Function: array-contents array strict
If ARRAY may be "unrolled" into a one dimensional shared array
without changing their order (last subscript changing fastest),
then `array-contents' returns that shared array, otherwise it
- returns `#f'. All arrays made by MAKE-ARRAY and CREATE-ARRAY may |
- be unrolled, some arrays made by MAKE-SHARED-ARRAY may not be. |
+ returns `#f'. All arrays made by CREATE-ARRAY may be unrolled,
+ some arrays made by MAKE-SHARED-ARRAY may not be.
If the optional argument STRICT is provided, a shared array will
be returned only if its elements are stored internally contiguous
in memory.

-File: scm.info, Node: Array Mapping, Next: Uniform Array, Prev: Conventional Arrays, Up: Arrays
-
-Array Mapping
--------------
-
-`(require 'array-for-each)'
-
- - Function: array-map! array0 proc array1 ...
- If ARRAY1, ... are arrays, they must have the same number of
- dimensions as ARRAY0 and have a range for each index which
- includes the range for the corresponding index in ARRAY0. If they
- are scalars, that is, not arrays, vectors, or strings, then they
- will be converted internally to arrays of the appropriate shape.
- PROC is applied to each tuple of elements of ARRAY1 ... and the
- result is stored as the corresponding element in ARRAY0. The
- value returned is unspecified. The order of application is
- unspecified.
-
-
- - Function: serial-array-map! array0 proc array1 ...
- Same as ARRAY-MAP!, but guaranteed to apply PROC in row-major
- order.
-
- - Function: array-for-each proc array0 ...
- PROC is applied to each tuple of elements of ARRAY0 ... in
- row-major order. The value returned is unspecified.
-
- - Function: array-index-map! array proc
- applies PROC to the indices of each element of ARRAY in turn,
- storing the result in the corresponding element. The value
- returned and the order of application are unspecified.
-
- One can implement ARRAY-INDEXES as
- (define (array-indexes array)
- (let ((ra (apply make-array #f (array-shape array))))
- (array-index-map! ra (lambda x x))
- ra))
- Another example:
- (define (apl:index-generator n)
- (let ((v (make-vector n 1))) |
- (array-index-map! v (lambda (i) i))
- v))
-
- - Function: scalar->array scalar array prototype
- Returns a uniform array of the same shape as ARRAY, having only
- one shared element, which is `eqv?' to SCALAR. If the optional
- argument PROTOTYPE is supplied it will be used as the prototype
- for the returned array. Otherwise the returned array will be of
- the same type as `array' if that is possible, and a conventional
- array if it is not. This function is used internally by
- `array-map!' and friends to handle scalar arguments.
-
-
-File: scm.info, Node: Uniform Array, Next: Bit Vectors, Prev: Array Mapping, Up: Arrays
+File: scm.info, Node: Uniform Array, Next: Bit Vectors, Prev: Conventional Arrays, Up: Arrays
Uniform Array
-------------
@@ -3751,51 +3813,51 @@ same type. Uniform vectors occupy less storage than conventional
vectors. Uniform Array procedures also work on vectors,
uniform-vectors, bit-vectors, and strings.
-SLIB now supports uniform arrys. The primary array creation procedure |
-is `create-array', detailed in *Note Arrays: (slib)Arrays. |
+SLIB now supports uniform arrys. The primary array creation procedure
+is `create-array', detailed in *Note Arrays: (slib)Arrays.
Unshared uniform character 0-based arrays of rank 1 (dimension) are
equivalent to (and can't be distinguished from) strings.
- (create-array "" 3) => "$q2" |
+ (create-array "" 3) => "$q2"
Unshared uniform boolean 0-based arrays of rank 1 (dimension) are
equivalent to (and can't be distinguished from) *Note bit-vectors: Bit
Vectors.
- (create-array '#at() 3) => #*000 |
+ (create-array '#at() 3) => #*000
==
#At(#f #f #f) => #*000
==
#1At(#f #f #f) => #*000
-PROTOTYPE arguments in the following procedures are interpreted |
-according to the table: |
+PROTOTYPE arguments in the following procedures are interpreted
+according to the table:
- prototype type display prefix |
+ prototype type display prefix
- () conventional vector #a |
- +64i complex (double precision) #ac64 |
- 64.0 double (double precision) #ar64 |
- 32.0 float (single precision) #ar32 |
- 32 unsigned integer (32-bit) #au32 |
- -32 signed integer (32-bit) #as32 |
- -16 signed integer (16-bit) #as16 |
- #\a char (string) #a\ |
- #t boolean (bit-vector) #at |
- |
-Other uniform vectors are written in a form similar to that of general |
-arrays, except that one or more modifying characters are put between the |
-#\A character and the contents list. For example, `'#As32(3 5 9)' |
-returns a uniform vector of signed integers. |
+ () conventional vector #a
+ +64i complex (double precision) #ac64
+ 64.0 double (double precision) #ar64
+ 32.0 float (single precision) #ar32
+ 32 unsigned integer (32-bit) #au32
+ -32 signed integer (32-bit) #as32
+ -16 signed integer (16-bit) #as16
+ #\a char (string) #a\
+ #t boolean (bit-vector) #at
+
+Other uniform vectors are written in a form similar to that of general
+arrays, except that one or more modifying characters are put between the
+#\A character and the contents list. For example, `'#As32(3 5 9)'
+returns a uniform vector of signed integers.
- Function: array? obj prototype
Returns `#t' if the OBJ is an array of type corresponding to
PROTOTYPE, and `#f' if not.
- |
+
- Function: array-prototype array
Returns an object that would produce an array of the same type as
- ARRAY, if used as the PROTOTYPE for `list->uniform-array'. |
+ ARRAY, if used as the PROTOTYPE for `list->uniform-array'.
- - Function: list->uniform-array rank prot lst |
+ - Function: list->uniform-array rank prot lst
Returns a uniform array of the type indicated by prototype PROT
with elements the same as those of LST. Elements must be of the
appropriate type, no coercions are done.
@@ -3808,19 +3870,8 @@ returns a uniform vector of signed integers. |
If RANK is zero, LST, which need not be a list, is the single
element of the returned array.
- - Function: uniform-vector-fill! uve fill
- Stores FILL in every element of UVE. The value returned is
- unspecified.
- |
- - Function: dimensions->uniform-array dims prototype fill
- - Function: dimensions->uniform-array dims prototype |
- Creates and returns a uniform array or vector of type
- corresponding to PROTOTYPE with dimensions DIMS or length LENGTH.
- If the FILL argument is supplied, the returned array is filled with
- this value.
-
- Function: uniform-array-read! ura
- - Function: uniform-array-read! ura port |
+ - Function: uniform-array-read! ura port
Attempts to read all elements of URA, in lexicographic order, as
binary objects from PORT. If an end of file is encountered during
uniform-array-read! the objects up to that point only are put into
@@ -3832,7 +3883,7 @@ returns a uniform vector of signed integers. |
`(current-input-port)'.
- Function: uniform-array-write ura
- - Function: uniform-array-write ura port |
+ - Function: uniform-array-write ura port
Writes all elements of URA as binary objects to PORT. The number
of of objects actually written is returned. PORT may be omitted,
in which case it defaults to the value returned by
@@ -3860,7 +3911,7 @@ returns a uniform vector of signed integers. |
integer or if VAL is not boolean.

-File: scm.info, Node: Bit Vectors, Prev: Uniform Array, Up: Arrays
+File: scm.info, Node: Bit Vectors, Next: Array Mapping, Prev: Uniform Array, Up: Arrays
Bit Vectors
-----------
@@ -3901,30 +3952,90 @@ uniform-arrays.
BV is not modified.

-File: scm.info, Node: Records, Next: I/O-Extensions, Prev: Arrays, Up: Packages
- |
-Records |
-======= |
- |
-SCM provides user-definable datatypes with the same interface as SLIB, |
-see *Note Records: (slib)Records, with the following extension. |
- |
- - Function: record-printer-set! rtd printer |
- Causes records of type RTD to be printed in a user-specified |
- format. RTD must be a record type descriptor returned by |
- `make-record-type', PRINTER a procedure accepting three arguments: |
- the record to be printed, the port to print to, and a boolean |
- which is true if the record is being written on behalf of `write' |
- and false if for `display'. If PRINTER returns #f, the default |
- record printer will be called. |
- |
- A PRINTER value of #f means use the default printer. |
- |
- Only the default printer will be used when printing error messages. |
+File: scm.info, Node: Array Mapping, Prev: Bit Vectors, Up: Arrays
+
+Array Mapping
+-------------
+
+`(require 'array-for-each)'
+
+SCM has some extra functions in feature `array-for-each':
+
+ - Function: array-fill! array fill
+ Stores FILL in every element of ARRAY. The value returned is
+ unspecified.
+
+ - Function: serial-array-copy! source destination
+ Same as `array-copy!' but guaranteed to copy in row-major order.
+
+ - Function: array-equal? array0 array1 ...
+ Returns `#t' iff all arguments are arrays with the same shape, the
+ same type, and have corresponding elements which are either
+ `equal?' or `array-equal?'. This function differs from `equal?'
+ in that a one dimensional shared array may be ARRAY-EQUAL? but not
+ EQUAL? to a vector or uniform vector.
+
+ - Function: array-map! array0 proc array1 ...
+ If ARRAY1, ... are arrays, they must have the same number of
+ dimensions as ARRAY0 and have a range for each index which
+ includes the range for the corresponding index in ARRAY0. If they
+ are scalars, that is, not arrays, vectors, or strings, then they
+ will be converted internally to arrays of the appropriate shape.
+ PROC is applied to each tuple of elements of ARRAY1 ... and the
+ result is stored as the corresponding element in ARRAY0. The
+ value returned is unspecified. The order of application is
+ unspecified.
+
+ Handling non-array arguments is a SCM extension of *Note
+ array-map!: (slib)Array Mapping
+
+ - Function: serial-array-map! array0 proc array1 ...
+ Same as ARRAY-MAP!, but guaranteed to apply PROC in row-major
+ order.
+
+ - Function: array-map prototype proc array1 array2 ... |
+ ARRAY2, ... must have the same number of dimensions as ARRAY1 and |
+ have a range for each index which includes the range for the |
+ corresponding index in ARRAY1. PROC is applied to each tuple of |
+ elements of ARRAY1, ARRAY2, ... and the result is stored as the |
+ corresponding element in a new array of type PROTOTYPE. The new |
+ array is returned. The order of application is unspecified. |
|
+ - Function: scalar->array scalar array prototype
+ - Function: scalar->array scalar array
+ Returns a uniform array of the same shape as ARRAY, having only
+ one shared element, which is `eqv?' to SCALAR. If the optional
+ argument PROTOTYPE is supplied it will be used as the prototype
+ for the returned array. Otherwise the returned array will be of
+ the same type as `array' if that is possible, and a conventional
+ array if it is not. This function is used internally by
+ `array-map!' and friends to handle scalar arguments.
+
+
+File: scm.info, Node: Records, Next: I/O-Extensions, Prev: Arrays, Up: Packages
+
+Records
+=======
+
+SCM provides user-definable datatypes with the same interface as SLIB,
+see *Note Records: (slib)Records, with the following extension.
+
+ - Function: record-printer-set! rtd printer
+ Causes records of type RTD to be printed in a user-specified
+ format. RTD must be a record type descriptor returned by
+ `make-record-type', PRINTER a procedure accepting three arguments:
+ the record to be printed, the port to print to, and a boolean
+ which is true if the record is being written on behalf of `write'
+ and false if for `display'. If PRINTER returns #f, the default
+ record printer will be called.
+
+ A PRINTER value of #f means use the default printer.
+
+ Only the default printer will be used when printing error messages.
+

File: scm.info, Node: I/O-Extensions, Next: Posix Extensions, Prev: Records, Up: Packages
- |
+
I/O-Extensions
==============
@@ -3988,13 +4099,13 @@ I/O: (slib)Line I/O, and the following functions are defined:
`file-set-position' is unspecified. The result of
`file-set-position' is unspecified.
- - Function: try-create-file name modes perms |
- If the file with name NAME already exists, return `#f', otherwise |
+ - Function: try-create-file name modes perms
+ If the file with name NAME already exists, return `#f', otherwise
try to create and open the file like `try-open-file', *Note Files
- and Ports::. If the optional integer argument PERMS is provided, |
- it is used as the permissions of the new file (modified by the |
- current umask). |
- |
+ and Ports::. If the optional integer argument PERMS is provided,
+ it is used as the permissions of the new file (modified by the
+ current umask).
+
- Function: reopen-file filename modes port
Closes port PORT and reopens it with FILENAME and MODES.
`reopen-file' returns `#t' if successful, `#f' if not.
@@ -4027,11 +4138,11 @@ I/O: (slib)Line I/O, and the following functions are defined:
`closedir' returns a `#f'.
- Function: directory-for-each proc directory
- The LISTs must be lists, and PROC must be a procedure taking one
- argument. `Directory-For-Each' applies PROC to the (string) name
- of each file in DIRECTORY. The dynamic order in which PROC is
- applied to the elements of the LISTs is unspecified. The value
- returned by `directory-for-each' is unspecified.
+ PROC must be a procedure taking one argument.
+ `Directory-For-Each' applies PROC to the (string) name of each
+ file in DIRECTORY. The dynamic order in which PROC is applied to
+ the filenames is unspecified. The value returned by
+ `directory-for-each' is unspecified.
- Function: directory-for-each proc directory pred
Applies PROC only to those filenames for which the procedure PRED
@@ -4042,7 +4153,7 @@ I/O: (slib)Line I/O, and the following functions are defined:
MATCH)' would return a non-false value (*note Filenames:
(slib)Filenames.).
- (require 'directory-for-each)
+ (require 'directory)
(directory-for-each print "." "[A-Z]*.scm")
-|
"Init.scm"
@@ -4050,7 +4161,7 @@ I/O: (slib)Line I/O, and the following functions are defined:
"Link.scm"
"Macro.scm"
"Transcen.scm"
- "Init5d6.scm" |
+ "Init5d9.scm" |
- Function: mkdir path mode
The `mkdir' function creates a new, empty directory whose name is
@@ -4164,7 +4275,7 @@ I/O: (slib)Line I/O, and the following functions are defined:

File: scm.info, Node: Posix Extensions, Next: Unix Extensions, Prev: I/O-Extensions, Up: Packages
- |
+
Posix Extensions
================
@@ -4188,14 +4299,14 @@ functions are defined:
the standard input of the system command STRING. If a pipe cannot
be created `#f' is returned.
- - Function: broken-pipe port |
- If this function is defined at top level, it will be called when an |
- output pipe is closed from the other side (this is the condition |
- under which a SIGPIPE is sent). The already closed PORT will be |
- passed so that any necessary cleanup may be done. An error is not |
- signaled when output to a pipe fails in this way, but any further |
- output to the closed pipe will cause an error to be signaled. |
- |
+ - Function: broken-pipe port
+ If this function is defined at top level, it will be called when an
+ output pipe is closed from the other side (this is the condition
+ under which a SIGPIPE is sent). The already closed PORT will be
+ passed so that any necessary cleanup may be done. An error is not
+ signaled when output to a pipe fails in this way, but any further
+ output to the closed pipe will cause an error to be signaled.
+
- Function: close-port pipe
Closes the PIPE, rendering it incapable of delivering or accepting
characters. This routine has no effect if the pipe has already
@@ -4218,11 +4329,6 @@ Persona.
Returns the process ID of the parent of the current process. For
a process's own ID *Note getpid: I/O-Extensions.
- - Function: getlogin |
- Returns the (login) name of the user logged in on the controlling |
- terminal of the process, or #f if this information cannot be |
- determined. |
- |
- Function: getuid
Returns the real user ID of this process.
@@ -4435,14 +4541,14 @@ Persona.

File: scm.info, Node: Unix Extensions, Next: Regular Expression Pattern Matching, Prev: Posix Extensions, Up: Packages
- |
+
Unix Extensions
===============
If `'unix' is provided (by linking in `unix.o'), the following
functions are defined:
-These "privileged" and symbolic link functions are not in Posix: |
+These "privileged" and symbolic link functions are not in Posix:
- Function: symlink oldname newname
The `symlink' function makes a symbolic link to OLDNAME named
@@ -4468,7 +4574,7 @@ These "privileged" and symbolic link functions are not in Posix: |
- Function: acct filename
When called with the name of an exisitng file as argument,
- accounting is turned on, records for each terminating process are |
+ accounting is turned on, records for each terminating process are
appended to FILENAME as it terminates. An argument of `#f' causes
accounting to be turned off.
@@ -4489,7 +4595,7 @@ These "privileged" and symbolic link functions are not in Posix: |

File: scm.info, Node: Regular Expression Pattern Matching, Next: Line Editing, Prev: Unix Extensions, Up: Packages
- |
+
Regular Expression Pattern Matching
===================================
@@ -5021,15 +5127,15 @@ Sockets: (libc)Sockets.
* Menu:
-* Host Data::
+* Host and Other Inquiries::
* Internet Addresses and Socket Names::
* Socket::

-File: scm.info, Node: Host Data, Next: Internet Addresses and Socket Names, Prev: Sockets, Up: Sockets
+File: scm.info, Node: Host and Other Inquiries, Next: Internet Addresses and Socket Names, Prev: Sockets, Up: Sockets
-Host Data, Network, Protocol, and Service Inquiries
----------------------------------------------------
+Host and Other Inquiries
+------------------------
- Constant: af_inet
- Constant: af_unix
@@ -5119,7 +5225,7 @@ Host Data, Network, Protocol, and Service Inquiries
When called without an argument, the service table is closed.

-File: scm.info, Node: Internet Addresses and Socket Names, Next: Socket, Prev: Host Data, Up: Sockets
+File: scm.info, Node: Internet Addresses and Socket Names, Next: Socket, Prev: Host and Other Inquiries, Up: Sockets
Internet Addresses and Socket Names
-----------------------------------
@@ -5622,9 +5728,9 @@ memory allocated by `malloc'.
- Header: tc7_uvect
uniform vector of non-negative integers
- - Header: tc7_svect |
- uniform vector of short integers |
- |
+ - Header: tc7_svect
+ uniform vector of short integers
+
- Header: tc7_fvect
uniform vector of short inexact real numbers
@@ -5861,7 +5967,7 @@ Defining Smobs::). These are the initial smobs:
synchronization object. *Note Process Synchronization::.
- smob: tc16_macro
- macro expanding function. *Note Low Level Syntactic Hooks::.
+ macro expanding function. *Note Macro Primitives::.
- smob: tc16_array
multi-dimensional array. *Note Arrays::.
@@ -5908,7 +6014,7 @@ bvect .........long length....G0010101 ..........long *words...........
ivect .........long length....G0011101 ..........long *words...........
uvect .........long length....G0011111 ......unsigned long *words......
spare G0100101
-svect .........long length....G0100111 ........ short *words........... |
+svect .........long length....G0100111 ........ short *words...........
fvect .........long length....G0101101 .........float *words...........
dvect .........long length....G0101111 ........double *words...........
cvect .........long length....G0110101 ........double *words...........
@@ -5917,15 +6023,15 @@ contin .........long length....G0111101 .............*regs..............
specfun ................xxxxxxxxG1111111 ...........SCM name.............
cclo ..short length..xxxxxx10G1111111 ...........SCM **elts...........
PTOBs:
- port 0bwroxxxxxxxxG0110111 ..........FILE *stream..........
- socket ttttttt 00001xxxxxxxxG0110111 ..........FILE *stream..........
- inport uuuuuuuuuuU00011xxxxxxxxG0110111 ..........FILE *stream..........
-outport 0000000000000101xxxxxxxxG0110111 ..........FILE *stream..........
- ioport uuuuuuuuuuU00111xxxxxxxxG0110111 ..........FILE *stream..........
-fport 00 00000000G0110111 ..........FILE *stream..........
-pipe 00 00000001G0110111 ..........FILE *stream..........
-strport 00 00000010G0110111 ..........FILE *stream..........
-sfport 00 00000011G0110111 ..........FILE *stream..........
+ port int portnum.CwroxxxxxxxxG0110111 ..........FILE *stream.......... |
+ socket int portnum.C001xxxxxxxxG0110111 ..........FILE *stream.......... |
+ inport int portnum.C011xxxxxxxxG0110111 ..........FILE *stream.......... |
+outport int portnum.0101xxxxxxxxG0110111 ..........FILE *stream.......... |
+ ioport int portnum.C111xxxxxxxxG0110111 ..........FILE *stream.......... |
+fport int portnum.C 00000000G0110111 ..........FILE *stream.......... |
+pipe int portnum.C 00000001G0110111 ..........FILE *stream.......... |
+strport 00000000000.0 00000010G0110111 ..........FILE *stream.......... |
+sfport int portnum.C 00000011G0110111 ..........FILE *stream.......... |
SUBRs:
spare 010001x1
spare 010011x1
@@ -6215,7 +6321,7 @@ File: scm.info, Node: C Macros, Next: Changing Scm, Prev: Signals, Up: Opera
C Macros
--------
- - Macro: ASSERT cond arg pos subr
+ - Macro: ASRTER cond arg pos subr
signals an error if the expression (COND) is 0. ARG is the
offending object, SUBR is the string naming the subr, and POS
indicates the position or type of error. POS can be one of
@@ -6256,12 +6362,12 @@ C Macros
* a C string `(char *)'
- Error checking is not done by `ASSERT' if the flag `RECKLESS' is
+ Error checking is not done by `ASRTER' if the flag `RECKLESS' is
defined. An error condition can still be signaled in this case
with a call to `wta(arg, pos, subr)'.
- Macro: ASRTGO cond label
- `goto' LABEL if the expression (COND) is 0. Like `ASSERT',
+ `goto' LABEL if the expression (COND) is 0. Like `ASRTER',
`ASRTGO' does is not active if the flag `RECKLESS' is defined.

@@ -6289,11 +6395,18 @@ or put this assignment somewhere in your routine:
of the local `SCM' variable to _any_ procedure also protects it. The
procedure `scm_protect_temp' is provided for this purpose.
+ - Function: void scm_protect_temp (SCM *PTR)
+ Forces the SCM object PTR to be saved on the C-stack, where it
+ will be traced for GC.
+
Also, if you maintain a static pointer to some (non-immediate) `SCM'
object, you must either make your pointer be the value cell of a symbol
-(see `errobj' for an example) or make your pointer be one of the
-`sys_protects' (see `dynwinds' for an example). The former method is
-prefered since it does not require any changes to the SCM distribution.
+(see `errobj' for an example) or (permanently) add your pointer to
+`sys_protects' using:
+
+ - Function: SCM scm_gc_protect (SCM OBJ)
+ Permanently adds OBJ to a table of objects protected from garbage
+ collection. `scm_gc_protect' returns OBJ.
To add a C routine to scm:
@@ -6353,7 +6466,7 @@ To add a package of new procedures to scm (see `crs.c' for example):
7. put any scheme code which needs to be run as part of your package
into `Ifoo.scm'.
- 8. put an `if' into `Init5d6.scm' which loads `Ifoo.scm' if your |
+ 8. put an `if' into `Init5d9.scm' which loads `Ifoo.scm' if your |
package is included:
(if (defined? twiddle-bits!)
@@ -6385,7 +6498,7 @@ Special forms (new syntax) can be added to scm.
New syntax can now be added without recompiling SCM by the use of the
`procedure->syntax', `procedure->macro', `procedure->memoizing-macro',
-and `defmacro'. For details, *Note Syntax Extensions::.
+and `defmacro'. For details, *Note Syntax::.

File: scm.info, Node: Defining Subrs, Next: Defining Smobs, Prev: Changing Scm, Up: Operations
@@ -6494,10 +6607,10 @@ following lines need to be added to your code:
is the smob object. The second, of type `SCM', is the stream
on which to write the result. The third, of type int, is 1
if the object should be `write'n, 0 if it should be
- `display'ed, and 2 if it should be `write'n for an error |
- report. This function should return non-zero if it printed, |
- and zero otherwise (in which case a hexadecimal number will |
- be printed). |
+ `display'ed, and 2 if it should be `write'n for an error
+ report. This function should return non-zero if it printed,
+ and zero otherwise (in which case a hexadecimal number will
+ be printed).
`smob.equalp'
is 0 or a function of 2 `SCM' arguments. Both of these
@@ -6584,9 +6697,9 @@ following functions are provided for that purpose:
`must_malloc', `must_malloc_cell', `must_realloc', and
`must_realloc_cell' must be called with interrupts deferred *Note
-Signals::. `must_realloc' and `must_realloc_cell' must not be called |
-during initialization (non-zero errjmp_bad) - the initial allocations |
-must be large enough. |
+Signals::. `must_realloc' and `must_realloc_cell' must not be called
+during initialization (non-zero errjmp_bad) - the initial allocations
+must be large enough.
- Function: void must_free (char *PTR, sizet LEN)
`must_free' is used to free a block of memory allocated by the
@@ -6653,7 +6766,7 @@ SCM, then you can replace `scm_find_implpath'.
environment variable is defined, its value will be returned from
`scm_find_implpath'. Otherwise find_impl_file() is called with the
arguments EXECPATH, GENERIC_NAME (default "scm"), INIT_FILE_NAME
- (default "Init5d6_scm"), and the directory separator string |
+ (default "Init5d9_scm"), and the directory separator string |
DIRSEP. If find_impl_file() returns 0 and IMPLINIT is defined,
then a copy of the string IMPLINIT is returned.
@@ -6740,9 +6853,9 @@ Here is a minimal embedding program `libtest.c':
/* include patchlvl.h for SCM's INIT_FILE_NAME. */
#include "patchlvl.h"
- void init_user_scm()
+ void libtest_init_user_scm() |
{
- fputs("This is init_user_scm\n", stderr); fflush(stderr);
+ fputs("This is libtest_init_user_scm\n", stderr); fflush(stderr); |
sysintern("*the-string*", makfrom0str("hello world\n"));
}
@@ -6761,6 +6874,7 @@ Here is a minimal embedding program `libtest.c':
SCM retval;
char *implpath, *execpath;
+ init_user_scm = libtest_init_user_scm; |
execpath = dld_find_executable(argv[0]);
fprintf(stderr, "dld_find_executable(%s): %s\n", argv[0], execpath);
implpath = find_impl_file(execpath, "scm", INIT_FILE_NAME, dirsep);
@@ -6775,8 +6889,8 @@ Here is a minimal embedding program `libtest.c':
-|
dld_find_executable(./libtest): /home/jaffer/scm/libtest
- implpath: /home/jaffer/scm/Init5d6.scm |
- This is init_user_scm
+ implpath: /home/jaffer/scm/Init5d9.scm |
+ This is libtest_init_user_scm |
hello world

@@ -6791,7 +6905,7 @@ The source code for these routines are found in `rope.c'.
- Function: int scm_ldfile (char *FILE)
Loads the Scheme source file FILE. Returns 0 if successful, non-0
if not. This function is used to load SCM's initialization file
- `Init5d6.scm'. |
+ `Init5d9.scm'. |
- Function: int scm_ldprog (char *FILE)
Loads the Scheme source file `(in-vicinity (program-vicinity)
@@ -6849,21 +6963,23 @@ code. Most are defined in `rope.c'.
- Function: long num2long (SCM NUM, char *POS, char *S_CALLER)
- Function: unsigned long num2ulong (SCM NUM, char *POS, char
*S_CALLER)
+ - Function: short num2short (SCM NUM, char *POS, char *S_CALLER)
- Function: unsigned short num2ushort (SCM NUM, char *POS, char
*S_CALLER)
- Function: unsigned char num2uchar (SCM NUM, char *POS, char
*S_CALLER)
+ - Function: double num2dbl (SCM NUM, char *POS, char *S_CALLER)
These functions are used to check and convert `SCM' arguments to
the named C type. The first argument NUM is checked to see it it
is within the range of the destination type. If so, the converted
- number is returned. If not, the `ASSERT' macro calls `wta' with
+ number is returned. If not, the `ASRTER' macro calls `wta' with
NUM and strings POS and S_CALLER. For a listing of useful
predefined POS macros, *Note C Macros::.
- _Note:_ Inexact numbers are accepted only by `num2long' and
- `num2ulong' (for when `SCM' is compiled without bignums). To
- convert inexact numbers to exact numbers, *Note inexact->exact:
- (r5rs)Numerical operations.
+ _Note:_ Inexact numbers are accepted only by `num2dbl',
+ `num2long', and `num2ulong' (for when `SCM' is compiled without
+ bignums). To convert inexact numbers to exact numbers, *Note
+ inexact->exact: (r5rs)Numerical operations.
- Function: unsigned long scm_addr (SCM ARGS, char *S_NAME)
Returns a pointer (cast to an `unsigned long') to the storage
@@ -6874,10 +6990,16 @@ code. Most are defined in `rope.c'.
`scm_addr' is useful for performing C operations on strings or
other uniform arrays (*note Uniform Array::).
- _Note:_ While you use a pointer returned from `scm_addr' you must
- keep a pointer to the associated `SCM' object in a stack allocated
- variable or GC-protected location in order to assure that SCM does
- not reuse that storage before you are done with it.
+ - Function: unsigned long scm_base_addr(SCM RA, char *S_NAME)
+ Returns a pointer (cast to an `unsigned long') to the beginning of
+ storage of array RA. Note that if RA is a shared-array, the
+ strorage accessed this way may be much larger than RA.
+
+ _Note:_ While you use a pointer returned from `scm_addr' or
+ `scm_base_addr' you must keep a pointer to the associated `SCM'
+ object in a stack allocated variable or GC-protected location in
+ order to assure that SCM does not reuse that storage before you
+ are done with it. *Note scm_gc_protect: Changing Scm.
- Function: SCM makfrom0str (char *SRC)
- Function: SCM makfromstr (char *SRC, sizet LEN)
@@ -7203,7 +7325,7 @@ File: scm.info, Node: Executable Pathname, Next: Script Support, Prev: File-S
Executable Pathname
-------------------
-For purposes of finding `Init5d6.scm', dumping an executable, and |
+For purposes of finding `Init5d9.scm', dumping an executable, and |
dynamic linking, a SCM session needs the pathname of its executable
image.
@@ -7316,22 +7438,20 @@ Improvements To Make
gets set which tells the interpreter to instead always look
up the values of the associated symbols.
+ * Scott Schwartz <schwartz@galapagos.cse.psu.edu> suggests: One way
+ to tidy up the dynamic loading stuff would be to grab the code
+ from perl5.
+
* Menu:
-* Finishing Dynamic Linking::
+* VMS Dynamic Linking:: Finishing the job. |

-File: scm.info, Node: Finishing Dynamic Linking, Prev: Improvements To Make, Up: Improvements To Make
-
-Finishing Dynamic Linking
--------------------------
-
-Scott Schwartz <schwartz@galapagos.cse.psu.edu> suggests: One way to
-tidy up the dynamic loading stuff would be to grab the code from perl5.
-
-VMS
-...
+File: scm.info, Node: VMS Dynamic Linking, Prev: Improvements To Make, Up: Improvements To Make
+ |
+VMS Dynamic Linking
+-------------------
George Carrette (gjc@mitech.com) outlines how to dynamically link on
VMS. There is already some code in `dynl.c' to do this, but someone
@@ -7447,97 +7567,9 @@ with a VMS system needs to finish and debug it.
modify and relink `LISPLIB.EXE' without having to relink programs
that have been linked against it.
-Windows NT
-..........
-
-George Carrette (gjc@mitech.com) outlines how to dynamically link on
-Windows NT:
-
- * The Software Developers Kit has a sample called SIMPLDLL. Here is
- the gist of it, following along the lines of the VMS description
- above (contents of a makefile for the SDK NMAKE)
-
- LISPLIB.exp:
- LISPLIB.lib: LISPLIB.def
- $(implib) -machine:$(CPU) -def:LISPLIB.def -out:LISPLIB.lib
-
- LISPLIB.DLL : $(LISPLIB_OBJS) LISPLIB.EXP
- $(link) $(linkdebug) \
- -dll \
- -out:LISPLIB.DLL \
- LISPLIB.EXP $(LISPLIB_OBJS) $(conlibsdll)
-
- * The `LISPDEF.DEF' file has this:
-
- LIBRARY lisplib
- EXPORT
- init_lisp
- init_repl
-
- * And `MAIN.EXE' using:
-
- CLINK = $(link) $(ldebug) $(conflags) -out:$*.exe $** $(conlibsdll)
-
- MAIN.EXE : MAIN.OBJ LISPLIB.LIB
- $(CLINK)
-
- * And `MYSUBRS.DLL' is produced using:
-
- mysubrs.exp:
- mysubrs.lib: mysubrs.def
- $(implib) -machine:$(CPU) -def:MYSUBRS.def -out:MYSUBRS.lib
-
- mysubrs.dll : mysubrs.obj mysubrs.exp mysubrs.lib
- $(link) $(linkdebug) \
- -dll \
- -out:mysubrs.dll \
- MYSUBRS.OBJ MYSUBRS.EXP LISPLIB.LIB $(conlibsdll)
-
- * Where `MYSUBRS.DEF' has
-
- LIBRARY mysubrs
- EXPORT
- INIT_MYSUBRS
-
- * And the dynamic loader looks something like this, calling the two
- procedures `LoadLibrary' and `GetProcAddress'.
-
- LISP share_image_load(LISP fname)
- {long iflag;
- LISP retval,(*fcn)(void);
- HANDLE hLib;
- DWORD err;
- char *libname,fcnname[64];
- iflag = nointerrupt(1);
- libname = c_string(fname);
- _snprintf(fcnname,sizeof(fcnname),"INIT_%s",libname);
- if (!(hLib = LoadLibrary(libname)))
- {err = GetLastError();
- retval = list2(fname,LSPNUM(err));
- serror1("library failed to load",retval);}
- if (!(fcn = (LISP (*)(void)) GetProcAddress(hLib,fcnname)))
- {err = GetLastError();
- retval = list2(fname,LSPNUM(err));
- serror1("could not find library init procedure",retval);}
- retval = (*fcn)();
- nointerrupt(iflag);
- return(retval);}
-
- * _Note:_ in VMS the linker and dynamic loader is case sensitive, but
- all the language compilers, including C, will by default upper-case
- external symbols for use by the linker, although the debugger gets
- its own symbols and case sensitivity is language mode dependant.
- In Windows NT things are case sensitive generally except for file
- and device names, which are case canonicalizing like in the
- Symbolics filesystem.
-
- * _Also:_ All this WINDOWS NT stuff will work in MS-DOS MS-Windows
- 3.1 too, by a method of compiling and linking under Windows NT,
- and then copying various files over to MS-DOS/WINDOWS.
-

File: scm.info, Node: Index, Prev: The Implementation, Up: Top
-
+ |
Procedure and Macro Index
*************************
@@ -7546,13 +7578,16 @@ This is an alphabetical list of all the procedures and macros in SCM.
* Menu:
* #!: Unix Scheme Scripts.
-* #': Syntax Extensions.
-* #+: Syntax Extensions.
-* #-: Syntax Extensions.
-* #.: Syntax Extensions.
-* #;text-till-end-of-line: Syntax Extensions.
-* #\token: Syntax Extensions.
-* #|: Syntax Extensions.
+* #': Common-Lisp Read Syntax.
+* #+: Common-Lisp Read Syntax.
+* #-: Common-Lisp Read Syntax.
+* #.: Common-Lisp Read Syntax.
+* #;text-till-end-of-line: Documentation and Comments.
+* #?column: Load Syntax. |
+* #?file: Load Syntax. |
+* #?line: Load Syntax. |
+* #\token: Common-Lisp Read Syntax.
+* #|: Common-Lisp Read Syntax.
* $abs: Numeric.
* $acos: Numeric.
* $acosh: Numeric.
@@ -7600,6 +7635,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
* -e: SCM Options.
* -f: SCM Options.
* -F: Build Options.
+* -f: Build Options.
* -h <1>: SCM Options.
* -h: Build Options.
* -i <1>: SCM Options.
@@ -7621,19 +7657,19 @@ This is an alphabetical list of all the procedures and macros in SCM.
* -u: SCM Options.
* -v: SCM Options.
* -w: Build Options.
-* @apply: Low Level Syntactic Hooks.
-* @copy-tree: Miscellaneous Procedures. |
+* @apply: Environment Frames.
+* @copy-tree: Storage.
* @macroexpand1: Syntactic Hooks for Hygienic Macros.
-* _exclusive: Files and Ports. |
-* _ionbf: Files and Ports.
-* _tracked: Files and Ports.
+* _exclusive: Opening and Closing.
+* _ionbf: Opening and Closing.
+* _tracked: Opening and Closing.
* abort: Internal State.
* access: I/O-Extensions.
-* acct: Unix Extensions. |
-* acons: Miscellaneous Procedures.
+* acct: Unix Extensions.
+* acons: Storage.
* acosh: Numeric.
* add-alias: Configure Module Catalog.
-* add-finalizer: Interrupts. |
+* add-finalizer: Storage.
* add-link: Configure Module Catalog.
* add-source: Configure Module Catalog.
* alarm: Interrupts.
@@ -7644,73 +7680,64 @@ This is an alphabetical list of all the procedures and macros in SCM.
* arithmetic-error: Interrupts.
* array->list: Conventional Arrays.
* array-contents: Conventional Arrays.
-* array-copy!: Conventional Arrays.
-* array-dimensions: Conventional Arrays.
-* array-equal?: Conventional Arrays.
-* array-fill!: Conventional Arrays.
-* array-for-each: Array Mapping.
-* array-in-bounds?: Conventional Arrays.
-* array-index-map!: Array Mapping.
+* array-equal?: Array Mapping.
+* array-fill!: Array Mapping.
+* array-map: Array Mapping. |
* array-map!: Array Mapping.
* array-prototype: Uniform Array.
-* array-rank: Conventional Arrays.
-* array-ref: Conventional Arrays.
-* array-set!: Conventional Arrays.
-* array-shape: Conventional Arrays.
-* array? <1>: Uniform Array.
-* array?: Conventional Arrays.
+* array?: Uniform Array.
* asinh: Numeric.
+* ASRTER: C Macros.
* ASRTGO: C Macros.
-* ASSERT: C Macros.
* atanh: Numeric.
* bit-count: Bit Vectors.
* bit-count*: Bit Vectors.
* bit-invert!: Bit Vectors.
* bit-position: Bit Vectors.
* bit-set*!: Bit Vectors.
-* boot-tail <1>: Dump. |
-* boot-tail: SCM Session. |
+* boot-tail <1>: Dump.
+* boot-tail: SCM Session.
* box: Curses Miscellany.
-* broken-pipe: Posix Extensions. |
-* call-with-outputs: Files and Ports.
-* CAR: Cells. |
+* broken-pipe: Posix Extensions.
+* call-with-outputs: Port Redirection.
+* CAR: Cells.
* cbreak: Terminal Mode Setting.
* CCLO_LENGTH: Header Cells.
* CDR: Cells.
* char: Type Conversions.
-* char-ready: Files and Ports.
+* char-ready: Port Properties.
* char-ready? <1>: Socket.
-* char-ready?: Files and Ports.
+* char-ready?: Port Properties.
+* char:sharp: Modifying Read Syntax. |
* CHARS: Header Cells.
* chdir: I/O-Extensions.
* CHEAP_CONTINUATIONS: Continuations.
* chmod: I/O-Extensions.
* chown: Posix Extensions.
-* clearok: Output Options Setting. |
+* clearok: Output Options Setting.
* close-port <1>: Window Manipulation.
* close-port <2>: Posix Extensions.
-* close-port: Files and Ports.
+* close-port: Opening and Closing.
* closedir: I/O-Extensions.
* CLOSEDP: Ptob Cells.
* CLOSUREP: Cells.
* CODE: Cells.
-* comment: Syntax Extensions. |
+* comment: Documentation and Comments.
* CONSP: Cells.
-* copy-tree: Miscellaneous Procedures.
+* copy-tree: Storage.
* cosh: Numeric.
* could-not-open: Interrupts.
-* current-error-port: Files and Ports.
-* current-input-port: Files and Ports.
+* current-error-port: Port Redirection.
+* current-input-port: Port Properties.
* current-time: Time.
* default-input-port: Line Editing.
* default-output-port: Line Editing.
-* defconst: Syntax Extensions.
+* defconst: Define and Set.
* DEFER_INTS: Signals.
-* defined?: Syntax Extensions.
-* defmacro: Syntax Extensions.
-* defsyntax: Low Level Syntactic Hooks. |
-* defvar: Syntax Extensions.
-* dimensions->uniform-array: Uniform Array.
+* defined?: Define and Set.
+* defmacro: Defmacro.
+* defsyntax: Macro Primitives.
+* defvar: Define and Set.
* directory-for-each: I/O-Extensions.
* display: Output.
* dld_find_executable: Executable Pathname.
@@ -7725,13 +7752,13 @@ This is an alphabetical list of all the procedures and macros in SCM.
* enclose-array: Conventional Arrays.
* end-of-program: Interrupts.
* endwin: Curses.
-* ENV: Cells. |
+* ENV: Cells.
* errno: Errors.
* error: Errors.
* eval: Evaluation.
* EVAL: Evaluation.
-* eval: Miscellaneous Procedures.
-* eval-string: Miscellaneous Procedures.
+* eval: Eval and Load.
+* eval-string: Eval and Load.
* exec-self: Internal State.
* execl: I/O-Extensions.
* execlp: I/O-Extensions.
@@ -7749,13 +7776,13 @@ This is an alphabetical list of all the procedures and macros in SCM.
* fork: Posix Extensions.
* FPORTP: Ptob Cells.
* free_continuation: Continuations.
-* freshline: Files and Ports.
+* freshline: Port Properties.
* gc: Internal State.
-* gc-hook: Interrupts. |
+* gc-hook: Storage.
* gc_mark: Marking Cells.
* GCCDR: Marking Cells.
* GCTYP16: Marking Cells.
-* gentemp: Syntax Extensions.
+* gentemp: Defmacro.
* get-internal-real-time: Time.
* get-internal-run-time: Time.
* getcwd: I/O-Extensions.
@@ -7764,15 +7791,15 @@ This is an alphabetical list of all the procedures and macros in SCM.
* getgid: Posix Extensions.
* getgr: Posix Extensions.
* getgroups: Posix Extensions.
-* gethost: Host Data.
-* getlogin: Posix Extensions. |
-* getnet: Host Data.
+* gethost: Host and Other Inquiries.
+* getlogin: SCM Session.
+* getnet: Host and Other Inquiries.
* getpeername: Internet Addresses and Socket Names.
* getpid: I/O-Extensions.
* getppid: Posix Extensions.
-* getproto: Host Data.
+* getproto: Host and Other Inquiries.
* getpw: Posix Extensions.
-* getserv: Host Data.
+* getserv: Host and Other Inquiries.
* getsockname: Internet Addresses and Socket Names.
* getuid: Posix Extensions.
* getyx: Input.
@@ -7797,10 +7824,10 @@ This is an alphabetical list of all the procedures and macros in SCM.
* initscr: Curses.
* INPORTP: Ptob Cells.
* int_signal: Signals.
-* integer->line-number: Line Numbers. |
+* integer->line-number: Line Numbers.
* INUM: Immediates.
* INUMP: Immediates.
-* isatty?: Files and Ports.
+* isatty?: Port Properties.
* ISYMCHARS: Immediates.
* ISYMNUM: Immediates.
* ISYMP: Immediates.
@@ -7808,32 +7835,30 @@ This is an alphabetical list of all the procedures and macros in SCM.
* leaveok: Output Options Setting.
* LENGTH: Header Cells.
* line-editing: Line Editing.
-* line-number: Miscellaneous Procedures.
-* line-number->integer: Line Numbers. |
-* line-number?: Line Numbers. |
-* link: Posix Extensions. |
-* list->uniform-array: Uniform Array. |
-* list-file: Miscellaneous Procedures.
+* line-number: Eval and Load.
+* line-number->integer: Line Numbers.
+* line-number?: Line Numbers.
+* link: Posix Extensions.
+* list->uniform-array: Uniform Array.
* load: Dynamic Linking.
-* load-string: Miscellaneous Procedures.
+* load-string: Eval and Load.
+* load:sharp: Modifying Read Syntax. |
* logaref: Uniform Array.
* logaset!: Uniform Array.
* long: Type Conversions.
* long2num: Type Conversions.
-* lstat: Unix Extensions. |
-* macroexpand: Syntax Extensions.
-* macroexpand-1: Syntax Extensions.
+* lstat: Unix Extensions.
+* macroexpand: Defmacro.
+* macroexpand-1: Defmacro.
* main: Embedding SCM.
* makargvfrmstrs: Type Conversions.
* makcclo: Header Cells.
* make-arbiter: Process Synchronization.
-* make-array: Conventional Arrays.
* make-edited-line-port: Line Editing.
-* make-exchanger: Process Synchronization. |
-* make-shared-array: Conventional Arrays.
+* make-exchanger: Process Synchronization.
* make-soft-port: Soft Ports.
* make-stream-socket: Socket.
-* make-stream-socketpair: Socket. |
+* make-stream-socketpair: Socket.
* make_continuation: Continuations.
* make_gsubr: Defining Subrs.
* make_root_continuation: Continuations.
@@ -7848,7 +7873,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
* mark_locations: Marking Cells.
* milli-alarm: Interrupts.
* mkdir: I/O-Extensions.
-* mknod: Unix Extensions. |
+* mknod: Unix Extensions.
* must_free: Allocating memory.
* must_free_argv: Type Conversions.
* must_malloc: Allocating memory.
@@ -7859,7 +7884,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
* NCONSP: Cells.
* NEWCELL: Cells.
* newwin: Window Manipulation.
-* nice: Unix Extensions. |
+* nice: Unix Extensions.
* NIMP: Immediates.
* NINUMP: Immediates.
* nl: Terminal Mode Setting.
@@ -7869,13 +7894,15 @@ This is an alphabetical list of all the procedures and macros in SCM.
* nonl: Terminal Mode Setting.
* noraw: Terminal Mode Setting.
* NSTRINGP: Header Cells.
+* num2dbl: Type Conversions.
* num2long: Type Conversions.
+* num2short: Type Conversions.
* NVECTORP: Header Cells.
-* open-file: Files and Ports.
-* open-input-pipe: Posix Extensions. |
+* open-file: Opening and Closing.
+* open-input-pipe: Posix Extensions.
* open-output-pipe: Posix Extensions.
* open-pipe: Posix Extensions.
-* open-ports: Files and Ports. |
+* open-ports: Opening and Closing.
* opendir: I/O-Extensions.
* OPENP: Ptob Cells.
* OPFPORTP: Ptob Cells.
@@ -7892,35 +7919,34 @@ This is an alphabetical list of all the procedures and macros in SCM.
* pi*: Numeric.
* pi/: Numeric.
* pipe: Posix Extensions.
-* port-closed?: Files and Ports. |
-* port-column: Miscellaneous Procedures.
-* port-filename: Miscellaneous Procedures.
-* port-line: Miscellaneous Procedures.
-* port-type: Files and Ports. |
+* port-closed?: Port Properties.
+* port-column: Port Properties.
+* port-filename: Port Properties.
+* port-line: Port Properties.
+* port-type: Port Properties.
* PORTP: Ptob Cells.
-* print <1>: Miscellaneous Procedures.
* print: Debugging Scheme Code.
* print-args: Debugging Scheme Code.
-* procedure->identifier-macro: Low Level Syntactic Hooks.
-* procedure->macro: Low Level Syntactic Hooks.
-* procedure->memoizing-macro: Low Level Syntactic Hooks.
-* procedure->syntax: Low Level Syntactic Hooks.
-* procedure-documentation: Syntax Extensions.
+* procedure->identifier-macro: Macro Primitives.
+* procedure->macro: Macro Primitives.
+* procedure->memoizing-macro: Macro Primitives.
+* procedure->syntax: Macro Primitives.
+* procedure-documentation: Documentation and Comments.
* profile-alarm: Interrupts.
* profile-alarm-interrupt: Interrupts.
* program-arguments: SCM Session.
* putenv: I/O-Extensions.
-* qase: Syntax Extensions. |
+* qase: Define and Set.
* quit: SCM Session.
* raw: Terminal Mode Setting.
* read-char <1>: Input.
-* read-char: Files and Ports.
-* read-numbered: Line Numbers. |
-* read:sharp: Low Level Syntactic Hooks.
-* read:sharp-char: Low Level Syntactic Hooks.
+* read-char: Port Properties.
+* read-for-load: Line Numbers. |
+* read-numbered: Line Numbers.
+* read:sharp: Modifying Read Syntax. |
* readdir: I/O-Extensions.
-* readlink: Unix Extensions. |
-* record-printer-set!: Records. |
+* readlink: Unix Extensions.
+* record-printer-set!: Records.
* redirect-port!: I/O-Extensions.
* refresh: Window Manipulation.
* regcomp: Regular Expression Pattern Matching.
@@ -7948,28 +7974,30 @@ This is an alphabetical list of all the procedures and macros in SCM.
* scm_evstr: Callbacks.
* scm_find_execpath: Embedding SCM.
* scm_find_implpath: Embedding SCM.
+* scm_gc_protect: Changing Scm.
* scm_init_from_argv: Embedding SCM.
* scm_ldfile: Callbacks.
* scm_ldprog: Callbacks.
* scm_ldstr: Callbacks.
+* scm_protect_temp: Changing Scm.
* scm_top_level: Embedding SCM.
* script_count_argv: Script Support.
* script_find_executable: Script Support.
* script_process_argv: Script Support.
* scroll: Output.
* scrollok: Output Options Setting.
-* serial-array-copy!: Conventional Arrays.
+* serial-array-copy!: Array Mapping.
* serial-array-map!: Array Mapping.
-* set!: Syntax Extensions.
+* set!: Define and Set.
* setegid: Posix Extensions.
* seteuid: Posix Extensions.
* setgid: Posix Extensions.
* setgrent: Posix Extensions.
-* sethostent: Host Data.
-* setnetent: Host Data.
-* setprotoent: Host Data.
+* sethostent: Host and Other Inquiries.
+* setnetent: Host and Other Inquiries.
+* setprotoent: Host and Other Inquiries.
* setpwent: Posix Extensions.
-* setservent: Host Data.
+* setservent: Host and Other Inquiries.
* setuid: Posix Extensions.
* short: Type Conversions.
* SHORT_ALIGN: Continuations.
@@ -7994,12 +8022,11 @@ This is an alphabetical list of all the procedures and macros in SCM.
* STRINGP: Header Cells.
* subwin: Window Manipulation.
* SYMBOLP: Header Cells.
-* symlink: Unix Extensions. |
-* sync: Unix Extensions. |
+* symlink: Unix Extensions.
+* sync: Unix Extensions.
* syntax-quote: Syntactic Hooks for Hygienic Macros.
-* syntax-rules: Syntax Extensions.
+* syntax-rules: Syntax-Rules.
* tanh: Numeric.
-* terms: Miscellaneous Procedures.
* the-macro: Syntactic Hooks for Hygienic Macros.
* throw_to_continuation: Continuations.
* ticks: Interrupts.
@@ -8009,10 +8036,10 @@ This is an alphabetical list of all the procedures and macros in SCM.
* trace: Debugging Scheme Code.
* transpose-array: Conventional Arrays.
* try-arbiter: Process Synchronization.
-* try-create-file: I/O-Extensions. |
-* try-load <1>: Line Numbers. |
-* try-load: Miscellaneous Procedures.
-* try-open-file: Files and Ports.
+* try-create-file: I/O-Extensions.
+* try-load <1>: Line Numbers.
+* try-load: Eval and Load.
+* try-open-file: Opening and Closing.
* ttyname: Posix Extensions.
* TYP16: Cells.
* TYP3: Cells.
@@ -8024,12 +8051,11 @@ This is an alphabetical list of all the procedures and macros in SCM.
* unctrl: Curses Miscellany.
* uniform-array-read!: Uniform Array.
* uniform-array-write: Uniform Array.
-* uniform-vector-fill!: Uniform Array. |
* untrace: Debugging Scheme Code.
* user-interrupt: Interrupts.
* usr:lib: Dynamic Linking.
* utime: I/O-Extensions.
-* vector-set-length!: Miscellaneous Procedures.
+* vector-set-length!: Storage.
* VECTORP: Header Cells.
* VELTS: Header Cells.
* verbose: Internal State.
@@ -8038,7 +8064,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
* vms-debug: SCM Session.
* void: Sweeping the Heap.
* wadd: Output.
-* wait-for-input: Files and Ports.
+* wait-for-input: Port Properties.
* waitpid: Posix Extensions.
* warn: Errors.
* wclear: Output.
@@ -8050,10 +8076,10 @@ This is an alphabetical list of all the procedures and macros in SCM.
* winch: Input.
* winsch: Output.
* winsertln: Output.
-* with-error-to-file: Files and Ports.
-* with-error-to-port: Files and Ports.
-* with-input-from-port: Files and Ports.
-* with-output-to-port: Files and Ports.
+* with-error-to-file: Port Redirection.
+* with-error-to-port: Port Redirection.
+* with-input-from-port: Port Redirection.
+* with-output-to-port: Port Redirection.
* wmove: Window Manipulation.
* wstandend: Curses Miscellany.
* wstandout: Curses Miscellany.
@@ -8071,13 +8097,13 @@ This is an alphabetical list of all the global variables in SCM.
* *execpath: Embedding SCM.
* *interactive* <1>: Internal State.
* *interactive*: SCM Variables.
-* *load-pathname*: Miscellaneous Procedures.
-* *load-reader*: Line Numbers. |
+* *load-pathname*: Eval and Load.
+* *load-reader*: Line Numbers.
* *scm-version*: Internal State.
-* *slib-load-reader*: Line Numbers. |
-* *syntax-rules*: SCM Variables. |
-* af_inet: Host Data.
-* af_unix: Host Data.
+* *slib-load-reader*: Line Numbers.
+* *syntax-rules*: SCM Variables.
+* af_inet: Host and Other Inquiries.
+* af_unix: Host and Other Inquiries.
* BOOL_F: Immediates.
* BOOL_T: Immediates.
* EDITOR: SCM Variables.
@@ -8092,9 +8118,9 @@ This is an alphabetical list of all the global variables in SCM.
* most-positive-fixnum: Numeric.
* NUM_ISPCSYM: Immediates.
* NUM_ISYMS: Immediates.
-* open_both: Files and Ports.
-* open_read: Files and Ports.
-* open_write: Files and Ports.
+* open_both: Opening and Closing.
+* open_read: Opening and Closing.
+* open_write: Opening and Closing.
* pi: Numeric.
* SCHEME_LIBRARY_PATH: SCM Variables.
* SCM_INIT_PATH: SCM Variables.
@@ -8179,7 +8205,7 @@ This is an alphabetical list of data types and feature names in SCM.
* tc7_subr_2: Subr Cells.
* tc7_subr_2o: Subr Cells.
* tc7_subr_3: Subr Cells.
-* tc7_svect: Header Cells. |
+* tc7_svect: Header Cells.
* tc7_uvect: Header Cells.
* tc7_vector: Header Cells.
* tc_dblc: Smob Cells.
@@ -8204,6 +8230,7 @@ Concept Index
* array-for-each: Build Options.
* arrays: Build Options.
* bignums: Build Options.
+* byte: Build Options. |
* callbacks: Callbacks.
* careful-interrupt-masking: Build Options.
* cautious: Build Options.
@@ -8212,32 +8239,34 @@ Concept Index
* continuations: Continuations.
* curses: Build Options.
* debug: Build Options.
-* documentation string: Syntax Extensions.
+* documentation string: Documentation and Comments.
* dump: Build Options.
* dynamic-linking: Build Options.
-* ecache: Memory Management for Environments. |
+* ecache: Memory Management for Environments.
* edit-line: Build Options.
* Embedding SCM: Embedding SCM.
* engineering-notation: Build Options.
-* environments: Memory Management for Environments. |
-* exchanger: Process Synchronization. |
+* environments: Memory Management for Environments.
+* exchanger: Process Synchronization.
* Exrename: Bibliography.
* Extending Scm: Compiling and Linking Custom Files.
* foo.c: Compiling and Linking Custom Files.
* generalized-c-arguments: Build Options.
* graphics: Packages.
-* hobbit: Packages. |
+* hobbit: Packages.
* i/o-extensions: Build Options.
* IEEE: Bibliography.
* inexact: Build Options.
* JACAL: Bibliography.
* lit: Build Options.
* macro: Build Options.
-* memory management: Memory Management for Environments. |
+* memory management: Memory Management for Environments.
* mysql: Build Options.
* no-heap-shrink: Build Options.
-* NO_ENV_CACHE: Memory Management for Environments. |
+* NO_ENV_CACHE: Memory Management for Environments.
* none: Build Options.
+* posix: Posix Extensions.
+* Posix: Posix Extensions.
* posix: Build Options.
* R4RS: Bibliography.
* R5RS: Bibliography.
@@ -8245,6 +8274,8 @@ Concept Index
* record: Build Options.
* regex: Build Options.
* rev2-procedures: Build Options.
+* rope <1>: Type Conversions.
+* rope: Callbacks.
* SchemePrimer: Bibliography.
* SICP: Build Options.
* sicp: Build Options.
@@ -8257,6 +8288,8 @@ Concept Index
* stack-limit: Build Options.
* tick-interrupts: Build Options.
* turtlegr: Build Options.
+* unix: Unix Extensions.
+* Unix: Unix Extensions.
* unix: Build Options.
* windows: Build Options.
* X: Packages.
@@ -8271,113 +8304,126 @@ Concept Index

Tag Table:
-Node: Top203
-Node: Overview1481
-Node: SCM Features1792
-Node: SCM Authors3804
-Node: Copying4742
-Node: Bibliography7831
-Node: Installing SCM9699
-Node: Making SCM10214
-Node: SLIB11131
-Node: Building SCM13149
-Node: Invoking Build13723
-Node: Build Options16516
-Node: Compiling and Linking Custom Files29598
-Node: Installing Dynamic Linking31577
-Node: Configure Module Catalog33361
-Node: Saving Images35358
-Node: Automatic C Preprocessor Definitions36033
-Node: Problems Compiling39541
-Node: Problems Linking41194
-Node: Problems Running41459
-Node: Testing43567
-Node: Reporting Problems46654
-Node: Operational Features47577
-Node: Invoking SCM47941
-Node: SCM Options49585
-Node: Invocation Examples54026
-Node: SCM Variables54978
-Node: SCM Session56487
-Node: Editing Scheme Code58010
-Node: Debugging Scheme Code60153
-Node: Errors63776
-Node: Memoized Expressions68075
-Node: Internal State70439
-Node: Scripting73727
-Node: Unix Scheme Scripts74021
-Node: MS-DOS Compatible Scripts77233
-Node: Unix Shell Scripts79045
-Node: The Language81235
-Node: Standards Compliance81890
-Node: Miscellaneous Procedures84304
-Node: Time87460
-Node: Interrupts88454
-Node: Process Synchronization94464
-Node: Files and Ports97244
-Node: Line Numbers104204
-Node: Soft Ports108304
-Node: Syntax Extensions110296
-Node: Low Level Syntactic Hooks119654
-Node: Syntactic Hooks for Hygienic Macros126507
-Node: Packages133588
-Node: Dynamic Linking134544
-Node: Dump139232
-Node: Numeric143350
-Node: Arrays145077
-Node: Conventional Arrays145366
-Node: Array Mapping152015
-Node: Uniform Array154278
-Node: Bit Vectors160302
-Node: Records161567
-Node: I/O-Extensions163253
-Node: Posix Extensions172179
-Node: Unix Extensions182353
-Node: Regular Expression Pattern Matching184358
-Node: Line Editing188387
-Node: Curses189733
-Node: Output Options Setting190656
-Node: Terminal Mode Setting193305
-Node: Window Manipulation196383
-Node: Output199843
-Node: Input203469
-Node: Curses Miscellany204496
-Node: Sockets205920
-Node: Host Data206244
-Node: Internet Addresses and Socket Names209392
-Node: Socket210926
-Node: The Implementation218163
-Node: Data Types218422
-Node: Immediates219243
-Node: Cells223579
-Node: Header Cells225671
-Node: Subr Cells228892
-Node: Ptob Cells231110
-Node: Smob Cells232649
-Node: Data Type Representations235845
-Node: Operations240503
-Node: Garbage Collection241089
-Node: Marking Cells241710
-Node: Sweeping the Heap243812
-Node: Memory Management for Environments244757
-Node: Signals249314
-Node: C Macros250858
-Node: Changing Scm251981
-Node: Defining Subrs256253
-Node: Defining Smobs258130
-Node: Defining Ptobs261265
-Node: Allocating memory262442
-Node: Embedding SCM264833
-Node: Callbacks272486
-Node: Type Conversions274289
-Node: Continuations277845
-Node: Evaluation282059
-Node: Program Self-Knowledge287222
-Node: File-System Habitat287468
-Node: Executable Pathname291068
-Node: Script Support292686
-Node: Improvements To Make294004
-Node: Finishing Dynamic Linking296036
-Node: Index303782
+Node: Top217
+Node: Overview1471
+Node: SCM Features1782
+Node: SCM Authors3794
+Node: Copying4687
+Node: Bibliography7776
+Node: Installing SCM9644
+Node: Making SCM10159
+Node: SLIB11076
+Node: Building SCM12984
+Node: Invoking Build13558
+Node: Build Options15882
+Node: Compiling and Linking Custom Files31338
+Node: Installing Dynamic Linking33321
+Node: Configure Module Catalog35099
+Node: Saving Images37096
+Node: Automatic C Preprocessor Definitions37771
+Node: Problems Compiling41545
+Node: Problems Linking43198
+Node: Problems Running43463
+Node: Testing45571
+Node: Reporting Problems48635
+Node: Operational Features49477
+Node: Invoking SCM49841
+Node: SCM Options51487
+Node: Invocation Examples55906
+Node: SCM Variables56858
+Node: SCM Session58315
+Node: Editing Scheme Code59830
+Node: Debugging Scheme Code61891
+Node: Errors65514
+Node: Memoized Expressions69813
+Node: Internal State72177
+Node: Scripting75309
+Node: Unix Scheme Scripts75603
+Node: MS-DOS Compatible Scripts78663
+Node: Unix Shell Scripts80641
+Node: The Language82786
+Node: Standards Compliance83404
+Node: Storage85801
+Node: Time88267
+Node: Interrupts89244
+Node: Process Synchronization92854
+Node: Files and Ports94391
+Node: Opening and Closing94724
+Node: Port Properties97193
+Node: Port Redirection99852
+Node: Soft Ports101326
+Node: Eval and Load103105
+Node: Line Numbers104507
+Node: Lexical Conventions107446
+Node: Common-Lisp Read Syntax107764
+Node: Load Syntax110587
+Node: Documentation and Comments112063
+Node: Modifying Read Syntax113388
+Node: Syntax115499
+Node: Define and Set116395
+Node: Defmacro119928
+Node: Syntax-Rules121006
+Node: Macro Primitives122815
+Node: Environment Frames124447
+Node: Syntactic Hooks for Hygienic Macros126853
+Node: Packages133814
+Node: Dynamic Linking134616
+Node: Dump139225
+Node: Numeric143234
+Node: Arrays144961
+Node: Conventional Arrays145171
+Node: Uniform Array148868
+Node: Bit Vectors153661
+Node: Array Mapping154948
+Node: Records157791
+Node: I/O-Extensions158654
+Node: Posix Extensions167248
+Node: Unix Extensions176757
+Node: Regular Expression Pattern Matching178659
+Node: Line Editing182609
+Node: Curses183955
+Node: Output Options Setting184878
+Node: Terminal Mode Setting187527
+Node: Window Manipulation190605
+Node: Output194065
+Node: Input197691
+Node: Curses Miscellany198718
+Node: Sockets200142
+Node: Host and Other Inquiries200481
+Node: Internet Addresses and Socket Names203590
+Node: Socket205139
+Node: The Implementation212376
+Node: Data Types212635
+Node: Immediates213456
+Node: Cells217792
+Node: Header Cells219884
+Node: Subr Cells222925
+Node: Ptob Cells225143
+Node: Smob Cells226682
+Node: Data Type Representations229869
+Node: Operations234567
+Node: Garbage Collection235153
+Node: Marking Cells235774
+Node: Sweeping the Heap237876
+Node: Memory Management for Environments238821
+Node: Signals243378
+Node: C Macros244922
+Node: Changing Scm246045
+Node: Defining Subrs250493
+Node: Defining Smobs252370
+Node: Defining Ptobs255416
+Node: Allocating memory256593
+Node: Embedding SCM258906
+Node: Callbacks266761
+Node: Type Conversions268564
+Node: Continuations272586
+Node: Evaluation276800
+Node: Program Self-Knowledge281963
+Node: File-System Habitat282209
+Node: Executable Pathname285809
+Node: Script Support287427
+Node: Improvements To Make288745
+Node: VMS Dynamic Linking290984
+Node: Index295773

End Tag Table
diff --git a/scm.spec b/scm.spec
index 4be109c..5205315 100644
--- a/scm.spec
+++ b/scm.spec
@@ -1,5 +1,5 @@
%define name scm
-%define version 5d6
+%define version 5d9
%define release 1
%define implpath %{prefix}/lib/scm
# rpm seems to require all on one line, bleah.
@@ -18,7 +18,7 @@ Requires: slib
Summary: SCM Scheme implementation.
Source: ftp://swissnet.ai.mit.edu/pub/scm/scm%{version}.zip
-URL: http://swissnet.ai.mit.edu/~jaffer/SCM.html
+URL: http://swissnet.ai.mit.edu/~jaffer/SCM
BuildRoot: %{_tmppath}/%{name}%{version}
Prefix: /usr
@@ -53,20 +53,21 @@ make clean
export PATH=.:$PATH # to get scmlit in the path.
# Build the executable.
-./build -h system -o udscm5 -l debug -s %{implpath} -F %{features}
+./build -h system -o udscm5 --compiler-options="-O3" -l debug -s %{implpath} -F %{features}
echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm
make check
# Build dlls
make x.so
-./build -h system -F curses -t dll
+./build -h system -F curses -t dll --compiler-options="-O3"
./build -h system -t dll -c sc2.c rgx.c record.c gsubr.c ioext.c posix.c \
- unix.c socket.c ramap.c
-./build -h system -F edit-line -t dll
-./build -h system -F x -t dll
+ unix.c socket.c ramap.c --compiler-options="-O3"
+./build -h system -F edit-line -t dll --compiler-options="-O3"
+./build -h system -F x -t dll --compiler-options="-O3"
# Build libscm.a static library
-./build -h system -F cautious bignums arrays inexact dynamic-linking -t lib
+./build -h system -F cautious bignums arrays inexact dynamic-linking -t lib \
+ --compiler-options="-O3"
%install
mkdir -p ${RPM_BUILD_ROOT}%{prefix}/bin
@@ -143,6 +144,7 @@ rm -f %{prefix}/bin/scm
%{prefix}/lib/scm/hobbit.scm
%{prefix}/lib/scm/scmhob.scm
%{prefix}/lib/scm/scmhob.h
+%{prefix}/lib/scm/patchlvl.h
%{prefix}/lib/scm/build.scm
%{prefix}/lib/scm/build
%{prefix}/lib/scm/Iedline.scm
diff --git a/scm.texi b/scm.texi
index f0cd485..2f87364 100644
--- a/scm.texi
+++ b/scm.texi
@@ -55,7 +55,7 @@ This manual documents the SCM Scheme implementation. SCM version
@value{SCMVERSION} was released @value{SCMDATE}. The most recent
information about SCM can be found on SCM's @dfn{WWW} home page:
-@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM}
Copyright (C) 1990-1999 Free Software Foundation
@@ -84,7 +84,7 @@ by the author.
@menu
* Overview::
-* Installing SCM::
+* Installing SCM:: How to
* Operational Features::
* The Language:: Reference.
* Packages:: Optional Capabilities.
@@ -105,9 +105,9 @@ The most recent information about SCM can be found on SCM's @dfn{WWW}
home page:
@ifset html
-<A HREF="http://swissnet.ai.mit.edu/~jaffer/SCM.html">
+<A HREF="http://swissnet.ai.mit.edu/~jaffer/SCM">
@end ifset
-@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM}
@ifset html
</A>
@end ifset
@@ -174,7 +174,7 @@ timing information printed interactively (the @code{verbose} function).
@section Authors
@table @b
-@item Aubrey Jaffer (jaffer @@ alum.mit.edu)
+@item Aubrey Jaffer (agj @@ alum.mit.edu)
Most of SCM.
@item Radey Shouman
Arrays, @code{gsubr}s, compiled closures, records, Ecache, syntax-rules
@@ -480,34 +480,34 @@ low priority. SLIB is available from the same sites as SCM:
@ifclear html
@itemize @bullet
@item
-swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz
+swissnet.ai.mit.edu:/pub/scm/slib3a1.tar.gz
@item
-ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz
+ftp.gnu.org:/pub/gnu/jacal/slib3a1.tar.gz
@item
-ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz
+ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib3a1.tar.gz
@end itemize
@end ifclear
@ifset html
@itemize @bullet
@item
-<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip">
-http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip
+<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib3a1.zip">
+http://swissnet.ai.mit.edu/ftpdir/scm/slib3a1.zip
</A>
@item
-<A HREF="ftp://ftp.gnu.org/pub/gnu/jacal/slib2d4.tar.gz">
-ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz
+<A HREF="ftp://ftp.gnu.org/pub/gnu/jacal/slib3a1.tar.gz">
+ftp.gnu.org:/pub/gnu/jacal/slib3a1.tar.gz
</A>
@item
-<A HREF="ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2d4.tar.gz">
-ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2d4.tar.gz
+<A HREF="ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib3a1.tar.gz">
+ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib3a1.tar.gz
</A>
@end itemize
@end ifset
@noindent
-Unpack SLIB (@samp{tar xzf slib2d4.tar.gz} or @samp{unzip -ao
-slib2d4.zip}) in an appropriate directory for your system; both
+Unpack SLIB (@samp{tar xzf slib3a1.tar.gz} or @samp{unzip -ao
+slib3a1.zip}) in an appropriate directory for your system; both
@code{tar} and @code{unzip} will create the directory @file{slib}.
@noindent
@@ -518,7 +518,6 @@ file @file{Init@value{SCMVERSION}.scm} is installed).
@example
(define (library-vicinity) "/usr/local/lib/slib/")
-(load (in-vicinity (library-vicinity) "require"))
@end example
@noindent
@@ -533,7 +532,6 @@ implementation-vicinity, which is absolute:
(define library-vicinity
(let ((lv (string-append (implementation-vicinity) "../slib/")))
(lambda () lv)))
-(load (in-vicinity (library-vicinity) "require"))
@end example
@noindent
@@ -647,6 +645,33 @@ The platforms defined by table @dfn{platform} in @file{build.scm} are:
@include platform.txi
@end example
+@deffn {Build Option} -f @var{pathname}
+specifies that the build options contained in @var{pathname} be
+spliced into the argument list at this point. The use of option files
+can separate functional features from platform-specific ones.
+
+The @file{Makefile} calls out builds with the options in @samp{.opt}
+files:
+
+@table @file
+@item dlls.opt
+Options for Makefile targets mydlls, myturtle, and x.so.
+@item gdb.opt
+Options for udgdbscm and gdbscm.
+@item libscm.opt
+Options for libscm.a.
+@item pg.opt
+Options for pgscm, which instruments C functions.
+@item udscm4.opt
+Options for targets udscm4 and myscm4 (scm).
+@item udscm5.opt
+Options for targets udscm5 and myscm5 (scm).
+@end table
+
+The Makefile creates options files it depends on only if they do not
+already exist.
+@end deffn
+
@deffn {Build Option} -o @var{filename}
@deffnx {Build Option} ---outname=@var{filename}
specifies that the compilation should produce an executable or object
@@ -793,7 +818,7 @@ compile and link your file at compile time, use the @samp{-c} and
@samp{-i} options to build:
@example
-bash$ build -c foo.c -i init_foo
+bash$ ./build -c foo.c -i init_foo
@print{}
#! /bin/sh
rm -f scmflags.h
@@ -812,7 +837,7 @@ gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \
To make a dynamically loadable object file use the @code{-t dll} option:
@example
-bash$ build -t dll -c foo.c
+bash$ ./build -t dll -c foo.c
@print{}
#! /bin/sh
rm -f scmflags.h
@@ -840,7 +865,7 @@ in the BSD family (a.out binary format) can usually be ported to
@dfn{DLD}. The @dfn{dl} library (@code{#define SUN_DL} for SCM) was a
proposed POSIX standard and may be available on other machines with
@dfn{COFF} binary format. For notes about porting to MS-Windows and
-finishing the port to VMS @ref{Finishing Dynamic Linking}.
+finishing the port to VMS @ref{VMS Dynamic Linking}.
@noindent
@dfn{DLD} is a library package of C functions that performs @dfn{dynamic
@@ -1006,7 +1031,9 @@ macintosh Macintosh (THINK_C and __MWERKS__ define)
MCH_AMIGA Aztec_c 5.2a on AMIGA
__MACH__ Apple Darwin
MSDOS Microsoft C 5.10 and 6.00A
+_MSDOS Microsoft CLARM and CLTHUMB compilers.
__MSDOS__ Turbo C, Borland C, and DJGPP
+__NetBSD__ NetBSD
nosve Control Data NOS/VE
SVR2 System V Revision 2.
__SVR4 SunOS
@@ -1021,13 +1048,19 @@ vax11c VAX C compiler
VAX11 VAX C compiler
_Windows Borland C 3.1 compiling for Windows
_WIN32 MS VisualC++ 4.2 and Cygwin (Win32 API)
+_WIN32_WCE MS Windows CE
vms (and VMS) VAX-11 C under VMS.
__alpha DEC Alpha processor
__alpha__ DEC Alpha processor
hp9000s800 HP RISC processor
+__ia64 GCC on IA64
+__ia64__ GCC on IA64
+_LONGLONG GCC on IA64
__i386__ DJGPP
i386 DJGPP
+_M_ARM Microsoft CLARM compiler defines as 4 for ARM.
+_M_ARMT Microsoft CLTHUMB compiler defines as 4 for Thumb.
MULTIMAX Encore computer
ppc PowerPC
__ppc__ PowerPC
@@ -1230,7 +1263,7 @@ call-with-current-continuations.
@noindent
Reported problems and solutions are grouped under Compiling, Linking,
Running, and Testing. If you don't find your problem listed there, you
-can send a bug report to @code{jaffer @@ alum.mit.edu}. The bug report
+can send a bug report to @code{agj @@ alum.mit.edu}. The bug report
should include:
@enumerate
@@ -1313,8 +1346,8 @@ on the command line, or from standard input.
This explanation applies to SCMLIT or other builds of SCM.
@noindent
-Scheme-code files can also invoke SCM and its variants. @xref{Syntax
-Extensions, #!}.
+Scheme-code files can also invoke SCM and its variants.
+@xref{Lexical Conventions, #!}.
@node SCM Options, Invocation Examples, Invoking SCM, Operational Features
@section Options
@@ -1345,10 +1378,10 @@ prints version information and exit.
@deffn {Command Option} -r feature
requires @var{feature}. This will load a file from [SLIB] if that
-@var{feature} is not already provided. If @var{feature} is 2, 2rs,
-r2rs, 3, 3rs, r3rs, 4, 4rs, r4rs, 5, 5rs, or r5rs; @code{scm} will
-require the features neccessary to support [R2RS], [R3RS], [R4RS], or
-[R5RS], respectively.
+@var{feature} is not already provided. If @var{feature} is 2, 2rs, or
+r2rs; 3, 3rs, or r3rs; 4, 4rs, or r4rs; 5, 5rs, or r5rs; @code{scm}
+will require the features neccessary to support [R2RS]; [R3RS];
+[R4RS]; or [R5RS], respectively.
@end deffn
@deffn {Command Option} -h feature
@@ -1357,10 +1390,9 @@ provides @var{feature}.
@deffn {Command Option} -l filename
@deffnx {Command Option} -f filename
-loads @var{filename}. @code{Scm} will load the first (unoptioned) file
-named on the command line if no @code{-c}, @code{-e}, @code{-f},
-@code{-l}, or @code{-s} option preceeds
-it.
+loads @var{filename}. @code{Scm} will load the first (unoptioned)
+file named on the command line if no @code{-c}, @code{-e}, @code{-f},
+@code{-l}, or @code{-s} option preceeds it.
@end deffn
@deffn {Command Option} -d filename
@@ -1435,13 +1467,14 @@ are errors.
@end deffn
@deffn {Command Option} -s
-specifies, by analogy with @code{sh}, that further options are to be
-treated as program aguments.
+specifies, by analogy with @code{sh}, that @code{scm} should run
+interactively and that further options are to be treated as program
+aguments.
@end deffn
@deffn {Command Option} -
@deffnx {Command Option} ---
-specifies that there are no more options on the command line.
+specifies that further options are to be treated as program aguments.
@end deffn
@node Invocation Examples, SCM Variables, SCM Options, Operational Features
@@ -1556,6 +1589,11 @@ interactive top-level is not entered.
Returns a list of strings of the arguments scm was called with.
@end defun
+@defun getlogin
+Returns the (login) name of the user logged in on the controlling
+terminal of the process, or #f if this information cannot be determined.
+@end defun
+
@noindent
For documentation of the procedures @code{getenv} and @code{system}
@xref{System Interface, , , slib, SLIB}.
@@ -1583,10 +1621,7 @@ single the single argument @var{filename}.
@table @asis
@item Gnu Emacs:
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:
-
-@center @url{http://simtel.coast.net/SimTel/gnu/demacs.html}
+ending in .scm are automatically put into scheme-mode.
If your Emacs can run a process in a buffer you can use the Emacs
command @samp{M-x run-scheme} with SCM. Otherwise, use the emacs
@@ -2059,7 +2094,7 @@ variable @code{PATH} are @emph{not} searched to find @var{interpreter}.
When executing a shell-script, the operating system invokes
@var{interpreter} with a single argument encapsulating the rest of the
-first line's contents (if if not just whitespace), the pathname of the
+first line's contents (if not just whitespace), the pathname of the
Scheme Script file, and then any arguments which the shell-script was
invoked with.
@@ -2104,25 +2139,25 @@ The following Scheme-Script prints factorial of its argument:
@example
#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
- !#
- ; -*-scheme-*-
-(define (go-script)
- (cond ((not *script*))
- ((and (= 1 (- (length *argv*) *optind*))
- (string->number (list-ref *argv* *optind*)))
- => (lambda (n) (print (fact n))))
- (else
- (print *argv*)
- (display "\
-Usage: fact n
- Returns the factorial of N.
-http://swissnet.ai.mit.edu/~jaffer/SLIB.html
+(define (fact.script args)
+ (cond ((and (= 1 (length args))
+ (string->number (car args)))
+ => (lambda (n) (print (fact n)) #t))
+ (else (fact.usage))))
+
+(define (fact.usage)
+ (print *argv*)
+ (display "\
+Usage: fact N
+ Returns the factorial of N.
"
- (current-error-port))
- (exit #f))))
+ (current-error-port))
+ #f)
(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n)))))
-(go-script)
+
+(if *script* (exit (fact.script (list-tail *argv* *optind*))))
@end example
@example
@@ -2139,10 +2174,8 @@ If the wrong number of arguments is given, @code{fact} prints its
./fact 3 2
@print{}
("./fact" "3" "2")
-Usage: fact n
+Usage: fact N
Returns the factorial of N.
-
-http://swissnet.ai.mit.edu/~jaffer/SLIB.html
@end example
@@ -2152,11 +2185,13 @@ http://swissnet.ai.mit.edu/~jaffer/SLIB.html
@noindent
It turns out that we can create scheme-scripts which run both under unix
and MS-DOS. To implement this, I have written the MS-DOS programs:
-@code{#!.bat} and @code{!#.exe}.
+@code{#!.bat} and @code{!#.exe},
@cindex !#
@cindex !#.exe
@cindex #!
@cindex #!.bat
+which are available from:
+@url{http://swissnet.ai.mit.edu/ftpdir/scm/sharpbang.zip}
@noindent
With these two programs installed in a @code{PATH} directory, we have
@@ -2183,7 +2218,7 @@ executables, @code{#!} tries all directories named by environment
variable @code{PATH}.
Once the @var{interpreter} executable path is found, arguments are
-processed in the manner of scheme-shell, with the all the text after the
+processed in the manner of scheme-shell, with all the text after the
@samp{\} taken as part of the meta-argument. More precisely, @code{#!}
calls @var{interpreter} with any options on the second line of the
Scheme-Script up to @samp{!#}, the name of the Scheme-Script file, and
@@ -2241,25 +2276,24 @@ example.
#! /bin/sh
:;exec scm -e"(set! *script* \"$0\")" -l$0 $*
-(define (go-script)
- (cond ((not *script*))
- ((and (= 1 (- (length *argv*) *optind*))
- (string->number (list-ref *argv* *optind*)))
- => (lambda (n) (print (fact n))))
- (else
- (print *argv*)
- (display "\
-Usage: fact n
- Returns the factorial of N.
+(define (fact.script args)
+ (cond ((and (= 1 (length args))
+ (string->number (car args)))
+ => (lambda (n) (print (fact n)) #t))
+ (else (fact.usage))))
-http://swissnet.ai.mit.edu/~jaffer/SLIB.html
+(define (fact.usage)
+ (print *argv*)
+ (display "\
+Usage: fact N
+ Returns the factorial of N.
"
- (current-error-port))
- (exit #f))))
+ (current-error-port))
+ #f)
(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n)))))
-(go-script)
+(if *script* (exit (fact.script (list-tail *argv* *optind*))))
@end example
@example
@@ -2273,19 +2307,17 @@ http://swissnet.ai.mit.edu/~jaffer/SLIB.html
@menu
* Standards Compliance:: Links to sections in [R5RS] and [SLIB]
-* Miscellaneous Procedures::
+* Storage:: Finalizers, GC-hook, vector-set-length!
* Time:: Both real time and processor time
* Interrupts:: and exceptions
* Process Synchronization:: Because interrupts are preemptive
* Files and Ports::
-* Line Numbers::
-* Soft Ports:: Emulate I/O devices
-* Syntax Extensions::
-* Low Level Syntactic Hooks::
-* Syntactic Hooks for Hygienic Macros::
+* Eval and Load:: and line-numbers
+* Lexical Conventions:: Also called read-syntax
+* Syntax:: Macros
@end menu
-@node Standards Compliance, Miscellaneous Procedures, The Language, The Language
+@node Standards Compliance, Storage, The Language, The Language
@section Standards Compliance
@noindent
@@ -2408,59 +2440,9 @@ See SLIB file @file{Template.scm}.
@xref{Require, , , slib, SLIB}.
@end table
-@node Miscellaneous Procedures, Time, Standards Compliance, The Language
-@section Miscellaneous Procedures
-@defun try-load filename
-If the string @var{filename} names an existing file, the try-load
-procedure reads Scheme source code expressions and definitions from the
-file and evaluates them sequentially and returns @code{#t}. If not,
-try-load returns @code{#f}. The try-load procedure does not affect the
-values returned by @code{current-input-port} and
-@code{current-output-port}.
-@end defun
-
-@defvar *load-pathname*
-Is set to the pathname given as argument to @code{load},
-@code{try-load}, and @code{dyn:link}
-(@pxref{Compiling And Linking, , , hobbit, Hobbit}).
-@code{*load-pathname*} is used to compute the value of
-@ref{Vicinity, program-vicinity, , slib, SLIB}.
-@end defvar
-
-@defun line-number
-Returns the current line number of the file currently being loaded.
-@end defun
-
-@defun port-filename port
-Returns the filename @var{port} was opened with. If @var{port} is
-not open to a file the result is unspecified.
-@end defun
-
-@defun port-line port
-@defunx port-column port
-If @var{port} is a tracked port, return the current line (column) number,
-otherwise return @code{#f}. Line and column numbers begin with 1.
-The column number applies to the next character to be read; if that
-character is a newline, then the column number will be one more than
-the length of the line.
-@end defun
-
-@defun eval obj
-Alias for @ref{System, eval, , slib, SLIB}.
-@end defun
-
-@defun eval-string str
-Returns the result of reading an expression from @var{str} and
-evaluating it. @code{eval-string} does not change
-@code{*load-pathname*} or @code{line-number}.
-@end defun
-
-@defun load-string str
-Reads and evaluates all the expressions from @var{str}. As with
-@code{load}, the value returned is unspecified. @code{load-string} does
-not change @code{*load-pathname*} or @code{line-number}.
-@end defun
+@node Storage, Time, Standards Compliance, The Language
+@section Storage
@defun vector-set-length! object length
Change the length of string, vector, bit-vector, or uniform-array
@@ -2479,25 +2461,50 @@ depend on this feature; @code{copy-tree} could get redefined.
@end defun
@defun acons obj1 obj2 obj3
-Returns (cons (cons obj1 obj2) obj3). The expression (set! a-list
-(acons key datum a-list)) adds a new association to a-list.
-@end defun
+Returns (cons (cons obj1 obj2) obj3).
-@defun terms
-This command displays the GNU General Public License.
-@end defun
+@lisp
+(set! a-list (acons key datum a-list))
+@end lisp
-@defun list-file filename
-Displays the text contents of @var{filename}.
+Adds a new association to a-list.
@end defun
-@deffn Procedure print arg1 @dots{}
-@code{Print} writes all its arguments, separated by spaces.
-@code{Print} outputs a @code{newline} at the end and returns the value
-of the last argument.
+@deffn {Callback procedure} gc-hook @dots{}
+Allows a Scheme procedure to be run shortly after each garbage collection.
+This procedure will not be run recursively. If it runs long enough
+to cause a garbage collection before returning a warning will be
+printed.
+
+To remove the gc-hook, @code{(set! gc-hook #f)}.
@end deffn
-@node Time, Interrupts, Miscellaneous Procedures, The Language
+@defun add-finalizer object finalizer
+@var{object} may be any garbage collected object, that is, any object
+other than an immediate integer, character, or special token such
+as @code{#f} or @code{#t}, @xref{Immediates}. @var{finalizer} is
+a thunk, or procedure taking no arguments.
+
+@var{finalizer} will be invoked asynchronously exactly once some time
+after @var{object} becomes eligible for garbage collection. A reference
+to @var{object} in the environment of @var{finalizer} will not prevent
+finalization, but will delay the reclamation of @var{object} at least
+until the next garbage collection. A reference to @var{object} in some
+other object's finalizer will necessarily prevent finalization until both
+objects are eligible for garbage collection.
+
+Finalizers are not run in any predictable order. All finalizers will be
+run by the time the program ends.
+
+This facility was based on the paper by Simon Peyton Jones, et al,
+``Stretching the storage manager: weak pointers and stable names in
+Haskell'', Proc. 11th International Workshop on the Implementation of
+Functional Languages, The Netherlands, September 7-10 1999,
+Springer-Verlag LNCS.
+@end defun
+
+
+@node Time, Interrupts, Storage, The Language
@section Time
@defvr Constant internal-time-units-per-second
@@ -2610,37 +2617,6 @@ To unestablish a response for an error set the handler symbol to
@code{#f}. For instance, @code{(set! could-not-open #f)}.
@end deffn
-@deffn {Callback procedure} gc-hook @dots{}
-Allows a Scheme procedure to be run shortly after each garbage collection.
-This procedure will not be run recursively. If it runs long enough
-to cause a garbage collection before returning a warning will be
-printed.
-@end deffn
-
-@defun add-finalizer object finalizer
-@var{object} may be any garbage collected object, that is, any object
-other than an immediate integer, character, or special token such
-as @code{#f} or @code{#t}, @xref{Immediates}. @var{finalizer} is
-a thunk, or procedure taking no arguments.
-
-@var{finalizer} will be invoked asynchronously exactly once some time
-after @var{object} becomes eligible for garbage collection. A reference
-to @var{object} in the environment of @var{finalizer} will not prevent
-finalization, but will delay the reclamation of @var{object} at least
-until the next garbage collection. A reference to @var{object} in some
-other object's finalizer will necessarily prevent finalization until both
-objects are eligible for garbage collection.
-
-Finalizers are not run in any predictable order. All finalizers will be
-run by the time the program ends.
-
-This facility was based on the paper by Simon Peyton Jones, et al,
-``Stretching the storage manager: weak pointers and stable names in
-Haskell'', Proc. 11th International Workshop on the Implementation of
-Functional Languages, The Netherlands, September 7-10 1999,
-Springer-Verlag LNCS.
-
-@end defun
@node Process Synchronization, Files and Ports, Interrupts, The Language
@section Process Synchronization
@@ -2699,13 +2675,26 @@ Returns @code{#t} and unlocks @var{arbiter} if @var{arbiter} was locked.
Otherwise, returns @code{#f}.
@end defun
-@node Files and Ports, Line Numbers, Process Synchronization, The Language
+
+
+@node Files and Ports, Eval and Load, Process Synchronization, The Language
@section Files and Ports
@noindent
These procedures generalize and extend the standard capabilities in
@ref{Ports, , ,r5rs, Revised(5) Scheme}.
+
+@menu
+* Opening and Closing::
+* Port Properties::
+* Port Redirection::
+* Soft Ports::
+@end menu
+
+@node Opening and Closing, Port Properties, Files and Ports, Files and Ports
+@subsection Opening and Closing
+
@defun open-file string modes
@defunx try-open-file string modes
Returns a port capable of receiving or delivering characters as
@@ -2752,6 +2741,22 @@ does not already exist. This functionality is provided by calling
for all platforms.
@end defun
+@defun open-ports
+Returns a list of all currently open ports, excluding string ports,
+see @xref{String Ports, , , slib, SLIB}. This may be useful after
+a fork @xref{Posix Extensions}, or for debugging. Bear in mind that
+ports that would be closed by gc will be kept open by a reference to
+this list.
+@end defun
+
+@defun close-port port
+Closes @var{port}. The same as close-input-port and close-output-port.
+@end defun
+
+
+@node Port Properties, Port Redirection, Opening and Closing, Files and Ports
+@subsection Port Properties
+
@defun port-closed? port
Returns #t if @var{port} is closed.
@end defun
@@ -2761,38 +2766,31 @@ If @var{obj} is not a port returns false, otherwise returns
a symbol describing the port type, for example string or pipe.
@end defun
-@defun close-port port
-Closes @var{port}. The same as close-input-port and close-output-port.
-@end defun
-
-@defun current-error-port
-Returns the current port to which diagnostic output is directed.
+@defun port-filename port
+Returns the filename @var{port} was opened with. If @var{port} is
+not open to a file the result is unspecified.
@end defun
-@defun with-error-to-file string thunk
-@var{thunk} must be a procedure of no arguments, and string must be a
-string naming a file. The file is opened for output, an output port
-connected to it is made the default value returned by
-current-error-port, and the @var{thunk} is called with no arguments. When
-the thunk returns, the port is closed and the previous default is
-restored. With-error-to-file returns the value yielded by @var{thunk}.
+@defun port-line port
+@defunx port-column port
+If @var{port} is a tracked port, return the current line (column) number,
+otherwise return @code{#f}. Line and column numbers begin with 1.
+The column number applies to the next character to be read; if that
+character is a newline, then the column number will be one more than
+the length of the line.
@end defun
-@defun with-input-from-port port thunk
-@defunx with-output-to-port port thunk
-@defunx with-error-to-port port thunk
-These routines differ from with-input-from-file, with-output-to-file,
-and with-error-to-file in that the first argument is a port, rather
-than a string naming a file.
+@defun freshline port
+Outputs a newline to optional argument @var{port} unless the current
+output column number of @var{port} is known to be zero, ie output will
+start at the beginning of a new line. @var{port} defaults to
+@code{current-output-port}. If @var{port} is not a tracked port
+@code{freshline} is equivalent to @code{newline}.
@end defun
-@defun call-with-outputs thunk proc
-Calls the @var{thunk} procedure while the current-output-port and
-current-error-port are directed to string-ports. If @var{thunk}
-returns, the @var{proc} procedure is called with the output-string, the
-error-string, and the value returned by @var{thunk}. If @var{thunk}
-does not return a value (perhaps because of error), @var{proc} is called
-with just the output-string and the error-string as arguments.
+@defun isatty? port
+Returns @code{#t} if @var{port} is input or output to a serial non-file
+device.
@end defun
@deffn {procedure} char-ready?
@@ -2836,31 +2834,145 @@ to the list of the value returned by @code{current-input-port}.
@findex current-input-port
@end deffn
-@defun isatty? port
-Returns @code{#t} if @var{port} is input or output to a serial non-file device.
+
+@node Port Redirection, Soft Ports, Port Properties, Files and Ports
+@subsection Port Redirection
+
+@defun current-error-port
+Returns the current port to which diagnostic output is directed.
@end defun
-@defun freshline port
-Outputs a newline to optional argument @var{port} unless the current
-output column number of @var{port} is known to be zero, ie output will
-start at the beginning of a new line. @var{port} defaults to
-@code{current-output-port}. If @var{port} is not a tracked port
-@code{freshline} is equivalent to @code{newline}.
+@defun with-error-to-file string thunk
+@var{thunk} must be a procedure of no arguments, and string must be a
+string naming a file. The file is opened for output, an output port
+connected to it is made the default value returned by
+current-error-port, and the @var{thunk} is called with no arguments. When
+the thunk returns, the port is closed and the previous default is
+restored. With-error-to-file returns the value yielded by @var{thunk}.
@end defun
-@defun open-ports
-Returns a list of all currently open ports, excluding string ports,
-see @xref{String Ports, , , slib, SLIB}. This may be useful after
-a fork @xref{Posix Extensions}, or for debugging. Bear in mind that
-ports that would be closed by gc will be kept open by a reference to
-this list.
+@defun with-input-from-port port thunk
+@defunx with-output-to-port port thunk
+@defunx with-error-to-port port thunk
+These routines differ from with-input-from-file, with-output-to-file,
+and with-error-to-file in that the first argument is a port, rather
+than a string naming a file.
@end defun
+@defun call-with-outputs thunk proc
+Calls the @var{thunk} procedure while the current-output-port and
+current-error-port are directed to string-ports. If @var{thunk}
+returns, the @var{proc} procedure is called with the output-string, the
+error-string, and the value returned by @var{thunk}. If @var{thunk}
+does not return a value (perhaps because of error), @var{proc} is called
+with just the output-string and the error-string as arguments.
+@end defun
+
+
+@node Soft Ports, , Port Redirection, Files and Ports
+@subsection Soft Ports
+
+@noindent
+A @dfn{soft-port} is a port based on a vector of procedures capable of
+accepting or delivering characters. It allows emulation of I/O ports.
+
+@defun make-soft-port vector modes
+Returns a port capable of receiving or delivering characters as
+specified by the @var{modes} string (@pxref{Files and Ports,
+open-file}). @var{vector} must be a vector of length 6. Its components
+are as follows:
+
+@enumerate 0
+@item
+procedure accepting one character for output
+@item
+procedure accepting a string for output
+@item
+thunk for flushing output
+@item
+thunk for getting one character
+@item
+thunk for closing port (not by garbage collection)
+@end enumerate
-@node Line Numbers, Soft Ports, Files and Ports, The Language
-@section Line Numbers
+For an output-only port only elements 0, 1, 2, and 4 need be
+procedures. For an input-only port only elements 3 and 4 need be
+procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful
+operation for them to perform.
-Scheme code define by load may optionally contain line number
+If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input,
+eof-object?, ,r5rs, Revised(5) Scheme}) it indicates that the port has
+reached end-of-file. For example:
+
+If it is necessary to explicitly close the port when it is garbage
+collected, (@pxref{Interrupts, add-finalizer}).
+
+@example
+(define stdout (current-output-port))
+(define p (make-soft-port
+ (vector
+ (lambda (c) (write c stdout))
+ (lambda (s) (display s stdout))
+ (lambda () (display "." stdout))
+ (lambda () (char-upcase (read-char)))
+ (lambda () (display "@@" stdout)))
+ "rw"))
+
+(write p p) @result{} #<input-output-soft#\space45d10#\>
+@end example
+@end defun
+
+
+
+@node Eval and Load, Lexical Conventions, Files and Ports, The Language
+@section Eval and Load
+
+@defun try-load filename
+If the string @var{filename} names an existing file, the try-load
+procedure reads Scheme source code expressions and definitions from the
+file and evaluates them sequentially and returns @code{#t}. If not,
+try-load returns @code{#f}. The try-load procedure does not affect the
+values returned by @code{current-input-port} and
+@code{current-output-port}.
+@end defun
+
+@defvar *load-pathname*
+Is set to the pathname given as argument to @code{load},
+@code{try-load}, and @code{dyn:link}
+(@pxref{Compiling And Linking, , , hobbit, Hobbit}).
+@code{*load-pathname*} is used to compute the value of
+@ref{Vicinity, program-vicinity, , slib, SLIB}.
+@end defvar
+
+@defun eval obj
+Alias for @ref{System, eval, , slib, SLIB}.
+@end defun
+
+@defun eval-string str
+Returns the result of reading an expression from @var{str} and
+evaluating it. @code{eval-string} does not change
+@code{*load-pathname*} or @code{line-number}.
+@end defun
+
+@defun load-string str
+Reads and evaluates all the expressions from @var{str}. As with
+@code{load}, the value returned is unspecified. @code{load-string} does
+not change @code{*load-pathname*} or @code{line-number}.
+@end defun
+
+@defun line-number
+Returns the current line number of the file currently being loaded.
+@end defun
+
+
+@menu
+* Line Numbers::
+@end menu
+
+@node Line Numbers, , Eval and Load, Eval and Load
+@subsection Line Numbers
+
+Scheme code defined by load may optionally contain line number
information. Currently this information is used only for reporting
expansion time errors, but in the future run-time error messages may
also include line number information.
@@ -2881,10 +2993,18 @@ equivalent to the vector. The meaning of s-expressions with
line-numbers in other positions is undefined.
@defun read-numbered port
-Behaves like @code{read}, except that every s-expression read will be
+Behaves like @code{read}, except that
+
+@itemize bullet
+@item
+Load (read) sytnaxes are enabled.
+@item
+every s-expression read will be
replaced with a cons of a line-number object and the sexp actually read.
This replacement is done only if @var{port} is a tracked port
See @xref{Files and Ports}.
+@end itemize
+
@end defun
@defun integer->line-number int
@@ -2900,6 +3020,10 @@ Returns the value of line-number object @var{linum} as an integer.
Returns true if and only if @var{obj} is a line-number object.
@end defun
+@defun read-for-load port
+Behaves like @code{read}, except that load syntaxes are enabled.
+@end defun
+
@defvar *load-reader*
@defvarx *slib-load-reader*
The value of @code{*load-reader*} should be a value acceptable as
@@ -2913,61 +3037,102 @@ In order to disable all line-numbering, it is sufficient to set!
@end defvar
-@node Soft Ports, Syntax Extensions, Line Numbers, The Language
-@section Soft Ports
+@node Lexical Conventions, Syntax, Eval and Load, The Language
+@section Lexical Conventions
-@noindent
-A @dfn{soft-port} is a port based on a vector of procedures capable of
-accepting or delivering characters. It allows emulation of I/O ports.
-@defun make-soft-port vector modes
-Returns a port capable of receiving or delivering characters as
-specified by the @var{modes} string (@pxref{Files and Ports,
-open-file}). @var{vector} must be a vector of length 6. Its components
-are as follows:
+@menu
+* Common-Lisp Read Syntax::
+* Load Syntax::
+* Documentation and Comments::
+* Modifying Read Syntax::
+@end menu
-@enumerate 0
-@item
-procedure accepting one character for output
-@item
-procedure accepting a string for output
-@item
-thunk for flushing output
-@item
-thunk for getting one character
-@item
-thunk for closing port (not by garbage collection)
-@end enumerate
+@node Common-Lisp Read Syntax, Load Syntax, Lexical Conventions, Lexical Conventions
+@subsection Common-Lisp Read Syntax
-For an output-only port only elements 0, 1, 2, and 4 need be
-procedures. For an input-only port only elements 3 and 4 need be
-procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful
-operation for them to perform.
+@deffn {Read syntax} #\token
+If @var{token} is a sequence of two or more digits, then this syntax is
+equivalent to @code{#.(integer->char (string->number token 8))}.
-If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input,
-eof-object?, ,r5rs, Revised(5) Scheme}) it indicates that the port has
-reached end-of-file. For example:
+If @var{token} is @code{C-}, @code{c-}, or @code{^} followed by a
+character, then this syntax is read as a control character. If
+@var{token} is @code{M-} or @code{m-} followed by a character, then a
+meta character is read. @code{c-} and @code{m-} prefixes may be
+combined.
+@end deffn
-If it is necessary to explicitly close the port when it is garbage
-collected, (@pxref{Interrupts, add-finalizer}).
+@deffn {Read syntax} #+ feature form
+If feature is @code{provided?} (by @code{*features*}) then @var{form} is
+read as a scheme expression. If not, then @var{form} is treated as
+whitespace.
-@example
-(define stdout (current-output-port))
-(define p (make-soft-port
- (vector
- (lambda (c) (write c stdout))
- (lambda (s) (display s stdout))
- (lambda () (display "." stdout))
- (lambda () (char-upcase (read-char)))
- (lambda () (display "@@" stdout)))
- "rw"))
+Feature is a boolean expression composed of symbols and @code{and},
+@code{or}, and @code{not} of boolean expressions.
-(write p p) @result{} #<input-output-soft#\space45d10#\>
+For more information on @code{provided?} and @code{*features*},
+@xref{Require, , , slib, SLIB}.
+@end deffn
+
+@deffn {Read syntax} #- feature form
+is equivalent to @code{#+(not feature) expression}.
+@end deffn
+
+@deffn {Read syntax} #| any thing |#
+Is a balanced comment. Everything up to the matching @code{|#} is
+ignored by the @code{read}. Nested @code{#|@dots{}|#} can occur inside
+@var{any thing}.
+@end deffn
+
+@noindent
+@dfn{Load sytax} is Read syntax enabled for @code{read} only when that
+@code{read} is part of loading a file or string. This distinction was
+made so that reading from a datafile would not be able to corrupt a
+scheme program using @samp{#.}.
+
+@deffn {Load syntax} #. expression
+Is read as the object resulting from the evaluation of @var{expression}.
+This substitution occurs even inside quoted structure.
+
+In order to allow compiled code to work with @code{#.} it is good
+practice to define those symbols used inside of @var{expression} with
+@code{#.(define @dots{})}. For example:
+
+@example
+#.(define foo 9) @result{} #<unspecified>
+'(#.foo #.(+ foo foo)) @result{} (9 18)
@end example
-@end defun
+@end deffn
+
+@deffn {Load syntax} #' form
+is equivalent to @var{form} (for compatibility with common-lisp).
+@end deffn
+
+
+@node Load Syntax, Documentation and Comments, Common-Lisp Read Syntax, Lexical Conventions
+@subsection Load Syntax
+
+@noindent
+@dfn{#!} is the unix mechanism for executing scripts.
+See @ref{Unix Scheme Scripts} for the full description of how this
+comment supports scripting.
-@node Syntax Extensions, Low Level Syntactic Hooks, Soft Ports, The Language
-@section Syntax Extensions
+@deffn {Load syntax} #?line
+@deffnx {Load syntax} #?column
+Return integers for the current line and column being read during a
+load.
+@end deffn
+
+@deffn {Load syntax} #?file
+Returns the string naming the file currently being loaded. This path
+is the string passed to @code{load}, possibly with @samp{.scm}
+appended.
+@end deffn
+
+
+
+@node Documentation and Comments, Modifying Read Syntax, Load Syntax, Lexical Conventions
+@subsection Documentation and Comments
@deffn {procedure} procedure-documentation proc
Returns the documentation string of @var{proc} if it exists, or
@@ -2992,69 +3157,91 @@ internal definitions) is a string, then that string is the
@defun comment string1 @dots{}
Appends @var{string1} @dots{} to the strings given as arguments to
previous calls @code{comment}.
+
@defunx comment
Returns the (appended) strings given as arguments to previous calls
@code{comment} and empties the current string collection.
@end defun
-@deffn {Read syntax} #;text-till-end-of-line
+@deffn {Load syntax} #;text-till-end-of-line
Behaves as @code{(comment "@var{text-till-end-of-line}")}.
@end deffn
-@deffn {Read syntax} #. expression
-Is read as the object resulting from the evaluation of @var{expression}.
-This substitution occurs even inside quoted structure.
-In order to allow compiled code to work with @code{#.} it is good
-practice to define those symbols used inside of @var{expression} with
-@code{#.(define @dots{})}. For example:
-@example
-#.(define foo 9) @result{} #<unspecified>
-'(#.foo #.(+ foo foo)) @result{} (9 18)
-@end example
-@end deffn
+@node Modifying Read Syntax, , Documentation and Comments, Lexical Conventions
+@subsection Modifying Read Syntax
-@deffn {Read syntax} #+ feature form
-If feature is @code{provided?} (by @code{*features*}) then @var{form} is
-read as a scheme expression. If not, then @var{form} is treated as
-whitespace.
-
-Feature is a boolean expression composed of symbols and @code{and},
-@code{or}, and @code{not} of boolean expressions.
+@deffn {Callback procedure} read:sharp c port
+If a @key{#} followed by a character (for a non-standard syntax) is
+encountered by @code{read}, @code{read} will call the value of the
+symbol @code{read:sharp} with arguments the character and the port being
+read from. The value returned by this function will be the value of
+@code{read} for this expression unless the function returns
+@code{#<unspecified>} in which case the expression will be treated as
+whitespace. @code{#<unspecified>} is the value returned by the
+expression @code{(if #f #f)}.
-For more information on @code{provided?} and @code{*features*},
-@xref{Require, , , slib, SLIB}.
+@deffnx {Callback procedure} load:sharp c port
+Dispatches like @code{read:sharp}, but only during @code{load}s. The
+read-syntaxes handled by @code{load:sharp} are a superset of those
+handled by @code{read:sharp}. @code{load:sharp} calls
+@code{read:sharp} if none of its syntaxes match @var{c}.
@end deffn
-@deffn {Read syntax} #- feature form
-is equivalent to @code{#+(not feature) expression}.
+@deffn {Callback procedure} char:sharp token
+If the sequence @key{#\} followed by a non-standard character name is
+encountered by @code{read}, @code{read} will call the value of the
+symbol @code{char:sharp} with the token (a string of length at
+least two) as argument. If the value returned is a character, then that
+will be the value of @code{read} for this expression, otherwise an error
+will be signaled.
@end deffn
-@deffn {Read syntax} #' form
-is equivalent to @var{form} (for compatibility with common-lisp).
-@end deffn
+@emph{Note:} When adding new @key{#} syntaxes, have your code save the
+previous value of @code{load:sharp}, @code{read:sharp}, or
+@code{char:sharp} when defining it. Call this saved value if an
+invocation's syntax is not recognized. This will allow @code{#+},
+@code{#-}, and @ref{Uniform Array}s to still be supported (as they
+dispatch from @code{read:sharp}).
-@deffn {Read syntax} #| any thing |#
-Is a balanced comment. Everything up to the matching @code{|#} is
-ignored by the @code{read}. Nested @code{#|@dots{}|#} can occur inside
-@var{any thing}.
-@end deffn
-@noindent
-A similar read syntax @dfn{#!} (exclamation rather than vertical bar) is
-supported for Posix shell-scripts (@pxref{Scripting}).
-@deffn {Read syntax} #\token
-If @var{token} is a sequence of two or more digits, then this syntax is
-equivalent to @code{#.(integer->char (string->number token 8))}.
+@node Syntax, , Lexical Conventions, The Language
+@section Syntax
-If @var{token} is @code{C-}, @code{c-}, or @code{^} followed by a
-character, then this syntax is read as a control character. If
-@var{token} is @code{M-} or @code{m-} followed by a character, then a
-meta character is read. @code{c-} and @code{m-} prefixes may be
-combined.
-@end deffn
+SCM provides a native implementation of @dfn{defmacro}.
+@xref{Defmacro, , , slib, SLIB}.
+
+When built with @samp{-F macro} build option (@pxref{Build Options}) and
+@samp{*syntax-rules*} is non-false, SCM also supports [R5RS]
+@code{syntax-rules} macros. @xref{Macros, , ,r5rs, Revised(5) Scheme}.
+
+Other Scheme Syntax Extension Packages from SLIB can be employed through
+the use of @samp{macro:eval} and @samp{macro:load}; Or by using the SLIB
+read-eval-print-loop:
+
+@example
+(require 'repl)
+(repl:top-level macro:eval)
+@end example
+
+With the appropriate catalog entries
+(@pxref{Library Catalogs, , , slib, SLIB}), files using macro
+packages will automatically use the correct macro loader when
+@samp{require}d.
+
+@menu
+* Define and Set::
+* Defmacro::
+* Syntax-Rules::
+* Macro Primitives::
+* Environment Frames::
+* Syntactic Hooks for Hygienic Macros::
+@end menu
+
+@node Define and Set, Defmacro, Syntax, Syntax
+@subsection Define and Set
@defspec defined? symbol
Equivalent to @code{#t} if @var{symbol} is a syntactic keyword (such as
@@ -3069,7 +3256,7 @@ 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. @code{defconst} is valid only
+@var{identifier}'s value is not changed. @code{defvar} is valid only
when used at top-level.
@end defspec
@@ -3145,15 +3332,19 @@ expansion. @code{defconst} constants should be defined before use.
(else 'consonant)) ==> consonant
}
@end format
-
@end defspec
+
+
+@node Defmacro, Syntax-Rules, Define and Set, Syntax
+@subsection Defmacro
+
@noindent
@findex defmacro
@findex macroexpand
@findex macroexpand-1
@findex gentemp
-SCM also supports the following constructs from Common Lisp:
+SCM supports the following constructs from Common Lisp:
@code{defmacro}, @code{macroexpand}, @code{macroexpand-1}, and
@code{gentemp}. @xref{Defmacro, , , slib, SLIB}.
@@ -3187,6 +3378,10 @@ For example:
(let1 not legal syntax) @error{} not "does not match" ((name value))
@end lisp
+
+@node Syntax-Rules, Macro Primitives, Defmacro, Syntax
+@subsection Syntax-Rules
+
@findex syntax-rules
SCM supports [R5RS] @code{syntax-rules} macros
@xref{Macros, , ,r5rs, Revised(5) Scheme}.
@@ -3241,34 +3436,9 @@ For example:
(set! eight 9) @result{} ERROR
@end lisp
-@node Low Level Syntactic Hooks, Syntactic Hooks for Hygienic Macros, Syntax Extensions, The Language
-@section Low Level Syntactic Hooks
-
-@deffn {Callback procedure} read:sharp c port
-If a @key{#} followed by a character (for a non-standard syntax) is
-encountered by @code{read}, @code{read} will call the value of the
-symbol @code{read:sharp} with arguments the character and the port being
-read from. The value returned by this function will be the value of
-@code{read} for this expression unless the function returns
-@code{#<unspecified>} in which case the expression will be treated as
-whitespace. @code{#<unspecified>} is the value returned by the
-expression @code{(if #f #f)}.
-@end deffn
-
-@deffn {Callback procedure} read:sharp-char token
-If the sequence @key{#\} followed by a non-standard character name is
-encountered by @code{read}, @code{read} will call the value of the
-symbol @code{read:sharp-char} with the token (a string of length at
-least two) as argument. If the value returned is a character, then that
-will be the value of @code{read} for this expression, otherwise an error
-will be signaled.
-@end deffn
-@emph{Note:} When adding new @key{#} syntaxes, have your code save the
-previous value of @code{read:sharp} or @code{read:sharp-char} when
-defining it. Call this saved value if an invocation's syntax is not
-recognized. This will allow @code{#+}, @code{#-}, @code{#!}, and
-@ref{Uniform Array}s to still be supported (as they use @code{read:sharp}).
+@node Macro Primitives, Environment Frames, Syntax-Rules, Syntax
+@subsection Macro Primitives
@defun procedure->syntax proc
Returns a @dfn{macro} which, when a symbol defined to this value appears
@@ -3310,6 +3480,10 @@ purpose may not result in @var{name} being interpreted as a macro
keyword.
@end defspec
+
+@node Environment Frames, Syntactic Hooks for Hygienic Macros, Macro Primitives, Syntax
+@subsection Environment Frames
+
An @dfn{environment} is a list of frames representing lexical bindings.
Only the names and scope of the bindings are included in environments
passed to macro expanders -- run-time values are not included.
@@ -3391,8 +3565,8 @@ Thus a mutable environment can be treated as both a list and local
bindings.
@end defspec
-@node Syntactic Hooks for Hygienic Macros, , Low Level Syntactic Hooks, The Language
-@section Syntactic Hooks for Hygienic Macros
+@node Syntactic Hooks for Hygienic Macros, , Environment Frames, Syntax
+@subsection Syntactic Hooks for Hygienic Macros
SCM provides a synthetic identifier type for efficient implementation of
hygienic macros (for example, @code{syntax-rules} @pxref{Macros, , ,
@@ -3432,7 +3606,8 @@ Returns the symbol obtained by recursively extracting the parent of
@var{id}, which must be an identifier.
@end defun
-@subsection Use of synthetic identifiers
+@subsection Use of Synthetic Identifiers
+
@code{renamed-identifier} may be used as a replacement for @code{gentemp}:
@lisp
(define gentemp
@@ -3931,22 +4106,25 @@ is not real.
@menu
* Conventional Arrays::
-* Array Mapping:: array-for-each
* Uniform Array::
* Bit Vectors::
+* Array Mapping:: array-for-each
@end menu
-@node Conventional Arrays, Array Mapping, Arrays, Arrays
+@node Conventional Arrays, Uniform Array, Arrays, Arrays
@subsection Conventional Arrays
+The following syntax and procedures are SCM extensions to feature
+@code{array} in @ref{Arrays, , , slib, SLIB}.
+
@dfn{Arrays} read and write as a @code{#} followed by the @dfn{rank}
@cindex array
(number of dimensions) followed by the character #\a or #\A and what
appear as lists (of lists) of elements. The lists must be nested to the
depth of the rank. For each depth, all lists must be the same length.
@example
-(make-array 'ho 3 3) @result{}
-#2A((ho ho ho) (ho ho ho) (ho ho ho))
+(create-array '#(ho) 4 3) @result{}
+#2A((ho ho ho) (ho ho ho) (ho ho ho) (ho ho ho))
@end example
The rank may be elided, in which case it is read as one.
@@ -3954,60 +4132,11 @@ The rank may be elided, in which case it is read as one.
'#A(a b c) @equiv{} '#(a b c)
@end example
-Unshared conventional (not uniform) 0-based arrays of rank 1 (dimension)
-are equivalent to (and can't be distinguished from) vectors.
-@example
-(make-array 'ho 3) @result{} #(ho ho ho)
-@end example
-
-When constructing an array, @var{bound} is either an inclusive range of
-indices expressed as a two element list, or an upper bound expressed
-as a single integer. So
-@example
-(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2))
-@end example
-
-@defun array? obj
-Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.
-@end defun
-
-@defun make-array initial-value bound1 bound2 @dots{}
-Creates and returns an array that has as many dimensions as there are
-@var{bound}s and fills it with @var{initial-value}.
-@end defun
-
-@defun array-ref array index1 index2 @dots{}
-Returns the @var{index1}, @var{index2}, @dots{}'th element of
-@var{array}.
-@end defun
-
-@defun array-in-bounds? array index1 index2 @dots{}
-Returns @code{#t} if its arguments would be acceptable to @var{array-ref}.
-@end defun
-
-@defun array-set! array new-value index1 index2 @dots{}
-Sets the @var{index1}, @var{index2}, @dots{}'th element of @var{array}
-to @var{new-value}. The value returned by @code{array-set!} is
-unspecified.
-@end defun
-
-@defun make-shared-array array mapper bound1 bound2 @dots{}
-@code{make-shared-array} can be used to create shared subarrays of other
-arrays. The @var{mapper} is a function that translates coordinates in
-the new array into coordinates in the old array. A @var{mapper} must be
-linear, and its range must stay within the bounds of the old array, but
-it can be otherwise arbitrary. A simple example:
+Unshared, conventional (not uniform) 0-based arrays of rank 1 are
+equivalent to (and can't be distinguished from) scheme vectors.
@example
-(define fred (make-array #f 8 8))
-(define freds-diagonal
- (make-shared-array fred (lambda (i) (list i i)) 8))
-(array-set! freds-diagonal 'foo 3)
-(array-ref fred 3 3) @result{} foo
-(define freds-center
- (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))
-(array-ref freds-center 0 0) @result{} foo
+(create-array '#(ho) 3) @result{} #(ho ho ho)
@end example
-@end defun
@defun transpose-array array dim0 dim1 @dots{}
Returns an array sharing contents with @var{array}, but with dimensions
@@ -4055,132 +4184,26 @@ examples:
@end example
@end defun
-@defun array-shape array
-Returns a list of inclusive bounds of integers.
-@example
-(array-shape (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) (0 4))
-@end example
-@end defun
-
-@defun array-dimensions array
-@code{Array-dimensions} is similar to @code{array-shape} but replaces
-elements with a @code{0} minimum with one greater than the maximum. So:
-@example
-(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)
-@end example
-@end defun
-
-@defun array-rank obj
-Returns the number of dimensions of @var{obj}. If @var{obj} is not an
-array, @code{0} is returned.
-@end defun
-
@defun array->list array
Returns a list consisting of all the elements, in order, of @var{array}.
In the case of a rank-0 array, returns the single element.
@end defun
-@defun array-copy! source destination
-Copies every element from vector or array @var{source} to the
-corresponding element of @var{destination}. @var{destination} must have
-the same rank as @var{source}, and be at least as large in each
-dimension. The order of copying is unspecified.
-@end defun
-
-@defun serial-array-copy! source destination
-Same as @code{array-copy!} but guaranteed to copy in row-major order.
-@end defun
-
-@defun array-fill! array fill
-Stores @var{fill} in every element of @var{array}. The value returned
-is unspecified.
-@end defun
-
-@defun array-equal? array0 array1 @dots{}
-Returns @code{#t} iff all arguments are arrays with the same shape, the
-same type, and have corresponding elements which are either
-@code{equal?} or @code{array-equal?}. This function differs from
-@code{equal?} in that a one dimensional shared array may be
-@var{array-equal?} but not @var{equal?} to a vector or uniform vector.
-@end defun
-
@defun array-contents array
@defunx array-contents array strict
-If @var{array} may be @dfn{unrolled} into a one dimensional shared array
-without changing their order (last subscript changing fastest), then
-@code{array-contents} returns that shared array, otherwise it returns
-@code{#f}. All arrays made by @var{make-array} and
-@var{create-array} may be unrolled, some arrays made by
-@var{make-shared-array} may not be.
+If @var{array} may be @dfn{unrolled} into a one dimensional shared
+array without changing their order (last subscript changing fastest),
+then @code{array-contents} returns that shared array, otherwise it
+returns @code{#f}. All arrays made by @var{create-array} may be
+unrolled, some arrays made by @var{make-shared-array} may not be.
If the optional argument @var{strict} is provided, a shared array will
be returned only if its elements are stored internally contiguous in
memory.
@end defun
-@node Array Mapping, Uniform Array, Conventional Arrays, Arrays
-@subsection Array Mapping
-@code{(require 'array-for-each)}
-@ftindex array-for-each
-
-@defun array-map! array0 proc array1 @dots{}
-
-If @var{array1}, @dots{} are arrays, they must have the same number of
-dimensions as @var{array0} and have a range for each index which
-includes the range for the corresponding index in @var{array0}.
-If they are scalars, that is, not arrays, vectors, or strings, then
-they will be converted internally to arrays of the appropriate shape.
-@var{proc} is applied to each tuple of elements of @var{array1} @dots{}
-and the result is stored as the corresponding element in @var{array0}.
-The value returned is unspecified. The order of application is
-unspecified.
-
-@end defun
-
-@defun serial-array-map! array0 proc array1 @dots{}
-Same as @var{array-map!}, but guaranteed to apply @var{proc} in
-row-major order.
-@end defun
-
-@defun array-for-each proc array0 @dots{}
-@var{proc} is applied to each tuple of elements of @var{array0} @dots{}
-in row-major order. The value returned is unspecified.
-@end defun
-
-@defun array-index-map! array proc
-applies @var{proc} to the indices of each element of @var{array} in
-turn, storing the result in the corresponding element. The value
-returned and the order of application are unspecified.
-
-One can implement @var{array-indexes} as
-@example
-(define (array-indexes array)
- (let ((ra (apply make-array #f (array-shape array))))
- (array-index-map! ra (lambda x x))
- ra))
-@end example
-Another example:
-@example
-(define (apl:index-generator n)
- (let ((v (make-vector n 1)))
- (array-index-map! v (lambda (i) i))
- v))
-@end example
-@end defun
-
-@defun scalar->array scalar array prototype
-Returns a uniform array of the same shape as @var{array}, having only
-one shared element, which is @code{eqv?} to @var{scalar}.
-If the optional argument @var{prototype} is supplied it will be used
-as the prototype for the returned array. Otherwise the returned array
-will be of the same type as @code{array} if that is possible, and
-a conventional array if it is not. This function is used internally
-by @code{array-map!} and friends to handle scalar arguments.
-@end defun
-
-
-@node Uniform Array, Bit Vectors, Array Mapping, Arrays
+@node Uniform Array, Bit Vectors, Conventional Arrays, Arrays
@subsection Uniform Array
@noindent
@@ -4260,19 +4283,6 @@ If @var{rank} is zero, @var{lst}, which need not be a list, is the
single element of the returned array.
@end defun
-@defun uniform-vector-fill! uve fill
-Stores @var{fill} in every element of @var{uve}. The value returned is
-unspecified.
-@end defun
-
-@defun dimensions->uniform-array dims prototype fill
-@defunx dimensions->uniform-array dims prototype
-Creates and returns a uniform array or vector of type corresponding to
-@var{prototype} with dimensions @var{dims} or length @var{length}. If
-the @var{fill} argument is supplied, the returned array is filled with
-this value.
-@end defun
-
@defun uniform-array-read! ura
@defunx uniform-array-read! ura port
Attempts to read all elements of @var{ura}, in lexicographic order, as
@@ -4321,7 +4331,7 @@ if the array element is not an exact integer or if @var{val} is not
boolean.
@end defun
-@node Bit Vectors, , Uniform Array, Arrays
+@node Bit Vectors, Array Mapping, Uniform Array, Arrays
@subsection Bit Vectors
@noindent
@@ -4370,6 +4380,74 @@ Returns
@var{bv} is not modified.
@end defun
+
+@node Array Mapping, , Bit Vectors, Arrays
+@subsection Array Mapping
+
+@code{(require 'array-for-each)}
+@ftindex array-for-each
+
+SCM has some extra functions in feature @code{array-for-each}:
+
+@defun array-fill! array fill
+Stores @var{fill} in every element of @var{array}. The value returned
+is unspecified.
+@end defun
+
+@defun serial-array-copy! source destination
+Same as @code{array-copy!} but guaranteed to copy in row-major order.
+@end defun
+
+@defun array-equal? array0 array1 @dots{}
+Returns @code{#t} iff all arguments are arrays with the same shape, the
+same type, and have corresponding elements which are either
+@code{equal?} or @code{array-equal?}. This function differs from
+@code{equal?} in that a one dimensional shared array may be
+@var{array-equal?} but not @var{equal?} to a vector or uniform vector.
+@end defun
+
+@defun array-map! array0 proc array1 @dots{}
+If @var{array1}, @dots{} are arrays, they must have the same number of
+dimensions as @var{array0} and have a range for each index which
+includes the range for the corresponding index in @var{array0}. If
+they are scalars, that is, not arrays, vectors, or strings, then they
+will be converted internally to arrays of the appropriate shape.
+@var{proc} is applied to each tuple of elements of @var{array1}
+@dots{} and the result is stored as the corresponding element in
+@var{array0}. The value returned is unspecified. The order of
+application is unspecified.
+
+Handling non-array arguments is a SCM extension of
+@ref{Array Mapping, array-map!, , slib, SLIB}
+@end defun
+
+@defun serial-array-map! array0 proc array1 @dots{}
+Same as @var{array-map!}, but guaranteed to apply @var{proc} in
+row-major order.
+@end defun
+
+@defun array-map prototype proc array1 array2 @dots{}
+@var{array2}, @dots{} must have the same number of dimensions as
+@var{array1} and have a range for each index which includes the
+range for the corresponding index in @var{array1}. @var{proc} is
+applied to each tuple of elements of @var{array1}, @var{array2},
+@dots{} and the result is stored as the corresponding element in a
+new array of type @var{prototype}. The new array is returned. The
+order of application is unspecified.
+@end defun
+
+@defun scalar->array scalar array prototype
+@defunx scalar->array scalar array
+Returns a uniform array of the same shape as @var{array}, having only
+one shared element, which is @code{eqv?} to @var{scalar}.
+If the optional argument @var{prototype} is supplied it will be used
+as the prototype for the returned array. Otherwise the returned array
+will be of the same type as @code{array} if that is possible, and
+a conventional array if it is not. This function is used internally
+by @code{array-map!} and friends to handle scalar arguments.
+@end defun
+
+
@node Records, I/O-Extensions, Arrays, Packages
@section Records
@@ -4498,12 +4576,11 @@ closed,, @code{closedir} returns a @code{#f}.
@end defun
@defun directory-for-each proc directory
-The @var{list}s must be lists, and @var{proc} must be a procedure taking
-one argument. @samp{Directory-For-Each} applies @var{proc} to the
-(string) name of each file in @var{directory}. The dynamic order in
-which @var{proc} is applied to the elements of the @var{list}s is
-unspecified. The value returned by @samp{directory-for-each} is
-unspecified.
+@var{proc} must be a procedure taking one argument.
+@samp{Directory-For-Each} applies @var{proc} to the (string) name of
+each file in @var{directory}. The dynamic order in which @var{proc} is
+applied to the filenames is unspecified. The value returned by
+@samp{directory-for-each} is unspecified.
@defunx directory-for-each proc directory pred
Applies @var{proc} only to those filenames for which the procedure
@@ -4515,7 +4592,7 @@ Applies @var{proc} only to those filenames for which
(@pxref{Filenames, , , slib, SLIB}).
@example
-(require 'directory-for-each)
+(require 'directory)
(directory-for-each print "." "[A-Z]*.scm")
@print{}
"Init.scm"
@@ -4657,6 +4734,8 @@ Interface, getenv, , slib, SLIB}).
@node Posix Extensions, Unix Extensions, I/O-Extensions, Packages
@section Posix Extensions
+@cindex Posix
+@cindex posix
@noindent
If @code{'posix} is provided (by linking in @file{posix.o}), the
following functions are defined:
@@ -4718,11 +4797,6 @@ Returns the process ID of the parent of the current process.
For a process's own ID @xref{I/O-Extensions, getpid}.
@end defun
-@defun getlogin
-Returns the (login) name of the user logged in on the controlling
-terminal of the process, or #f if this information cannot be determined.
-@end defun
-
@defun getuid
Returns the real user ID of this process.
@end defun
@@ -4974,6 +5048,8 @@ string containing the file name of termainal device; otherwise
@node Unix Extensions, Regular Expression Pattern Matching, Posix Extensions, Packages
@section Unix Extensions
+@cindex Unix
+@cindex unix
@noindent
If @code{'unix} is provided (by linking in @file{unix.o}), the following
functions are defined:
@@ -5613,13 +5689,13 @@ to most of the C @dfn{socket} library. For more information on sockets,
@xref{Sockets, , , libc, The GNU C Library Reference Manual}.
@menu
-* Host Data::
+* Host and Other Inquiries::
* Internet Addresses and Socket Names::
* Socket::
@end menu
-@node Host Data, Internet Addresses and Socket Names, Sockets, Sockets
-@subsection Host Data, Network, Protocol, and Service Inquiries
+@node Host and Other Inquiries, Internet Addresses and Socket Names, Sockets, Sockets
+@subsection Host and Other Inquiries
@defvr Constant af_inet
@defvrx Constant af_unix
@@ -5728,7 +5804,7 @@ between calls to getserv. Otherwise, the table stays open. When
called without an argument, the service table is closed.
@end defun
-@node Internet Addresses and Socket Names, Socket, Host Data, Sockets
+@node Internet Addresses and Socket Names, Socket, Host and Other Inquiries, Sockets
@subsection Internet Addresses and Socket Names
@defun inet:string->address string
@@ -6620,7 +6696,7 @@ synchronization object. @xref{Process Synchronization}.
@end deftp
@deftp smob tc16_macro
-macro expanding function. @xref{Low Level Syntactic Hooks}.
+macro expanding function. @xref{Macro Primitives}.
@end deftp
@deftp smob tc16_array
@@ -6676,15 +6752,15 @@ contin .........long length....G0111101 .............*regs..............
specfun ................xxxxxxxxG1111111 ...........SCM name.............
cclo ..short length..xxxxxx10G1111111 ...........SCM **elts...........}
@r{ PTOBs:}
-@t{ port 0bwroxxxxxxxxG0110111 ..........FILE *stream..........
- socket ttttttt 00001xxxxxxxxG0110111 ..........FILE *stream..........
- inport uuuuuuuuuuU00011xxxxxxxxG0110111 ..........FILE *stream..........
-outport 0000000000000101xxxxxxxxG0110111 ..........FILE *stream..........
- ioport uuuuuuuuuuU00111xxxxxxxxG0110111 ..........FILE *stream..........
-fport 00 00000000G0110111 ..........FILE *stream..........
-pipe 00 00000001G0110111 ..........FILE *stream..........
-strport 00 00000010G0110111 ..........FILE *stream..........
-sfport 00 00000011G0110111 ..........FILE *stream..........}
+@t{ port int portnum.CwroxxxxxxxxG0110111 ..........FILE *stream..........
+ socket int portnum.C001xxxxxxxxG0110111 ..........FILE *stream..........
+ inport int portnum.C011xxxxxxxxG0110111 ..........FILE *stream..........
+outport int portnum.0101xxxxxxxxG0110111 ..........FILE *stream..........
+ ioport int portnum.C111xxxxxxxxG0110111 ..........FILE *stream..........
+fport int portnum.C 00000000G0110111 ..........FILE *stream..........
+pipe int portnum.C 00000001G0110111 ..........FILE *stream..........
+strport 00000000000.0 00000010G0110111 ..........FILE *stream..........
+sfport int portnum.C 00000011G0110111 ..........FILE *stream..........}
@r{ SUBRs:}
@t{ spare 010001x1
spare 010011x1
@@ -6823,6 +6899,9 @@ object is freed. If the type header of smob is collected, the smob's
@node Memory Management for Environments, Signals, Garbage Collection, Operations
@subsection Memory Management for Environments
+@ifset html
+<A NAME="ecache"></A>
+@end ifset
@cindex memory management
@cindex environments
@cindex ecache
@@ -6979,7 +7058,7 @@ that this constraint is satisfied @code{#define CAREFUL_INTS} in
@subsection C Macros
-@defmac ASSERT cond arg pos subr
+@defmac ASRTER cond arg pos subr
signals an error if the expression (@var{cond}) is 0. @var{arg} is the
offending object, @var{subr} is the string naming the subr, and
@var{pos} indicates the position or type of error. @var{pos} can be one
@@ -7006,14 +7085,14 @@ of
@item a C string @code{(char *)}
@end itemize
-Error checking is not done by @code{ASSERT} if the flag @code{RECKLESS}
+Error checking is not done by @code{ASRTER} if the flag @code{RECKLESS}
is defined. An error condition can still be signaled in this case with
a call to @code{wta(arg, pos, subr)}.
@end defmac
@defmac ASRTGO cond label
@code{goto} @var{label} if the expression (@var{cond}) is 0. Like
-@code{ASSERT}, @code{ASRTGO} does is not active if the flag
+@code{ASRTER}, @code{ASRTGO} does is not active if the flag
@code{RECKLESS} is defined.
@end defmac
@@ -7049,13 +7128,21 @@ address of the local @code{SCM} variable to @emph{any} procedure also
protects it. The procedure @code{scm_protect_temp} is provided for
this purpose.
+@deftypefun void scm_protect_temp (SCM *@var{ptr})
+Forces the SCM object @var{ptr} to be saved on the C-stack, where it
+will be traced for GC.
+@end deftypefun
+
@noindent
Also, if you maintain a static pointer to some (non-immediate)
@code{SCM} object, you must either make your pointer be the value cell
-of a symbol (see @code{errobj} for an example) or make your pointer be
-one of the @code{sys_protects} (see @code{dynwinds} for an example).
-The former method is prefered since it does not require any changes to
-the SCM distribution.
+of a symbol (see @code{errobj} for an example) or (permanently) add
+your pointer to @code{sys_protects} using:
+
+@deftypefun SCM scm_gc_protect (SCM @var{obj})
+Permanently adds @var{obj} to a table of objects protected from
+garbage collection. @code{scm_gc_protect} returns @var{obj}.
+@end deftypefun
@noindent
To add a C routine to scm:
@@ -7178,7 +7265,8 @@ add @code{case:} clause to @code{ceval()} near @code{i_quasiquote} (in
New syntax can now be added without recompiling SCM by the use of the
@code{procedure->syntax}, @code{procedure->macro},
@code{procedure->memoizing-macro}, and @code{defmacro}. For details,
-@xref{Syntax Extensions}.
+@xref{Syntax}.
+
@node Defining Subrs, Defining Smobs, Changing Scm, Operations
@subsection Defining Subrs
@@ -7557,9 +7645,9 @@ Here is a minimal embedding program @file{libtest.c}:
/* include patchlvl.h for SCM's INIT_FILE_NAME. */
#include "patchlvl.h"
-void init_user_scm()
+void libtest_init_user_scm()
@{
- fputs("This is init_user_scm\n", stderr); fflush(stderr);
+ fputs("This is libtest_init_user_scm\n", stderr); fflush(stderr);
sysintern("*the-string*", makfrom0str("hello world\n"));
@}
@@ -7578,6 +7666,7 @@ int main(argc, argv)
SCM retval;
char *implpath, *execpath;
+ init_user_scm = libtest_init_user_scm;
execpath = dld_find_executable(argv[0]);
fprintf(stderr, "dld_find_executable(%s): %s\n", argv[0], execpath);
implpath = find_impl_file(execpath, "scm", INIT_FILE_NAME, dirsep);
@@ -7593,7 +7682,7 @@ int main(argc, argv)
@print{}
dld_find_executable(./libtest): /home/jaffer/scm/libtest
implpath: /home/jaffer/scm/Init@value{SCMVERSION}.scm
-This is init_user_scm
+This is libtest_init_user_scm
hello world
@end example
@@ -7602,6 +7691,7 @@ hello world
@subsection Callbacks
@cindex callbacks
+@cindex rope
@noindent
SCM now has routines to make calling back to Scheme procedures easier.
The source code for these routines are found in @file{rope.c}.
@@ -7653,9 +7743,12 @@ can use a wrapper like this for your Scheme procedures:
@noindent
Calls to procedures so wrapped will return even if an error occurs.
+
+
@node Type Conversions, Continuations, Callbacks, Operations
@subsection Type Conversions
+@cindex rope
These type conversion functions are very useful for connecting SCM and C
code. Most are defined in @file{rope.c}.
@@ -7672,19 +7765,21 @@ To convert integer numbers of smaller types (@code{short} or
@deftypefun long num2long (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
@deftypefunx unsigned long num2ulong (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
+@deftypefunx short num2short (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
@deftypefunx unsigned short num2ushort (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
@deftypefunx unsigned char num2uchar (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
+@deftypefunx double num2dbl (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
These functions are used to check and convert @code{SCM} arguments to
the named C type. The first argument @var{num} is checked to see it it
is within the range of the destination type. If so, the converted
-number is returned. If not, the @code{ASSERT} macro calls @code{wta}
+number is returned. If not, the @code{ASRTER} macro calls @code{wta}
with @var{num} and strings @var{pos} and @var{s_caller}. For a listing
of useful predefined @var{pos} macros, @xref{C Macros}.
-@emph{Note:} Inexact numbers are accepted only by @code{num2long} and
-@code{num2ulong} (for when @code{SCM} is compiled without bignums). To
-convert inexact numbers to exact numbers, @xref{Numerical operations,
-inexact->exact, , r5rs, Revised(5) Scheme}.
+@emph{Note:} Inexact numbers are accepted only by @code{num2dbl},
+@code{num2long}, and @code{num2ulong} (for when @code{SCM} is compiled
+without bignums). To convert inexact numbers to exact numbers,
+@xref{Numerical operations, inexact->exact, , r5rs, Revised(5) Scheme}.
@end deftypefun
@deftypefun unsigned long scm_addr (SCM @var{args}, char *@var{s_name})
@@ -7696,10 +7791,17 @@ any messages from error calls by @code{scm_addr}.
@code{scm_addr} is useful for performing C operations on strings or
other uniform arrays (@pxref{Uniform Array}).
-@emph{Note:} While you use a pointer returned from @code{scm_addr} you
-must keep a pointer to the associated @code{SCM} object in a stack
-allocated variable or GC-protected location in order to assure that SCM
-does not reuse that storage before you are done with it.
+@deftypefunx unsigned long scm_base_addr(SCM @var{ra}, char *@var{s_name})
+Returns a pointer (cast to an @code{unsigned long}) to the beginning
+of storage of array @var{ra}. Note that if @var{ra} is a
+shared-array, the strorage accessed this way may be much larger than
+@var{ra}.
+
+@emph{Note:} While you use a pointer returned from @code{scm_addr} or
+@code{scm_base_addr} you must keep a pointer to the associated
+@code{SCM} object in a stack allocated variable or GC-protected
+location in order to assure that SCM does not reuse that storage
+before you are done with it. @xref{Changing Scm, scm_gc_protect}.
@end deftypefun
@deftypefun SCM makfrom0str (char *@var{src})
@@ -8178,20 +8280,18 @@ the interpreter to instead always look up the values of the associated
symbols.
@end quotation
+@item
+Scott Schwartz <schwartz@@galapagos.cse.psu.edu> suggests: One way to
+tidy up the dynamic loading stuff would be to grab the code from perl5.
+
@end itemize
@menu
-* Finishing Dynamic Linking::
+* VMS Dynamic Linking:: Finishing the job.
@end menu
-@node Finishing Dynamic Linking, , Improvements To Make, Improvements To Make
-@subsection Finishing Dynamic Linking
-
-@noindent
-Scott Schwartz <schwartz@@galapagos.cse.psu.edu> suggests: One way to
-tidy up the dynamic loading stuff would be to grab the code from perl5.
-
-@subsubheading VMS
+@node VMS Dynamic Linking, , Improvements To Make, Improvements To Make
+@subsection VMS Dynamic Linking
@noindent
George Carrette (gjc@@mitech.com) outlines how to dynamically link on
@@ -8329,113 +8429,6 @@ modify and relink @file{LISPLIB.EXE} without having to relink programs
that have been linked against it.
@end enumerate
-@subsubheading Windows NT
-@noindent
-George Carrette (gjc@@mitech.com) outlines how to dynamically link on
-Windows NT:
-
-@itemize @bullet
-@item
-The Software Developers Kit has a sample called SIMPLDLL.
-Here is the gist of it, following along the lines of the VMS description
-above (contents of a makefile for the SDK NMAKE)
-
-@format
-@t{LISPLIB.exp:
-LISPLIB.lib: LISPLIB.def
- $(implib) -machine:$(CPU) -def:LISPLIB.def -out:LISPLIB.lib
-
-LISPLIB.DLL : $(LISPLIB_OBJS) LISPLIB.EXP
- $(link) $(linkdebug) \
- -dll \
- -out:LISPLIB.DLL \
- LISPLIB.EXP $(LISPLIB_OBJS) $(conlibsdll)}
-@end format
-
-@item
-The @file{LISPDEF.DEF} file has this:
-
-@format
-@t{LIBRARY lisplib
-EXPORT
- init_lisp
- init_repl}
-@end format
-
-@item
-And @file{MAIN.EXE} using:
-
-@format
-@t{CLINK = $(link) $(ldebug) $(conflags) -out:$*.exe $** $(conlibsdll)
-
-MAIN.EXE : MAIN.OBJ LISPLIB.LIB
- $(CLINK)}
-@end format
-
-@item
-And @file{MYSUBRS.DLL} is produced using:
-
-@format
-@t{mysubrs.exp:
-mysubrs.lib: mysubrs.def
- $(implib) -machine:$(CPU) -def:MYSUBRS.def -out:MYSUBRS.lib
-
-mysubrs.dll : mysubrs.obj mysubrs.exp mysubrs.lib
- $(link) $(linkdebug) \
- -dll \
- -out:mysubrs.dll \
- MYSUBRS.OBJ MYSUBRS.EXP LISPLIB.LIB $(conlibsdll)}
-@end format
-
-@item
-Where @file{MYSUBRS.DEF} has
-
-@format
-@t{LIBRARY mysubrs
-EXPORT
- INIT_MYSUBRS}
-@end format
-
-@item
-And the dynamic loader looks something like this, calling the two
-procedures @code{LoadLibrary} and @code{GetProcAddress}.
-
-@format
-@t{LISP share_image_load(LISP fname)
-@{long iflag;
- LISP retval,(*fcn)(void);
- HANDLE hLib;
- DWORD err;
- char *libname,fcnname[64];
- iflag = nointerrupt(1);
- libname = c_string(fname);
- _snprintf(fcnname,sizeof(fcnname),"INIT_%s",libname);
- if (!(hLib = LoadLibrary(libname)))
- @{err = GetLastError();
- retval = list2(fname,LSPNUM(err));
- serror1("library failed to load",retval);@}
- if (!(fcn = (LISP (*)(void)) GetProcAddress(hLib,fcnname)))
- @{err = GetLastError();
- retval = list2(fname,LSPNUM(err));
- serror1("could not find library init procedure",retval);@}
- retval = (*fcn)();
- nointerrupt(iflag);
- return(retval);@}}
-@end format
-
-@item
-@emph{Note:} in VMS the linker and dynamic loader is case sensitive, but
-all the language compilers, including C, will by default upper-case
-external symbols for use by the linker, although the debugger gets its
-own symbols and case sensitivity is language mode dependant. In Windows
-NT things are case sensitive generally except for file and device names,
-which are case canonicalizing like in the Symbolics filesystem.
-
-@item
-@emph{Also:} All this WINDOWS NT stuff will work in MS-DOS MS-Windows
-3.1 too, by a method of compiling and linking under Windows NT, and then
-copying various files over to MS-DOS/WINDOWS.
-@end itemize
@node Index, , The Implementation, Top
diff --git a/scmfig.h b/scmfig.h
index a87e928..3e4b531 100644
--- a/scmfig.h
+++ b/scmfig.h
@@ -52,6 +52,46 @@
# endif
#endif
+/* MS Windows signal handling hack added by Rainer Urian */
+/*
+ SCM crashes on WindowsNT after hitting control-c.
+
+ This is because signal handling in windows console applications is
+ rather different from unix apps. If control-c is hit on a console
+ application Windows creates a new thread which executes the
+ control-c signal handler. Now, if the SCM handler does the longjmp
+ back to the repl loop it does it via the stack of the signal
+ handler thread which results always ever is an access violation.
+
+ The solution to this problem is to let the signal handler thread
+ raise a software interrupt in the main thread.
+
+ This is done with the following steps:
+
+ 1. contol-c is hit
+
+ 2. Windows creates the signal handler thread which in turn executes
+ the routine win32_sigint as its signal handler.
+
+ 3. The handler suspends the main thread and gets the main threads
+ register context.
+
+ 4. The handler simulates an interrupt call on the main thread by
+ pointing Eip to the sigintstub stub function and also simulates a
+ pushad , pushf of the main threads registers
+
+ 5. The handler resumes the main thread which when scheduled will
+ execute sigintstub, which in turn calls the proper signal interupt
+ (scamble_signal)
+*/
+#ifdef _WIN32
+/* POCKETCONSOLE has the signal handler implemented in the runtime */
+# ifndef POCKETCONSOLE
+# define WINSIGNALS
+# endif
+#endif
+
+
#include "scmflags.h" /* user specified, system independent flags */
/* IMPLINIT is the full pathname (surrounded by double quotes) of
@@ -241,6 +281,10 @@ rgx.c init_rgx(); regcomp and regexec. */
#ifdef __alpha
# define SHORT_INT
#endif
+#ifdef __ia64
+# define SHORT_INT
+# define CDR_DOUBLES
+#endif
#ifdef MSDOS /* Microsoft C 5.10 and 6.00A */
# ifndef GO32
# define SHORT_INT
@@ -273,9 +317,16 @@ rgx.c init_rgx(); regcomp and regexec. */
#ifdef MSDOS
# define STDC_HEADERS
#endif
+
+#ifdef POCKETCONSOLE
+# define NOSETBUF
+# define LACK_FTIME
+#endif
+
#ifdef vms
# define STDC_HEADERS
#endif
+
#ifdef nosve
# define STDC_HEADERS
#endif
@@ -637,8 +688,12 @@ extern ints_infot *ints_info;
#endif
#ifndef macintosh
-# ifdef __WINDOWS__ /* there should be a better flag for this. */
-# define PROT386
+# ifndef _M_ARM
+# ifndef _M_ARMT
+# ifdef __WINDOWS__ /* there should be a better flag for this. */
+# define PROT386
+# endif
+# endif
# endif
#endif
@@ -721,7 +776,12 @@ typedef SCM *SCMPTR;
# define SCM_INTERRUPTED(errno) (0)
#endif
-#define SYSCALL(line) do{errno = 0;line}while(SCM_INTERRUPTED(errno))
+#ifdef _WIN32
+// Windows doesn't set errno = EINTR
+# define SYSCALL(line) do{ line; while(GetLastError() == ERROR_OPERATION_ABORTED){SetLastError(0);Sleep(10);line};}while(0)
+#else
+# define SYSCALL(line) do{errno = 0;line}while(SCM_INTERRUPTED(errno))
+#endif
#ifdef EMFILE
# ifdef ENFILE
diff --git a/scmmain.c b/scmmain.c
index ce2d000..7e501fa 100644
--- a/scmmain.c
+++ b/scmmain.c
@@ -47,12 +47,19 @@
# include <floatingpoint.h>
#endif
+#ifdef _WIN32
+# include <io.h>
+#endif
+
#include "scm.h"
#include "patchlvl.h"
#ifdef __IBMC__
# include <io.h>
#endif
+#ifdef __NetBSD__
+# include <unistd.h>
+#endif
#ifdef __OpenBSD__
# include <unistd.h>
#endif
@@ -68,6 +75,7 @@ char *scm_find_implpath(execpath)
{
char *implpath = 0;
#ifndef nosve
+# ifndef POCKETCONSOLE
char *getenvpath = getenv(INIT_GETENV);
/* fprintf(stderr, "%s=%s\n", INIT_GETENV, getenvpath); fflush(stderr); */
if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L);
@@ -80,6 +88,7 @@ char *scm_find_implpath(execpath)
fputs("\") not found; Trying elsewhere\n", stderr);
}
}
+# endif
#endif
if (!implpath && execpath)
implpath = find_impl_file(execpath, GENERIC_NAME, INIT_FILE_NAME, dirsep);
@@ -90,6 +99,12 @@ char *scm_find_implpath(execpath)
}
char *generic_name[] = { GENERIC_NAME };
+#ifdef WINSIGNALS
+SCM_EXPORT HANDLE scm_hMainThread;
+#endif
+
+void scmmain_init_user_scm();
+
int main(argc, argv)
int argc;
char **argv;
@@ -102,10 +117,19 @@ int main(argc, argv)
#ifdef __FreeBSD__
fp_prec_t fpspec;
#endif
+
+#ifdef WINSIGNALS
+ /* need a handle to access the main thread from the signal handler thread */
+ DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(),
+ &scm_hMainThread, 0, TRUE, DUPLICATE_SAME_ACCESS);
+#endif
+
/* {char ** argvv = argv; */
/* for (;*argvv;argvv++) {fputs(*argvv, stderr); fputs(" ", stderr);} */
/* fputs("\n", stderr);} */
+ init_user_scm = scmmain_init_user_scm;
+
if (0==argc) {argc = 1; argv = generic_name;} /* for macintosh */
#ifndef LACK_SBRK
init_sbrk(); /* Do this before malloc()s. */
@@ -162,7 +186,7 @@ int main(argc, argv)
/* init_user_scm() is called by the scheme procedure
SCM_INIT_EXTENSIONS in "Init5xx.scm" */
-void init_user_scm()
+void scmmain_init_user_scm()
{
/* Put calls to your C initialization routines here. */
}
diff --git a/script.c b/script.c
index 5cbe10f..e186eb9 100644
--- a/script.c
+++ b/script.c
@@ -155,34 +155,6 @@ char *script_find_executable(name)
}
#endif /* unix */
-#ifdef MSDOS
-# define DEFAULT_PATH "C:\\DOS"
-# define PATH_DELIMITER ';'
-# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '\\') \
- || (fname[0] && (fname[1] == ':')))
-
-char *dld_find_executable(file)
- const char *file;
-{
- /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */
- return scm_cat_path(0L, file, 0L);
-}
-#endif /* def MSDOS */
-
-#ifdef __IBMC__
-# define PATH_DELIMITER ';'
-# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') \
- || (fname[0] == '\\') \
- || (fname[0] && (fname[1] == ':')))
-
-char *dld_find_executable(file)
- const char *file;
-{
- /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */
- return scm_cat_path(0L, file, 0L);
-}
-#endif /* def __IBMC__ */
-
/* Given dld_find_executable()'s best guess for the pathname of this
executable, find (and verify the existence of) initname in the
implementation-vicinity of this program. Returns a newly allocated
@@ -420,3 +392,16 @@ int script_count_argv(argv)
while (argv[argc]) argc++;
return argc;
}
+
+#ifdef __IBMC__
+# define MSDOS
+#endif
+
+#ifdef MSDOS
+char *dld_find_executable(file)
+ const char *file;
+{
+ /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */
+ return scm_cat_path(0L, file, 0L);
+}
+#endif /* def MSDOS */
diff --git a/socket.c b/socket.c
index 5c0aa7b..290de2f 100644
--- a/socket.c
+++ b/socket.c
@@ -48,8 +48,8 @@
#include "scm.h"
#ifdef macintosh
-#define SOCKETDEFS
-#include "macsocket.h"
+# define SOCKETDEFS
+# include "macsocket.h"
#endif
#include <sys/types.h>
@@ -72,6 +72,9 @@
# ifdef __OpenBSD__
# include <unistd.h>
# endif
+# ifdef __NetBSD__
+# include <unistd.h>
+# endif
#endif /* STDC_HEADERS */
static char s_inetaddr[] = "inet:string->address";
@@ -79,7 +82,7 @@ SCM l_inetaddr (host)
SCM host;
{
struct in_addr soka;
- ASSERT(NIMP(host) && STRINGP(host), host, ARG1, s_inetaddr);
+ ASRTER(NIMP(host) && STRINGP(host), host, ARG1, s_inetaddr);
soka.s_addr = inet_addr(CHARS(host));
if (-1==soka.s_addr) {
struct hostent *entry;
@@ -247,15 +250,15 @@ SCM l_servinfo(args)
}
name = CAR(args);
proto = CDR(args);
- ASSERT(NIMP(proto) && CONSP(proto), args, WNA, s_servinfo);
+ ASRTER(NIMP(proto) && CONSP(proto), args, WNA, s_servinfo);
proto = CAR(proto);
- ASSERT(NIMP(proto) && STRINGP(proto), args, ARG2, s_servinfo);
+ ASRTER(NIMP(proto) && STRINGP(proto), args, ARG2, s_servinfo);
DEFER_INTS;
if (NIMP(name) && STRINGP(name)) {
SYSCALL(entry = getservbyname(CHARS(name), CHARS(proto)););
}
else {
- ASSERT(INUMP(proto), proto, ARG1, s_servinfo);
+ ASRTER(INUMP(proto), proto, ARG1, s_servinfo);
SYSCALL(entry = getservbyport(INUM(proto), CHARS(proto)););
}
comlab: ALLOW_INTS;
@@ -303,9 +306,9 @@ SCM l_socket(fam, proto)
int sd, j, tp = INUM(fam);
FILE* f;
SCM port;
- ASSERT(INUMP(fam), fam, ARG1, s_socket);
+ ASRTER(INUMP(fam), fam, ARG1, s_socket);
if UNBNDP(proto) proto = INUM0;
- else ASSERT(INUMP(proto), proto, ARG2, s_socket);
+ else ASRTER(INUMP(proto), proto, ARG2, s_socket);
NEWCELL(port);
DEFER_INTS;
SYSCALL(sd = socket(tp, SOCK_STREAM, INUM(proto)););
@@ -326,7 +329,7 @@ SCM l_socket(fam, proto)
#else
sd = setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, &j, sizeof(j));
#endif
- ASSERT(!sd, port, "could not set socket option", s_socket);
+ ASRTER(!sd, port, "could not set socket option", s_socket);
}
return port;
}
@@ -338,9 +341,9 @@ SCM l_socketpair(fam, proto)
int sv[2];
FILE* f[2];
SCM port[2];
- ASSERT(INUMP(fam), fam, ARG1, s_socketpair);
+ ASRTER(INUMP(fam), fam, ARG1, s_socketpair);
if UNBNDP(proto) proto = INUM0;
- else ASSERT(INUMP(proto), proto, ARG2, s_socketpair);
+ else ASRTER(INUMP(proto), proto, ARG2, s_socketpair);
NEWCELL(port[0]); NEWCELL(port[1]);
DEFER_INTS;
SYSCALL(sts = socketpair(tp, SOCK_STREAM, INUM(proto), sv););
@@ -368,8 +371,8 @@ SCM l_shutdown(port, how)
SCM port, how;
{
int sts;
- ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_shutdown);
- ASSERT(INUMP(how) && 0 <= INUM(how) && 2 >= INUM(how),
+ ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_shutdown);
+ ASRTER(INUMP(how) && 0 <= INUM(how) && 2 >= INUM(how),
how, ARG2, s_shutdown);
SYSCALL(sts = shutdown(fileno(STREAM(port)), INUM(how)););
if (sts) return BOOL_F;
@@ -390,14 +393,14 @@ SCM l_connect (sockpt, address, arg)
{
long flags;
int sts;
- ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_connect);
+ ASRTER(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_connect);
switch SOCKTYP(sockpt) {
default:
- ASSERT(0, sockpt, s_unkfam, s_connect);
+ ASRTER(0, sockpt, s_unkfam, s_connect);
case AF_INET:
- ASSERT(NIMP(arg) && CONSP(arg) && NULLP(CDR(arg)), arg, WNA, s_connect);
+ ASRTER(NIMP(arg) && CONSP(arg) && NULLP(CDR(arg)), arg, WNA, s_connect);
arg = CAR(arg);
- ASSERT(INUMP(arg), arg, ARG3, s_connect);
+ ASRTER(INUMP(arg), arg, ARG3, s_connect);
{
struct sockaddr_in soka;
soka.sin_addr.s_addr =
@@ -409,8 +412,8 @@ SCM l_connect (sockpt, address, arg)
}
break;
case AF_UNIX:
- ASSERT(NULLP(arg), arg, WNA, s_connect);
- ASSERT(NIMP(address) && STRINGP(address), address, ARG2, s_connect);
+ ASRTER(NULLP(arg), arg, WNA, s_connect);
+ ASRTER(NIMP(address) && STRINGP(address), address, ARG2, s_connect);
{
struct sockaddr_un soka;
soka.sun_family = AF_UNIX;
@@ -433,12 +436,12 @@ SCM l_bind(sockpt, address)
SCM sockpt, address;
{
int sts;
- ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_bind);
+ ASRTER(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_bind);
switch SOCKTYP(sockpt) {
default:
- ASSERT(0, sockpt, s_unkfam, s_bind);
+ ASRTER(0, sockpt, s_unkfam, s_bind);
case AF_UNIX:
- ASSERT(NIMP(address) && STRINGP(address), address, ARG2, s_bind);
+ ASRTER(NIMP(address) && STRINGP(address), address, ARG2, s_bind);
{
struct sockaddr_un sa_server;
bzero((char *) &sa_server, sizeof(sa_server));
@@ -449,7 +452,7 @@ SCM l_bind(sockpt, address)
}
break;
case AF_INET:
- ASSERT(INUMP(address), address, ARG2, s_bind);
+ ASRTER(INUMP(address), address, ARG2, s_bind);
{
struct sockaddr_in sa_server;
bzero((char *) &sa_server, sizeof(sa_server));
@@ -470,8 +473,8 @@ SCM l_listen(port, backlog)
{
long flags;
int sts;
- ASSERT(NIMP(port) && SOCKP(port), port, ARG1, s_listen);
- ASSERT(INUMP(backlog), backlog, ARG2, s_listen);
+ ASRTER(NIMP(port) && SOCKP(port), port, ARG1, s_listen);
+ ASRTER(INUMP(backlog), backlog, ARG2, s_listen);
SYSCALL(sts = listen(fileno(STREAM(port)), INUM(backlog)););
if (sts) return BOOL_F;
DEFER_INTS;
@@ -491,7 +494,7 @@ SCM l_accept(sockpt)
FILE *newfd;
SCM newpt;
NEWCELL(newpt);
- ASSERT(NIMP(sockpt) && OPINPORTP(sockpt), sockpt, ARG1, s_accept);
+ ASRTER(NIMP(sockpt) && OPINPORTP(sockpt), sockpt, ARG1, s_accept);
sadlen=sizeof(sad);
SYSCALL(newsd = accept(fileno(STREAM(sockpt)), &sad, &sadlen););
if (-1==newsd) {
@@ -548,7 +551,7 @@ char s_sknm_family[] = "socket-name:family";
SCM l_sknm_family(snm)
SCM snm;
{
- ASSERT(NIMP(snm) && TYP16(snm)==tc16_sknm, snm, ARG1, s_sknm_family);
+ ASRTER(NIMP(snm) && TYP16(snm)==tc16_sknm, snm, ARG1, s_sknm_family);
return MAKINUM(((struct sockaddr *)CDR(snm))->sa_family + 0L);
}
char s_sknm_port_num[] = "socket-name:port-number";
@@ -600,11 +603,11 @@ SCM l_getpeername(sockpt)
struct sockaddr_in sad;
int sts, sadlen = sizeof(sad);
bzero((char *) &sad, sizeof(sad));
- ASSERT(NIMP(sockpt) && OPFPORTP(sockpt), sockpt, ARG1, s_getpeername);
+ ASRTER(NIMP(sockpt) && OPFPORTP(sockpt), sockpt, ARG1, s_getpeername);
SYSCALL(sts = getpeername(fileno(STREAM(sockpt)),
(struct sockaddr*)&sad, &sadlen););
if (sts || sizeof(sad) != sadlen) return BOOL_F;
-/* ASSERT(sad.sin_family==AF_INET, sockpt, "non-internet", s_getpeername); */
+/* ASRTER(sad.sin_family==AF_INET, sockpt, "non-internet", s_getpeername); */
return maksknm(&sad);
}
static char s_getsockname[] = "getsockname";
@@ -614,7 +617,7 @@ SCM l_getsockname(sockpt)
struct sockaddr_in sad;
int sts, sadlen = sizeof(sad);
bzero((char *) &sad, sizeof(sad));
- ASSERT(NIMP(sockpt) && OPFPORTP(sockpt), sockpt, ARG1, s_getsockname);
+ ASRTER(NIMP(sockpt) && OPFPORTP(sockpt), sockpt, ARG1, s_getsockname);
SYSCALL(sts = getsockname(fileno(STREAM(sockpt)),
(struct sockaddr*)&sad, &sadlen););
if (sts || sizeof(sad) != sadlen) return BOOL_F;
@@ -625,7 +628,6 @@ static iproc subr1s[] = {
{s_inetstr, l_inetstr},
{s_network, l_network},
{s_lna, l_lna},
- {s_makaddr, l_makaddr},
{s_accept, l_accept},
{s_sknm_family, l_sknm_family},
diff --git a/subr.c b/subr.c
index e8b5176..f486932 100644
--- a/subr.c
+++ b/subr.c
@@ -114,14 +114,14 @@ SCM consp(x)
SCM setcar(pair, value)
SCM pair, value;
{
- ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcar);
+ ASRTER(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcar);
CAR(pair) = value;
return UNSPECIFIED;
}
SCM setcdr(pair, value)
SCM pair, value;
{
- ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcdr);
+ ASRTER(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcdr);
CDR(pair) = value;
return UNSPECIFIED;
}
@@ -164,7 +164,7 @@ SCM length(x)
SCM x;
{
SCM i = MAKINUM(ilength(x));
- ASSERT(i >= INUM0, x, ARG1, s_length);
+ ASRTER(i >= INUM0, x, ARG1, s_length);
return i;
}
SCM append(args)
@@ -173,25 +173,25 @@ SCM append(args)
SCM res = EOL;
SCM *lloc = &res, arg;
if IMP(args) {
- ASSERT(NULLP(args), args, ARGn, s_append);
+ ASRTER(NULLP(args), args, ARGn, s_append);
return res;
}
- ASSERT(CONSP(args), args, ARGn, s_append);
+ ASRTER(CONSP(args), args, ARGn, s_append);
while (1) {
arg = CAR(args);
args = CDR(args);
if IMP(args) {
*lloc = arg;
- ASSERT(NULLP(args), args, ARGn, s_append);
+ ASRTER(NULLP(args), args, ARGn, s_append);
return res;
}
- ASSERT(CONSP(args), args, ARGn, s_append);
+ ASRTER(CONSP(args), args, ARGn, s_append);
for(;NIMP(arg);arg = CDR(arg)) {
- ASSERT(CONSP(arg), arg, ARGn, s_append);
+ ASRTER(CONSP(arg), arg, ARGn, s_append);
*lloc = cons(CAR(arg), EOL);
lloc = &CDR(*lloc);
}
- ASSERT(NULLP(arg), arg, ARGn, s_append);
+ ASRTER(NULLP(arg), arg, ARGn, s_append);
}
}
SCM reverse(lst)
@@ -200,24 +200,24 @@ SCM reverse(lst)
SCM res = EOL;
SCM p = lst;
for(;NIMP(p);p = CDR(p)) {
- ASSERT(CONSP(p), lst, ARG1, s_reverse);
+ ASRTER(CONSP(p), lst, ARG1, s_reverse);
res = cons(CAR(p), res);
}
- ASSERT(NULLP(p), lst, ARG1, s_reverse);
+ ASRTER(NULLP(p), lst, ARG1, s_reverse);
return res;
}
SCM list_ref(lst, k)
SCM lst, k;
{
register long i;
- ASSERT(INUMP(k), k, ARG2, s_list_ref);
+ ASRTER(INUMP(k), k, ARG2, s_list_ref);
i = INUM(k);
- ASSERT(i >= 0, k, ARG2, s_list_ref);
+ ASRTER(i >= 0, k, ARG2, s_list_ref);
while (i-- > 0) {
ASRTGO(NIMP(lst) && CONSP(lst), erout);
lst = CDR(lst);
}
-erout: ASSERT(NIMP(lst) && CONSP(lst),
+erout: ASRTER(NIMP(lst) && CONSP(lst),
NULLP(lst)?k:lst, NULLP(lst)?OUTOFRANGE:ARG1, s_list_ref);
return CAR(lst);
}
@@ -225,20 +225,20 @@ SCM memq(x, lst)
SCM x, lst;
{
for(;NIMP(lst);lst = CDR(lst)) {
- ASSERT(CONSP(lst), lst, ARG2, s_memq);
+ ASRTER(CONSP(lst), lst, ARG2, s_memq);
if (CAR(lst)==x) return lst;
}
- ASSERT(NULLP(lst), lst, ARG2, s_memq);
+ ASRTER(NULLP(lst), lst, ARG2, s_memq);
return BOOL_F;
}
SCM member(x, lst)
SCM x, lst;
{
for(;NIMP(lst);lst = CDR(lst)) {
- ASSERT(CONSP(lst), lst, ARG2, s_member);
+ ASRTER(CONSP(lst), lst, ARG2, s_member);
if NFALSEP(equal(CAR(lst), x)) return lst;
}
- ASSERT(NULLP(lst), lst, ARG2, s_member);
+ ASRTER(NULLP(lst), lst, ARG2, s_member);
return BOOL_F;
}
SCM assq(x, alist)
@@ -246,12 +246,12 @@ SCM assq(x, alist)
{
SCM tmp;
for(;NIMP(alist);alist = CDR(alist)) {
- ASSERT(CONSP(alist), alist, ARG2, s_assq);
+ ASRTER(CONSP(alist), alist, ARG2, s_assq);
tmp = CAR(alist);
- ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq);
+ ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq);
if (CAR(tmp)==x) return tmp;
}
- ASSERT(NULLP(alist), alist, ARG2, s_assq);
+ ASRTER(NULLP(alist), alist, ARG2, s_assq);
return BOOL_F;
}
SCM assoc(x, alist)
@@ -259,12 +259,12 @@ SCM assoc(x, alist)
{
SCM tmp;
for(;NIMP(alist);alist = CDR(alist)) {
- ASSERT(CONSP(alist), alist, ARG2, s_assoc);
+ ASRTER(CONSP(alist), alist, ARG2, s_assoc);
tmp = CAR(alist);
- ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc);
+ ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc);
if NFALSEP(equal(CAR(tmp), x)) return tmp;
}
- ASSERT(NULLP(alist), alist, ARG2, s_assoc);
+ ASRTER(NULLP(alist), alist, ARG2, s_assoc);
return BOOL_F;
}
@@ -284,13 +284,13 @@ SCM symbolp(x)
SCM symbol2string(s)
SCM s;
{
- ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol2string);
+ ASRTER(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol2string);
return makfromstr(CHARS(s), (sizet)LENGTH(s));
}
SCM string2symbol(s)
SCM s;
{
- ASSERT(NIMP(s) && STRINGP(s), s, ARG1, s_str2symbol);
+ ASRTER(NIMP(s) && STRINGP(s), s, ARG1, s_str2symbol);
s = intern(CHARS(s), (sizet)LENGTH(s));
return CAR(s);
}
@@ -309,11 +309,11 @@ SCM oddp(n)
{
#ifdef BIGDIG
if NINUMP(n) {
- ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_oddp);
+ ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_oddp);
return (1 & BDIGITS(n)[0]) ? BOOL_T : BOOL_F;
}
#else
- ASSERT(INUMP(n), n, ARG1, s_oddp);
+ ASRTER(INUMP(n), n, ARG1, s_oddp);
#endif
return (4 & (int)n) ? BOOL_T : BOOL_F;
}
@@ -322,11 +322,11 @@ SCM evenp(n)
{
#ifdef BIGDIG
if NINUMP(n) {
- ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_evenp);
+ ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_evenp);
return (1 & BDIGITS(n)[0]) ? BOOL_F : BOOL_T;
}
#else
- ASSERT(INUMP(n), n, ARG1, s_evenp);
+ ASRTER(INUMP(n), n, ARG1, s_evenp);
#endif
return (4 & (int)n) ? BOOL_F : BOOL_T;
}
@@ -335,12 +335,12 @@ SCM absval(x)
{
#ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_abs);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_abs);
if (TYP16(x)==tc16_bigpos) return x;
return copybig(x, 0);
}
#else
- ASSERT(INUMP(x), x, ARG1, s_abs);
+ ASRTER(INUMP(x), x, ARG1, s_abs);
#endif
if (INUM(x) >= 0) return x;
x = -INUM(x);
@@ -359,7 +359,7 @@ SCM lquotient(x, y)
#ifdef BIGDIG
if NINUMP(x) {
long w;
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_quotient);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_quotient);
if NINUMP(y) {
ASRTGO(NIMP(y) && BIGP(y), bady);
return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
@@ -394,8 +394,8 @@ SCM lquotient(x, y)
return INUM0;
}
#else
- ASSERT(INUMP(x), x, ARG1, s_quotient);
- ASSERT(INUMP(y), y, ARG2, s_quotient);
+ ASRTER(INUMP(x), x, ARG1, s_quotient);
+ ASRTER(INUMP(y), y, ARG2, s_quotient);
#endif
if ((z = INUM(y))==0)
ov: wta(y, (char *)OVFLOW, s_quotient);
@@ -428,7 +428,7 @@ SCM lremainder(x, y)
register long z;
#ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_remainder);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_remainder);
if NINUMP(y) {
ASRTGO(NIMP(y) && BIGP(y), bady);
return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
@@ -445,8 +445,8 @@ SCM lremainder(x, y)
return x;
}
#else
- ASSERT(INUMP(x), x, ARG1, s_remainder);
- ASSERT(INUMP(y), y, ARG2, s_remainder);
+ ASRTER(INUMP(x), x, ARG1, s_remainder);
+ ASRTER(INUMP(y), y, ARG2, s_remainder);
#endif
if (!(z = INUM(y)))
ov: wta(y, (char *)OVFLOW, s_remainder);
@@ -469,7 +469,7 @@ SCM modulo(x, y)
register long yy, z;
#ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_modulo);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_modulo);
if NINUMP(y) {
ASRTGO(NIMP(y) && BIGP(y), bady);
return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
@@ -486,8 +486,8 @@ SCM modulo(x, y)
return (BIGSIGN(y) ? (INUM(x)>0) : (INUM(x)<0)) ? sum(x, y) : x;
}
#else
- ASSERT(INUMP(x), x, ARG1, s_modulo);
- ASSERT(INUMP(y), y, ARG2, s_modulo);
+ ASRTER(INUMP(x), x, ARG1, s_modulo);
+ ASRTER(INUMP(y), y, ARG2, s_modulo);
#endif
if (!(yy = INUM(y)))
ov: wta(y, (char *)OVFLOW, s_modulo);
@@ -509,11 +509,11 @@ SCM lgcd(x, y)
#ifdef BIGDIG
if NINUMP(x) {
big_gcd:
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_gcd);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_gcd);
if BIGSIGN(x) x = copybig(x, 0);
newy:
if NINUMP(y) {
- ASSERT(NIMP(y) && BIGP(y), y, ARG2, s_gcd);
+ ASRTER(NIMP(y) && BIGP(y), y, ARG2, s_gcd);
if BIGSIGN(y) y = copybig(y, 0);
switch (bigcomp(x, y)) {
case -1:
@@ -527,8 +527,8 @@ SCM lgcd(x, y)
}
if NINUMP(y) { t=x; x=y; y=t; goto big_gcd;}
#else
- ASSERT(INUMP(x), x, ARG1, s_gcd);
- ASSERT(INUMP(y), y, ARG2, s_gcd);
+ ASRTER(INUMP(x), x, ARG1, s_gcd);
+ ASRTER(INUMP(y), y, ARG2, s_gcd);
#endif
u = INUM(x);
if (u<0) u = -u;
@@ -1003,7 +1003,7 @@ SCM scm_logior(x, y)
}}
#else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_logior);
+ ASRTER(INUMP(y), y, ARG2, s_logior);
#endif
return MAKINUM(INUM(x) | INUM(y));
}
@@ -1052,7 +1052,7 @@ SCM scm_logand(x, y)
}}
#else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_logand);
+ ASRTER(INUMP(y), y, ARG2, s_logand);
#endif
return MAKINUM(INUM(x) & INUM(y));
}
@@ -1094,7 +1094,7 @@ SCM scm_logxor(x, y)
}}
#else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_logxor);
+ ASRTER(INUMP(y), y, ARG2, s_logxor);
#endif
return (x ^ y) + INUM0;
}
@@ -1132,7 +1132,7 @@ SCM scm_logtest(x, y)
}}
#else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_logtest);
+ ASRTER(INUMP(y), y, ARG2, s_logtest);
#endif
return (INUM(x) & INUM(y)) ? BOOL_T : BOOL_F;
}
@@ -1140,10 +1140,10 @@ SCM scm_logtest(x, y)
SCM scm_logbitp(index, j1)
SCM index, j1;
{
- ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp);
+ ASRTER(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp);
#ifdef BIGDIG
if NINUMP(j1) {
- ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_logbitp);
+ ASRTER(NIMP(j1) && BIGP(j1), j1, ARG2, s_logbitp);
if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F;
else if BIGSIGN(j1) {
long num = -1;
@@ -1162,15 +1162,16 @@ SCM scm_logbitp(index, j1)
(1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F;
}
#else
- ASSERT(INUMP(j1), j1, ARG2, s_logbitp);
+ ASRTER(INUMP(j1), j1, ARG2, s_logbitp);
#endif
+ if (index >= LONG_BIT) return j1 < 0 ? BOOL_T : BOOL_F;
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);
+ ASRTER(INUMP(index) && INUM(index) >= 0, index, ARG1, s_copybit);
#ifdef BIGDIG
{
SCM res;
@@ -1178,7 +1179,7 @@ SCM scm_copybit(index, j1, bit)
sizet i = INUM(index);
int sign;
if (!INUMP(j1)) {
- ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_copybit);
+ ASRTER(NIMP(j1) && BIGP(j1), j1, ARG2, s_copybit);
sign = BIGSIGN(j1);
ovflow:
res = scm_copy_big_2scomp(j1, i + 1, sign);
@@ -1196,8 +1197,8 @@ SCM scm_copybit(index, j1, bit)
}
}
#else
- ASSERT(INUMP(j1), j1, ARG2, s_copybit);
- ASSERT(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
+ ASRTER(INUMP(j1), j1, ARG2, s_copybit);
+ ASRTER(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
#endif
if NFALSEP(bit)
return MAKINUM(INUM(j1) | (1L << INUM(index)));
@@ -1215,10 +1216,13 @@ SCM scm_ash(n, cnt)
SCM n, cnt;
{
SCM res = INUM(n);
- ASSERT(INUMP(cnt), cnt, ARG2, s_ash);
+ ASRTER(INUMP(cnt), cnt, ARG2, s_ash);
cnt = INUM(cnt);
if (INUMP(n)) {
- if (cnt < 0) return MAKINUM(SRS(res, -cnt));
+ if (cnt < 0) {
+ if (-cnt >= LONG_BIT) return INUM0;
+ return MAKINUM(SRS(res, -cnt));
+ }
if (cnt >= LONG_BIT) goto ovflow;
res = MAKINUM(res<<cnt);
if (INUM(res)>>cnt != INUM(n))
@@ -1227,7 +1231,7 @@ SCM scm_ash(n, cnt)
return res;
}
#ifdef BIGDIG
- ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_ash);
+ ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_ash);
ovflow:
if (0==cnt) return n;
return scm_big_ash(n, cnt);
@@ -1242,15 +1246,15 @@ SCM scm_bitfield(n, start, end)
SCM n, start, end;
{
int sign;
- ASSERT(INUMP(start), start, ARG2, s_bitfield);
- ASSERT(INUMP(end), end, ARG3, s_bitfield);
+ ASRTER(INUMP(start), start, ARG2, s_bitfield);
+ ASRTER(INUMP(end), end, ARG3, s_bitfield);
start = INUM(start); end = INUM(end);
- ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield);
+ ASRTER(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield);
#ifdef BIGDIG
if (NINUMP(n)) {
BIGDIG *ds;
sizet i, nd;
- ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_bitfield);
+ ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_bitfield);
sign = BIGSIGN(n);
big:
if (sign) n = scm_copy_big_2scomp(n, (sizet)end, 0);
@@ -1272,8 +1276,8 @@ SCM scm_bitfield(n, start, end)
goto big;
}
#else
- ASSERT(INUMP(n), n, ARG1, s_bitfield);
- ASSERT(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield);
+ ASRTER(INUMP(n), n, ARG1, s_bitfield);
+ ASRTER(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield);
#endif
return MAKINUM((INUM(n)>>start) & ((1L<<(end - start)) - 1));
}
@@ -1286,9 +1290,9 @@ SCM scm_bitif(mask, n0, 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);
+ ASRTER(INUMP(mask), mask, ARG1, s_bitif);
+ ASRTER(INUMP(n0), n0, ARG2, s_bitif);
+ ASRTER(INUMP(n1), n1, ARG3, s_bitif);
#endif
return MAKINUM((INUM(mask) & INUM(n0)) | (~(INUM(mask)) & INUM(n1)));
}
@@ -1307,10 +1311,10 @@ SCM scm_copybitfield(to, start, 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);
+ ASRTER(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);
+ ASRTER(INUMP(end), end, ARG3, s_copybitfield);
+ ASRTER(len >= 0, MAKINUM(len), OUTOFRANGE, s_copybitfield);
#ifdef BIGDIG
if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) {
SCM mask = difference(scm_ash(MAKINUM(1L), MAKINUM(len)), MAKINUM(1L));
@@ -1319,9 +1323,9 @@ SCM scm_copybitfield(to, start, rest)
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);
+ ASRTER(INUMP(to), to, ARG1, s_copybitfield);
+ ASRTER(INUMP(from), from, ARG4, s_copybitfield);
+ ASRTER(INUM(end) < LONG_BIT - 2, end, OUTOFRANGE, s_copybitfield);
#endif
{
long mask = ((1L<<len) - 1)<<INUM(start);
@@ -1338,7 +1342,7 @@ SCM scm_logcount(n)
#ifdef BIGDIG
if NINUMP(n) {
sizet i; BIGDIG *ds, d;
- ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_logcount);
+ ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_logcount);
if BIGSIGN(n) return scm_logcount(difference(MAKINUM(-1L), n));
ds = BDIGITS(n);
for(i = NUMDIGS(n); i--; )
@@ -1346,7 +1350,7 @@ SCM scm_logcount(n)
return MAKINUM(c);
}
#else
- ASSERT(INUMP(n), n, ARG1, s_logcount);
+ ASRTER(INUMP(n), n, ARG1, s_logcount);
#endif
if ((nn = INUM(n)) < 0) nn = -1 - nn;
for(; nn; nn >>= 4) c += logtab[15 & nn];
@@ -1363,7 +1367,7 @@ SCM scm_intlength(n)
#ifdef BIGDIG
if NINUMP(n) {
BIGDIG *ds, d;
- ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_intlength);
+ ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_intlength);
if BIGSIGN(n) return scm_intlength(difference(MAKINUM(-1L), n));
ds = BDIGITS(n);
d = ds[c = NUMDIGS(n)-1];
@@ -1371,7 +1375,7 @@ SCM scm_intlength(n)
return MAKINUM(c - 4 + l);
}
#else
- ASSERT(INUMP(n), n, ARG1, s_intlength);
+ ASRTER(INUMP(n), n, ARG1, s_intlength);
#endif
if ((nn = INUM(n)) < 0) nn = -1 - nn;
for(;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];}
@@ -1386,120 +1390,120 @@ SCM charp(x)
SCM char_lessp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ch_lessp);
- ASSERT(ICHRP(y), y, ARG2, s_ch_lessp);
+ ASRTER(ICHRP(x), x, ARG1, s_ch_lessp);
+ ASRTER(ICHRP(y), y, ARG2, s_ch_lessp);
return (ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F;
}
SCM char_leqp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ch_leqp);
- ASSERT(ICHRP(y), y, ARG2, s_ch_leqp);
+ ASRTER(ICHRP(x), x, ARG1, s_ch_leqp);
+ ASRTER(ICHRP(y), y, ARG2, s_ch_leqp);
return (ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F;
}
SCM char_grp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ch_grp);
- ASSERT(ICHRP(y), y, ARG2, s_ch_grp);
+ ASRTER(ICHRP(x), x, ARG1, s_ch_grp);
+ ASRTER(ICHRP(y), y, ARG2, s_ch_grp);
return (ICHR(x) > ICHR(y)) ? BOOL_T : BOOL_F;
}
SCM char_geqp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ch_geqp);
- ASSERT(ICHRP(y), y, ARG2, s_ch_geqp);
+ ASRTER(ICHRP(x), x, ARG1, s_ch_geqp);
+ ASRTER(ICHRP(y), y, ARG2, s_ch_geqp);
return (ICHR(x) >= ICHR(y)) ? BOOL_T : BOOL_F;
}
SCM chci_eq(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ci_eq);
- ASSERT(ICHRP(y), y, ARG2, s_ci_eq);
+ ASRTER(ICHRP(x), x, ARG1, s_ci_eq);
+ ASRTER(ICHRP(y), y, ARG2, s_ci_eq);
return (upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM chci_lessp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ci_lessp);
- ASSERT(ICHRP(y), y, ARG2, s_ci_lessp);
+ ASRTER(ICHRP(x), x, ARG1, s_ci_lessp);
+ ASRTER(ICHRP(y), y, ARG2, s_ci_lessp);
return (upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM chci_leqp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ci_leqp);
- ASSERT(ICHRP(y), y, ARG2, s_ci_leqp);
+ ASRTER(ICHRP(x), x, ARG1, s_ci_leqp);
+ ASRTER(ICHRP(y), y, ARG2, s_ci_leqp);
return (upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM chci_grp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ci_grp);
- ASSERT(ICHRP(y), y, ARG2, s_ci_grp);
+ ASRTER(ICHRP(x), x, ARG1, s_ci_grp);
+ ASRTER(ICHRP(y), y, ARG2, s_ci_grp);
return (upcase[ICHR(x)] > upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM chci_geqp(x, y)
SCM x, y;
{
- ASSERT(ICHRP(x), x, ARG1, s_ci_geqp);
- ASSERT(ICHRP(y), y, ARG2, s_ci_geqp);
+ ASRTER(ICHRP(x), x, ARG1, s_ci_geqp);
+ ASRTER(ICHRP(y), y, ARG2, s_ci_geqp);
return (upcase[ICHR(x)] >= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM char_alphap(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_ch_alphap);
+ ASRTER(ICHRP(chr), chr, ARG1, s_ch_alphap);
return (isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F;
}
SCM char_nump(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_ch_nump);
+ ASRTER(ICHRP(chr), chr, ARG1, s_ch_nump);
return (isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F;
}
SCM char_whitep(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_ch_whitep);
+ ASRTER(ICHRP(chr), chr, ARG1, s_ch_whitep);
return (isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F;
}
SCM char_upperp(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_ch_upperp);
+ ASRTER(ICHRP(chr), chr, ARG1, s_ch_upperp);
return (isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F;
}
SCM char_lowerp(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_ch_lowerp);
+ ASRTER(ICHRP(chr), chr, ARG1, s_ch_lowerp);
return (isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F;
}
SCM char2int(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_char2int);
+ ASRTER(ICHRP(chr), chr, ARG1, s_char2int);
return MAKINUM(ICHR(chr));
}
SCM int2char(n)
SCM n;
{
- ASSERT(INUMP(n), n, ARG1, s_int2char);
- ASSERT((n >= INUM0) && (n < MAKINUM(CHAR_CODE_LIMIT)),
+ ASRTER(INUMP(n), n, ARG1, s_int2char);
+ ASRTER((n >= INUM0) && (n < MAKINUM(CHAR_CODE_LIMIT)),
n, OUTOFRANGE, s_int2char);
return MAKICHR(INUM(n));
}
SCM char_upcase(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_ch_upcase);
+ ASRTER(ICHRP(chr), chr, ARG1, s_ch_upcase);
return MAKICHR(upcase[ICHR(chr)]);
}
SCM char_downcase(chr)
SCM chr;
{
- ASSERT(ICHRP(chr), chr, ARG1, s_ch_downcase);
+ ASRTER(ICHRP(chr), chr, ARG1, s_ch_downcase);
return MAKICHR(downcase[ICHR(chr)]);
}
@@ -1515,11 +1519,11 @@ SCM string(chrs)
SCM res;
register unsigned char *data;
long i = ilength(chrs);
- ASSERT(i >= 0, chrs, ARG1, s_string);
+ ASRTER(i >= 0, chrs, ARG1, s_string);
res = makstr(i);
data = UCHARS(res);
for(;NNULLP(chrs);chrs = CDR(chrs)) {
- ASSERT(ICHRP(CAR(chrs)), chrs, ARG1, s_string);
+ ASRTER(ICHRP(CAR(chrs)), chrs, ARG1, s_string);
*data++ = ICHR(CAR(chrs));
}
return res;
@@ -1530,12 +1534,12 @@ SCM make_string(k, chr)
SCM res;
register unsigned char *dst;
register long i;
- ASSERT(INUMP(k) && (k >= 0), k, ARG1, s_make_string);
+ ASRTER(INUMP(k) && (k >= 0), k, ARG1, s_make_string);
i = INUM(k);
res = makstr(i);
dst = UCHARS(res);
if (!UNBNDP(chr)) {
- ASSERT(ICHRP(chr), chr, ARG2, s_make_string);
+ ASRTER(ICHRP(chr), chr, ARG2, s_make_string);
for(i--;i >= 0;i--) dst[i] = ICHR(chr);
}
return res;
@@ -1543,24 +1547,24 @@ SCM make_string(k, chr)
SCM st_length(str)
SCM str;
{
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_length);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_length);
return MAKINUM(LENGTH(str));
}
SCM st_ref(str, k)
SCM str, k;
{
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_ref);
- ASSERT(INUMP(k), k, ARG2, s_st_ref);
- ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_ref);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_ref);
+ ASRTER(INUMP(k), k, ARG2, s_st_ref);
+ ASRTER(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_ref);
return MAKICHR(UCHARS(str)[INUM(k)]);
}
SCM st_set(str, k, chr)
SCM str, k, chr;
{
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_set);
- ASSERT(INUMP(k), k, ARG2, s_st_set);
- ASSERT(ICHRP(chr), chr, ARG3, s_st_set);
- ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_set);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_set);
+ ASRTER(INUMP(k), k, ARG2, s_st_set);
+ ASRTER(ICHRP(chr), chr, ARG3, s_st_set);
+ ASRTER(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_set);
UCHARS(str)[INUM(k)] = ICHR(chr);
return UNSPECIFIED;
}
@@ -1569,8 +1573,8 @@ SCM st_equal(s1, s2)
{
register sizet i;
register unsigned char *c1, *c2;
- ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_equal);
- ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_equal);
+ ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_equal);
+ ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_equal);
i = LENGTH(s2);
if (LENGTH(s1) != i) return BOOL_F;
c1 = UCHARS(s1);
@@ -1583,8 +1587,8 @@ SCM stci_equal(s1, s2)
{
register sizet i;
register unsigned char *c1, *c2;
- ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_equal);
- ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_equal);
+ ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_equal);
+ ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_equal);
i = LENGTH(s2);
if (LENGTH(s1) != i) return BOOL_F;
c1 = UCHARS(s1);
@@ -1598,8 +1602,8 @@ SCM st_lessp(s1, s2)
register sizet i, len;
register unsigned char *c1, *c2;
register int c;
- ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_lessp);
- ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_lessp);
+ ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_lessp);
+ ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_lessp);
len = LENGTH(s1);
i = LENGTH(s2);
if (len>i) i = len;
@@ -1633,8 +1637,8 @@ SCM stci_lessp(s1, s2)
register sizet i, len;
register unsigned char *c1, *c2;
register int c;
- ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_lessp);
- ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_lessp);
+ ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_lessp);
+ ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_lessp);
len = LENGTH(s1);
i = LENGTH(s2);
if (len>i) i=len;
@@ -1666,13 +1670,13 @@ SCM substring(str, start, end)
SCM str, start, end;
{
long l;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_substring);
- ASSERT(INUMP(start), start, ARG2, s_substring);
- ASSERT(INUMP(end), end, ARG3, s_substring);
- ASSERT(INUM(start) <= LENGTH(str), start, OUTOFRANGE, s_substring);
- ASSERT(INUM(end) <= LENGTH(str), end, OUTOFRANGE, s_substring);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_substring);
+ ASRTER(INUMP(start), start, ARG2, s_substring);
+ ASRTER(INUMP(end), end, ARG3, s_substring);
+ ASRTER(INUM(start) <= LENGTH(str), start, OUTOFRANGE, s_substring);
+ ASRTER(INUM(end) <= LENGTH(str), end, OUTOFRANGE, s_substring);
l = INUM(end)-INUM(start);
- ASSERT(l >= 0, MAKINUM(l), OUTOFRANGE, s_substring);
+ ASRTER(l >= 0, MAKINUM(l), OUTOFRANGE, s_substring);
return makfromstr(&CHARS(str)[INUM(start)], (sizet)l);
}
SCM st_append(args)
@@ -1683,13 +1687,13 @@ SCM st_append(args)
register SCM l, s;
register unsigned char *data;
for(l = args;NIMP(l);) {
- ASSERT(CONSP(l), l, ARGn, s_st_append);
+ ASRTER(CONSP(l), l, ARGn, s_st_append);
s = CAR(l);
- ASSERT(NIMP(s) && STRINGP(s), s, ARGn, s_st_append);
+ ASRTER(NIMP(s) && STRINGP(s), s, ARGn, s_st_append);
i += LENGTH(s);
l = CDR(l);
}
- ASSERT(NULLP(l), args, ARGn, s_st_append);
+ ASRTER(NULLP(l), args, ARGn, s_st_append);
res = makstr(i);
data = UCHARS(res);
for(l = args;NIMP(l);l = CDR(l)) {
@@ -1708,7 +1712,7 @@ SCM vectorp(x)
SCM vector_length(v)
SCM v;
{
- ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_length);
+ ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_length);
return MAKINUM(LENGTH(v));
}
SCM vector(l)
@@ -1717,7 +1721,7 @@ SCM vector(l)
SCM res;
register SCM *data;
long i = ilength(l);
- ASSERT(i >= 0, l, ARG1, s_vector);
+ ASRTER(i >= 0, l, ARG1, s_vector);
res = make_vector(MAKINUM(i), UNSPECIFIED);
data = VELTS(res);
for(;NIMP(l);l = CDR(l)) *data++ = CAR(l);
@@ -1726,17 +1730,17 @@ SCM vector(l)
SCM vector_ref(v, k)
SCM v, k;
{
- ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_ref);
- ASSERT(INUMP(k), k, ARG2, s_ve_ref);
- ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_ref);
+ ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_ref);
+ ASRTER(INUMP(k), k, ARG2, s_ve_ref);
+ ASRTER((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_ref);
return VELTS(v)[((long) INUM(k))];
}
SCM vector_set(v, k, obj)
SCM v, k, obj;
{
- ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_set);
- ASSERT(INUMP(k), k, ARG2, s_ve_set);
- ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_set);
+ ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_set);
+ ASRTER(INUMP(k), k, ARG2, s_ve_set);
+ ASRTER((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_set);
VELTS(v)[((long) INUM(k))] = obj;
return UNSPECIFIED;
}
@@ -1748,9 +1752,9 @@ SCM make_vector(k, fill)
register long i;
register SCM *velts;
#ifdef SHORT_SIZET
- ASSERT(INUMP(k), k, ARG1, s_make_vector);
+ ASRTER(INUMP(k), k, ARG1, s_make_vector);
#else
- ASSERT(INUMP(k) && (!(~LENGTH_MAX & INUM(k))), k, ARG1, s_make_vector);
+ ASRTER(INUMP(k) && (!(~LENGTH_MAX & INUM(k))), k, ARG1, s_make_vector);
#endif
if UNBNDP(fill) fill = UNSPECIFIED;
i = INUM(k);
diff --git a/sys.c b/sys.c
index 3a8906f..0ace3a5 100644
--- a/sys.c
+++ b/sys.c
@@ -45,6 +45,11 @@
#include "scm.h"
#include "setjump.h"
+
+#ifdef POCKETCONSOLE
+# include <io.h>
+#endif
+
void igc P((char *what, STACKITEM *stackbase));
void lfflush P((SCM port)); /* internal SCM call */
SCM *loc_open_file; /* for open-file callback */
@@ -73,6 +78,9 @@ SCM *loc_try_create_file;
# ifdef linux
# include <unistd.h>
# endif
+# ifdef __NetBSD__
+# include <unistd.h>
+# endif
# ifdef __OpenBSD__
# include <unistd.h>
# endif
@@ -172,10 +180,10 @@ SCM try_open_file(filename, modes)
FILE *f;
char cmodes[4];
long flags;
- ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
- ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file);
+ ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
+ ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file);
flags = mode_bits(CHARS(modes), cmodes);
- ASSERT(flags, modes, ARG2, s_open_file);
+ ASRTER(flags, modes, ARG2, s_open_file);
if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) {
port = apply(*loc_try_create_file, filename, cons(modes, listofnull));
if (UNSPECIFIED != port) return port;
@@ -207,12 +215,18 @@ SCM close_port(port)
SCM port;
{
sizet i;
- ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_close_port);
+ SCM ret = UNSPECIFIED;
+ ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_close_port);
if CLOSEDP(port) return UNSPECIFIED;
i = PTOBNUM(port);
DEFER_INTS;
if (ptobs[i].fclose) {
- SYSCALL((ptobs[i].fclose)(STREAM(port)););
+ int r;
+ SYSCALL(r = (ptobs[i].fclose)(STREAM(port)););
+ if (EOF == r)
+ ret = BOOL_F;
+ else
+ ret = MAKINUM(r);
}
CAR(port) &= ~OPN;
SCM_PORTFLAGS(port) &= ~OPN;
@@ -220,7 +234,7 @@ SCM close_port(port)
This allows catching some errors cheaply. */
SCM_SET_PTOBNUM(port, tc16_clport);
ALLOW_INTS;
- return UNSPECIFIED;
+ return ret;
}
SCM input_portp(x)
SCM x;
@@ -237,7 +251,7 @@ SCM output_portp(x)
SCM port_closedp(port)
SCM port;
{
- ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp);
+ ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp);
if CLOSEDP(port) return BOOL_T;
return BOOL_F;
}
@@ -325,7 +339,7 @@ SCM del_fil(str)
SCM str;
{
int ans;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil);
#ifdef STDC_HEADERS
SYSCALL(ans = remove(CHARS(str)););
#else
@@ -368,6 +382,12 @@ void prinport(exp, port, type)
intprint((long)fileno(STREAM(exp)), 10, port);
else
intprint(CDR(exp), -16, port);
+ if (TRACKED & SCM_PORTFLAGS(exp)) {
+ lputs(" L", port);
+ intprint(scm_port_table[SCM_PORTNUM(exp)].line, 10, port);
+ lputs(" C", port);
+ intprint(scm_port_table[SCM_PORTNUM(exp)].col+0L, 10, port);
+ }
}
lputc('>', port);
}
@@ -424,7 +444,7 @@ static int stungetc(c, p)
ind = INUM(CAR(p));
if (ind == 0) return EOF;
CAR(p) = MAKINUM(--ind);
- ASSERT(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", "");
+ ASRTER(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", "");
return c;
}
int noop0(stream)
@@ -439,8 +459,8 @@ SCM mkstrport(pos, str, modes, caller)
char *caller;
{
SCM z;
- ASSERT(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller);
- ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller);
+ ASRTER(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller);
+ ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller);
str = cons(pos, str);
NEWCELL(z);
DEFER_INTS;
@@ -577,7 +597,7 @@ static int sfgetc(p)
ans = scm_cvapply(VELTS(p)[3], 0L, (SCM *)0);
errno = 0;
if (FALSEP(ans) || EOF_VAL==ans) return EOF;
- ASSERT(ICHRP(ans), ans, ARG1, "getc");
+ ASRTER(ICHRP(ans), ans, ARG1, "getc");
return ICHR(ans);
}
static int sfclose(p)
@@ -606,9 +626,9 @@ SCM mksfpt(pv, modes)
badarg);
}
#endif
- ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt);
+ ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt);
flags = mode_bits(CHARS(modes), (char *)0);
- ASSERT(flags, modes, ARG2, s_mksfpt);
+ ASRTER(flags, modes, ARG2, s_mksfpt);
DEFER_INTS;
z = scm_port_entry((FILE *)pv, tc16_sfport, flags);
ALLOW_INTS;
@@ -752,7 +772,7 @@ SCM mksafeport(maxlen, port)
{
SCM z;
if UNBNDP(port) port = cur_errp;
- ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
+ ASRTER(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
z = must_malloc_cell(sizeof(safeport)+0L,
tc16_safeport | OPN | WRTNG,
s_msp);
@@ -940,7 +960,7 @@ SCM scm_add_finalizer(value, finalizer)
SCM value, finalizer;
{
SCM z;
- ASSERT(NIMP(value), value, ARG1, s_add_finalizer);
+ ASRTER(NIMP(value), value, ARG1, s_add_finalizer);
#ifndef RECKLESS
scm_arity_check(finalizer, 0L, s_add_finalizer);
#endif
@@ -1035,8 +1055,10 @@ void scm_estk_shrink()
parent = SCM_ESTK_PARENT(scm_estk);
i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk));
if IMP(parent) wta(UNDEFINED, "underflow", s_estk);
- if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk))
+ if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk)) {
parent = make_stk_seg((sizet)LENGTH(parent), parent);
+ SCM_ESTK_PARENT_WRITABLEP(parent) = BOOL_F;
+ }
SCM_ESTK_PARENT(scm_estk) = estk_pool;
estk_pool = scm_estk;
scm_estk_size -= LENGTH(scm_estk);
@@ -1239,7 +1261,7 @@ static char *igc_for_alloc(where, olen, size, what)
char *ptr;
long nm;
/* Check to see that heap is initialized */
- ASSERT(heap_cells > 0, MAKINUM(size), NALLOC, what);
+ ASRTER(heap_cells > 0, MAKINUM(size), NALLOC, what);
/* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */
igc(what, CONT(rootcont)->stkbse);
nm = mallocated + size - olen;
@@ -1249,7 +1271,7 @@ static char *igc_for_alloc(where, olen, size, what)
}
if (where) SYSCALL(ptr = (char *)realloc(where, size););
else SYSCALL(ptr = (char *)malloc(size););
- ASSERT(ptr, MAKINUM(size), NALLOC, what);
+ ASRTER(ptr, MAKINUM(size), NALLOC, what);
if (nm > mltrigger) {
if (nm > mtrigger) mtrigger = nm + nm/2;
else mtrigger += mtrigger/2;
@@ -1267,7 +1289,7 @@ char *must_malloc(len, what)
long nm = mallocated + size;
VERIFY_INTS("must_malloc", what);
#ifdef SHORT_SIZET
- ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
else ptr = 0;
@@ -1287,7 +1309,7 @@ SCM must_malloc_cell(len, c, what)
long nm = mallocated + size;
VERIFY_INTS("must_malloc_cell", what);
#ifdef SHORT_SIZET
- ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
NEWCELL(z);
if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
@@ -1309,9 +1331,9 @@ char *must_realloc(where, olen, len, what)
long nm = mallocated + size - olen;
VERIFY_INTS("must_realloc", what);
#ifdef SHORT_SIZET
- ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
- ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what);
+ ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what);
/* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout);
printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */
if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
@@ -1330,9 +1352,9 @@ void must_realloc_cell(z, olen, len, what)
long nm = mallocated + size - olen;
VERIFY_INTS("must_realloc_cell", what);
#ifdef SHORT_SIZET
- ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
- ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what);
+ ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what);
/* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */
if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
else ptr = 0;
@@ -1479,7 +1501,7 @@ SCM makstr(len)
{
SCM s;
#ifndef SHORT_SIZET
- ASSERT(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string);
+ ASRTER(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string);
#endif
DEFER_INTS;
s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string);
@@ -1488,6 +1510,7 @@ SCM makstr(len)
return s;
}
+char s_redefining[] = "redefining ";
scm_gra subrs_gra;
SCM scm_maksubr(name, type, fcn)
const char *name;
@@ -1498,7 +1521,14 @@ SCM scm_maksubr(name, type, fcn)
int isubr;
register SCM z;
info.name = name;
+ for (isubr = subrs_gra.len; 0 < isubr--;) {
+ if (0==strcmp(((char **)subrs_gra.elts)[isubr], name)) {
+ scm_warn(s_redefining, (char *)name, UNDEFINED);
+ goto foundit;
+ }
+ }
isubr = scm_grow_gra(&subrs_gra, (char *)&info);
+ foundit:
NEWCELL(z);
if (!fcn && tc7_cxr==type) {
const char *p = name;
@@ -1531,7 +1561,7 @@ SCM makcclo(proc, len)
{
SCM s;
# ifndef SHORT_SIZET
- ASSERT(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo);
+ ASRTER(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo);
# endif
DEFER_INTS;
s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo),
@@ -1637,7 +1667,11 @@ SCM scm_make_cont()
ncont->other.stkframe[0] = scm_env;
ncont->other.stkframe[1] = scm_env_tmp;
ncont->other.estk = estk;
+#ifdef CHEAP_CONTINUATIONS
ncont->other.estk_ptr = scm_estk_ptr;
+#else
+ ncont->other.estk_ptr = (SCM *)0;
+#endif
#ifndef RECKLESS
ncont->other.stkframe[2] = scm_trace_env;
ncont->other.stkframe[3] = scm_trace;
@@ -1660,11 +1694,11 @@ void scm_dynthrow(tocont, val)
scm_estk_ptr = cont->other.estk_ptr;
#else
{
- SCM *from = VELTS(cont->other.estk);
- SCM *to = VELTS(scm_estk);
+ SCM *to, *from = VELTS(cont->other.estk);
sizet n = LENGTH(cont->other.estk);
- if (LENGTH(scm_estk) < n) scm_estk_reset((sizet)LENGTH(scm_estk));
- scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
+ if (LENGTH(scm_estk) < n) scm_estk_reset(n);
+ to = VELTS(scm_estk);
+ scm_estk_ptr = &(to[n - SCM_ESTK_FRLEN]);
while(n--) to[n] = from[n];
}
#endif
@@ -1710,7 +1744,7 @@ SCM obunhash(obj)
goto comm;
}
#endif
- ASSERT(INUMP(obj), obj, ARG1, s_obunhash);
+ ASRTER(INUMP(obj), obj, ARG1, s_obunhash);
obj = SRS(obj, 1) & ~1L;
comm:
if IMP(obj) return obj;
@@ -1969,7 +2003,7 @@ SCM scm_port_entry(stream, ptype, flags)
int i, j;
VERIFY_INTS("scm_port_entry", 0L);
flags = flags | (ptype & ~0xffffL);
- ASSERT(flags, INUM0, ARG1, "scm_port_entry");
+ ASRTER(flags, INUM0, ARG1, "scm_port_entry");
for (i = 1; i < scm_port_table_len; i++)
if (0L==scm_port_table[i].flags) goto ret;
if (scm_port_table_len <= SCM_PORTNUM_MAX) {
@@ -2044,6 +2078,10 @@ void init_storage(stack_start_ptr, init_heap_size)
/* Because not all protects may get initialized */
freelist = EOL;
expmem = 0;
+ estk_pool = EOL;
+ scm_estk = BOOL_F;
+ scm_port_table = 0;
+ scm_port_table_len = 0;
#ifdef SHORT_SIZET
if (sizeof(sizet) >= sizeof(long))
@@ -2064,11 +2102,12 @@ void init_storage(stack_start_ptr, init_heap_size)
fixconfig(remsg, "CDR_DOUBLES", 0);
#else
# ifdef SINGLES
- if (sizeof(float) != sizeof(long))
+ if (sizeof(float) != sizeof(long)) {
if (sizeof(double) == sizeof(long))
fixconfig(addmsg, "CDR_DOUBLES", 0);
else
fixconfig(remsg, "SINGLES", 0);
+ }
# endif
#endif
#ifdef BIGDIG
@@ -2508,7 +2547,7 @@ void gc_mark(p)
case tc7_string:
case tc7_msymbol:
if GC8MARKP(ptr) break;
- ASSERT(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
+ ASRTER(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
s_wrong_length, s_gc);
case tc7_ssymbol:
case tc7_bvect:
@@ -2536,7 +2575,7 @@ void gc_mark(p)
switch TYP16(ptr) { /* should be faster than going through smobs */
case tc_free_cell:
/* printf("found free_cell %X ", ptr); fflush(stdout); */
- ASSERT(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
+ ASRTER(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
/* CDR(ptr) = UNDEFINED */;
break;
#ifdef BIGDIG
@@ -2784,14 +2823,14 @@ static void mark_syms(v)
while (k--)
for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
/* If this bucket has already been marked, then something is wrong. */
- ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym);
+ ASRTER(!GCMARKP(al), al, s_bad_type, s_gc_sym);
x = CAR(al);
SETGCMARK(al); /* Do mark bucket list */
# 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))]),
+ ASRTER(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym);
+ ASRTER(!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)),
+ ASRTER(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)),
(unsigned long)symhash_dim)==k,
CAR(x), "bad hash", s_gc_sym);
# endif
@@ -2907,7 +2946,7 @@ static void mark_port_table(port)
SCM port;
{
int i = SCM_PORTNUM(port);
- ASSERT(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc);
+ ASRTER(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc);
if (i) {
scm_port_table[i].flags |= 1;
if (NIMP(scm_port_table[i].data))
@@ -3004,11 +3043,12 @@ static void egc_copy_locations(ve, len)
SCM x;
while (len--) {
x = ve[len];
- if (NIMP(x) && ECACHEP(x))
+ if (NIMP(x) && ECACHEP(x)) {
if (tc_broken_heart==CAR(x))
ve[len] = CDR(x);
else
egc_copy(&(ve[len]));
+ }
}
}
static void egc_copy_stack(stk, len)
@@ -3112,7 +3152,7 @@ void scm_egc()
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);
+ ASRTER(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc);
scm_egc_start();
stkframe[0] = scm_env;
stkframe[1] = scm_env_tmp;
diff --git a/time.c b/time.c
index 7cefb94..a57034a 100644
--- a/time.c
+++ b/time.c
@@ -117,6 +117,11 @@
# include <sys/timeb.h>
# define USE_GETTIMEOFDAY
#endif
+#ifdef __NetBSD__
+# include <sys/timeb.h>
+# include <sys/times.h>
+# define USE_GETTIMEOFDAY
+#endif
#ifdef __OpenBSD__
# include <sys/types.h>
# include <sys/time.h>
@@ -352,9 +357,8 @@ SCM your_time()
}
else if ((1 + time_buffer1.time)==time_buffer2.time) ;
else if (cnt < TIMETRIES) goto tryagain;
- else {
- scm_warn("could not read two ftime()s within one second in 10 tries",
- "", UNDEFINED);
+ else { /* could not read two ftime()s within one second in 10 tries */
+ scm_warn("ftime()s too fast", "", MAKINUM(TIMETRIES));
return MAKINUM(-1);
}
tmp = CLKTCK*(time_buffer2.millitm - your_base.millitm);
diff --git a/unif.c b/unif.c
index ae5c1b7..86ae50a 100644
--- a/unif.c
+++ b/unif.c
@@ -106,7 +106,7 @@ SCM resizuve(vect, len)
# endif
#endif
}
- ASSERT(INUMP(len), len, ARG2, s_resizuve);
+ ASRTER(INUMP(len), len, ARG2, s_resizuve);
if (!l) l = 1L;
siz = l * sz;
if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve);
@@ -202,6 +202,7 @@ SCM make_uve(k, prot)
# endif
}
DEFER_INTS;
+ /* Make a potentially HUGE object */
v = must_malloc_cell((i ? i : 1L),
MAKE_LENGTH((k < LENGTH_MAX ? k : LENGTH_MAX), type),
s_vector);
@@ -287,26 +288,27 @@ long aind(ra, args, what)
register sizet k = ARRAY_NDIM(ra);
array_dim *s = ARRAY_DIMS(ra);
if INUMP(args) {
- ASSERT(1==k, UNDEFINED, WNA, what);
+ ASRTER(1==k, UNDEFINED, WNA, what);
j = INUM(args);
- ASSERT(j >= (s->lbnd) && j <= (s->ubnd), args, OUTOFRANGE, what);
+ ASRTER(j >= (s->lbnd) && j <= (s->ubnd), args, OUTOFRANGE, what);
return pos + (j - s->lbnd)*(s->inc);
}
- ASSERT((IMP(args) ? NULLP(args) : CONSP(args)), args, s_bad_ind, what);
+ ASRTER((IMP(args) ? NULLP(args) : CONSP(args)), args, s_bad_ind, what);
while (k && NIMP(args)) {
ind = CAR(args);
args = CDR(args);
- ASSERT(INUMP(ind), ind, s_bad_ind, what);
+ ASRTER(INUMP(ind), ind, s_bad_ind, what);
j = INUM(ind);
- ASSERT(j >= (s->lbnd) && j <= (s->ubnd), ind, OUTOFRANGE, what);
+ ASRTER(j >= (s->lbnd) && j <= (s->ubnd), ind, OUTOFRANGE, what);
pos += (j - s->lbnd)*(s->inc);
k--;
s++;
}
- ASSERT(0==k && NULLP(args), UNDEFINED, WNA, what);
+ ASRTER(0==k && NULLP(args), UNDEFINED, WNA, what);
return pos;
}
+/* Given rank, allocate cell only. */
SCM make_ra(ndim)
int ndim;
{
@@ -329,32 +331,33 @@ SCM shap2ra(args, what)
array_dim *s;
SCM ra, spec, sp;
int ndim = ilength(args);
- ASSERT(0 <= ndim, args, s_bad_spec, what);
+ ASRTER(0 <= ndim, args, s_bad_spec, what);
ra = make_ra(ndim);
ARRAY_BASE(ra) = 0;
s = ARRAY_DIMS(ra);
for (; NIMP(args); s++, args = CDR(args)) {
spec = CAR(args);
if IMP(spec) {
- ASSERT(INUMP(spec)&&INUM(spec)>=0, spec, s_bad_spec, what);
+ ASRTER(INUMP(spec)&&INUM(spec)>=0, spec, s_bad_spec, what);
s->lbnd = 0;
s->ubnd = INUM(spec) - 1;
s->inc = 1;
}
else {
- ASSERT(CONSP(spec) && INUMP(CAR(spec)), spec, s_bad_spec, what);
+ ASRTER(CONSP(spec) && INUMP(CAR(spec)), spec, s_bad_spec, what);
s->lbnd = INUM(CAR(spec));
sp = CDR(spec);
- ASSERT(NIMP(sp) && INUMP(CAR(sp)) && NULLP(CDR(sp)),
+ ASRTER(NIMP(sp) && INUMP(CAR(sp)) && NULLP(CDR(sp)),
spec, s_bad_spec, what);
s->ubnd = INUM(CAR(sp));
+ ASRTER(s->ubnd >= s->lbnd, spec, s_bad_spec, what);
s->inc = 1;
}
}
return ra;
}
-static char s_uve_fill[] = "uniform-vector-fill!";
+char s_array_fill[] = "array-fill!";
int rafill(ra, fill, ignore)
SCM ra, fill, ignore;
{
@@ -370,8 +373,8 @@ int rafill(ra, fill, ignore)
else
n = LENGTH(ra);
switch TYP7(ra) {
- badarg2: wta(fill, (char *)ARG2, s_uve_fill);
- default: ASSERT(NFALSEP(arrayp(ra, UNDEFINED)), ra, ARG1, s_uve_fill);
+ badarg2: wta(fill, (char *)ARG2, s_array_fill);
+ default: ASRTER(NFALSEP(arrayp(ra, UNDEFINED)), ra, ARG1, s_array_fill);
for (i = base; n--; i += inc)
aset(ra, fill, MAKINUM(i));
break;
@@ -427,8 +430,8 @@ int rafill(ra, fill, ignore)
{
long *ve = VELTS(ra);
long f = (tc7_uvect==TYP7(ra) ?
- num2ulong(fill, (char *)ARG2, s_uve_fill) :
- num2long(fill, (char *)ARG2, s_uve_fill));
+ num2ulong(fill, (char *)ARG2, s_array_fill) :
+ num2long(fill, (char *)ARG2, s_array_fill));
for (i = base; n--; i += inc)
ve[i] = f;
break;
@@ -436,14 +439,14 @@ int rafill(ra, fill, ignore)
# ifdef FLOATS
case tc7_fvect: {
float *ve = (float *)VELTS(ra);
- float f = num2dbl(fill, (char *)ARG2, s_uve_fill);
+ float f = num2dbl(fill, (char *)ARG2, s_array_fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
}
case tc7_dvect: {
double *ve = (double *)VELTS(ra);
- double f = num2dbl(fill, (char *)ARG2, s_uve_fill);
+ double f = num2dbl(fill, (char *)ARG2, s_array_fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
@@ -456,7 +459,7 @@ int rafill(ra, fill, ignore)
fi = IMAG(fill);
}
else
- fr = num2dbl(fill, (char *)ARG2, s_uve_fill);
+ fr = num2dbl(fill, (char *)ARG2, s_array_fill);
for (i = base; n--; i += inc) {
ve[i][0] = fr;
ve[i][1] = fi;
@@ -467,15 +470,6 @@ int rafill(ra, fill, ignore)
}
return 1;
}
-SCM uve_fill(uve, fill)
- SCM uve, fill;
-{
-
- ASSERT(NIMP(uve) && (!ARRAYP(uve) || 1==ARRAY_NDIM(uve)),
- uve, ARG1, s_uve_fill);
- rafill(uve, fill, EOL);
- return UNSPECIFIED;
-}
static char s_dims2ura[] = "dimensions->uniform-array";
SCM dims2ura(dims, prot, fill)
@@ -485,16 +479,17 @@ SCM dims2ura(dims, prot, fill)
long rlen = 1;
array_dim *s;
SCM ra;
- if INUMP(dims)
+ if INUMP(dims) {
if (INUM(dims) < LENGTH_MAX) {
ra = make_uve(INUM(dims), prot);
if NNULLP(fill)
- rafill(ra, CAR(fill), EOL);
+ rafill(ra, CAR(fill), UNDEFINED);
return ra;
}
else
dims = cons(dims, EOL);
- ASSERT(NULLP(dims) || (NIMP(dims) && CONSP(dims)), dims, ARG1, s_dims2ura);
+ }
+ ASRTER(NULLP(dims) || (NIMP(dims) && CONSP(dims)), dims, ARG1, s_dims2ura);
ra = shap2ra(dims, s_dims2ura);
CAR(ra) |= ARRAY_CONTIGUOUS;
s = ARRAY_DIMS(ra);
@@ -504,8 +499,10 @@ SCM dims2ura(dims, prot, fill)
rlen = (s[k].ubnd - s[k].lbnd + 1)*s[k].inc;
vlen *= (s[k].ubnd - s[k].lbnd + 1);
}
- if (rlen < LENGTH_MAX)
- ARRAY_V(ra) = make_uve((rlen > 0 ? rlen : 0L), prot);
+ if (rlen <= 0)
+ ARRAY_V(ra) = make_uve(0L, prot);
+ else if (rlen < LENGTH_MAX)
+ ARRAY_V(ra) = make_uve(rlen, prot);
else {
sizet bit;
switch TYP7(make_uve(0L, prot)) {
@@ -523,8 +520,8 @@ SCM dims2ura(dims, prot, fill)
*((long *)VELTS(ARRAY_V(ra))) = rlen;
}
if NNULLP(fill) {
- ASSERT(1==ilength(fill), UNDEFINED, WNA, s_dims2ura);
- rafill(ARRAY_V(ra), CAR(fill), EOL);
+ ASRTER(1==ilength(fill), UNDEFINED, WNA, s_dims2ura);
+ rafill(ARRAY_V(ra), CAR(fill), UNDEFINED);
}
if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra))
if (s->ubnd < s->lbnd || (0==s->lbnd && 1==s->inc)) return ARRAY_V(ra);
@@ -557,8 +554,11 @@ SCM make_sh_array(oldra, mapfunc, dims)
sizet i, k;
long old_min, new_min, old_max, new_max;
array_dim *s;
- ASSERT(BOOL_T==procedurep(mapfunc), mapfunc, ARG2, s_make_sh_array);
- ASSERT(NIMP(oldra) && arrayp(oldra, UNDEFINED), oldra, ARG1, s_make_sh_array);
+ ASRTER(BOOL_T==procedurep(mapfunc), mapfunc, ARG2, s_make_sh_array);
+ ASRTER(NIMP(oldra) && arrayp(oldra, UNDEFINED), oldra, ARG1, s_make_sh_array);
+# ifndef RECKLESS
+ scm_arity_check(mapfunc, ilength(dims), s_make_sh_array);
+# endif
ra = shap2ra(dims, s_make_sh_array);
if (ARRAYP(oldra)) {
ARRAY_V(ra) = ARRAY_V(oldra);
@@ -598,7 +598,7 @@ SCM make_sh_array(oldra, mapfunc, dims)
i = (sizet)aind(oldra, imap, s_make_sh_array);
else {
if NINUMP(imap) {
- ASSERT(1==ilength(imap) && INUMP(CAR(imap)),
+ ASRTER(1==ilength(imap) && INUMP(CAR(imap)),
imap, s_bad_ind, s_make_sh_array);
imap = CAR(imap);
}
@@ -616,7 +616,7 @@ SCM make_sh_array(oldra, mapfunc, dims)
s[k].inc = aind(oldra, imap, s_make_sh_array) - i;
else {
if NINUMP(imap) {
- ASSERT(1==ilength(imap) && INUMP(CAR(imap)),
+ ASRTER(1==ilength(imap) && INUMP(CAR(imap)),
imap, s_bad_ind, s_make_sh_array);
imap = CAR(imap);
}
@@ -631,7 +631,7 @@ SCM make_sh_array(oldra, mapfunc, dims)
else
s[k].inc = new_max - new_min + 1; /* contiguous by default */
}
- ASSERT(old_min <= new_min && old_max >= new_max, UNDEFINED,
+ ASRTER(old_min <= new_min && old_max >= new_max, UNDEFINED,
"mapping out of range", s_make_sh_array);
if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra)) {
if (1==s->inc && 0==s->lbnd
@@ -650,24 +650,24 @@ SCM trans_array(args)
SCM ra, res, vargs, *ve = &vargs;
array_dim *s, *r;
int ndim, i, k;
- ASSERT(NIMP(args), UNDEFINED, WNA, s_trans_array);
+ ASRTER(NIMP(args), UNDEFINED, WNA, s_trans_array);
ra = CAR(args);
args = CDR(args);
switch TYP7(ra) {
default: badarg: wta(ra, (char *)ARG1, s_trans_array);
case tc7_vector:
case tcs_uves:
- ASSERT(NIMP(args) && NULLP(CDR(args)), UNDEFINED, WNA, s_trans_array);
- ASSERT(INUM0==CAR(args), CAR(args), ARG1, s_trans_array);
+ ASRTER(NIMP(args) && NULLP(CDR(args)), UNDEFINED, WNA, s_trans_array);
+ ASRTER(INUM0==CAR(args), CAR(args), ARG1, s_trans_array);
return ra;
case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
vargs = vector(args);
- ASSERT(LENGTH(vargs)==ARRAY_NDIM(ra), UNDEFINED, WNA, s_trans_array);
+ ASRTER(LENGTH(vargs)==ARRAY_NDIM(ra), UNDEFINED, WNA, s_trans_array);
ve = VELTS(vargs);
ndim = 0;
for (k = 0; k < ARRAY_NDIM(ra); k++) {
i = INUM(ve[k]);
- ASSERT(INUMP(ve[k]) && i >=0 && i < ARRAY_NDIM(ra),
+ ASRTER(INUMP(ve[k]) && i >=0 && i < ARRAY_NDIM(ra),
ve[k], ARG2, s_trans_array);
if (ndim < i) ndim = i;
}
@@ -699,7 +699,7 @@ SCM trans_array(args)
r->inc += s->inc;
}
}
- ASSERT(ndim <= 0, args, "bad argument list", s_trans_array);
+ ASRTER(ndim <= 0, args, "bad argument list", s_trans_array);
ra_set_contp(res);
return res;
}
@@ -713,7 +713,7 @@ SCM encl_array(axes)
SCM axv, ra, res, ra_inr;
array_dim vdim, *s = &vdim;
int ndim, j, k, ninr, noutr;
- ASSERT(NIMP(axes), UNDEFINED, WNA, s_encl_array);
+ ASRTER(NIMP(axes), UNDEFINED, WNA, s_encl_array);
ra = CAR(axes);
axes = CDR(axes);
if NULLP(axes)
@@ -741,13 +741,13 @@ SCM encl_array(axes)
}
noutr = ndim - ninr;
axv = make_string(MAKINUM(ndim), MAKICHR(0));
- ASSERT(0 <= noutr && 0 <= ninr, UNDEFINED, WNA, s_encl_array);
+ ASRTER(0 <= noutr && 0 <= ninr, UNDEFINED, WNA, s_encl_array);
res = make_ra(noutr);
ARRAY_BASE(res) = ARRAY_BASE(ra_inr);
ARRAY_V(res) = ra_inr;
for (k = 0; k < ninr; k++, axes = CDR(axes)) {
j = INUM(CAR(axes));
- ASSERT(INUMP(CAR(axes)) && j<ndim, CAR(axes), "bad axis", s_encl_array);
+ ASRTER(INUMP(CAR(axes)) && j<ndim, CAR(axes), "bad axis", s_encl_array);
ARRAY_DIMS(ra_inr)[k].lbnd = s[j].lbnd;
ARRAY_DIMS(ra_inr)[k].ubnd = s[j].ubnd;
ARRAY_DIMS(ra_inr)[k].inc = s[j].inc;
@@ -787,7 +787,7 @@ SCM array_inbp(args)
while (k && NIMP(args)) {
ind = CAR(args);
args = CDR(args);
- ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp);
+ ASRTER(INUMP(ind), ind, s_bad_ind, s_array_inbp);
j = INUM(ind);
if (j < (s->lbnd) || j > (s->ubnd)) ret = BOOL_F;
k--;
@@ -801,7 +801,7 @@ SCM array_inbp(args)
case tcs_uves:
ASRTGO(NIMP(args) && NULLP(CDR(args)), wna);
ind = CAR(args);
- ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp);
+ ASRTER(INUMP(ind), ind, s_bad_ind, s_array_inbp);
j = INUM(ind);
return j >= 0 && j < LENGTH(v) ? BOOL_T : BOOL_F;
}
@@ -821,12 +821,12 @@ SCM aref(v, args)
}
else {
if NIMP(args) {
- ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aref);
+ ASRTER(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aref);
pos = INUM(CAR(args));
ASRTGO(NULLP(CDR(args)), wna);
}
else {
- ASSERT(INUMP(args), args, ARG2, s_aref);
+ ASRTER(INUMP(args), args, ARG2, s_aref);
pos = INUM(args);
}
ASRTGO(pos >= 0 && pos < LENGTH(v), outrng);
@@ -886,7 +886,7 @@ SCM aref(v, args)
SCM scm_array_ref(args)
SCM args;
{
- ASSERT(NIMP(args), UNDEFINED, WNA, s_aref);
+ ASRTER(NIMP(args), UNDEFINED, WNA, s_aref);
return aref(CAR(args), CDR(args));
}
@@ -994,12 +994,12 @@ SCM aset(v, obj, args)
}
else {
if NIMP(args) {
- ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aset);
+ ASRTER(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aset);
pos = INUM(CAR(args));
ASRTGO(NULLP(CDR(args)), wna);
}
else {
- ASSERT(INUMP(args), args, ARG2, s_aset);
+ ASRTER(INUMP(args), args, ARG2, s_aset);
pos = INUM(args);
}
ASRTGO(pos >= 0 && pos < LENGTH(v), outrng);
@@ -1099,7 +1099,7 @@ SCM uve_read(v, port)
long sz, len, ans;
long start=0;
if UNBNDP(port) port = cur_inp;
- ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
+ ASRTER(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
ASRTGO(NIMP(v), badarg1);
len = LENGTH(v);
loop:
@@ -1164,7 +1164,7 @@ SCM uve_write(v, port)
long sz, len, ans;
long start=0;
if UNBNDP(port) port = cur_outp;
- ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
+ ASRTER(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
ASRTGO(NIMP(v), badarg1);
len = LENGTH(v);
loop:
@@ -1220,7 +1220,7 @@ SCM lcount(item, seq)
long i, imin, ubnd, lbnd = 0;
int enclosed = 0;
register unsigned long cnt = 0, w;
- ASSERT(NIMP(seq), seq, ARG2, s_count);
+ ASRTER(NIMP(seq), seq, ARG2, s_count);
ubnd = LENGTH(seq) - 1;
tail:
switch TYP7(seq) {
@@ -1251,9 +1251,10 @@ SCM lcount(item, seq)
n = ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd + 1;
if (n<=0) return INUM0;
seq = ARRAY_V(seq);
- if FALSEP(item)
+ if FALSEP(item) {
for (;n--; i+=inc)
if (!((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT)))) cnt++;
+ }
else
for (;n--; i+=inc)
if ((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT))) cnt++;
@@ -1279,14 +1280,14 @@ SCM bit_position(item, v, k)
long i, len, lenw, xbits, pos = INUM(k), offset = 0;
int enclosed = 0;
register unsigned long w;
- ASSERT(NIMP(v), v, ARG2, s_uve_pos);
- ASSERT(INUMP(k), k, ARG3, s_uve_pos);
+ ASRTER(NIMP(v), v, ARG2, s_uve_pos);
+ ASRTER(INUMP(k), k, ARG3, s_uve_pos);
len = LENGTH(v);
tail:
switch TYP7(v) {
default: badarg2: wta(v, (char *)ARG2, s_uve_pos);
case tc7_bvect:
- ASSERT((pos <= len) && (pos >= 0), k, OUTOFRANGE, s_uve_pos);
+ ASRTER((pos <= len) && (pos >= 0), k, OUTOFRANGE, s_uve_pos);
if (pos==len) return BOOL_F;
if (0==len) return MAKINUM(-1L);
lenw = (len-1)/LONG_BIT; /* watch for part words */
@@ -1315,7 +1316,7 @@ SCM bit_position(item, v, k)
}
return BOOL_F;
case tc7_smob: ASRTGO(ARRAYP(v) && 1==ARRAY_NDIM(v) && !enclosed++, badarg2);
- ASSERT(pos >= ARRAY_DIMS(v)->lbnd, k, OUTOFRANGE, s_uve_pos);
+ ASRTER(pos >= ARRAY_DIMS(v)->lbnd, k, OUTOFRANGE, s_uve_pos);
if (1==ARRAY_DIMS(v)->inc) {
len = ARRAY_DIMS(v)->ubnd - ARRAY_DIMS(v)->lbnd + ARRAY_BASE(v) + 1;
offset = ARRAY_BASE(v) - ARRAY_DIMS(v)->lbnd;
@@ -1357,12 +1358,12 @@ SCM bit_set(v, kv, obj)
vlen = LENGTH(v);
if (BOOL_F==obj) for (i = LENGTH(kv);i;) {
k = VELTS(kv)[--i];
- ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set);
+ ASRTER((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set);
VELTS(v)[k/LONG_BIT] &= ~(1L<<(k%LONG_BIT));
}
else if (BOOL_T==obj) for (i = LENGTH(kv); i;) {
k = VELTS(kv)[--i];
- ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set);
+ ASRTER((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set);
VELTS(v)[k/LONG_BIT] |= (1L<<(k%LONG_BIT));
}
else
@@ -1400,12 +1401,12 @@ SCM bit_count(v, kv, obj)
vlen = LENGTH(v);
if (BOOL_F==obj) for (i = LENGTH(kv);i;) {
k = VELTS(kv)[--i];
- ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count);
+ ASRTER((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count);
if (!(VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT)))) count++;
}
else if (BOOL_T==obj) for (i = LENGTH(kv); i;) {
k = VELTS(kv)[--i];
- ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count);
+ ASRTER((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count);
if (VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT))) count++;
}
else
@@ -1645,10 +1646,10 @@ SCM list2ura(ndim, prot, lst)
SCM ra;
long n;
sizet k = INUM(ndim);
- ASSERT(INUMP(ndim), ndim, ARG1, s_list2ura);
+ ASRTER(INUMP(ndim), ndim, ARG1, s_list2ura);
for (; k--; NIMP(row) && (row = CAR(row))) {
n = ilength(row);
- ASSERT(n>=0, lst, ARG2, s_list2ura);
+ ASRTER(n>=0, lst, ARG2, s_list2ura);
shp = cons(MAKINUM(n), shp);
}
ra = dims2ura(reverse(shp), prot, EOL);
@@ -1915,26 +1916,26 @@ SCM scm_logaref(args)
{
SCM ra, inds, ibit;
int i, rank = 1;
- ASSERT(NIMP(args), UNDEFINED, WNA, s_logaref);
+ ASRTER(NIMP(args), UNDEFINED, WNA, s_logaref);
ra = CAR(args);
- ASSERT(NIMP(ra), ra, ARG1, s_logaref);
+ ASRTER(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);
+ ASRTER(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)),
+ ASRTER(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
inds, WNA, s_logaref);
- ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaref);
+ ASRTER(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);
+ ASRTER(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaref);
args = CDR(args);
}
CDR(args) = EOL;
@@ -1951,29 +1952,29 @@ SCM scm_logaset(ra, obj, args)
{
SCM oval, inds, ibit;
int i, rank = 1;
- ASSERT(NIMP(ra), ra, ARG1, s_logaset);
+ ASRTER(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);
+ ASRTER(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaset);
args = CDR(args);
}
if NNULLP(args) {
- ASSERT(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
+ ASRTER(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
inds, WNA, s_logaset);
- ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaset);
+ ASRTER(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);
+ ASRTER(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);
+ ASRTER(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)));
@@ -1997,7 +1998,6 @@ static iproc subr3s[] = {
static iproc subr2s[] = {
{s_resizuve, resizuve},
{s_count, lcount},
- {s_uve_fill, uve_fill},
{0, 0}};
static iproc subr1s[] = {
diff --git a/unix.c b/unix.c
index 3cfc809..ccd24c7 100644
--- a/unix.c
+++ b/unix.c
@@ -69,6 +69,9 @@ SCM scm_lstat P((SCM str));
# ifdef SVR4
# include <unistd.h>
# endif
+# ifdef __NetBSD__
+# include <unistd.h>
+# endif
# ifdef __OpenBSD__
# include <unistd.h>
# endif
@@ -82,9 +85,9 @@ SCM scm_mknod(path, mode, dev)
SCM path, mode, dev;
{
int val;
- ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_mknod);
- ASSERT(INUMP(mode), mode, ARG2, s_mknod);
- ASSERT(INUMP(dev), dev, ARG3, s_mknod);
+ ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_mknod);
+ ASRTER(INUMP(mode), mode, ARG2, s_mknod);
+ ASRTER(INUMP(dev), dev, ARG3, s_mknod);
SYSCALL(val = mknod(CHARS(path), INUM(mode), INUM(dev)););
return val ? BOOL_F : BOOL_T;
}
@@ -97,7 +100,7 @@ SCM scm_acct(path)
SYSCALL(val = acct(0););
return val ? BOOL_F : BOOL_T;
}
- ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_acct);
+ ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_acct);
SYSCALL(val = acct(CHARS(path)););
return val ? BOOL_F : BOOL_T;
}
@@ -106,7 +109,7 @@ static char s_nice[] = "nice";
SCM scm_nice(incr)
SCM incr;
{
- ASSERT(INUMP(incr), incr, ARG1, s_nice);
+ ASRTER(INUMP(incr), incr, ARG1, s_nice);
return nice(INUM(incr)) ? BOOL_F : BOOL_T;
}
@@ -121,8 +124,8 @@ SCM scm_symlink(oldpath, newpath)
SCM oldpath, newpath;
{
int val;
- ASSERT(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_symlink);
- ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_symlink);
+ ASRTER(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_symlink);
+ ASRTER(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_symlink);
SYSCALL(val = symlink(CHARS(oldpath), CHARS(newpath)););
return val ? BOOL_F : BOOL_T;
}
@@ -132,7 +135,7 @@ SCM scm_readlink(path)
{
int i;
char buf[1024];
- ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_readlink);
+ ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_readlink);
SYSCALL(i = readlink(CHARS(path), buf, (sizet)sizeof(buf)););
if (-1==i) return BOOL_F;
return makfromstr(buf, (sizet)i);
@@ -143,7 +146,7 @@ SCM scm_lstat(str)
{
int i;
struct stat stat_temp;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_lstat);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_lstat);
SYSCALL(i = lstat(CHARS(str), &stat_temp););
if (i) return BOOL_F;
return stat2scm(&stat_temp);
diff --git a/version.txi b/version.txi
new file mode 100644
index 0000000..e2502a5
--- /dev/null
+++ b/version.txi
@@ -0,0 +1,2 @@
+@set SCMVERSION 5d9
+@set SCMDATE November 2003
diff --git a/x.c b/x.c
index 8b3a53c..2c9041f 100644
--- a/x.c
+++ b/x.c
@@ -59,6 +59,7 @@
#include <X11/Xlib.h>
#include <X11/Xcms.h>
/*#include <X11/Xcmsint.h>*/ /* For IntensityTbl */
+#include <X11/Xresource.h>
#include <X11/Xutil.h>
#include <X11/Xatom.h>
@@ -644,7 +645,7 @@ sizet x_free_xevent(ptr)
/* Utility macro and functions for checking and coercing SCM arguments. */
#define GET_NEXT_INT(result, args, err, rtn) \
- ASSERT(NIMP(args) && CONSP(args) && INUMP(CAR(args)), args, err, rtn); \
+ ASRTER(NIMP(args) && CONSP(args) && INUMP(CAR(args)), args, err, rtn); \
result = INUM(CAR(args)); \
args = CDR(args);
@@ -787,7 +788,7 @@ Pixmap thepxmap(obj, s_caller)
char *s_caller;
{
if (FALSEP(obj) || (INUM0==obj)) return 0L;
- ASSERT(NIMP(obj) && ((OpPxmpMask & (int)CAR(obj))==OpPxmp),
+ ASRTER(NIMP(obj) && ((OpPxmpMask & (int)CAR(obj))==OpPxmp),
obj, ARGn, s_caller);
return WINDOW(obj)->p.pm;
}
@@ -795,7 +796,7 @@ Font thefont(obj, s_caller)
SCM obj;
char *s_caller;
{
- ASSERT(NIMP(obj) && FONTP(obj), obj, ARGn, s_caller);
+ ASRTER(NIMP(obj) && FONTP(obj), obj, ARGn, s_caller);
return FONT(obj)->font;
}
Colormap thecmap(obj, s_caller)
@@ -803,7 +804,7 @@ Colormap thecmap(obj, s_caller)
char *s_caller;
{
if (FALSEP(obj) || (INUM0==obj)) return 0L;
- ASSERT(NIMP(obj) && COLORMAPP(obj), obj, ARGn, s_caller);
+ ASRTER(NIMP(obj) && COLORMAPP(obj), obj, ARGn, s_caller);
return COLORMAP(obj)->cm;
}
Cursor thecsr(obj, s_caller)
@@ -811,7 +812,7 @@ Cursor thecsr(obj, s_caller)
char *s_caller;
{
if (FALSEP(obj) || (INUM0==obj)) return 0L;
- ASSERT(NIMP(obj) && CURSORP(obj), obj, ARGn, s_caller);
+ ASRTER(NIMP(obj) && CURSORP(obj), obj, ARGn, s_caller);
return CURSOR(obj)->cursor;
}
Bool thebool(obj, s_caller)
@@ -819,7 +820,7 @@ Bool thebool(obj, s_caller)
char *s_caller;
{
SCM val = thevalue(obj);
- ASSERT(BOOL_F==val || BOOL_T==val, obj, ARGn, s_caller);
+ ASRTER(BOOL_F==val || BOOL_T==val, obj, ARGn, s_caller);
return NFALSEP(val);
}
int theint(obj, s_caller)
@@ -827,7 +828,7 @@ int theint(obj, s_caller)
char *s_caller;
{
SCM val = thevalue(obj);
- ASSERT(INUMP(val), obj, ARGn, s_caller);
+ ASRTER(INUMP(val), obj, ARGn, s_caller);
return INUM(val);
}
int theuint(obj, s_caller)
@@ -835,7 +836,7 @@ int theuint(obj, s_caller)
char *s_caller;
{
SCM val = thevalue(obj);
- ASSERT(INUMP(val) && (0 <= INUM(val)), obj, ARGn, s_caller);
+ ASRTER(INUMP(val) && (0 <= INUM(val)), obj, ARGn, s_caller);
return INUM(val);
}
@@ -847,7 +848,7 @@ static int args2valmask(oargs, s_caller)
int attr, len, attr_mask = 0;
if (!(len = ilength(args))) return 0;
while (len) {
- ASSERT(NIMP(args), oargs, WNA, s_caller);
+ ASRTER(NIMP(args), oargs, WNA, s_caller);
attr = theint(CAR(args), s_caller); args = CDR(args);
attr_mask |= attr;
len -= 1;
@@ -864,11 +865,11 @@ static int args2xgcvalues(sgc, vlu, oargs)
int attr, len, attr_mask = 0;
/* (void)memset((char *)vlu, 0, sizeof(XGCValues)); */
if (!(len = ilength(args))) return 0;
- ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_gc);
+ ASRTER(len > 0 && (! (len & 1)), oargs, WNA, s_gc);
while (len) {
- ASSERT(NIMP(args), oargs, WNA, s_gc);
+ ASRTER(NIMP(args), oargs, WNA, s_gc);
attr = theint(CAR(args), s_gc); args = CDR(args);
- ASSERT(NIMP(args), oargs, WNA, s_gc);
+ ASRTER(NIMP(args), oargs, WNA, s_gc);
sval = CAR(args); args = CDR(args);
attr_mask |= attr;
switch (attr) {
@@ -917,7 +918,7 @@ static int args2xgcvalues(sgc, vlu, oargs)
case GCDashList: vlu->dashes = (char)theint(sval, s_gc); break;
case GCArcMode: vlu->arc_mode = theint(sval, s_gc); break;
- default: ASSERT(0, MAKINUM(attr), ARGn, s_gc);
+ default: ASRTER(0, MAKINUM(attr), ARGn, s_gc);
}
len -= 2;
}
@@ -931,11 +932,11 @@ static int args2winattribs(vlu, oargs)
int attr, len, attr_mask = 0;
/* (void)memset((char *)vlu, 0, sizeof(XSetWindowAttributes)); */
if (!(len = ilength(args))) return 0;
- ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_window);
+ ASRTER(len > 0 && (! (len & 1)), oargs, WNA, s_window);
while (len) {
- ASSERT(NIMP(args), oargs, WNA, s_window);
+ ASRTER(NIMP(args), oargs, WNA, s_window);
attr = theint(CAR(args), s_window); args = CDR(args);
- ASSERT(NIMP(args), oargs, WNA, s_window);
+ ASRTER(NIMP(args), oargs, WNA, s_window);
sval = CAR(args); args = CDR(args);
attr_mask |= attr;
switch (attr) {
@@ -958,7 +959,7 @@ static int args2winattribs(vlu, oargs)
case CWColormap: vlu->colormap = thecmap(sval, s_window); break;
case CWCursor: vlu->cursor = thecsr(sval, s_window); break;
- default: ASSERT(0, MAKINUM(attr), ARGn, s_window);
+ default: ASRTER(0, MAKINUM(attr), ARGn, s_window);
}
len -= 2;
}
@@ -972,11 +973,11 @@ static int args2wincfgs(vlu, oargs)
int cfgs, len, cfgs_mask = 0;
/* (void)memset((char *)vlu, 0, sizeof(XWindowChanges)); */
if (!(len = ilength(args))) return 0;
- ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_window);
+ ASRTER(len > 0 && (! (len & 1)), oargs, WNA, s_window);
while (len) {
- ASSERT(NIMP(args), oargs, WNA, s_window);
+ ASRTER(NIMP(args), oargs, WNA, s_window);
cfgs = theint(CAR(args), s_window); args = CDR(args);
- ASSERT(NIMP(args), oargs, WNA, s_window);
+ ASRTER(NIMP(args), oargs, WNA, s_window);
sval = CAR(args); args = CDR(args);
cfgs_mask |= cfgs;
switch (cfgs) {
@@ -988,7 +989,7 @@ static int args2wincfgs(vlu, oargs)
case CWBorderWidth: vlu->border_width = theuint(sval, s_window); break;
case CWSibling: vlu->sibling =thepxmap(sval, s_window); break;
case CWStackMode: vlu->stack_mode = theint(sval, s_window); break;
- default: ASSERT(0, MAKINUM(cfgs), ARGn, s_window);
+ default: ASRTER(0, MAKINUM(cfgs), ARGn, s_window);
}
len -= 2;
}
@@ -1002,7 +1003,7 @@ SCM x_open_display(dpy_name)
{
Display *display;
if FALSEP(dpy_name) dpy_name = nullstr;
- ASSERT(NIMP(dpy_name) && STRINGP(dpy_name), dpy_name, ARG1, s_x_open_display);
+ ASRTER(NIMP(dpy_name) && STRINGP(dpy_name), dpy_name, ARG1, s_x_open_display);
display = XOpenDisplay(CHARS(dpy_name));
return (display ? make_xdisplay(display) : BOOL_F);
}
@@ -1019,7 +1020,7 @@ SCM x_display_debug(sd, si)
SCM x_default_screen(sdpy)
SCM sdpy;
{
- ASSERT(NIMP(sdpy) && OPDISPLAYP(sdpy), sdpy, ARG1, s_x_default_screen);
+ ASRTER(NIMP(sdpy) && OPDISPLAYP(sdpy), sdpy, ARG1, s_x_default_screen);
return MAKINUM(DefaultScreen(XDISPLAY(sdpy)));
}
@@ -1031,7 +1032,7 @@ SCM x_create_window(swin, spos, sargs)
Window window;
int len = ilength(sargs);
- ASSERT(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_create_window);
+ ASRTER(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_create_window);
scm2XPoint(!0, spos, &position, (char *)ARG2, s_x_create_window);
scm2XPoint(0, CAR(sargs), &size, (char *)ARG3, s_x_create_window);
sargs = CDR(sargs);
@@ -1052,11 +1053,11 @@ SCM x_create_window(swin, spos, sargs)
SCM svis;
unsigned long valuemask;
XSetWindowAttributes attributes;
- ASSERT(5 <= len, sargs, WNA, s_x_create_window);
+ ASRTER(5 <= len, sargs, WNA, s_x_create_window);
GET_NEXT_INT(depth, sargs, ARG5, s_x_create_window);
GET_NEXT_INT(class, sargs, ARGn, s_x_create_window);
svis = CAR(sargs); sargs = CDR(sargs);
- ASSERT(NIMP(svis) && VISUALP(svis), svis, ARGn, s_x_create_window);
+ ASRTER(NIMP(svis) && VISUALP(svis), svis, ARGn, s_x_create_window);
valuemask = args2winattribs(&attributes, sargs);
window = XCreateWindow(XWINDISPLAY(swin), XWINDOW(swin),
position.x, position.y, /* initial placement */
@@ -1098,7 +1099,7 @@ SCM x_create_pixmap(obj, s_size, s_depth)
}
else goto badarg1;
scm2XPoint(0, s_size, &size, (char *)ARG2, s_x_create_pixmap);
- ASSERT(INUMP(s_depth) && depth >= 0, s_depth, ARG3, s_x_create_pixmap);
+ ASRTER(INUMP(s_depth) && depth >= 0, s_depth, ARG3, s_x_create_pixmap);
p = XCreatePixmap(dpy, drawable, size.x, size.y, depth);
return make_xwindow(display, scn, p, (char) 1, (char) 0);
}
@@ -1111,10 +1112,10 @@ SCM x_window_ref(oargs)
XWindowAttributes vlu;
int attr, len = ilength(args);
/* (void)memset((char *)&vlu, 0, sizeof(XWindowAttributes)); */
- ASSERT(len > 0, oargs, WNA, s_x_window_ref);
+ ASRTER(len > 0, oargs, WNA, s_x_window_ref);
if (1==len--) return EOL;
swn = CAR(args); args = CDR(args);
- ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_ref);
+ ASRTER(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_ref);
xwn = WINDOW(swn);
if (!XGetWindowAttributes(xwn->dpy, xwn->p.win, &vlu)) return BOOL_F;
while (len) {
@@ -1133,7 +1134,7 @@ SCM x_window_ref(oargs)
case CWDontPropagate:sval = MAKINUM(vlu.do_not_propagate_mask); break;
case CWColormap: sval = make_xcolormap(xwn->display, vlu.colormap); break;
- default: ASSERT(0, MAKINUM(attr), ARGn, s_x_window_ref);
+ default: ASRTER(0, MAKINUM(attr), ARGn, s_x_window_ref);
}
CAR(valend) = sval;
CDR(valend) = cons(BOOL_T, EOL);
@@ -1151,9 +1152,9 @@ SCM x_window_set(args)
XSetWindowAttributes vlu;
unsigned long mask;
- ASSERT(NIMP(args), args, WNA, s_x_window_set);
+ ASRTER(NIMP(args), args, WNA, s_x_window_set);
swn = CAR(args); args = CDR(args);
- ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_set);
+ ASRTER(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_set);
xwn = WINDOW(swn);
mask = args2winattribs(&vlu, args);
XChangeWindowAttributes(xwn->dpy, xwn->p.win, mask, &vlu);
@@ -1169,7 +1170,7 @@ SCM x_window_geometry(swin)
int x, y;
unsigned int w, h, border_width, depth;
- ASSERT(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_window_geometry);
+ ASRTER(NIMP(swin) && OPWINDOWP(swin), swin, ARG1, s_x_window_geometry);
sxw = WINDOW(swin);
sts = XGetGeometry(sxw->dpy, sxw->p.drbl, &root, &x, &y,
&w, &h, &border_width, &depth);
@@ -1186,9 +1187,9 @@ SCM x_window_geometry_set(args)
XWindowChanges vlu;
unsigned long mask;
- ASSERT(NIMP(args), args, WNA, s_x_window_geometry_set);
+ ASRTER(NIMP(args), args, WNA, s_x_window_geometry_set);
swn = CAR(args); args = CDR(args);
- ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_geometry_set);
+ ASRTER(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_geometry_set);
xwn = WINDOW(swn);
mask = args2wincfgs(&vlu, args);
XConfigureWindow(xwn->dpy, xwn->p.win, mask, &vlu);
@@ -1198,10 +1199,10 @@ SCM x_window_geometry_set(args)
SCM x_close(obj)
SCM obj;
{
- ASSERT(NIMP(obj), obj, ARG1, s_x_close);
+ ASRTER(NIMP(obj), obj, ARG1, s_x_close);
if WINDOWP(obj) {
Display *dpy;
- ASSERT(!(CAR((SCM)obj) & SCROOT), obj, ARG1, s_x_close);
+ ASRTER(!(CAR((SCM)obj) & SCROOT), obj, ARG1, s_x_close);
if CLOSEDP(obj) return UNSPECIFIED;
DEFER_INTS;
dpy = XWINDISPLAY(obj);
@@ -1209,7 +1210,7 @@ SCM x_close(obj)
XFlush(dpy);
ALLOW_INTS;
} else {
- ASSERT(DISPLAYP(obj), obj, ARG1, s_x_close);
+ ASRTER(DISPLAYP(obj), obj, ARG1, s_x_close);
DEFER_INTS;
free_xdisplay((CELLPTR)obj);
ALLOW_INTS;
@@ -1237,12 +1238,12 @@ SCM x_create_colormap(swin, s_vis, s_alloc)
SCM alloc;
int allo;
struct xs_Window *sxw;
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_colormap);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_colormap);
sxw = WINDOW(swin);
- ASSERT(NIMP(s_vis) && VISUALP(s_vis), s_vis, ARG2, s_x_create_colormap);
+ ASRTER(NIMP(s_vis) && VISUALP(s_vis), s_vis, ARG2, s_x_create_colormap);
alloc = thevalue(s_alloc);
allo = INUM(alloc);
- ASSERT(INUMP(alloc) && (allo==AllocNone || allo==AllocAll),
+ ASRTER(INUMP(alloc) && (allo==AllocNone || allo==AllocAll),
s_alloc, ARG3, s_x_create_colormap);
return make_xcolormap(sxw->display,
XCreateColormap(sxw->dpy, sxw->p.win,
@@ -1252,7 +1253,7 @@ SCM x_recreate_colormap(s_cm)
SCM s_cm;
{
struct xs_Colormap *sxw;
- ASSERT(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_recreate_colormap);
+ ASRTER(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_recreate_colormap);
sxw = COLORMAP(s_cm);
return make_xcolormap(sxw->display,
XCopyColormapAndFree(XDISPLAY(sxw->display), sxw->cm));
@@ -1261,7 +1262,7 @@ SCM x_install_colormap(s_cm, s_flg)
SCM s_cm, s_flg;
{
struct xs_Colormap *xcm;
- ASSERT(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_install_colormap);
+ ASRTER(NIMP(s_cm) && COLORMAPP(s_cm), s_cm, ARG1, s_x_install_colormap);
if UNBNDP(s_flg) s_flg = BOOL_T;
xcm = COLORMAP(s_cm);
if FALSEP(s_flg) XUninstallColormap(XDISPLAY(xcm->display), xcm->cm);
@@ -1272,19 +1273,19 @@ SCM x_install_colormap(s_cm, s_flg)
/* SCM svsl; */
/* { */
/* XColormapInfo *vsl; */
-/* ASSERT(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_basis); */
+/* ASRTER(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_basis); */
/* vsl = XCOLORMAPINFO(svsl); */
/* return cons2(vsl->red_mult, vsl->green_mult, */
-/* cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */
+/* cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */
/* } */
/* SCM x_colormap_limits(svsl) */
/* SCM svsl; */
/* { */
/* XColormapInfo *vsl; */
-/* ASSERT(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_limits); */
+/* ASRTER(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_limits); */
/* vsl = XCOLORMAPINFO(svsl); */
/* return cons2(vsl->red_mult, vsl->green_mult, */
-/* cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */
+/* cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */
/* } */
/* Colors in Colormap */
@@ -1298,11 +1299,11 @@ SCM x_alloc_color_cells(scmap, spxls, sargs)
Bool contig = 0;
SCM pxra, plra;
unsigned int npixels, nplanes;
- ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_alloc_color_cells);
+ ASRTER(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_alloc_color_cells);
xcm = COLORMAP(scmap);
npixels = INUM(spxls);
- ASSERT(INUMP(spxls) && npixels > 0, spxls, ARG2, s_x_alloc_color_cells);
- pxra = make_uve(npixels, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */
+ ASRTER(INUMP(spxls) && npixels > 0, spxls, ARG2, s_x_alloc_color_cells);
+ pxra = make_uve(npixels, MAKINUM(32L)); /* Uniform vector of long */
switch (ilength(sargs) + 2) {
default: wta(sargs, (char *)WNA, s_x_alloc_color_cells);
case 3: case 4:
@@ -1322,7 +1323,7 @@ SCM x_alloc_color_cells(scmap, spxls, sargs)
nplanes = theuint(CAR(sargs), s_x_alloc_color_cells);
sargs = CDR(sargs);
if NNULLP(sargs) contig = thebool(CAR(sargs), s_x_alloc_color_cells);
- plra = make_uve(nplanes, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */
+ plra = make_uve(nplanes, MAKINUM(32L)); /* Uniform vector of long */
sts = XAllocColorCells(xcm->dpy, xcm->cm, contig,
VELTS(plra), nplanes, VELTS(pxra), npixels);
if (!sts) return BOOL_F;
@@ -1334,9 +1335,9 @@ SCM x_free_color_cells(scmap, spxls, sargs)
{
struct xs_Colormap *xcm;
unsigned int planes = 0;
- ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_free_color_cells);
+ ASRTER(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_free_color_cells);
xcm = COLORMAP(scmap);
- ASSERT(NIMP(spxls) && (TYP7(spxls)==tc7_uvect), spxls, ARG2,
+ ASRTER(NIMP(spxls) && (TYP7(spxls)==tc7_uvect), spxls, ARG2,
s_x_free_color_cells);
switch (ilength(sargs) + 2) {
default: wta(sargs, (char *)WNA, s_x_free_color_cells);
@@ -1354,10 +1355,10 @@ SCM x_find_color(scmap, dat)
XColor xclr;
struct xs_Colormap *xcm;
(void)memset((char *)&xclr, 0, sizeof(xclr));
- ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_find_color);
+ ASRTER(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_find_color);
xcm = COLORMAP(scmap);
if (!scm2XColor(dat, &xclr)) {
- ASSERT(NIMP(dat) && STRINGP(dat), dat, (char*)ARG2, s_x_find_color);
+ ASRTER(NIMP(dat) && STRINGP(dat), dat, (char*)ARG2, s_x_find_color);
if (XAllocNamedColor(xcm->dpy, xcm->cm, CHARS(dat), &xclr, &xclr))
return MAKINUM(xclr.pixel);
else return BOOL_F;
@@ -1372,13 +1373,13 @@ SCM x_color_set(scmap, s_pix, dat)
XColor xclr;
struct xs_Colormap *xcm;
(void)memset((char *)&xclr, 0, sizeof(xclr));
- ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_set);
- ASSERT(INUMP(s_pix), s_pix, ARG2, s_x_color_set);
+ ASRTER(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_set);
+ ASRTER(INUMP(s_pix), s_pix, ARG2, s_x_color_set);
xcm = COLORMAP(scmap);
xclr.pixel = INUM(s_pix);
xclr.flags = DoRed | DoGreen | DoBlue;
if (!scm2XColor(dat, &xclr)) {
- ASSERT(NIMP(dat) && STRINGP(dat), dat, (char*)ARG3, s_x_color_set);
+ ASRTER(NIMP(dat) && STRINGP(dat), dat, (char*)ARG3, s_x_color_set);
XStoreNamedColor(xcm->dpy, xcm->cm, CHARS(dat), xclr.pixel, xclr.flags);
}
else XStoreColor(xcm->dpy, xcm->cm, &xclr);
@@ -1390,9 +1391,9 @@ SCM x_color_ref(scmap, sidx)
XColor xclr;
struct xs_Colormap *xcm;
(void)memset((char *)&xclr, 0, sizeof(xclr));
- ASSERT(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_ref);
+ ASRTER(NIMP(scmap) && COLORMAPP(scmap), scmap, ARG1, s_x_color_ref);
xcm = COLORMAP(scmap);
- ASSERT(INUMP(sidx), sidx, (char*)ARG2, s_x_color_ref);
+ ASRTER(INUMP(sidx), sidx, (char*)ARG2, s_x_color_ref);
xclr.pixel = INUM(sidx);
XQueryColor(xcm->dpy, xcm->cm, &xclr);
if (xclr.flags==(DoRed | DoGreen | DoBlue))
@@ -1407,7 +1408,7 @@ SCM x_map_window(swin)
SCM swin;
{
struct xs_Window *w;
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
w = WINDOW(swin);
XMapWindow(w->dpy, w->p.win);
return UNSPECIFIED;
@@ -1416,7 +1417,7 @@ SCM x_map_subwindows(swin)
SCM swin;
{
struct xs_Window *w;
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_subwindows);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_subwindows);
w = WINDOW(swin);
XMapSubwindows(w->dpy, w->p.win);
return UNSPECIFIED;
@@ -1425,7 +1426,7 @@ SCM x_unmap_window(swin)
SCM swin;
{
struct xs_Window *w;
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_window);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_window);
w = WINDOW(swin);
XUnmapWindow(w->dpy, w->p.win);
return UNSPECIFIED;
@@ -1434,7 +1435,7 @@ SCM x_unmap_subwindows(swin)
SCM swin;
{
struct xs_Window *w;
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_subwindows);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_unmap_subwindows);
w = WINDOW(swin);
XUnmapSubwindows(w->dpy, w->p.win);
return UNSPECIFIED;
@@ -1450,9 +1451,9 @@ SCM x_create_gc(args)
unsigned long mask;
SCM ans;
- ASSERT(NIMP(args), args, WNA, s_x_create_gc);
+ ASRTER(NIMP(args), args, WNA, s_x_create_gc);
swin = CAR(args); args = CDR(args);
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_gc);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_create_gc);
xsw = WINDOW(swin);
ans = make_xgcontext(xsw->display, xsw->screen_number,
XCreateGC(xsw->dpy, xsw->p.drbl, 0L, &v), 0);
@@ -1469,9 +1470,9 @@ SCM x_gc_set(args)
XGCValues v;
unsigned long mask;
- ASSERT(NIMP(args), args, WNA, s_x_gc_set);
+ ASRTER(NIMP(args), args, WNA, s_x_gc_set);
sgc = CAR(args); args = CDR(args);
- ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_set);
+ ASRTER(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_set);
xgc = GCONTEXT(sgc);
mask = args2xgcvalues(sgc, &v, args);
XChangeGC(xgc->dpy, xgc->gc, mask, &v);
@@ -1485,8 +1486,8 @@ SCM x_copy_gc(dst, src, args)
struct xs_GContext *dgc, *sgc;
unsigned long mask;
- ASSERT(NIMP(dst) && GCONTEXTP(dst), dst, ARG1, s_x_copy_gc);
- ASSERT(NIMP(src) && GCONTEXTP(src), src, ARG2, s_x_copy_gc);
+ ASRTER(NIMP(dst) && GCONTEXTP(dst), dst, ARG1, s_x_copy_gc);
+ ASRTER(NIMP(src) && GCONTEXTP(src), src, ARG2, s_x_copy_gc);
dgc = GCONTEXT(dst);
sgc = GCONTEXT(src);
mask = args2valmask(args, s_gc);
@@ -1503,10 +1504,10 @@ SCM x_gc_ref(oargs)
XGCValues vlu;
int attr, len = ilength(args);
/* (void)memset((char *)&vlu, 0, sizeof(XGCValues)); */
- ASSERT(len > 0, oargs, WNA, s_x_gc_ref);
+ ASRTER(len > 0, oargs, WNA, s_x_gc_ref);
if (1==len--) return EOL;
sgc = CAR(args); args = CDR(args);
- ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_ref);
+ ASRTER(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_ref);
xgc = GCONTEXT(sgc);
valuemask = args2valmask(args, s_gc);
/* printf("valuemask = %lx\n", valuemask); */
@@ -1553,7 +1554,7 @@ SCM x_gc_ref(oargs)
case GCDashList: sval = MAKINUM(vlu.dashes); break;
case GCArcMode: sval = MAKINUM(vlu.arc_mode); break;
- default: ASSERT(0, MAKINUM(attr), ARGn, s_x_gc_ref);
+ default: ASRTER(0, MAKINUM(attr), ARGn, s_x_gc_ref);
}
CAR(valend) = sval;
CDR(valend) = cons(BOOL_T, EOL);
@@ -1570,12 +1571,12 @@ SCM x_create_cursor(sdpy, scsr, sargs)
Cursor cursor;
switch (ilength(sargs)) {
- default: ASSERT(0, sargs, WNA, s_x_create_cursor);
+ default: ASRTER(0, sargs, WNA, s_x_create_cursor);
case 0: {
SCM shape;
- ASSERT(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_create_cursor);
+ ASRTER(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_create_cursor);
shape = thevalue(scsr);
- ASSERT(INUMP(shape) && 0 <= INUM(shape), scsr, ARG2, s_x_create_cursor);
+ ASRTER(INUMP(shape) && 0 <= INUM(shape), scsr, ARG2, s_x_create_cursor);
cursor = XCreateFontCursor(XDISPLAY(sdpy), INUM(shape));
return make_xcursor(sdpy, cursor);
}
@@ -1583,14 +1584,14 @@ SCM x_create_cursor(sdpy, scsr, sargs)
XColor foreground_color, background_color;
XPoint origin;
int sts;
- ASSERT(NIMP(sdpy) && WINDOWP(sdpy), sdpy, ARG1, s_x_create_cursor);
- ASSERT(FALSEP(scsr) || (NIMP(scsr) && WINDOWP(scsr)), scsr, ARG2,
+ ASRTER(NIMP(sdpy) && WINDOWP(sdpy), sdpy, ARG1, s_x_create_cursor);
+ ASRTER(FALSEP(scsr) || (NIMP(scsr) && WINDOWP(scsr)), scsr, ARG2,
s_x_create_cursor);
sts = scm2XColor(CAR(sargs), &foreground_color);
- ASSERT(sts, CAR(sargs), ARG3, s_x_create_cursor);
+ ASRTER(sts, CAR(sargs), ARG3, s_x_create_cursor);
sargs = CDR(sargs);
sts = scm2XColor(CAR(sargs), &background_color);
- ASSERT(sts, CAR(sargs), ARG4, s_x_create_cursor);
+ ASRTER(sts, CAR(sargs), ARG4, s_x_create_cursor);
sargs = CDR(sargs);
scm2XPoint(0, CAR(sargs), &origin, (char*)ARG5, s_x_create_cursor);
cursor = XCreatePixmapCursor(XWINDISPLAY(sdpy), XWINDOW(sdpy),
@@ -1608,7 +1609,7 @@ SCM x_create_cursor(sdpy, scsr, sargs)
GET_NEXT_INT(source_char, sargs, ARG2, s_x_create_cursor);
if FALSEP(CAR(sargs)) {
sargs = CDR(sargs);
- ASSERT(FALSEP(CAR(sargs)), sargs, ARG4, s_x_create_cursor);
+ ASRTER(FALSEP(CAR(sargs)), sargs, ARG4, s_x_create_cursor);
sargs = CDR(sargs);
} else {
mask_font = thefont(CAR(sargs), s_x_create_cursor);
@@ -1616,10 +1617,10 @@ SCM x_create_cursor(sdpy, scsr, sargs)
GET_NEXT_INT(mask_char, sargs, ARG4, s_x_create_cursor);
}
sts = scm2XColor(CAR(sargs), &foreground_color);
- ASSERT(sts, CAR(sargs), ARG5, s_x_create_cursor);
+ ASRTER(sts, CAR(sargs), ARG5, s_x_create_cursor);
sargs = CDR(sargs);
sts = scm2XColor(CAR(sargs), &background_color);
- ASSERT(sts, CAR(sargs), ARGn, s_x_create_cursor);
+ ASRTER(sts, CAR(sargs), ARGn, s_x_create_cursor);
cursor = XCreateGlyphCursor(XWINDISPLAY(sdpy),
source_font, mask_font, source_char, mask_char,
&foreground_color, &background_color);
@@ -1632,8 +1633,8 @@ SCM x_load_font(sdpy, fntnam)
{
Font font;
- ASSERT(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_load_font);
- ASSERT(NIMP(fntnam) && STRINGP(fntnam), fntnam, ARG2, s_x_load_font);
+ ASRTER(NIMP(sdpy) && DISPLAYP(sdpy), sdpy, ARG1, s_x_load_font);
+ ASRTER(NIMP(fntnam) && STRINGP(fntnam), fntnam, ARG2, s_x_load_font);
font = XLoadFont(XDISPLAY(sdpy), CHARS(fntnam));
return make_xfont(sdpy, font, fntnam);
}
@@ -1749,7 +1750,7 @@ SCM x_screen_depths(sd, si)
scm2display_screen(sd, si, &dspscn, s_x_screen_depths);
depths = XListDepths(dspscn.dpy, dspscn.screen_number, &count_return);
if (!depths) return BOOL_F;
- depra = make_uve(count_return, MOST_POSITIVE_FIXNUM); /* Uniform vector of long */
+ depra = make_uve(count_return, MAKINUM(32L)); /* Uniform vector of long */
for (;count_return--;) VELTS(depra)[count_return] = depths[count_return];
XFree(depths);
return depra;
@@ -1835,7 +1836,7 @@ SCM x_visual_geometry(svsl)
SCM svsl;
{
XVisualInfo *vsl;
- ASSERT(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_geometry);
+ ASRTER(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_geometry);
vsl = XVISUALINFO(svsl);
return cons2(MAKINUM(vsl->red_mask), MAKINUM(vsl->green_mask),
cons2(MAKINUM(vsl->blue_mask), MAKINUM(vsl->colormap_size),
@@ -1845,7 +1846,7 @@ SCM x_visual_class(svsl)
SCM svsl;
{
XVisualInfo *vsl;
- ASSERT(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_class);
+ ASRTER(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_class);
vsl = XVISUALINFO(svsl);
return MAKINUM(vsl->class);
}
@@ -1916,8 +1917,8 @@ SCM x_ccc_screen_info(sccc, sfmt)
{
XcmsCCC xccc;
XcmsPerScrnInfo *pPerScrnInfo;
- ASSERT(NIMP(sccc) && CCCP(sccc), sccc, ARG1, s_x_ccc_screen_info);
- ASSERT(NIMP(sfmt) && STRINGP(sfmt), sfmt, ARG2, s_x_ccc_screen_info);
+ ASRTER(NIMP(sccc) && CCCP(sccc), sccc, ARG1, s_x_ccc_screen_info);
+ ASRTER(NIMP(sfmt) && STRINGP(sfmt), sfmt, ARG2, s_x_ccc_screen_info);
xccc = XCCC(sccc);
pPerScrnInfo = (XcmsFunctionSet *)xccc->pPerScrnInfo;
return ;
@@ -1989,13 +1990,13 @@ SCM x_get_window_property(swin, sprop, sargs)
unsigned long bytes_after_return;
unsigned char *prop_return;
int sarglen = ilength(sargs);
- ASSERT(IMP(sprop) ? INUMP(sprop) : STRINGP(sprop),
+ ASRTER(IMP(sprop) ? INUMP(sprop) : STRINGP(sprop),
sprop, ARG2, s_x_get_window_property);
- ASSERT(sarglen >= 0 && sarglen < 2, sargs, WNA, s_x_get_window_property);
+ ASRTER(sarglen >= 0 && sarglen < 2, sargs, WNA, s_x_get_window_property);
if (1 == sarglen) {
- ASSERT(NFALSEP(booleanp(CAR(sargs))), sargs, ARG3, s_x_get_window_property);
+ ASRTER(NFALSEP(booleanp(CAR(sargs))), sargs, ARG3, s_x_get_window_property);
}
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
xwn = WINDOW(swin);
if (INUMP(sprop))
property = INUM(sprop);
@@ -2024,7 +2025,7 @@ SCM x_list_properties(swin)
Atom *atoms;
int num_prop_return;
SCM lst;
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
xwn = WINDOW(swin);
atoms = XListProperties(xwn->dpy, xwn->p.win, &num_prop_return);
{
@@ -2046,8 +2047,8 @@ SCM x_clear_area(swin, spos, sargs)
SCM swin, spos, sargs;
{
XPoint position, size;
- ASSERT(2==ilength(sargs), sargs, WNA, s_x_clear_area);
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_clear_area);
+ ASRTER(2==ilength(sargs), sargs, WNA, s_x_clear_area);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_clear_area);
scm2XPoint(!0, spos, &position, (char *)ARG2, s_x_clear_area);
scm2XPoint(0, CAR(sargs), &size, (char *)ARG3, s_x_clear_area);
sargs = CDR(sargs);
@@ -2060,9 +2061,9 @@ SCM x_fill_rectangle(swin, sgc, sargs)
SCM swin, sgc, sargs;
{
XPoint position, size;
- ASSERT(2==ilength(sargs), sargs, WNA, s_x_fill_rectangle);
- ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_fill_rectangle);
- ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_fill_rectangle);
+ ASRTER(2==ilength(sargs), sargs, WNA, s_x_fill_rectangle);
+ ASRTER(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_fill_rectangle);
+ ASRTER(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_fill_rectangle);
scm2XPoint(!0, CAR(sargs), &position, (char *)ARG3, s_x_fill_rectangle);
sargs = CDR(sargs);
scm2XPoint(0, CAR(sargs), &size, (char *)ARG4, s_x_fill_rectangle);
@@ -2077,13 +2078,13 @@ void xldraw_string(sdbl, sgc, sargs, proc, s_caller)
char *s_caller;
{
XPoint position;
- ASSERT(2==ilength(sargs), sargs, WNA, s_caller);
- ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller);
- ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller);
+ ASRTER(2==ilength(sargs), sargs, WNA, s_caller);
+ ASRTER(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller);
+ ASRTER(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller);
scm2XPoint(!0, CAR(sargs), &position, (char *)ARG3, s_caller);
sargs = CDR(sargs);
sargs = CAR(sargs);
- ASSERT(NIMP(sargs) && STRINGP(sargs), sargs, ARG4, s_caller);
+ ASRTER(NIMP(sargs) && STRINGP(sargs), sargs, ARG4, s_caller);
proc(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
position.x, position.y, CHARS(sargs), LENGTH(sargs));
}
@@ -2106,13 +2107,13 @@ SCM x_draw_points(sdbl, sgc, sargs)
XPoint pos[1];
int len;
SCM sarg;
- ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_draw_points);
- ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_draw_points);
+ ASRTER(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_draw_points);
+ ASRTER(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_x_draw_points);
loop:
if NULLP(sargs) return UNSPECIFIED;
sarg = CAR(sargs); sargs = CDR(sargs);
if (INUMP(sarg)) {
- ASSERT(NNULLP(sargs), sargs, WNA, s_x_draw_points);
+ ASRTER(NNULLP(sargs), sargs, WNA, s_x_draw_points);
pos[0].x = INUM(sarg);
GET_NEXT_INT(pos[0].y, sargs, ARGn, s_x_draw_points);
goto drawshort;
@@ -2125,7 +2126,7 @@ SCM x_draw_points(sdbl, sgc, sargs)
&(pos[0]), 1, CoordModeOrigin);
goto loop;
} else {
- ASSERT(NULLP(sargs), sargs, WNA, s_x_draw_points);
+ ASRTER(NULLP(sargs), sargs, WNA, s_x_draw_points);
XDrawPoints(XWINDISPLAY(sdbl), XWINDOW(sdbl), XGCONTEXT(sgc),
(XPoint *)scm_base_addr(sarg, s_x_draw_points), len,
CoordModeOrigin);
@@ -2140,13 +2141,13 @@ SCM xldraw_lines(sdbl, sgc, sargs, funcod, s_caller)
XPoint pos[2];
int len;
SCM sarg;
- ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller);
- ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller);
+ ASRTER(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_caller);
+ ASRTER(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG2, s_caller);
loop:
if NULLP(sargs) return UNSPECIFIED;
sarg = CAR(sargs); sargs = CDR(sargs);
if (INUMP(sarg)) {
- ASSERT(NNULLP(sargs), sargs, WNA, s_caller);
+ ASRTER(NNULLP(sargs), sargs, WNA, s_caller);
pos[0].x = INUM(sarg);
GET_NEXT_INT(pos[0].y, sargs, ARGn, s_caller);
GET_NEXT_INT(pos[1].x, sargs, ARGn, s_caller);
@@ -2214,7 +2215,7 @@ SCM x_read_bitmap_file(sdbl, sfname)
unsigned int w, h;
int x, y;
Pixmap pxmp;
- ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_read_bitmap_file);
+ ASRTER(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_read_bitmap_file);
if (XReadBitmapFile(XWINDISPLAY(sdbl),
WINDOW(sdbl)->p.pm,
CHARS(sfname),
@@ -2238,8 +2239,8 @@ SCM x_event_ref(sevent, sfield)
SCM sevent, sfield;
{
void *x;
- ASSERT(NIMP(sevent) && XEVENTP(sevent), sevent, ARG1, s_x_event_ref);
- ASSERT(INUMP(sfield), sfield, ARG2, s_x_event_ref);
+ ASRTER(NIMP(sevent) && XEVENTP(sevent), sevent, ARG1, s_x_event_ref);
+ ASRTER(INUMP(sfield), sfield, ARG2, s_x_event_ref);
x = (void *) CHARS(sevent);
switch (((((XEvent*)x)->type)<<8)+INUM(sfield)) {
default: wta(sevent, "Incompatible field for", s_x_event_ref);
diff --git a/x11.scm b/x11.scm
index 7b49bf1..0ea4210 100644
--- a/x11.scm
+++ b/x11.scm
@@ -425,22 +425,23 @@
(define XC:xterm 152)
;;inc2scm extracted #define values from /usr/include/X11/Xlib.h
(define x:Xlib-Specification-Release 6)
+(define X:HAVE-UTF8-STRING 1)
(define x:True 1)
(define x:False 0)
(define x:Queued-Already 0)
(define x:Queued-After-Reading 1)
(define x:Queued-After-Flush 2)
(define x:All-Planes -1)
-(define x:XN-Required-Char-Set 134529975)
-(define x:XN-Query-Orientation 134530014)
-(define x:XN-Base-Font-Name 134530054)
-(define x:XNOM-Automatic 134530087)
-(define x:XN-Missing-Char-Set 134530116)
-(define x:XN-Default-String 134530153)
-(define x:XN-Orientation 134530187)
-(define x:XN-Directional-Dependent-Drawing 134530216)
-(define x:XN-Contextual-Drawing 134530307)
-(define x:XN-Font-Info 134530349)
+(define x:XN-Required-Char-Set 134531850)
+(define x:XN-Query-Orientation 134531889)
+(define x:XN-Base-Font-Name 134531929)
+(define x:XNOM-Automatic 134531962)
+(define x:XN-Missing-Char-Set 134531991)
+(define x:XN-Default-String 134532028)
+(define x:XN-Orientation 134532062)
+(define x:XN-Directional-Dependent-Drawing 134532091)
+(define x:XN-Contextual-Drawing 134532163)
+(define x:XN-Font-Info 134532205)
(define x:XIM-Preedit-Area 1)
(define x:XIM-Preedit-Callbacks 2)
(define x:XIM-Preedit-Position 4)
@@ -450,48 +451,48 @@
(define x:XIM-Status-Callbacks 512)
(define x:XIM-Status-Nothing 1024)
(define x:XIM-Status-None 2048)
-(define x:XN-Va-Nested-List 134530560)
-(define x:XN-Query-Input-Style 134530595)
-(define x:XN-Client-Window 134530634)
-(define x:XN-Input-Style 134530666)
-(define x:XN-Focus-Window 134530694)
-(define x:XN-Resource-Name 134530724)
-(define x:XN-Resource-Class 134530756)
-(define x:XN-Geometry-Callback 134530790)
-(define x:XN-Destroy-Callback 134530830)
-(define x:XN-Filter-Events 134530868)
-(define x:XN-Preedit-Start-Callback 134530900)
-(define x:XN-Preedit-Done-Callback 134530949)
-(define x:XN-Preedit-Draw-Callback 134530996)
-(define x:XN-Preedit-Caret-Callback 134531043)
-(define x:XN-Preedit-State-Notify-Callback 134531092)
-(define x:XN-Preedit-Attributes 134531171)
-(define x:XN-Status-Start-Callback 134531213)
-(define x:XN-Status-Done-Callback 134531260)
-(define x:XN-Status-Draw-Callback 134531305)
-(define x:XN-Status-Attributes 134531350)
-(define x:XN-Area 134531390)
-(define x:XN-Area-Needed 134531405)
-(define x:XN-Spot-Location 134531433)
-(define x:XN-Colormap 134531465)
-(define x:XN-Std-Colormap 134531488)
-(define x:XN-Foreground 134531518)
-(define x:XN-Background 134531545)
-(define x:XN-Background-Pixmap 134531572)
-(define x:XN-Font-Set 134531612)
-(define x:XN-Line-Space 134531634)
-(define x:XN-Cursor 134531660)
-(define x:XN-Query-IM-Values-List 134531679)
-(define x:XN-Query-IC-Values-List 134531723)
-(define x:XN-Visible-Position 134531767)
-(define x:XNR6-Preedit-Callback 134531805)
-(define x:XN-String-Conversion-Callback 134531847)
-(define x:XN-String-Conversion 134531904)
-(define x:XN-Reset-State 134531944)
-(define x:XN-Hot-Key 134531972)
-(define x:XN-Hot-Key-State 134531992)
-(define x:XN-Preedit-State 134532023)
-(define x:XN-Separatorof-Nested-List 134532055)
+(define x:XN-Va-Nested-List 134532416)
+(define x:XN-Query-Input-Style 134532451)
+(define x:XN-Client-Window 134532490)
+(define x:XN-Input-Style 134532522)
+(define x:XN-Focus-Window 134532550)
+(define x:XN-Resource-Name 134532580)
+(define x:XN-Resource-Class 134532612)
+(define x:XN-Geometry-Callback 134532646)
+(define x:XN-Destroy-Callback 134532686)
+(define x:XN-Filter-Events 134532724)
+(define x:XN-Preedit-Start-Callback 134532756)
+(define x:XN-Preedit-Done-Callback 134532805)
+(define x:XN-Preedit-Draw-Callback 134532852)
+(define x:XN-Preedit-Caret-Callback 134532899)
+(define x:XN-Preedit-State-Notify-Callback 134532948)
+(define x:XN-Preedit-Attributes 134533027)
+(define x:XN-Status-Start-Callback 134533069)
+(define x:XN-Status-Done-Callback 134533116)
+(define x:XN-Status-Draw-Callback 134533161)
+(define x:XN-Status-Attributes 134533206)
+(define x:XN-Area 134533246)
+(define x:XN-Area-Needed 134533261)
+(define x:XN-Spot-Location 134533289)
+(define x:XN-Colormap 134533321)
+(define x:XN-Std-Colormap 134533344)
+(define x:XN-Foreground 134533374)
+(define x:XN-Background 134533401)
+(define x:XN-Background-Pixmap 134533428)
+(define x:XN-Font-Set 134533468)
+(define x:XN-Line-Space 134533490)
+(define x:XN-Cursor 134533516)
+(define x:XN-Query-IM-Values-List 134533535)
+(define x:XN-Query-IC-Values-List 134533579)
+(define x:XN-Visible-Position 134533623)
+(define x:XNR6-Preedit-Callback 134533661)
+(define x:XN-String-Conversion-Callback 134533703)
+(define x:XN-String-Conversion 134533760)
+(define x:XN-Reset-State 134533800)
+(define x:XN-Hot-Key 134533828)
+(define x:XN-Hot-Key-State 134533848)
+(define x:XN-Preedit-State 134533879)
+(define x:XN-Separatorof-Nested-List 134533911)
(define x:X-Buffer-Overflow -1)
(define x:X-Lookup-None 1)
(define x:X-Lookup-Chars 2)
diff --git a/xgen.scm b/xgen.scm
index 6c5bd4b..b4dfdc6 100755
--- a/xgen.scm
+++ b/xgen.scm
@@ -43,21 +43,25 @@
;;;; "xgen.scm", Convert C Event structs to xevent.h and xevent.scm.
;;; Author: Aubrey Jaffer.
-(define (go-script)
- (cond ;;((not *script*))
- ((>= 1 (- (length *argv*) *optind*))
+(define (xgen.scm args)
+ (cond ((= 1 (length args))
(xatoms)
- (apply xgen.scm (list-tail *argv* *optind*)))
- (else
- (display "\
+ (apply xgen args)
+ #t)
+ (else (xgen.usage))))
+
+(define (xgen.usage)
+ (display "\
\
Usage: xgen.scm /usr/include/X11/Xlib.h
\
Creates xevent.h and xevent.scm, from the `typedef struct's
in /usr/include/X11/xlib.h.
+
+http://swissnet.ai.mit.edu/~jaffer/SCM
"
- (current-error-port))
- (exit #f))))
+ (current-error-port))
+ #f)
(require 'common-list-functions)
(require 'string-search)
@@ -223,8 +227,7 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
(set! event-field-idx (+ 1 event-field-idx))
(+ -1 event-field-idx))))
-(define (xgen.scm . filename)
- (set! filename (if (null? filename) "/usr/include/X11/Xlib.h" (car filename)))
+(define (xgen filename)
(let ((structs (remove-if-not
(lambda (struct) (substring? "Event" (car struct)))
(call-with-input-file filename extract-structs))))
@@ -314,8 +317,7 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
((0 1) #f)
(else (slib:error 'xcms.h 'line line)))))))))
-(go-script)
-
;;; Local Variables:
;;; mode:scheme
;;; End:
+(exit (xgen.scm (list-tail *argv* *optind*))) ;(and *script* )