summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.cvsignore6
-rw-r--r--AUTHORS65
-rw-r--r--ChangeLog231
-rw-r--r--GUILE-VERSION5
-rw-r--r--HACKING88
-rw-r--r--INSTALL137
-rw-r--r--Makefile.am14
-rw-r--r--Makefile.in526
-rw-r--r--NEWS370
-rw-r--r--NOTES70
-rw-r--r--README152
-rw-r--r--RELEASE43
-rw-r--r--TODO38
-rw-r--r--aclocal.m4110
-rwxr-xr-xconfig.guess326
-rwxr-xr-xconfig.sub206
-rwxr-xr-xconfigure403
-rw-r--r--configure.in46
-rw-r--r--guile.m413
-rw-r--r--ice-9/.cvsignore3
-rw-r--r--ice-9/ChangeLog702
-rw-r--r--ice-9/Makefile.am10
-rw-r--r--ice-9/Makefile.in253
-rw-r--r--ice-9/aclocal.m4 (renamed from libguile/__scm.hd)0
-rw-r--r--ice-9/boot-9.scm1957
-rwxr-xr-xice-9/configure722
-rw-r--r--ice-9/configure.in17
-rw-r--r--ice-9/debug.scm195
-rw-r--r--ice-9/emacs.scm163
-rw-r--r--ice-9/expect.scm124
-rw-r--r--ice-9/gtcl.scm379
-rw-r--r--ice-9/gwish.scm90
-rw-r--r--ice-9/lineio.scm17
-rw-r--r--ice-9/mapping.scm3
-rw-r--r--ice-9/nonblocking.scm82
-rw-r--r--ice-9/oldprint.scm122
-rw-r--r--ice-9/poe.scm2
-rw-r--r--ice-9/r4rs.scm145
-rw-r--r--ice-9/slib.scm73
-rw-r--r--ice-9/source.scm161
-rw-r--r--ice-9/test.scm1032
-rw-r--r--ice-9/threads.scm53
-rw-r--r--libguile/.cvsignore20
-rw-r--r--libguile/ChangeLog3188
-rw-r--r--libguile/ChangeLog-gh256
-rw-r--r--libguile/ChangeLog-scm2610
-rw-r--r--libguile/ChangeLog-threads251
-rw-r--r--libguile/DYNAMIC-LINKING188
-rw-r--r--libguile/Makefile.am134
-rw-r--r--libguile/Makefile.in1539
-rw-r--r--libguile/__scm.h121
-rw-r--r--libguile/_scm.h66
-rw-r--r--libguile/acconfig.h (renamed from libguile/def.sed)0
-rw-r--r--libguile/acinclude.m40
-rw-r--r--libguile/aclocal.m4340
-rw-r--r--libguile/alist.c159
-rw-r--r--libguile/alist.h64
-rw-r--r--libguile/alloca.c504
-rw-r--r--libguile/append.c20
-rw-r--r--libguile/append.h21
-rw-r--r--libguile/appinit.c7
-rw-r--r--libguile/arbiters.c49
-rw-r--r--libguile/arbiters.h22
-rw-r--r--libguile/async.c234
-rw-r--r--libguile/async.h50
-rw-r--r--libguile/backtrace.c510
-rw-r--r--libguile/backtrace.h58
-rw-r--r--libguile/boolean.c20
-rw-r--r--libguile/boolean.h17
-rw-r--r--libguile/chars.c157
-rw-r--r--libguile/chars.h88
-rwxr-xr-xlibguile/configure2179
-rw-r--r--libguile/configure.in231
-rw-r--r--libguile/continuations.c61
-rw-r--r--libguile/continuations.h32
-rw-r--r--libguile/coop-defs.h149
-rw-r--r--libguile/coop-threads.c439
-rw-r--r--libguile/coop-threads.c.cygnus469
-rw-r--r--libguile/coop-threads.h140
-rw-r--r--libguile/coop-threads.h.cygnus223
-rw-r--r--libguile/coop.c588
-rw-r--r--libguile/cpp_cnvt.awk7
-rw-r--r--libguile/cpp_err_symbols.in122
-rw-r--r--libguile/cpp_errno.c3
-rw-r--r--libguile/cpp_sig_symbols.in34
-rw-r--r--libguile/cpp_signal.c3
-rw-r--r--libguile/debug.c427
-rw-r--r--libguile/debug.h204
-rw-r--r--libguile/dynl-dl.c103
-rw-r--r--libguile/dynl-dld.c128
-rw-r--r--libguile/dynl-shl.c98
-rw-r--r--libguile/dynl-vms.c106
-rw-r--r--libguile/dynl.c441
-rw-r--r--libguile/dynl.h63
-rw-r--r--libguile/dynwind.c21
-rw-r--r--libguile/dynwind.h20
-rw-r--r--libguile/eq.c30
-rw-r--r--libguile/eq.h18
-rw-r--r--libguile/error.c326
-rw-r--r--libguile/error.h56
-rw-r--r--libguile/eval.c1889
-rw-r--r--libguile/eval.h182
-rw-r--r--libguile/extchrs.c24
-rw-r--r--libguile/extchrs.h23
-rw-r--r--libguile/feature.c74
-rw-r--r--libguile/feature.h26
-rw-r--r--libguile/filesys.c1252
-rw-r--r--libguile/filesys.h105
-rw-r--r--libguile/fports.c216
-rw-r--r--libguile/fports.h33
-rw-r--r--libguile/fsu-pthreads.h166
-rw-r--r--libguile/gc.c527
-rw-r--r--libguile/gc.h75
-rw-r--r--libguile/gdb_interface.h127
-rw-r--r--libguile/gdbint.c325
-rw-r--r--libguile/gdbint.h58
-rw-r--r--libguile/genio.c81
-rw-r--r--libguile/genio.h26
-rw-r--r--libguile/gh.h195
-rw-r--r--libguile/gh_data.c286
-rw-r--r--libguile/gh_eval.c180
-rw-r--r--libguile/gh_funcs.c169
-rw-r--r--libguile/gh_init.c107
-rw-r--r--libguile/gh_io.c57
-rw-r--r--libguile/gh_list.c142
-rw-r--r--libguile/gh_predicates.c121
-rw-r--r--libguile/gh_test_c.c221
-rw-r--r--libguile/gh_test_repl.c156
-rw-r--r--libguile/gscm.c145
-rw-r--r--libguile/gscm.h42
-rw-r--r--libguile/gsubr.c34
-rw-r--r--libguile/gsubr.h18
-rw-r--r--libguile/guile-snarf.in4
-rw-r--r--libguile/hash.c50
-rw-r--r--libguile/hash.h35
-rw-r--r--libguile/hashtab.c189
-rw-r--r--libguile/hashtab.h98
-rw-r--r--libguile/inet_aton.c2
-rw-r--r--libguile/init.c500
-rw-r--r--libguile/init.h31
-rw-r--r--libguile/ioext.c471
-rw-r--r--libguile/ioext.h54
-rw-r--r--libguile/kw.c54
-rw-r--r--libguile/kw.h17
-rw-r--r--libguile/libguile.h166
-rw-r--r--libguile/list.c432
-rw-r--r--libguile/list.h107
-rw-r--r--libguile/load.c284
-rw-r--r--libguile/load.h21
-rw-r--r--libguile/mallocs.c44
-rw-r--r--libguile/mallocs.h14
-rw-r--r--libguile/markers.c19
-rw-r--r--libguile/markers.h17
-rw-r--r--libguile/mbstrings.c115
-rw-r--r--libguile/mbstrings.h62
-rw-r--r--libguile/mit-pthreads.c495
-rw-r--r--libguile/mit-pthreads.h187
-rw-r--r--libguile/net_db.c410
-rw-r--r--libguile/net_db.h69
-rw-r--r--libguile/numbers.c850
-rw-r--r--libguile/numbers.h315
-rw-r--r--libguile/objprop.c43
-rw-r--r--libguile/objprop.h23
-rw-r--r--libguile/options.c226
-rw-r--r--libguile/options.h71
-rw-r--r--libguile/pairs.c61
-rw-r--r--libguile/pairs.h44
-rw-r--r--libguile/ports.c435
-rw-r--r--libguile/ports.h158
-rw-r--r--libguile/posix.c1196
-rw-r--r--libguile/posix.h137
-rw-r--r--libguile/print.c509
-rw-r--r--libguile/print.h70
-rw-r--r--libguile/procprop.c43
-rw-r--r--libguile/procprop.h25
-rw-r--r--libguile/procs.c99
-rw-r--r--libguile/procs.h30
-rw-r--r--libguile/putenv.c111
-rw-r--r--libguile/ramap.c347
-rw-r--r--libguile/ramap.h72
-rw-r--r--libguile/read.c500
-rw-r--r--libguile/read.h42
-rw-r--r--libguile/root.c290
-rw-r--r--libguile/root.h69
-rw-r--r--libguile/scmconfig.h.in169
-rw-r--r--libguile/scmhob.h10
-rw-r--r--libguile/scmsigs.c61
-rw-r--r--libguile/scmsigs.h39
-rw-r--r--libguile/sequences.c25
-rw-r--r--libguile/sequences.h21
-rw-r--r--libguile/simpos.c53
-rw-r--r--libguile/simpos.h28
-rw-r--r--libguile/smob.c15
-rw-r--r--libguile/smob.h48
-rw-r--r--libguile/snarf.h120
-rw-r--r--libguile/socket.c1034
-rw-r--r--libguile/socket.h85
-rw-r--r--libguile/srcprop.c363
-rw-r--r--libguile/srcprop.h134
-rw-r--r--libguile/stackchk.c38
-rw-r--r--libguile/stackchk.h54
-rw-r--r--libguile/stacks.c698
-rw-r--r--libguile/stacks.h135
-rw-r--r--libguile/stamp-h.in0
-rw-r--r--libguile/stime.c410
-rw-r--r--libguile/stime.h39
-rw-r--r--libguile/strerror.c32
-rw-r--r--libguile/strings.c128
-rw-r--r--libguile/strings.h74
-rw-r--r--libguile/strop.c244
-rw-r--r--libguile/strop.h52
-rw-r--r--libguile/strorder.c74
-rw-r--r--libguile/strorder.h41
-rw-r--r--libguile/strports.c145
-rw-r--r--libguile/strports.h30
-rw-r--r--libguile/struct.c271
-rw-r--r--libguile/struct.h49
-rw-r--r--libguile/symbols.c484
-rw-r--r--libguile/symbols.h119
-rw-r--r--libguile/tag.c15
-rw-r--r--libguile/tag.h11
-rw-r--r--libguile/tags.h134
-rw-r--r--libguile/threads.c161
-rw-r--r--libguile/threads.h91
-rw-r--r--libguile/throw.c584
-rw-r--r--libguile/throw.h53
-rw-r--r--libguile/unif.c699
-rw-r--r--libguile/unif.h124
-rw-r--r--libguile/variable.c132
-rw-r--r--libguile/variable.h38
-rw-r--r--libguile/vectors.c76
-rw-r--r--libguile/vectors.h39
-rw-r--r--libguile/version.c85
-rw-r--r--libguile/version.h56
-rw-r--r--libguile/vports.c93
-rw-r--r--libguile/vports.h17
-rw-r--r--libguile/weaks.c73
-rw-r--r--libguile/weaks.h37
-rwxr-xr-xltconfig945
-rw-r--r--ltmain.sh1748
-rwxr-xr-xmdate-sh91
-rwxr-xr-xmissing134
-rwxr-xr-xmkinstalldirs36
-rw-r--r--qt/.cvsignore5
-rw-r--r--qt/CHANGES15
-rw-r--r--qt/ChangeLog68
-rw-r--r--qt/INSTALL81
-rw-r--r--qt/Makefile.am23
-rw-r--r--qt/Makefile.base112
-rw-r--r--qt/Makefile.in401
-rw-r--r--qt/README89
-rw-r--r--qt/README.MISC56
-rw-r--r--qt/README.PORT112
-rw-r--r--qt/aclocal.m40
-rw-r--r--qt/b.h11
-rwxr-xr-xqt/config308
-rwxr-xr-xqt/configure0
-rw-r--r--qt/configure.in0
-rw-r--r--qt/copyright.h12
-rw-r--r--qt/md/.cvsignore1
-rw-r--r--qt/md/Makefile.am11
-rw-r--r--qt/md/Makefile.in166
-rw-r--r--qt/md/_sparc.s142
-rw-r--r--qt/md/_sparc_b.s106
-rw-r--r--qt/md/axp.1.Makefile5
-rw-r--r--qt/md/axp.2.Makefile5
-rw-r--r--qt/md/axp.Makefile5
-rw-r--r--qt/md/axp.README10
-rw-r--r--qt/md/axp.c133
-rw-r--r--qt/md/axp.h160
-rw-r--r--qt/md/axp.s160
-rw-r--r--qt/md/axp_b.s111
-rw-r--r--qt/md/default.Makefile6
-rw-r--r--qt/md/hppa-cnx.Makefile9
-rw-r--r--qt/md/hppa.Makefile9
-rw-r--r--qt/md/hppa.h194
-rw-r--r--qt/md/hppa.s237
-rw-r--r--qt/md/hppa_b.s203
-rw-r--r--qt/md/i386.README7
-rw-r--r--qt/md/i386.h120
-rw-r--r--qt/md/i386.s108
-rw-r--r--qt/md/i386_b.s30
-rw-r--r--qt/md/ksr1.Makefile6
-rw-r--r--qt/md/ksr1.h164
-rw-r--r--qt/md/ksr1.s424
-rw-r--r--qt/md/ksr1_b.s49
-rw-r--r--qt/md/m88k.Makefile6
-rw-r--r--qt/md/m88k.c111
-rw-r--r--qt/md/m88k.h159
-rw-r--r--qt/md/m88k.s132
-rw-r--r--qt/md/m88k_b.s117
-rw-r--r--qt/md/mips-irix5.s182
-rw-r--r--qt/md/mips.h134
-rw-r--r--qt/md/mips.s164
-rw-r--r--qt/md/mips_b.s99
-rw-r--r--qt/md/null.README0
-rw-r--r--qt/md/null.c14
-rw-r--r--qt/md/solaris.README19
-rw-r--r--qt/md/sparc.h140
-rw-r--r--qt/md/sparc.s142
-rw-r--r--qt/md/sparc_b.s106
-rw-r--r--qt/md/vax.h130
-rw-r--r--qt/md/vax.s69
-rw-r--r--qt/md/vax_b.s92
-rw-r--r--qt/meas.c1049
-rw-r--r--qt/qt.c48
-rw-r--r--qt/qt.h.in176
-rw-r--r--qt/stp.c199
-rw-r--r--qt/stp.h51
-rw-r--r--qt/time/.cvsignore1
-rw-r--r--qt/time/Makefile.am5
-rw-r--r--qt/time/Makefile.in160
-rw-r--r--qt/time/README.time17
-rwxr-xr-xqt/time/assim42
-rwxr-xr-xqt/time/cswap37
-rwxr-xr-xqt/time/go43
-rwxr-xr-xqt/time/init42
-rwxr-xr-xqt/time/prim41
-rwxr-xr-xqt/time/raw58
-rw-r--r--threads.m4102
320 files changed, 48248 insertions, 13670 deletions
diff --git a/.cvsignore b/.cvsignore
new file mode 100644
index 000000000..76fb6f31a
--- /dev/null
+++ b/.cvsignore
@@ -0,0 +1,6 @@
+Makefile
+config.cache
+config.log
+config.status
+guile-*.tar.gz
+config.build-subdirs
diff --git a/AUTHORS b/AUTHORS
new file mode 100644
index 000000000..6491fa027
--- /dev/null
+++ b/AUTHORS
@@ -0,0 +1,65 @@
+To find out what should go in this file, see "Information For
+Maintainers of GNU Software" (maintain.texi), the section called
+"Recording Changes".
+
+
+George Carrette:
+wrote files present in Siod version 2.3, released in December of 1989.
+
+Aubrey Jaffer:
+Wrote substantial portions of guile.texi, and surely others.
+Changes to: eval.c, ioext.c, posix.c, gscm.c, scm.h, socket.c,
+gsubr.c, sys.c, test.scm, stime.c, and unif.c.
+
+Gary Houston: changes to many files in libguile.
+wrote: libguile/socket.c, ice-9/expect.scm
+
+Tom Lord: Many changes throughout.
+In the subdirectory ctax, wrote:
+ Makefile.in configure.in hashtabs.scm macros.scm scm-ops.scm
+ c-ops.scm grammar.scm lexer.scm reader.scm
+In the subdirectory gtcltk-lib, wrote:
+ Makefile.in guile-tcl.c guile-tk.c
+ configure.in guile-tcl.h guile-tk.h
+In the subdirectory guile, wrote:
+ Makefile.in getopt.c getopt1.c
+ configure.in getopt.h guile.c
+In the subdirectory ice-9, wrote:
+ Makefile.in configure.in lineio.scm poe.scm
+ boot-9.scm hcons.scm mapping.scm
+In the subdirectory lang, wrote:
+ Makefile.in grammar.scm lr0.scm pp.scm
+ configure.in lex.scm lr1.scm
+In the subdirectory rx, wrote:
+ Makefile.in runtests.c rxbitset.h rxnfa.c rxspencer.c
+ TESTS rx.c rxcontext.h rxnfa.h rxspencer.h
+ TESTS2C.sed rx.h rxcset.c rxnode.c rxstr.c
+ _rx.h rxall.h rxcset.h rxnode.h rxstr.h
+ configure.in rxanal.c rxdbug.c rxposix.c rxsuper.c
+ hashrexp.c rxanal.h rxgnucomp.c rxposix.h rxsuper.h
+ inst-rxposix.h rxbasic.c rxgnucomp.h rxproto.h rxunfa.c
+ rgx.c rxbasic.h rxhash.c rxsimp.c rxunfa.h
+ rgx.h rxbitset.c rxhash.h rxsimp.h testcases.h
+In the subdirectory doc, wrote:
+ ctax.texi gtcltk.texi in.texi lang.texi
+and portions of guile.texi.
+
+Anthony Green: wrote the original code in the 'threads' directory, and
+ice-9/threads.scm.
+
+Mikael Djurfeldt:
+In the subdirectory libguile, wrote:
+ backtrace.c debug.c options.c root.c srcprop.c stacks.c
+ backtrace.h debug.h options.h root.h srcprop.h stacks.h
+In the subdirectory threads, rewrote:
+ coop-threads.c coop.c mit-pthreads.c threads.c
+ coop-threads.h fsu-pthreads.h mit-pthreads.h threads.h
+Many other changes throughout.
+
+Mark Galassi:
+Designed and implemented the high-level libguile API (the @code{gh_}
+interface), based largely on the defunct @code{gscm_} interface. In the
+subdirectory libguile, wrote:
+gh.h gh_funcs.c gh_list.c gh_test_repl.c
+gh_data.c gh_init.c gh_predicates.c
+gh_eval.c gh_io.c gh_test_c.c
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 000000000..736e42350
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,231 @@
+Mon Apr 14 18:51:25 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * threads.m4 (CY_AC_WITH_THREADS): When using coop threads, no
+ need to link against libthreads; the files it used to contain
+ are now a part of libguile.
+
+Sun Apr 13 22:14:10 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * guile.m4: Revert change of Mar 15, and use the new 'no-define'
+ argument to the AM_INIT_AUTOMAKE macro.
+
+Fri Apr 11 15:43:07 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * ltconfig, ltmain.sh: Upgraded libtool files to 0.9d.
+ * README: Say where to find libtool 0.9d.
+
+Wed Apr 9 17:51:13 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Changes to work with automake-1.1n, which has better libtool
+ support. Also use libtool 0.8.
+ * README: Note new version numbers for automake and libtool.
+ * missing: New file required by new automake.
+ * Makefile.in: Regenerated.
+
+Sat Apr 5 16:48:38 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * newdoc/ref/scheme.texi (set-object-property!): Fix function name.
+
+ * Makefile.am: Omit doc subtree.
+ * configure.in: Omit makefiles in doc subtree.
+ * Makefile.in, configure: Rebuilt.
+
+Sat Mar 15 01:11:44 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.m4 (AM_INIT_GUILE_MODULE): Replaced AM_INIT_AUTOMAKE macro
+ with its definition and commented out definition of PACKAGE. This
+ changed seemed necessary after having removed PACKAGE from
+ libguile/acconfig.h.
+
+Mon Feb 24 21:43:26 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ltconfig, ltmain.sh: New versions from libtool-0.9.
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Fri Feb 7 17:57:46 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * config.sub, config.guess: New versions, that handle i686, etc.
+
+Thu Jan 23 07:06:15 1997 Mark Galassi <rosalia@papageno.lanl.gov>
+
+ * newdoc/tutorial/guile-tut.texi: started checking in the Guile
+ tutorial rewrite, but have not merged much into it yet.
+
+Tue Jan 21 17:28:40 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * newdoc/ref/guile-ref.texi: started checking in parts of the
+ reference manual re-write.
+
+Sat Jan 11 14:40:17 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * ltconfig, ltmain.sh: New files for libtool support. libguile,
+ rx, gh and gtcltk-lib can now be build as shared libraries.
+ * Makefile.am (EXTRA_DIST): Added ltconfig and ltmain.sh
+
+Sun Jan 5 16:57:10 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Guile 1.0 released. This is the first release by the Free
+ Software Foundation; Cygnus has also released earlier versions of
+ Guile.
+
+ * GUILE-VERSION: Updated version number.
+ * NEWS: Added comments for all the user-visible changes marked in
+ the ChangeLogs.
+ * README: Updated for release.
+
+Thu Dec 12 00:14:32 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scsh: new directory.
+
+Mon Dec 2 17:33:04 1996 Tom Tromey <tromey@cygnus.com>
+
+ * configure.in: Generate doc/guile-programmer/Makefile and
+ doc/guile-user/Makefile.
+
+Sat Nov 30 23:45:54 1996 Tom Tromey <tromey@cygnus.com>
+
+ * aclocal.m4: Now automatically generated by aclocal.
+ * threads.m4: New file.
+ * guile.m4: New file.
+ * Makefile.am, doc/Makefile.am: New files.
+ * configure.in: Updated for Automake. Avoid excessively verbose
+ "greet" messages.
+
+Wed Oct 16 07:32:14 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * lgh: directory renamed to gh, along with all prefixes of the
+ high level library procedures.
+
+Thu Oct 10 14:37:43 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS tags): Find the source files in $srcdir.
+
+Wed Oct 9 19:37:14 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (DISTFILES): Add AUTHORS and aclocal.m4.
+
+Tue Oct 1 00:13:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * configure.in: Added some configuration magic from the Cygnus
+ distribution.
+
+ * aclocal.m4: New file. For now used for thread support
+ configuration.
+
+Fri Sep 13 14:39:30 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * Makefile.in (DISTFILES): added mkinstalldirs to the DISTFILES
+
+ * PLUGIN: changed the PLUGIN/REQ files in the ice-9 and lgh
+ directories, to arrange for lgh to the last thing
+ configured/built.
+
+Wed Sep 11 21:11:33 1996 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * lgh/: added the directory in which I implement the high level
+ libguile library (lgh_) for this release of Guile. See the
+ ChangeLog in there for further details.
+
+Wed Sep 11 16:12:53 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * doc/ (guile-user and guile-programmer): added the guile-user and
+ guile-programmer directories which contain the user and programmer
+ manuals. See the ChangeLog entries there for detail.
+
+Wed Sep 11 14:33:49 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (distclean): Don't forget to delete doc/Makefile.
+
+ * Makefile.in (distclean): Don't forget to delete
+ config.build-subdirs.
+
+Thu Sep 5 17:36:15 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (tags): New name for `TAGS' target, which will
+ always run the commands.
+
+Thu Sep 5 09:56:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Doc fixes.
+
+Fri Aug 30 16:56:27 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS): Produce a single tags file for all of Guile.
+
+Thu Aug 15 19:03:03 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Check for -ldl, so the check for Tcl won't fail
+ spuriously.
+
+Thu Aug 15 01:29:29 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Change the way we decide whether to build gtcltk-lib, so that it's
+ omitted from the build process when appropriate, but never from
+ the dist process.
+ * configure.in: Don't edit all_subdirs depending on the
+ availability of Tk; let that be the list of all PLUGIN
+ subdirectories present, as it used to be. Instead, edit a new
+ variable, build_subdirs; write its final value, the list of
+ subdirs we do want to compile in, to config.build-subdirs.
+ Substitute that into the top-level Makefile too.
+ * Makefile.in (subdirs): Set this to @build_subdirs@, so we only
+ recurse on the subdirectories we should build.
+ (distdirs): Set this to @existingdirs@, so it includes the subdirs
+ we decided not to build.
+
+ * doc/gtcltk.texi: File resurrected from old Guile releases.
+ * doc/Makefile.in (info): Build the gtcltk documentation.
+ (DIST_FILES): Include it in the distribution.
+
+ * configure.in: If we can find the library for tcl7.5, build
+ gtcltk-lib. Call AC_PROG_CC, to help run that test with the right
+ compiler (not sure this is necessary).
+
+Mon Aug 12 15:09:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * NEWS: Fix bug reporting address.
+
+Fri Aug 9 15:58:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * AUTHORS: New file, in accordance with the GNU maintainers'
+ standards.
+
+Tue Aug 6 14:40:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Renamed from ANNOUNCE; include bug report address,
+ description, and short tour.
+ * INSTALL: Renamed from BUILDING.
+ * NEWS: New file.
+ * Makefile.in (DISTFILES): Update appropriately.
+
+Thu Aug 1 02:31:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * doc/Makefile.in: Added pattern targets for creating DVI and
+ PostScript files.
+ (%.ps, %.dvi, %.txt): New targets.
+ (DVIPS, TEXI2DVI): New variables.
+
+ * GUILE-VERSION: Updated to 1.0b3.
+
+ Rehashed distribution system, in preparation for nightly
+ snapshots. Other changes in subdirectories.
+ * Makefile.in (dist): Rewritten --- the old target was out of
+ date, dependent on files that we don't have, and relied on GNU
+ tar. The new target is simpler.
+ (VERSION, srcdir, dist_dirs): New variables.
+ (DISTFILES): Renamed from localfiles. Added GUILE-VERSION and
+ TODO.
+ (localtreats): Variable removed. We don't have this file.
+ (info): cd to doc and make info there; don't make info in every
+ ${subdir}; those Makefiles don't know what to do.
+ (distname, distdir, treats, announcefile): Variables removed.
+ (manifest-file): Target removed.
+ (dist-dir): New target, responsible for distributable files in
+ this directory.
+ (GZIP, GZIP_EXT, TAR_VERBOSE, DIST_NAME): New variables,
+ controlling the 'dist' target.
+ * configure.in: Substitute GUILE-VERSION into the top-level
+ Makefile. Build doc/Makefile from doc/Makefile.in.
+
+ * doc/Makefile.in: New file.
diff --git a/GUILE-VERSION b/GUILE-VERSION
index 891b63016..8ec5b4b4b 100644
--- a/GUILE-VERSION
+++ b/GUILE-VERSION
@@ -1,4 +1,7 @@
GUILE_MAJOR_VERSION=1
-GUILE_MINOR_VERSION=0
+GUILE_MINOR_VERSION=1a
GUILE_VERSION=$GUILE_MAJOR_VERSION.$GUILE_MINOR_VERSION
+# For automake.
+VERSION=$GUILE_VERSION
+PACKAGE=guile
diff --git a/HACKING b/HACKING
new file mode 100644
index 000000000..7855241c0
--- /dev/null
+++ b/HACKING
@@ -0,0 +1,88 @@
+Here are some guidelines for working on the Guile source tree at GNU.
+
+- As for any part of Project GNU, changes to Guile should follow the
+GNU coding standards. The standards are available via anonymous FTP
+from prep.ai.mit.edu, as /pub/gnu/standards/standards.texi and
+make-stds.texi.
+
+- Check Makefile.in and configure files into CVS, as well as any files
+used to create them (Makefile.am, configure.in); don't check in
+Makefiles or header files generated by configuration scripts. The
+general rule is that you should be able to check out a working
+directory of Guile from CVS, and then type "configure" and "make".
+
+- Make sure your changes compile and work, at least on your own
+machine, before checking them into the main branch of the Guile
+repository. If you really need to check in untested changes, make a
+branch.
+
+- When you make a user-visible change (i.e. one that should be
+documented, and appear in NEWS, put an asterisk in column zero of the
+start of the ChangeLog entry, like so:
+
+Sat Aug 3 01:27:14 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+* * fports.c (scm_open_file): don't return #f, throw error.
+
+When you've written a NEWS entry and updated the documentation, go
+ahead and remove the asterisk. I will use the asterisks to find and
+document changes that haven't been dealt with before a release.
+
+- Include each log entry in both the ChangeLog and in the CVS logs.
+If you're using Emacs, the pcl-cvs interface to CVS has features to
+make this easier; it checks the ChangeLog, and generates good default
+CVS log entries from that.
+
+- There's no need to keep a change log for documentation files. This
+is because documentation is not susceptible to bugs that are hard to
+fix. Documentation does not consist of parts that must interact in a
+precisely engineered fashion; to correct an error, you need not know
+the history of the erroneous passage. (This is copied from the GNU
+coding standards.)
+
+- If you add or remove files, don't forget to update the appropriate
+part of the relevant Makefile.am files, and regenerate the
+Makefile.in. If you forget this, the snapshot and distribution
+processes will not work.
+
+- Make sure you have papers from people before integrating their
+changes or contributions. This is very frustrating, but very
+important to do right. From maintain.texi, "Information for
+Maintainers of GNU Software":
+
+ When incorporating changes from other people, make sure to follow the
+ correct procedures. Doing this ensures that the FSF has the legal
+ right to distribute and defend GNU software.
+
+ For the sake of registering the copyright on later versions ofthe
+ software you need to keep track of each person who makes significant
+ changes. A change of ten lines or so, or a few such changes, in a
+ large program is not significant.
+
+ *Before* incorporating significant changes, make sure that the person
+ has signed copyright papers, and that the Free Software Foundation has
+ received them.
+
+If you receive contributions you want to use from someone, let me know
+and I'll take care of the administrivia. Put the contributions aside
+until we have the necessary papers.
+
+- When you make substantial changes to a file, add the current year to
+the list of years in the copyright notice at the top of the file.
+
+- [From Mikael Djurfeldt] When working on the Guile internals, it is
+quite often practical to implement a scheme-level procedure which
+helps you examine the feature you're working on.
+
+Examples of such procedures are: pt-size, debug-hand and
+current-pstate.
+
+I've now put #ifdef GUILE_DEBUG around all such procedures, so that
+they are not compiled into the "normal" Guile library. Please do the
+same when you add new procedures/C functions for debugging purpose.
+
+You can define the GUILE_DEBUG flag by passing --enable-guile-debug to
+the configure script.
+
+
+Jim Blandy
diff --git a/INSTALL b/INSTALL
new file mode 100644
index 000000000..4fc256515
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,137 @@
+To build Guile on unix, there are two basic steps:
+
+ 1. Configure the package by running the configure script.
+ 2. Build the package by running make.
+
+Generic instructions for configuring and compiling GNU distributions
+are included below. Here is an illustration of commands that might be
+used to build Guile. The voluminous output of the commands is not shown.
+
+ % tar xvfz guile-snap.tar.gz # unpack the sources
+ % cd guile-snap
+ % ./configure
+ % make
+
+The `configure' script examines your system, and adapts Guile to
+compile and run on it.
+
+The `make' command builds several things:
+- An executable file `guile/guile', which is an interactive shell for
+ talking with the Guile Scheme interpreter.
+- An object library `guile/libguile.a', containing the Guile Scheme
+ interpreter, ready to be linked into your programs.
+- An object library `gtcltk-lib/libgtcltk.a', containing a simple
+ interface between Guile and Tcl/Tk. This is only built if the
+ configure script notices that you have the appropriate version of
+ Tcl/Tk installed on your system already. If it is installed, `make'
+ will automatically include Tcl/Tk and the interface in the guile
+ shell. If the interface were documented, we'd include a pointer to
+ it here.
+
+To install Guile, type `make install'. This installs the executable
+and libraries mentioned above, as well as Guile's header files and
+Scheme libraries.
+
+If you want to run Guile without installing it, set the environment
+variable `SCHEME_LOAD_PATH' to a colon-separated list of directories,
+including the directory containing this INSTALL file. For example, if
+you unpacked Guile so that the full filename of this file is
+`/home/jimb/guile-snap/INSTALL', then you might say
+
+ export SCHEME_LOAD_PATH=/home/jimb/my-scheme:/home/jimb/guile-snap
+
+if you're using Bash or any other Bourne shell variant, or
+
+ setenv SCHEME_LOAD_PATH /home/jimb/my-scheme:/home/jimb/guile-snap
+
+if you're using CSH or one of its variants.
+
+
+ Generic Instructions for Building Auto-Configured Packages
+ ==========================================================
+
+
+To compile this package:
+
+1. Configure the package for your system. In the directory that this
+file is in, type `./configure'. If you're using `csh' on an old
+version of System V, you might need to type `sh configure' instead to
+prevent `csh' from trying to execute `configure' itself.
+
+The `configure' shell script attempts to guess correct values for
+various system-dependent variables used during compilation, and
+creates the Makefile(s) (one in each subdirectory of the source
+directory). In some packages it creates a C header file containing
+system-dependent definitions. It also creates a file `config.status'
+that you can run in the future to recreate the current configuration.
+Running `configure' takes a minute or two.
+
+To compile the package in a different directory from the one
+containing the source code, you must use GNU make. `cd' to the
+directory where you want the object files and executables to go and
+run `configure' with the option `--srcdir=DIR', where DIR is the
+directory that contains the source code. Using this option is
+actually unnecessary if the source code is in the parent directory of
+the one in which you are compiling; `configure' automatically checks
+for the source code in `..' if it does not find it in the current
+directory.
+
+By default, `make install' will install the package's files in
+/usr/local/bin, /usr/local/lib, /usr/local/man, etc. You can specify
+an installation prefix other than /usr/local by giving `configure' the
+option `--prefix=PATH'. Alternately, you can do so by changing the
+`prefix' variable in the Makefile that `configure' creates (the
+Makefile in the top-level directory, if the package contains
+subdirectories).
+
+You can specify separate installation prefixes for machine-specific
+files and machine-independent files. If you give `configure' the
+option `--exec_prefix=PATH', the package will use PATH as the prefix
+for installing programs and libraries. Normally, all files are
+installed using the same prefix.
+
+`configure' ignores any other arguments that you give it.
+
+If your system requires unusual options for compilation or linking
+that `configure' doesn't know about, you can give `configure' initial
+values for some variables by setting them in the environment. In
+Bourne-compatible shells, you can do that on the command line like
+this:
+ CC='gcc -traditional' DEFS=-D_POSIX_SOURCE ./configure
+
+The `make' variables that you might want to override with environment
+variables when running `configure' are:
+
+(For these variables, any value given in the environment overrides the
+value that `configure' would choose:)
+CC C compiler program.
+ Default is `cc', or `gcc' if `gcc' is in your PATH.
+INSTALL Program to use to install files.
+ Default is `install' if you have it, `cp' otherwise.
+INCLUDEDIR Directory for `configure' to search for include files.
+ Default is /usr/include.
+
+(For these variables, any value given in the environment is added to
+the value that `configure' chooses:)
+DEFS Configuration options, in the form '-Dfoo -Dbar ...'
+LIBS Libraries to link with, in the form '-lfoo -lbar ...'
+
+If you need to do unusual things to compile the package, we encourage
+you to teach `configure' how to do them and mail the diffs to the
+address given in the README so we can include them in the next
+release.
+
+2. Type `make' to compile the package.
+
+3. Type `make install' to install programs, data files, and
+documentation.
+
+4. You can remove the program binaries and object files from the
+source directory by typing `make clean'. To also remove the
+Makefile(s), the header file containing system-dependent definitions
+(if the package uses one), and `config.status' (all the files that
+`configure' created), type `make distclean'.
+
+The file `configure.in' is used as a template to create `configure' by
+a program called `autoconf'. You will only need it if you want to
+regenerate `configure' using a newer version of `autoconf'.
diff --git a/Makefile.am b/Makefile.am
new file mode 100644
index 000000000..a6ac392aa
--- /dev/null
+++ b/Makefile.am
@@ -0,0 +1,14 @@
+## Process this file with automake to produce Makefile.in.
+
+SUBDIRS = @existingdirs@ newdoc
+
+guile_dirs = @existingdirs@ newdoc
+guile-dist:
+ $(MAKE) SUBDIRS="$(guile_dirs)" dist
+
+## FIXME: in the future there will be direct automake support for
+## doing this. When that happens, switch over.
+aclocaldir = $(datadir)/aclocal
+aclocal_DATA = guile.m4 threads.m4
+
+EXTRA_DIST = $(aclocal_DATA) ltconfig ltmain.sh HACKING GUILE-VERSION
diff --git a/Makefile.in b/Makefile.in
index c2334e3f7..ff6515044 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -1,294 +1,298 @@
-# Copyright (C) 1994,1995 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-1307, USA.
+# Makefile.in generated automatically by automake 1.1n from Makefile.am
+
+# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
SHELL = /bin/sh
-subdirs=@existingdirs@
-
-localfiles = ANNOUNCE \
- COPYING \
- Makefile.in \
- configure \
- configure.in \
- config.sub \
- config.guess \
- install-sh
-
-localtreats = ANN.BX
-
-# `all'
-# Compile the entire program. This should be the default target.
-# This target need not rebuild any documentation files; info files
-# should normally be included in the distribution, and DVI files
-# should be made only when explicitly asked for.
-all:
- @for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} all; \
- cd .. ;\
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = .
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = true
+PRE_INSTALL = true
+POST_INSTALL = true
+NORMAL_UNINSTALL = true
+PRE_UNINSTALL = true
+POST_UNINSTALL = true
+MAINT = @MAINT@
+PACKAGE = @PACKAGE@
+VERSION = @VERSION@
+existingdirs = @existingdirs@
+
+SUBDIRS = @existingdirs@ newdoc
+
+guile_dirs = @existingdirs@ newdoc
+
+aclocaldir = $(datadir)/aclocal
+aclocal_DATA = guile.m4 threads.m4
+
+EXTRA_DIST = $(aclocal_DATA) ltconfig ltmain.sh HACKING GUILE-VERSION
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs
+CONFIG_CLEAN_FILES =
+DATA = $(aclocal_DATA)
+
+DIST_COMMON = README AUTHORS COPYING ChangeLog INSTALL Makefile.am \
+Makefile.in NEWS TODO aclocal.m4 config.guess config.sub configure \
+configure.in install-sh ltconfig ltmain.sh mdate-sh missing \
+mkinstalldirs
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = tar
+GZIP = --best
+default: all
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
+ cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile
+
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
+ cd $(top_builddir) \
+ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+$(srcdir)/aclocal.m4: @MAINT@ configure.in
+ cd $(srcdir) && $(ACLOCAL)
+
+config.status: configure
+ $(SHELL) ./config.status --recheck
+$(srcdir)/configure: @MAINT@configure.in $(ACLOCAL_M4) $(CONFIGURE_DEPENDENCIES)
+ cd $(srcdir) && $(AUTOCONF)
+
+install-aclocalDATA: $(aclocal_DATA)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(aclocaldir)
+ @list='$(aclocal_DATA)'; for p in $$list; do \
+ if test -f $(srcdir)/$$p; then \
+ echo " $(INSTALL_DATA) $(srcdir)/$$p $(aclocaldir)/$$p"; \
+ $(INSTALL_DATA) $(srcdir)/$$p $(aclocaldir)/$$p; \
+ else if test -f $$p; then \
+ echo " $(INSTALL_DATA) $$p $(aclocaldir)/$$p"; \
+ $(INSTALL_DATA) $$p $(aclocaldir)/$$p; \
+ fi; fi; \
done
-#`install'
-# Compile the program and copy the executables, libraries, and so on
-# to the file names where they should reside for actual use. If
-# there is a simple test to verify that a program is properly
-# installed then run that test.
-#
-# Use `-' before any command for installing a man page, so that
-# `make' will ignore any errors. This is in case there are systems
-# that don't have the Unix man page documentation system installed.
-#
-# In the future, when we have a standard way of installing info
-# files, `install' targets will be the proper place to do so.
-#
-subdir-inst-target=install-nobuild
-
-install: all
- ${MAKE} subdir-inst-target=install install-nobuild
-
-install-nobuild:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} ${subdir-inst-target}; \
- cd .. ;\
+uninstall-aclocalDATA:
+ $(NORMAL_UNINSTALL)
+ list='$(aclocal_DATA)'; for p in $$list; do \
+ rm -f $(aclocaldir)/$$p; \
done
-#`uninstall'
-# Delete all the installed files that the `install' target would
-# create (but not the noninstalled files such as `make all' would
-# create).
-uninstall:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} uninstall; \
- cd .. ;\
+# This directory's subdirectories are mostly independent; you can cd
+# into them and run `make' without going through this Makefile.
+# To change the values of `make' variables: instead of editing Makefiles,
+# (1) if the variable is set in `config.status', edit `config.status'
+# (which will cause the Makefiles to be regenerated when you run `make');
+# (2) otherwise, pass the desired values on the `make' command line.
+
+@SET_MAKE@
+
+all-recursive install-data-recursive install-exec-recursive \
+installdirs-recursive install-recursive uninstall-recursive \
+check-recursive installcheck-recursive info-recursive dvi-recursive \
+mostlyclean-recursive clean-recursive distclean-recursive \
+maintainer-clean-recursive:
+ @for subdir in $(SUBDIRS); do \
+ target=`echo $@ | sed s/-recursive//`; \
+ echo "Making $$target in $$subdir"; \
+ (cd $$subdir && $(MAKE) $$target) \
+ || case "$(MFLAGS)" in *k*) fail=yes;; *) exit 1;; esac; \
+ done && test -z "$$fail"
+tags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ (cd $$subdir && $(MAKE) tags); \
done
+tags: TAGS
-#`clean'
-# Delete all files from the current directory that are normally
-# created by building the program. Don't delete the files that
-# record the configuration. Also preserve files that could be made
-# by building, but normally aren't because the distribution comes
-# with them.
-#
-# Delete `.dvi' files here if they are not part of the distribution.
-#
-clean:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} clean; \
- cd .. ;\
- done
+ID: $(HEADERS) $(SOURCES)
+ here=`pwd` && cd $(srcdir) && mkid -f$$here/ID $(SOURCES) $(HEADERS)
-#`distclean'
-# Delete all files from the current directory that are created by
-# configuring or building the program. If you have unpacked the
-# source and built the program without creating any other files,
-# `make distclean' should leave only the files that were in the
-# distribution.
-distclean:
- rm -f config.cache
- rm -f config.log
- rm -f config.status
- rm -f Makefile
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} distclean; \
- cd .. ;\
- done
+TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES)
+ tags=; \
+ here=`pwd`; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \
+ done; \
+ test -z "$(ETAGS_ARGS)$(SOURCES)$(HEADERS)$$tags" \
+ || (cd $(srcdir) && etags $(ETAGS_ARGS) $$tags $(SOURCES) $(HEADERS) -o $$here/TAGS)
+mostlyclean-tags:
-#`mostlyclean'
-# Like `clean', but may refrain from deleting a few files that people
-# normally don't want to recompile. For example, the `mostlyclean'
-# target for GCC does not delete `libgcc.a', because recompiling it
-# is rarely necessary and takes a lot of time.
-mostlyclean:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} mostlyclean; \
- cd .. ;\
- done
+clean-tags:
+
+distclean-tags:
+ rm -f TAGS ID
+maintainer-clean-tags:
-#`realclean'
-# Delete everything from the current directory that can be
-# reconstructed with this Makefile. This typically includes
-# everything deleted by distclean, plus more: C source files
-# produced by Bison, tags tables, info files, and so on.
-#
-# One exception, however: `make realclean' should not delete
-# `configure' even if `configure' can be remade using a rule in the
-# Makefile. More generally, `make realclean' should not delete
-# anything that needs to exist in order to run `configure' and then
-# begin to build the program.
-realclean:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} realclean; \
- cd .. ;\
+distdir = $(PACKAGE)-$(VERSION)
+# This target untars the dist file and tries a VPATH configuration. Then
+# it guarantees that the distribution is self-contained by making another
+# tarfile.
+distcheck: dist
+ rm -rf $(distdir)
+ GZIP=$(GZIP) $(TAR) zxf $(distdir).tar.gz
+ mkdir $(distdir)/=build
+ mkdir $(distdir)/=inst
+ dc_install_base=`cd $(distdir)/=inst && pwd`; \
+ cd $(distdir)/=build \
+ && ../configure --srcdir=.. --prefix=$$dc_install_base \
+ && $(MAKE) \
+ && $(MAKE) dvi \
+ && $(MAKE) check \
+ && $(MAKE) install \
+ && $(MAKE) installcheck \
+ && $(MAKE) dist
+ rm -rf $(distdir)
+ @echo "========================"; \
+ echo "$(distdir).tar.gz is ready for distribution"; \
+ echo "========================"
+dist: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+dist-all: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+distdir: $(DISTFILES)
+ rm -rf $(distdir)
+ mkdir $(distdir)
+ -chmod 755 $(distdir)
+ here=`pwd`; distdir=`cd $(distdir) && pwd` \
+ && cd $(srcdir) \
+ && $(AUTOMAKE) --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --gnu
+ @for file in $(DISTFILES); do \
+ d=$(srcdir); \
+ test -f $(distdir)/$$file \
+ || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+ || cp -p $$d/$$file $(distdir)/$$file; \
done
+ for subdir in $(SUBDIRS); do \
+ test -d $(distdir)/$$subdir \
+ || mkdir $(distdir)/$$subdir \
+ || exit 1; \
+ chmod 755 $(distdir)/$$subdir; \
+ (cd $$subdir && $(MAKE) distdir=../$(distdir)/$$subdir distdir) \
+ || exit 1; \
+ done
+info: info-recursive
+dvi: dvi-recursive
+check: all-am
+ $(MAKE) check-recursive
+installcheck: installcheck-recursive
+all-am: $(DATA) Makefile
+install-data-am: install-aclocalDATA
-#`TAGS'
-# Update a tags table for this program.
-TAGS:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} TAGS; \
- cd .. ;\
- done
+uninstall-am: uninstall-aclocalDATA
-#`info'
-# Generate any info files needed. The best way to write the rules
-# is as follows:
-#
-# info: foo.info
-#
-# foo.info: $(srcdir)/foo.texi $(srcdir)/chap1.texi $(srcdir)/chap2.texi
-# $(MAKEINFO) $(srcdir)/foo.texi
-#
-# You must define the variable `MAKEINFO' in the Makefile. It
-# should run the Makeinfo program, which is part of the Texinfo2
-# distribution.
-info:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} info; \
- cd .. ;\
- done
+install-exec: install-exec-recursive
+ @$(NORMAL_INSTALL)
+install-data: install-data-recursive install-data-am
+ @$(NORMAL_INSTALL)
-#`dvi'
-# Generate DVI files for all TeXinfo documentation. For example:
-#
-# dvi: foo.dvi
-#
-# foo.dvi: $(srcdir)/foo.texi $(srcdir)/chap1.texi $(srcdir)/chap2.texi
-# $(TEXI2DVI) $(srcdir)/foo.texi
-#
-# You must define the variable `TEXI2DVI' in the Makefile. It should
-# run the program `texi2dvi', which is part of the Texinfo2
-# distribution. Alternatively, write just the dependencies, and
-# allow GNU Make to provide the command.
-dvi:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} dvi; \
- cd .. ;\
- done
+install: install-recursive install-data-am
+ @:
-#`dist'
-# Create a distribution tar file for this program. The tar file
-# should be set up so that the file names in the tar file start with
-# a subdirectory name which is the name of the package it is a
-# distribution for. This name can include the version number.
-#
-# For example, the distribution tar file of GCC version 1.40 unpacks
-# into a subdirectory named `gcc-1.40'.
-#
-# The easiest way to do this is to create a subdirectory
-# appropriately named, use `ln' or `cp' to install the proper files
-# in it, and then `tar' that subdirectory.
-#
-# The `dist' target should explicitly depend on all non-source files
-# that are in the distribution, to make sure they are up to date in
-# the distribution. *Ref Making Releases: (standards)Releases.
-distname = brand-x
-distdir = $(distname)
-treats = $(localtreats)
-announcefile = ANN.BX
-
-manifest-file:
- rm -f MANIFEST
- cp $(announcefile) ANNOUNCE
- for treat in $(localfiles) $(treats) ; \
- do echo $$treat >> MANIFEST ; \
- done
- for subdir in $(subdirs) ; do \
- make -s -f $$subdir/Makefile.in SUBDIR=$$subdir manifest >> MANIFEST ; \
- done
- sed -e "s%^%$(distdir)/%" MANIFEST > M2
- sed -e "/Entering dir/d" -e "/Leaving dir/d" M2 > MANIFEST
- rm M2
+uninstall: uninstall-recursive uninstall-am
+all: all-recursive all-am
+install-strip:
+ $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
+installdirs: installdirs-recursive
+ $(mkinstalldirs) $(aclocaldir)
-dist: manifest-file
- mkdir $(distdir)
- - cd $(distdir); \
- for file in $(localfiles) $(treats) $(subdirs); do ln -s ../$$file .; done; \
- cd ..; \
- gtar -zhcvf $(distname).tar.gz --files-from MANIFEST
- rm -rf $(distdir)
- -gtar ztvf $(distname).tar.gz | grep ".*~" > BACKUPS
- test -s BACKUPS && (echo WARNING -- MANIFEST INCLUDES BACK FILES; cat BACKUPS)
-
-#`check'
-# Perform self-tests (if any). The user must build the program
-# before running the tests, but need not install the program; you
-# should write the self-tests so that they work when the program is
-# built but not installed.
-check:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} check; \
- cd .. ;\
- done
+mostlyclean-generic:
+ test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
-#`installcheck'
-# Perform installation tests (if any). The user must build and
-# install the program before running the tests. You should not
-# assume that `$(bindir)' is in the search path.
-installcheck:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} installcheck; \
- cd .. ;\
- done
+clean-generic:
+ test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+distclean-generic:
+ rm -f Makefile $(DISTCLEANFILES)
+ rm -f config.cache config.log stamp-h
+ test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
-#`installdirs'
-# It's useful to add a target named `installdirs' to create the
-# directories where files are installed, and their parent
-# directories. There is a script called `mkinstalldirs' which is
-# convenient for this; find it in the Texinfo package.You can use a
-# rule like this:
-#
-# # Make sure all installation directories, e.g. $(bindir) actually exist by
-# # making them if necessary.
-# installdirs: mkinstalldirs
-# $(srcdir)/mkinstalldirs $(bindir) $(datadir) $(libdir) \
-# $(infodir) $(mandir)
-installdirs:
- for dir in ${subdirs}; do \
- cd $$dir; \
- ${MAKE} installdirs; \
- cd .. ;\
- done
+maintainer-clean-generic:
+ test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+ test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+mostlyclean-am: mostlyclean-tags mostlyclean-generic
+clean-am: clean-tags clean-generic mostlyclean-am
+distclean-am: distclean-tags distclean-generic clean-am
+
+maintainer-clean-am: maintainer-clean-tags maintainer-clean-generic \
+ distclean-am
+
+mostlyclean: mostlyclean-recursive mostlyclean-am
+
+clean: clean-recursive clean-am
+
+distclean: distclean-recursive distclean-am
+ rm -f config.status
+
+maintainer-clean: maintainer-clean-recursive maintainer-clean-am
+ @echo "This command is intended for maintainers to use;"
+ @echo "it deletes files that may require special tools to rebuild."
+ rm -f config.status
-# Cygnus extention:
-#
-# `Makefile'
-# Calls `./config.status' to rebuild the `Makefile' in this
-# directory.
-Makefile:
- ${SHELL-/bin/sh} config.status
+.PHONY: default uninstall-aclocalDATA install-aclocalDATA \
+install-data-recursive uninstall-data-recursive install-exec-recursive \
+uninstall-exec-recursive installdirs-recursive uninstalldirs-recursive \
+all-recursive check-recursive installcheck-recursive info-recursive \
+dvi-recursive mostlyclean-recursive distclean-recursive clean-recursive \
+maintainer-clean-recursive tags tags-recursive mostlyclean-tags \
+distclean-tags clean-tags maintainer-clean-tags distdir info dvi \
+installcheck all-am install-data-am uninstall-am install-exec \
+install-data install uninstall all installdirs mostlyclean-generic \
+distclean-generic clean-generic maintainer-clean-generic clean \
+mostlyclean distclean maintainer-clean
+
+guile-dist:
+ $(MAKE) SUBDIRS="$(guile_dirs)" dist
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/NEWS b/NEWS
new file mode 100644
index 000000000..832bc1507
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,370 @@
+Guile NEWS --- history of user-visible changes. -*- text -*-
+Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+See the end for copying conditions.
+
+Please send Guile bug reports to bug-guile@prep.ai.mit.edu.
+
+Changes since Guile 1.0 (Sun 5 Jan 1997):
+
+* Changes to the gh_ interface
+
+** gh_eval_str() now returns an SCM object which is the result of the
+evaluation
+
+** gh_scm2str() now copies the Scheme data to a caller-provided C
+array
+
+** gh_scm2newstr() now makes a C array, copies the Scheme data to it,
+and returns the array
+
+** gh_scm2str0() is gone: there is no need to distinguish
+null-terminated from non-null-terminated, since gh_scm2newstr() allows
+the user to interpret the data both ways.
+
+* Changes to documentation
+
+** the $(srcdir)/newdoc hierarchy now contains a new approach to the
+manuals. The approach, recommended by Jim Blandy, is to have: (*) a
+tutorial with the pedagogical style of guile-user, and a non-dry
+reference manual in the style of the most excellent GNU libc reference
+manual: the reference manual should be complete, but at the same time
+it should have an introductory screen for each major topic, which can
+be referenced if the user goes "up" a level in the info documentation.
+
+
+Guile 1.0b3
+
+User-visible changes from Thursday, September 5, 1996 until Guile 1.0:
+
+* Changes to the 'guile' program:
+
+** Guile now loads some new files when it starts up. Guile first
+searches the load path for init.scm, and loads it if found. Then, if
+Guile is not being used to execute a script, and the user's home
+directory contains a file named `.guile', Guile loads that.
+
+** You can now use Guile as a shell script interpreter.
+
+To paraphrase the SCSH manual:
+
+ When Unix tries to execute an executable file whose first two
+ characters are the `#!', it treats the file not as machine code to
+ be directly executed by the native processor, but as source code
+ to be executed by some interpreter. The interpreter to use is
+ specified immediately after the #! sequence on the first line of
+ the source file. The kernel reads in the name of the interpreter,
+ and executes that instead. It passes the interpreter the source
+ filename as its first argument, with the original arguments
+ following. Consult the Unix man page for the `exec' system call
+ for more information.
+
+Now you can use Guile as an interpreter, using a mechanism which is a
+compatible subset of that provided by SCSH.
+
+Guile now recognizes a '-s' command line switch, whose argument is the
+name of a file of Scheme code to load. It also treats the two
+characters `#!' as the start of a comment, terminated by `!#'. Thus,
+to make a file of Scheme code directly executable by Unix, insert the
+following two lines at the top of the file:
+
+#!/usr/local/bin/guile -s
+!#
+
+Guile treats the argument of the `-s' command-line switch as the name
+of a file of Scheme code to load, and treats the sequence `#!' as the
+start of a block comment, terminated by `!#'.
+
+For example, here's a version of 'echo' written in Scheme:
+
+#!/usr/local/bin/guile -s
+!#
+(let loop ((args (cdr (program-arguments))))
+ (if (pair? args)
+ (begin
+ (display (car args))
+ (if (pair? (cdr args))
+ (display " "))
+ (loop (cdr args)))))
+(newline)
+
+Why does `#!' start a block comment terminated by `!#', instead of the
+end of the line? That is the notation SCSH uses, and although we
+don't yet support the other SCSH features that motivate that choice,
+we would like to be backward-compatible with any existing Guile
+scripts once we do. Furthermore, if the path to Guile on your system
+is too long for your kernel, you can start the script with this
+horrible hack:
+
+#!/bin/sh
+exec /really/long/path/to/guile -s "$0" ${1+"$@"}
+!#
+
+Note that some very old Unix systems don't support the `#!' syntax.
+
+
+** You can now run Guile without installing it.
+
+Previous versions of the interactive Guile interpreter (`guile')
+couldn't start up unless Guile's Scheme library had been installed;
+they used the value of the environment variable `SCHEME_LOAD_PATH'
+later on in the startup process, but not to find the startup code
+itself. Now Guile uses `SCHEME_LOAD_PATH' in all searches for Scheme
+code.
+
+To run Guile without installing it, build it in the normal way, and
+then set the environment variable `SCHEME_LOAD_PATH' to a
+colon-separated list of directories, including the top-level directory
+of the Guile sources. For example, if you unpacked Guile so that the
+full filename of this NEWS file is /home/jimb/guile-1.0b3/NEWS, then
+you might say
+
+ export SCHEME_LOAD_PATH=/home/jimb/my-scheme:/home/jimb/guile-1.0b3
+
+
+** Guile's read-eval-print loop no longer prints #<unspecified>
+results. If the user wants to see this, she can evaluate the
+expression (assert-repl-print-unspecified #t), perhaps in her startup
+file.
+
+** Guile no longer shows backtraces by default when an error occurs;
+however, it does display a message saying how to get one, and how to
+request that they be displayed by default. After an error, evaluate
+ (backtrace)
+to see a backtrace, and
+ (debug-enable 'backtrace)
+to see them by default.
+
+
+
+* Changes to Guile Scheme:
+
+** Guile now distinguishes between #f and the empty list.
+
+This is for compatibility with the IEEE standard, the (possibly)
+upcoming Revised^5 Report on Scheme, and many extant Scheme
+implementations.
+
+Guile used to have #f and '() denote the same object, to make Scheme's
+type system more compatible with Emacs Lisp's. However, the change
+caused too much trouble for Scheme programmers, and we found another
+way to reconcile Emacs Lisp with Scheme that didn't require this.
+
+
+** Guile's delq, delv, delete functions, and their destructive
+counterparts, delq!, delv!, and delete!, now remove all matching
+elements from the list, not just the first. This matches the behavior
+of the corresponding Emacs Lisp functions, and (I believe) the Maclisp
+functions which inspired them.
+
+I recognize that this change may break code in subtle ways, but it
+seems best to make the change before the FSF's first Guile release,
+rather than after.
+
+
+** The compiled-library-path function has been deleted from libguile.
+
+** The facilities for loading Scheme source files have changed.
+
+*** The variable %load-path now tells Guile which directories to search
+for Scheme code. Its value is a list of strings, each of which names
+a directory.
+
+*** The variable %load-extensions now tells Guile which extensions to
+try appending to a filename when searching the load path. Its value
+is a list of strings. Its default value is ("" ".scm").
+
+*** (%search-load-path FILENAME) searches the directories listed in the
+value of the %load-path variable for a Scheme file named FILENAME,
+with all the extensions listed in %load-extensions. If it finds a
+match, then it returns its full filename. If FILENAME is absolute, it
+returns it unchanged. Otherwise, it returns #f.
+
+%search-load-path will not return matches that refer to directories.
+
+*** (primitive-load FILENAME :optional CASE-INSENSITIVE-P SHARP)
+uses %seach-load-path to find a file named FILENAME, and loads it if
+it finds it. If it can't read FILENAME for any reason, it throws an
+error.
+
+The arguments CASE-INSENSITIVE-P and SHARP are interpreted as by the
+`read' function.
+
+*** load uses the same searching semantics as primitive-load.
+
+*** The functions %try-load, try-load-with-path, %load, load-with-path,
+basic-try-load-with-path, basic-load-with-path, try-load-module-with-
+path, and load-module-with-path have been deleted. The functions
+above should serve their purposes.
+
+*** If the value of the variable %load-hook is a procedure,
+`primitive-load' applies its value to the name of the file being
+loaded (without the load path directory name prepended). If its value
+is #f, it is ignored. Otherwise, an error occurs.
+
+This is mostly useful for printing load notification messages.
+
+
+** The function `eval!' is no longer accessible from the scheme level.
+We can't allow operations which introduce glocs into the scheme level,
+because Guile's type system can't handle these as data. Use `eval' or
+`read-and-eval!' (see below) as replacement.
+
+** The new function read-and-eval! reads an expression from PORT,
+evaluates it, and returns the result. This is more efficient than
+simply calling `read' and `eval', since it is not necessary to make a
+copy of the expression for the evaluator to munge.
+
+Its optional arguments CASE_INSENSITIVE_P and SHARP are interpreted as
+for the `read' function.
+
+
+** The function `int?' has been removed; its definition was identical
+to that of `integer?'.
+
+** The functions `<?', `<?', `<=?', `=?', `>?', and `>=?'. Code should
+use the R4RS names for these functions.
+
+** The function object-properties no longer returns the hash handle;
+it simply returns the object's property list.
+
+** Many functions have been changed to throw errors, instead of
+returning #f on failure. The point of providing exception handling in
+the language is to simplify the logic of user code, but this is less
+useful if Guile's primitives don't throw exceptions.
+
+** The function `fileno' has been renamed from `%fileno'.
+
+** The function primitive-mode->fdes returns #t or #f now, not 1 or 0.
+
+
+* Changes to Guile's C interface:
+
+** The library's initialization procedure has been simplified.
+scm_boot_guile now has the prototype:
+
+void scm_boot_guile (int ARGC,
+ char **ARGV,
+ void (*main_func) (),
+ void *closure);
+
+scm_boot_guile calls MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.
+MAIN_FUNC should do all the work of the program (initializing other
+packages, reading user input, etc.) before returning. When MAIN_FUNC
+returns, call exit (0); this function never returns. If you want some
+other exit value, MAIN_FUNC may call exit itself.
+
+scm_boot_guile arranges for program-arguments to return the strings
+given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should call
+scm_set_program_arguments with the final list, so Scheme code will
+know which arguments have been processed.
+
+scm_boot_guile establishes a catch-all catch handler which prints an
+error message and exits the process. This means that Guile exits in a
+coherent way when system errors occur and the user isn't prepared to
+handle it. If the user doesn't like this behavior, they can establish
+their own universal catcher in MAIN_FUNC to shadow this one.
+
+Why must the caller do all the real work from MAIN_FUNC? The garbage
+collector assumes that all local variables of type SCM will be above
+scm_boot_guile's stack frame on the stack. If you try to manipulate
+SCM values after this function returns, it's the luck of the draw
+whether the GC will be able to find the objects you allocate. So,
+scm_boot_guile function exits, rather than returning, to discourage
+people from making that mistake.
+
+The IN, OUT, and ERR arguments were removed; there are other
+convenient ways to override these when desired.
+
+The RESULT argument was deleted; this function should never return.
+
+The BOOT_CMD argument was deleted; the MAIN_FUNC argument is more
+general.
+
+
+** Guile's header files should no longer conflict with your system's
+header files.
+
+In order to compile code which #included <libguile.h>, previous
+versions of Guile required you to add a directory containing all the
+Guile header files to your #include path. This was a problem, since
+Guile's header files have names which conflict with many systems'
+header files.
+
+Now only <libguile.h> need appear in your #include path; you must
+refer to all Guile's other header files as <libguile/mumble.h>.
+Guile's installation procedure puts libguile.h in $(includedir), and
+the rest in $(includedir)/libguile.
+
+
+** Two new C functions, scm_protect_object and scm_unprotect_object,
+have been added to the Guile library.
+
+scm_protect_object (OBJ) protects OBJ from the garbage collector.
+OBJ will not be freed, even if all other references are dropped,
+until someone does scm_unprotect_object (OBJ). Both functions
+return OBJ.
+
+Note that calls to scm_protect_object do not nest. You can call
+scm_protect_object any number of times on a given object, and the
+next call to scm_unprotect_object will unprotect it completely.
+
+Basically, scm_protect_object and scm_unprotect_object just
+maintain a list of references to things. Since the GC knows about
+this list, all objects it mentions stay alive. scm_protect_object
+adds its argument to the list; scm_unprotect_object remove its
+argument from the list.
+
+
+** scm_eval_0str now returns the value of the last expression
+evaluated.
+
+** The new function scm_read_0str reads an s-expression from a
+null-terminated string, and returns it.
+
+** The new function `scm_stdio_to_port' converts a STDIO file pointer
+to a Scheme port object.
+
+** The new function `scm_set_program_arguments' allows C code to set
+the value teruturned by the Scheme `program-arguments' function.
+
+
+Older changes:
+
+* Guile no longer includes sophisticated Tcl/Tk support.
+
+The old Tcl/Tk support was unsatisfying to us, because it required the
+user to link against the Tcl library, as well as Tk and Guile. The
+interface was also un-lispy, in that it preserved Tcl/Tk's practice of
+referring to widgets by names, rather than exporting widgets to Scheme
+code as a special datatype.
+
+In the Usenix Tk Developer's Workshop held in July 1996, the Tcl/Tk
+maintainers described some very interesting changes in progress to the
+Tcl/Tk internals, which would facilitate clean interfaces between lone
+Tk and other interpreters --- even for garbage-collected languages
+like Scheme. They expected the new Tk to be publicly available in the
+fall of 1996.
+
+Since it seems that Guile might soon have a new, cleaner interface to
+lone Tk, and that the old Guile/Tk glue code would probably need to be
+completely rewritten, we (Jim Blandy and Richard Stallman) have
+decided not to support the old code. We'll spend the time instead on
+a good interface to the newer Tk, as soon as it is available.
+
+Until then, gtcltk-lib provides trivial, low-maintenance functionality.
+
+
+Copyright information:
+
+Copyright (C) 1996,1997 Free Software Foundation, Inc.
+
+ Permission is granted to anyone to make or distribute verbatim copies
+ of this document as received, in any medium, provided that the
+ copyright notice and this permission notice are preserved,
+ thus giving the recipient permission to redistribute in turn.
+
+ Permission is granted to distribute modified versions
+ of this document, or of portions of it,
+ under the above conditions, provided also that they
+ carry prominent notices stating who last changed them.
+
diff --git a/NOTES b/NOTES
new file mode 100644
index 000000000..73262c0ea
--- /dev/null
+++ b/NOTES
@@ -0,0 +1,70 @@
+This is the Guile developer notice-board. -*- change-log -*-
+----------------------------------------------------------------------
+CONTENTS: Notes of various kinds which the Guile developers want to
+share among eachother, e. g., a memo about something which needs
+fixing. Describing a certain problem here means that everyone is free
+to fix it when and as he wishes. (Of course it can sometimes be suitable
+to discuss it first.)
+
+RULES: Entries should have a date and the name of the author. Entries
+should be sufficiently detailed to enable other members of the team to
+understand them, but they need not be comprehensible to people who
+don't spend much time on Guile. This file should not go into
+snapshots or distributions, but is a strictly internal document.
+
+CONVENTIONS: ChangeLog format. (Reverse chronological order.)
+----------------------------------------------------------------------
+
+Sun Mar 9 15:45:14 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * We need to discuss the long-term solution to Guile configuration
+ and customization.
+
+ * Some day when more important stuff (module system, threads, Tk
+ interface etc) has been completed, we should split up SCM's
+ ChangeLog among us, and go through all changes since the birth of
+ Guile. We might find many nice bug fixes and improvements...
+
+ * libguile/gc.c (scm_gc_sweep): The probability of collecting a
+ free cell should be very low (only occurring when a signal has
+ interrupted allocation). Nevertheless, the GC immediately exits
+ when the free cell test is enabled in the sweeper. Where does
+ this free cell come from?
+
+ * libguile/arbiters.c: Remove this file? When we've implemented
+ POSIX thread support, "arbiters" will be superfluous.
+
+Thu Mar 6 00:54:59 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libguile/unif.c: Introduce "fancy printing" for vectors. "Fancy
+ printing" is performed by the printer when the `fancyp' flag is
+ set in the print state (see print.h). One of its effects is that
+ sequences should be printed with maximum `length' objects. (This
+ is currently only used in backtraces and error messages).
+ This works for lists, but not yet for vectors and arrays.
+
+Wed Mar 5 22:56:19 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libguile/struct.c, libguile/struct.h, libguile/gc.c: Structs
+ need reimplementation. Both user interface and representation
+ need to be improved. E. g., the struct part of scm_gc_mark need
+ to be a lot more efficient. We should probably do this redesign
+ when designing(/porting) the object system.
+
+ * libguile/symbols.c (SCM_SYMBOL_HASH): This is slot is currently
+ not used for anything (except that it is used by symbol-hash). I
+ suppose it was originally intended to avoid doing multiple hashing
+ steps when handling symbols.
+
+Mon Mar 3 21:36:58 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libguile/procprop.c: The current implementation of procedure
+ properties of closures uses a special property slot
+ (SCM_PROCPROPS (closure)), but primitive procedures don't have
+ such a slot. Setting or getting source properties for primitive
+ procedures currently involves making fake closures. These are
+ stored in an alist => finding the properties of a primitive
+ procedure is O (n primitive procedures with properties) which is
+ unacceptable.
+
+ \ No newline at end of file
diff --git a/README b/README
new file mode 100644
index 000000000..c44f89d57
--- /dev/null
+++ b/README
@@ -0,0 +1,152 @@
+This is a nightly snapshot of Guile, a portable, embeddable Scheme
+implementation written in C. Guile provides a machine independent
+execution platform that can be linked in as a library when building
+extensible programs.
+
+Please send bug reports to bug-guile@prep.ai.mit.edu.
+
+
+Important Facts About Snapshots ======================================
+
+Please keep in mind that these sources are strictly experimental; they
+will usually not be well-tested, and may not even compile on some
+systems. They may contain interfaces which will change. They will
+usually not be of sufficient quality for use by people not comfortable
+hacking the innards of Guile. Caveat!
+
+However, we're providing them anyway for several reasons. We'd like
+to encourage people to get involved in developing Guile. People
+willing to use the bleeding edge of development can get earlier access
+to new, experimental features. Patches submitted relative to recent
+snapshots will be easier for us to evaluate and install, since the
+patch's original sources will be closer to what we're working with.
+And it allows us to start testing features earlier.
+
+Nightly snapshots of the Guile development sources are available via
+anonymous FTP from ftp.cyclic.com, as /pub/guile/guile-snap.tar.gz.
+
+Via the web, that's: ftp://ftp.cyclic.com/pub/guile/guile-snap.tar.gz
+For getit, that's: ftp.cyclic.com:/pub/guile/guile-snap.tar.gz
+
+
+The latest official Guile release is available via anonymous FTP from
+prep.ai.mit.edu, as /pub/gnu/guile-1.0.tar.gz.
+
+Via the web, that's: ftp://prep.ai.mit.edu/pub/gnu/guile-1.0.tar.gz
+For getit, that's: prep.ai.mit.edu:/pub/gnu/guile-1.0.tar.gz
+
+The mailing list `guile@cygnus.com' carries discussions, questions,
+and often answers, about Guile. To subscribe, send mail to
+guile-request@cygnus.com. Of course, please send bug reports (and
+fixes!) to bug-guile@prep.ai.mit.edu.
+
+
+About This Distribution ==============================================
+
+Building and installing this distribution gives you:
+guile --- a stand-alone interpreter for Guile, usually installed in
+ /usr/local/bin. With no arguments, this is a simple
+ interactive Scheme interpreter. It can also be used as an
+ interpreter for script files; see the NEWS file for details.
+libguile.a --- an object library containing the Guile interpreter,
+ usually installed in /usr/local/lib. You can use Guile in
+ your own programs by linking against this.
+<libguile.h>, <libguile/*.h> --- header files for libguile.a, usually
+ installed in /usr/local/include.
+
+
+Interesting files include:
+- INSTALL, which contains instructions on building and installing Guile.
+- NEWS, which describes user-visible changes since the last release of Guile.
+- COPYING, which describes the terms under which you may redistribute
+ Guile, and explains that there is no warranty.
+
+The Guile source tree is laid out as follows:
+
+doc: Documentation for Guile, in Texinfo form. (At the moment, these
+ manuals are incomplete and are currently being revised.)
+libguile:
+ The Guile Scheme interpreter, packaged as an object library
+ for you to link with your programs.
+guile: An interactive front end for the Guile Scheme interpreter.
+rx: A regular expression matching library, interfaced to Guile.
+ice-9: Guile's module system, initialization code, and other infrastructure.
+lang: A Guile module of tools for writing lexical analyzers and parsers.
+ctax: A Guile module providing a C-like syntax for Scheme.
+gtcltk-lib:
+ Glue code for talking to Tcl/Tk from Guile. The Tcl/Tk
+ developers have big plans for the next major release of Tcl/Tk
+ which will make possible a clean, direct interface between
+ Guile and Tk, so we're providing this very simple-minded
+ interface until that's ready.
+
+This distribution also includes `qt', a cooperative threads package
+from Washington University, which Guile can use. Qt is under a
+separate copyright; see `qt/README' for more details.
+
+
+Hacking It Yourself ==================================================
+
+As distributed, Guile needs only an ANSI C compiler and a Unix system
+to compile. However, Guile's makefiles, configuration scripts, and a
+few other files are automatically generated, not written by hand. If
+you want to make changes to the system (which we encourage!) you will
+find it helpful to have the tools we use to develop Guile. They
+are the following:
+
+Autoconf 2.12 --- a system for automatically generate `configure'
+ scripts from templates which list the non-portable features a
+ program would like to use. Available in
+ "ftp://prep.ai.mit.edu/pub/gnu".
+
+Automake 1.1n --- a system for automatically generating Makefiles that
+ conform to the (rather Byzantine) GNU coding standards. The
+ nice thing is that it takes care of hairy targets like 'make
+ dist' and 'make distclean', and automatically generates
+ Makefile dependencies. Available in
+ "ftp://ftp.cygnus.com/pub/tromey".
+
+libtool 0.9d --- a system for managing the zillion hairy options needed
+ on various systems to produce shared libraries. Available in
+ "ftp://alpha.gnu.ai.mit.edu/gnu".
+
+You are lost in a little maze of automatically generated files, all
+different.
+>
+
+
+Authors And Contributors =============================================
+
+Many people have generously contributed to Guile. However, any errors
+are the responsibility of the primary Guile maintainer, Jim Blandy.
+
+Mikael Djurfeldt designed and implemented:
+* the source-level debugging support (although the debugger's user
+ interface is not yet complete)
+* stack overflow detection,
+* the GDB patches to support debugging mixed Scheme/C code,
+* the original implementation of weak hash tables,
+* the `threads' interface (rewriting Anthony Green's work), and
+* detection of circular references during printing.
+
+Mark Galassi contributed the Guile high-level functions (libgh), and
+wrote the guile-programmer and guile-user manuals. (These are in the
+process of revision.)
+
+Anthony Green wrote the original version of `threads' the interface
+between Guile and qt.
+
+Gary Houston wrote the Unix system call support, including the socket
+support, and did a lot of work on the error handling code.
+
+Tom Lord librarified SCM, yielding Guile. He wrote Guile's operating
+system, Ice-9, and connected Guile to Tcl/Tk and the `rx' regular
+expression matcher.
+
+Aubrey Jaffer seriously tuned performance and added features. He
+designed many hairy but beautiful parts of the tag system and
+evaluator.
+
+George Carrette wrote SIOD, a stand-alone scheme interpreter.
+Although most of this code as been rewritten or replaced over time,
+the garbage collector from SIOD is still an important part of Guile.
diff --git a/RELEASE b/RELEASE
new file mode 100644
index 000000000..a32d11c54
--- /dev/null
+++ b/RELEASE
@@ -0,0 +1,43 @@
+This is a checklist for making Guile releases.
+It's specific to the FSF's development environment; please don't put
+it in the distribution.
+
+1) Verify that Guile builds and runs in your working directory. I
+ hope that we'll eventually have a test suite to make this more
+ concrete, but for the moment, just make sure things seem sane.
+2) Make sure NEWS and the docs are up to date:
+ a) Scan the ChangeLogs for user-visible changes, marked with an asterisk
+ at the left margin.
+ b) Update NEWS and the Texinfo documentation as appropriate.
+ c) Remove the user-visible markers from the log entries once they're
+ documented.
+3) Scan output from `cvs log' to find files that have changed a lot, but
+ do not have up-to-date copyright notices.
+4) Update the version numbers in GUILE-VERSION, and README, to remove the
+ "unreleased" indications. They should be straight numbers, of the form
+ "N.M", not alpha numbers, of the form "N.Ma".
+5) Do a `cvs update -A', to get rid of any sticky tags.
+6) Commit all changes to the CVS repository.
+7) Verify that the disty works, too:
+ a) Make a disty, using 'make dist'.
+ b) Unpack it somewhere else.
+ c) Remove automake and autoconf from your path, or turn off their
+ execute bits, or something. (Users should be able to build disty
+ without installing those tools.)
+ d) Configure, make, and install.
+ e) Test the installed version; don't forget to unset SCHEME_LOAD_PATH.
+ f) If you made any fixes, commit them, and start from a) again
+8) Tag the entire source tree with a tag of the form "release_N_M".
+9) Copy the tar file over to the GNU machines, and ask the appropriate
+ person to put it on prep. At the time of this writing, Daniel Hagerty
+ <hag@ai.mit.edu> has been generous about helping with that.
+10) Send an announcement message to gnu-announce@prep.ai.mit.edu. If I
+ remember correctly, the moderator will delay it until the tar file
+ appears on prep. The announcement text should be mostly taken from
+ Guile's README file.
+11) Tweak the version numbers in GUILE-VERSION, and README to indicate that
+ the sources are snapshot again. Snapshots should have version numbers
+ of the form "N.Ma", where the "a" means "alpha".
+12) Start a new section of the NEWS file.
+13) Send mail to majordomo-owner@cygnus.com updating the message you get
+ when you ask majordomo for "info guile".
diff --git a/TODO b/TODO
new file mode 100644
index 000000000..63ebfb78d
--- /dev/null
+++ b/TODO
@@ -0,0 +1,38 @@
+* Add facilities for debugging Scheme programs.
+
+The low-level debugging support is done, and we are now working on the
+user interface.
+
+* Documentation.
+
+We have a new layout for the reference manual which covers the
+C/Scheme interface, as well as the scheme variants. We also want a
+more thorough tutorial manual, but we haven't sketched that out yet.
+
+
+Desired later on
+
+* Good interface to Tk
+
+* Add a convenient facility for running a pipeline of processes
+with redirections. Gary Houston <ghouston@actrix.gen.nz>
+is working on this.
+
+* Make it possible to link Guile and TK without using libtcl.a, by
+providing Guile-based replacements for the libtcl.a functions that TK
+requires.
+
+* Make ordinary lambda functions work as callbacks for Tk;
+eliminate the need for tcl-lambda.
+
+* Translators for additional languages; in particular, Perl, Python,
+TCL, Emacs Lisp, and Rexx.
+
+* Clean up declarations of C functions to use a PROTO macro
+for conditional prototypes, instead of explicit conditionals.
+
+* A package for time conversions and formatting.
+
+* Make GDB work with Guile
+
+This would permit programmable debugging and a nice integrated GUI.
diff --git a/aclocal.m4 b/aclocal.m4
new file mode 100644
index 000000000..0f2c4a9cd
--- /dev/null
+++ b/aclocal.m4
@@ -0,0 +1,110 @@
+dnl aclocal.m4 generated automatically by aclocal 1.1n
+
+# Do all the work for Automake. This macro actually does too much --
+# some checks are only needed if your package does certain things.
+# But this isn't really a big deal.
+
+# serial 1
+
+dnl Usage:
+dnl AM_INIT_AUTOMAKE(package,version, [no-define])
+
+AC_DEFUN(AM_INIT_AUTOMAKE,
+[AC_REQUIRE([AM_PROG_INSTALL])
+PACKAGE=[$1]
+AC_SUBST(PACKAGE)
+VERSION=[$2]
+AC_SUBST(VERSION)
+ifelse([$3],,
+AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE")
+AC_DEFINE_UNQUOTED(VERSION, "$VERSION"))
+AM_SANITY_CHECK
+AC_ARG_PROGRAM
+dnl FIXME This is truly gross.
+missing_dir=`cd $ac_aux_dir && pwd`
+AM_MISSING_PROG(ACLOCAL, aclocal, $missing_dir)
+AM_MISSING_PROG(AUTOCONF, autoconf, $missing_dir)
+AM_MISSING_PROG(AUTOMAKE, automake, $missing_dir)
+AM_MISSING_PROG(AUTOHEADER, autoheader, $missing_dir)
+AM_MISSING_PROG(MAKEINFO, makeinfo, $missing_dir)
+AC_PROG_MAKE_SET])
+
+
+# serial 1
+
+AC_DEFUN(AM_PROG_INSTALL,
+[AC_REQUIRE([AC_PROG_INSTALL])
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
+AC_SUBST(INSTALL_SCRIPT)dnl
+])
+
+#
+# Check to make sure that the build environment is sane.
+#
+
+AC_DEFUN(AM_SANITY_CHECK,
+[AC_MSG_CHECKING([whether build environment is sane])
+# Just in case
+sleep 1
+echo timestamp > conftestfile
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments. Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+ set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
+ if test "$@" = "X"; then
+ # -L didn't work.
+ set X `ls -t $srcdir/configure conftestfile`
+ fi
+ test "[$]2" = conftestfile
+ )
+then
+ # Ok.
+ :
+else
+ AC_MSG_ERROR([newly created file is older than distributed files!
+Check your system clock])
+fi
+rm -f conftest*
+AC_MSG_RESULT(yes)])
+
+dnl AM_MISSING_PROG(NAME, PROGRAM, DIRECTORY)
+dnl The program must properly implement --version.
+AC_DEFUN(AM_MISSING_PROG,
+[AC_MSG_CHECKING(for working $2)
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if ($2 --version) > /dev/null 2>&1; then
+ $1=$2
+ AC_MSG_RESULT(found)
+else
+ $1="$3/missing $2"
+ AC_MSG_RESULT(missing)
+fi
+AC_SUBST($1)])
+
+# Add --enable-maintainer-mode option to configure.
+# From Jim Meyering
+
+# serial 1
+
+AC_DEFUN(AM_MAINTAINER_MODE,
+[AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles])
+ dnl maintainer-mode is disabled by default
+ AC_ARG_ENABLE(maintainer-mode,
+[ --enable-maintainer-mode enable make rules and dependencies not useful
+ (and sometimes confusing) to the casual installer],
+ USE_MAINTAINER_MODE=$enableval,
+ USE_MAINTAINER_MODE=no)
+ AC_MSG_RESULT($USE_MAINTAINER_MODE)
+ if test $USE_MAINTAINER_MODE = yes; then
+ MAINT=
+ else
+ MAINT='#M#'
+ fi
+ AC_SUBST(MAINT)dnl
+]
+)
+
diff --git a/config.guess b/config.guess
index a3d6a9f1b..a33514f24 100755
--- a/config.guess
+++ b/config.guess
@@ -1,6 +1,6 @@
#! /bin/sh
# Attempt to guess a canonical system name.
-# Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+# Copyright (C) 1992, 93, 94, 95, 96, 1997 Free Software Foundation, Inc.
#
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@@ -14,7 +14,7 @@
#
# 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
@@ -51,30 +51,48 @@ trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15
# Note: order is significant - the case branches are not exclusive.
case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
- alpha:OSF1:V*:*)
- # After 1.2, OSF1 uses "V1.3" for uname -r.
- echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'`
- exit 0 ;;
alpha:OSF1:*:*)
+ # A Vn.n version is a released version.
+ # A Tn.n version is a released field test version.
+ # A Xn.n version is an unreleased experimental baselevel.
# 1.2 uses "1.2" for uname -r.
- echo alpha-dec-osf${UNAME_RELEASE}
- exit 0 ;;
+ echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//'`
+ exit 0 ;;
+ 21064:Windows_NT:50:3)
+ echo alpha-dec-winnt3.5
+ exit 0 ;;
+ Amiga*:UNIX_System_V:4.0:*)
+ echo m68k-cbm-sysv4
+ exit 0;;
amiga:NetBSD:*:*)
echo m68k-cbm-netbsd${UNAME_RELEASE}
exit 0 ;;
+ amiga:OpenBSD:*:*)
+ echo m68k-cbm-openbsd${UNAME_RELEASE}
+ exit 0 ;;
arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
echo arm-acorn-riscix${UNAME_RELEASE}
exit 0;;
- Pyramid*:OSx*:*:*)
+ SR2?01:HI-UX/MPP:*:*)
+ echo hppa1.1-hitachi-hiuxmpp
+ exit 0;;
+ Pyramid*:OSx*:*:*|MIS*:OSx*:*:*)
+ # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.
if test "`(/bin/universe) 2>/dev/null`" = att ; then
echo pyramid-pyramid-sysv3
else
echo pyramid-pyramid-bsd
fi
exit 0 ;;
- sun4*:SunOS:5.*:*)
+ NILE:*:*:dcosx)
+ echo pyramid-pyramid-svr4
+ exit 0 ;;
+ sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
exit 0 ;;
+ i86pc:SunOS:5.*:*)
+ echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit 0 ;;
sun4*:SunOS:6*:*)
# According to config.sub, this is the proper way to canonicalize
# SunOS6. Hard to guess exactly what SunOS6 will be like, but
@@ -93,15 +111,65 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
sun3*:SunOS:*:*)
echo m68k-sun-sunos${UNAME_RELEASE}
exit 0 ;;
+ aushp:SunOS:*:*)
+ echo sparc-auspex-sunos${UNAME_RELEASE}
+ exit 0 ;;
+ atari*:NetBSD:*:*)
+ echo m68k-atari-netbsd${UNAME_RELEASE}
+ exit 0 ;;
+ atari*:OpenBSD:*:*)
+ echo m68k-atari-openbsd${UNAME_RELEASE}
+ exit 0 ;;
+ sun3*:NetBSD:*:*)
+ echo m68k-sun-netbsd${UNAME_RELEASE}
+ exit 0 ;;
+ sun3*:OpenBSD:*:*)
+ echo m68k-sun-openbsd${UNAME_RELEASE}
+ exit 0 ;;
+ mac68k:NetBSD:*:*)
+ echo m68k-apple-netbsd${UNAME_RELEASE}
+ exit 0 ;;
+ mac68k:OpenBSD:*:*)
+ echo m68k-apple-openbsd${UNAME_RELEASE}
+ exit 0 ;;
+ powerpc:machten:*:*)
+ echo powerpc-apple-machten${UNAME_RELEASE}
+ exit 0 ;;
+ RISC*:Mach:*:*)
+ echo mips-dec-mach_bsd4.3
+ exit 0 ;;
RISC*:ULTRIX:*:*)
echo mips-dec-ultrix${UNAME_RELEASE}
exit 0 ;;
VAX*:ULTRIX*:*:*)
echo vax-dec-ultrix${UNAME_RELEASE}
exit 0 ;;
- mips:*:5*:RISCos)
+ mips:*:*:UMIPS | mips:*:*:RISCos)
+ sed 's/^ //' << EOF >dummy.c
+ int main (argc, argv) int argc; char **argv; {
+ #if defined (host_mips) && defined (MIPSEB)
+ #if defined (SYSTYPE_SYSV)
+ printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_SVR4)
+ printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)
+ printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0);
+ #endif
+ #endif
+ exit (-1);
+ }
+EOF
+ ${CC-cc} dummy.c -o dummy \
+ && ./dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \
+ && rm dummy.c dummy && exit 0
+ rm -f dummy.c dummy
echo mips-mips-riscos${UNAME_RELEASE}
exit 0 ;;
+ Night_Hawk:Power_UNIX:*:*)
+ echo powerpc-harris-powerunix
+ exit 0 ;;
m88k:CX/UX:7*:*)
echo m88k-harris-cxux7
exit 0 ;;
@@ -112,12 +180,17 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
echo m88k-motorola-sysv3
exit 0 ;;
AViiON:dgux:*:*)
+ # DG/UX returns AViiON for all architectures
+ UNAME_PROCESSOR=`/usr/bin/uname -p`
+ if [ $UNAME_PROCESSOR = mc88100 -o $UNAME_PROCESSOR = mc88110 ] ; then
if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \
-o ${TARGET_BINARY_INTERFACE}x = x ] ; then
echo m88k-dg-dgux${UNAME_RELEASE}
else
echo m88k-dg-dguxbcs${UNAME_RELEASE}
fi
+ else echo i586-dg-dgux${UNAME_RELEASE}
+ fi
exit 0 ;;
M88*:DolphinOS:*:*) # DolphinOS (SVR3)
echo m88k-dolphin-sysv3
@@ -135,10 +208,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
*:IRIX*:*:*)
echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
exit 0 ;;
- ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
+ ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX '
- i[34]86:AIX:*:*)
+ i?86:AIX:*:*)
echo i386-ibm-aix
exit 0 ;;
*:AIX:2:3)
@@ -169,10 +242,8 @@ EOF
else
IBM_ARCH=powerpc
fi
- if grep bos410 /usr/include/stdio.h >/dev/null 2>&1; then
- IBM_REV=4.1
- elif grep bos411 /usr/include/stdio.h >/dev/null 2>&1; then
- IBM_REV=4.1.1
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
else
IBM_REV=4.${UNAME_RELEASE}
fi
@@ -185,7 +256,7 @@ EOF
echo romp-ibm-bsd4.4
exit 0 ;;
ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC NetBSD and
- echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
+ echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
exit 0 ;; # report: romp-ibm BSD 4.3
*:BOSX:*:*)
echo rs6000-bull-bosx
@@ -203,7 +274,7 @@ EOF
case "${UNAME_MACHINE}" in
9000/31? ) HP_ARCH=m68000 ;;
9000/[34]?? ) HP_ARCH=m68k ;;
- 9000/7?? | 9000/8?7 ) HP_ARCH=hppa1.1 ;;
+ 9000/7?? | 9000/8?[1679] ) HP_ARCH=hppa1.1 ;;
9000/8?? ) HP_ARCH=hppa1.0 ;;
esac
HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
@@ -239,18 +310,28 @@ EOF
rm -f dummy.c dummy
echo unknown-hitachi-hiuxwe2
exit 0 ;;
- 9000/7??:4.3bsd:*:* | 9000/8?7:4.3bsd:*:* )
+ 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
echo hppa1.1-hp-bsd
exit 0 ;;
9000/8??:4.3bsd:*:*)
echo hppa1.0-hp-bsd
exit 0 ;;
- hp7??:OSF1:*:* | hp8?7:OSF1:*:* )
+ hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
echo hppa1.1-hp-osf
exit 0 ;;
hp8??:OSF1:*:*)
echo hppa1.0-hp-osf
exit 0 ;;
+ i?86:OSF1:*:*)
+ if [ -x /usr/sbin/sysversion ] ; then
+ echo ${UNAME_MACHINE}-unknown-osf1mk
+ else
+ echo ${UNAME_MACHINE}-unknown-osf1
+ fi
+ exit 0 ;;
+ parisc*:Lites*:*:*)
+ echo hppa1.1-hp-lites
+ exit 0 ;;
C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
echo c1-convex-bsd
exit 0 ;;
@@ -269,20 +350,39 @@ EOF
C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
echo c4-convex-bsd
exit 0 ;;
- CRAY*X-MP:UNICOS:*:*)
+ CRAY*X-MP:*:*:*)
echo xmp-cray-unicos
exit 0 ;;
- CRAY*Y-MP:UNICOS:*:*)
- echo ymp-cray-unicos
- exit 0 ;;
- CRAY-2:UNICOS:*:*)
+ CRAY*Y-MP:*:*:*)
+ echo ymp-cray-unicos${UNAME_RELEASE}
+ exit 0 ;;
+ CRAY*[A-Z]90:*:*:*)
+ echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
+ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
+ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/
+ exit 0 ;;
+ CRAY*TS:*:*:*)
+ echo t90-cray-unicos${UNAME_RELEASE}
+ exit 0 ;;
+ CRAY-2:*:*:*)
echo cray2-cray-unicos
exit 0 ;;
+ F300:UNIX_System_V:*:*)
+ FUJITSU_SYS=`uname -p | tr [A-Z] [a-z] | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+ echo "f300-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+ exit 0 ;;
+ F301:UNIX_System_V:*:*)
+ echo f301-fujitsu-uxpv`echo $UNAME_RELEASE | sed 's/ .*//'`
+ exit 0 ;;
hp3[0-9][05]:NetBSD:*:*)
echo m68k-hp-netbsd${UNAME_RELEASE}
exit 0 ;;
- i[34]86:BSD/386:*:* | *:BSD/OS:*:*)
- echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
+ hp3[0-9][05]:OpenBSD:*:*)
+ echo m68k-hp-openbsd${UNAME_RELEASE}
+ exit 0 ;;
+ i?86:BSD/386:*:* | *:BSD/OS:*:*)
+ echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
exit 0 ;;
*:FreeBSD:*:*)
echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
@@ -290,38 +390,108 @@ EOF
*:NetBSD:*:*)
echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
exit 0 ;;
+ *:OpenBSD:*:*)
+ echo ${UNAME_MACHINE}-unknown-openbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
+ exit 0 ;;
+ i*:CYGWIN*:*)
+ echo i386-pc-cygwin32
+ exit 0 ;;
+ p*:CYGWIN*:*)
+ echo powerpcle-unknown-cygwin32
+ exit 0 ;;
+ prep*:SunOS:5.*:*)
+ echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit 0 ;;
*:GNU:*:*)
- echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
+ echo `echo ${UNAME_MACHINE}|sed -e 's,-.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
exit 0 ;;
*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux
- exit 0 ;;
+ # The BFD linker knows what the default object file format is, so
+ # first see if it will tell us.
+ ld_help_string=`ld --help 2>&1`
+ if echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: elf_i.86"; then
+ echo "${UNAME_MACHINE}-pc-linux-gnu" ; exit 0
+ elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: i.86linux"; then
+ echo "${UNAME_MACHINE}-pc-linux-gnuaout" ; exit 0
+ elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: i.86coff"; then
+ echo "${UNAME_MACHINE}-pc-linux-gnucoff" ; exit 0
+ elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: m68kelf"; then
+ echo "${UNAME_MACHINE}-unknown-linux-gnu" ; exit 0
+ elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: m68klinux"; then
+ echo "${UNAME_MACHINE}-unknown-linux-gnuaout" ; exit 0
+ elif echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations: elf32ppc"; then
+ echo "powerpc-unknown-linux-gnu" ; exit 0
+ elif test "${UNAME_MACHINE}" = "alpha" ; then
+ echo alpha-unknown-linux-gnu ; exit 0
+ elif test "${UNAME_MACHINE}" = "sparc" ; then
+ echo sparc-unknown-linux-gnu ; exit 0
+ elif test "${UNAME_MACHINE}" = "mips" ; then
+ cat >dummy.c <<EOF
+main(argc, argv)
+int argc;
+char *argv[];
+{
+#ifdef __MIPSEB__
+ printf ("%s-unknown-linux-gnu\n", argv[1]);
+#endif
+#ifdef __MIPSEL__
+ printf ("%sel-unknown-linux-gnu\n", argv[1]);
+#endif
+ return 0;
+}
+EOF
+ ${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0
+ rm -f dummy.c dummy
+ else
+ # Either a pre-BFD a.out linker (linux-gnuoldld) or one that does not give us
+ # useful --help. Gcc wants to distinguish between linux-gnuoldld and linux-gnuaout.
+ test ! -d /usr/lib/ldscripts/. \
+ && echo "${UNAME_MACHINE}-pc-linux-gnuoldld" && exit 0
+ # Determine whether the default compiler is a.out or elf
+ cat >dummy.c <<EOF
+main(argc, argv)
+int argc;
+char *argv[];
+{
+#ifdef __ELF__
+ printf ("%s-pc-linux-gnu\n", argv[1]);
+#else
+ printf ("%s-pc-linux-gnuaout\n", argv[1]);
+#endif
+ return 0;
+}
+EOF
+ ${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0
+ rm -f dummy.c dummy
+ fi ;;
# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions
# are messed up and put the nodename in both sysname and nodename.
- i[34]86:DYNIX/ptx:4*:*)
+ i?86:DYNIX/ptx:4*:*)
echo i386-sequent-sysv4
exit 0 ;;
- i[34]86:*:4.*:* | i[34]86:SYSTEM_V:4.*:*)
+ i?86:*:4.*:* | i?86:SYSTEM_V:4.*:*)
if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE}
else
- echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}
+ echo ${UNAME_MACHINE}-pc-sysv${UNAME_RELEASE}
fi
exit 0 ;;
- i[34]86:*:3.2:*)
+ i?86:*:3.2:*)
if test -f /usr/options/cb.name; then
UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
- echo ${UNAME_MACHINE}-unknown-isc$UNAME_REL
+ echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
elif /bin/uname -X 2>/dev/null >/dev/null ; then
UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')`
(/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486
- echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL
+ (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \
+ && UNAME_MACHINE=i586
+ echo ${UNAME_MACHINE}-pc-sco$UNAME_REL
else
- echo ${UNAME_MACHINE}-unknown-sysv32
+ echo ${UNAME_MACHINE}-pc-sysv32
fi
exit 0 ;;
Intel:Mach:3*:*)
- echo i386-unknown-mach3
+ echo i386-pc-mach3
exit 0 ;;
paragon:*:*:*)
echo i860-intel-osf1
@@ -337,28 +507,36 @@ EOF
# "miniframe"
echo m68010-convergent-sysv
exit 0 ;;
- M680[234]0:*:R3V[567]*:*)
+ M68*:*:R3V[567]*:*)
test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;;
- 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0)
- uname -p 2>/dev/null | grep 86 >/dev/null \
- && echo i486-ncr-sysv4.3 && exit 0 ;;
+ 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 4850:*:4.0:3.0)
+ OS_REL=''
+ test -r /etc/.relid \
+ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && echo i486-ncr-sysv4.3${OS_REL} && exit 0
+ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+ && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;;
3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
- uname -p 2>/dev/null | grep 86 >/dev/null \
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
&& echo i486-ncr-sysv4 && exit 0 ;;
- m680[234]0:LynxOS:2.2*:*)
- echo m68k-lynx-lynxos${UNAME_RELEASE}
+ m68*:LynxOS:2.*:*)
+ echo m68k-unknown-lynxos${UNAME_RELEASE}
exit 0 ;;
mc68030:UNIX_System_V:4.*:*)
echo m68k-atari-sysv4
exit 0 ;;
- i[34]86:LynxOS:2.2*:*)
- echo i386-lynx-lynxos${UNAME_RELEASE}
+ i?86:LynxOS:2.*:*)
+ echo i386-unknown-lynxos${UNAME_RELEASE}
+ exit 0 ;;
+ TSUNAMI:LynxOS:2.*:*)
+ echo sparc-unknown-lynxos${UNAME_RELEASE}
exit 0 ;;
- TSUNAMI:LynxOS:2.2*:*)
- echo sparc-lynx-lynxos${UNAME_RELEASE}
+ rs6000:LynxOS:2.*:* | PowerPC:LynxOS:2.*:*)
+ echo rs6000-unknown-lynxos${UNAME_RELEASE}
exit 0 ;;
- rs6000:LynxOS:2.2*:*)
- echo rs6000-lynx-lynxos${UNAME_RELEASE}
+ SM[BE]S:UNIX_SV:*:*)
+ echo mips-dde-sysv${UNAME_RELEASE}
exit 0 ;;
RM*:SINIX-*:*:*)
echo mips-sni-sysv4
@@ -371,12 +549,39 @@ EOF
echo ns32k-sni-sysv
fi
exit 0 ;;
+ PENTIUM:CPunix:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+ # says <Richard.M.Bartel@ccMail.Census.GOV>
+ echo i586-unisys-sysv4
+ exit 0 ;;
+ *:UNIX_System_V:4*:FTX*)
+ # From Gerald Hewes <hewes@openmarket.com>.
+ # How about differentiating between stratus architectures? -djm
+ echo hppa1.1-stratus-sysv4
+ exit 0 ;;
+ *:*:*:FTX*)
+ # From seanf@swdc.stratus.com.
+ echo i860-stratus-sysv4
+ exit 0 ;;
+ mc68*:A/UX:*:*)
+ echo m68k-apple-aux${UNAME_RELEASE}
+ exit 0 ;;
+ R3000:*System_V*:*:* | R4000:UNIX_SYSV:*:*)
+ if [ -d /usr/nec ]; then
+ echo mips-nec-sysv${UNAME_RELEASE}
+ else
+ echo mips-unknown-sysv${UNAME_RELEASE}
+ fi
+ exit 0 ;;
esac
#echo '(No uname command or uname output not recognized.)' 1>&2
#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2
cat >dummy.c <<EOF
+#ifdef _SEQUENT_
+# include <sys/types.h>
+# include <sys/utsname.h>
+#endif
main ()
{
#if defined (sony)
@@ -410,7 +615,7 @@ main ()
#endif
int version;
version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
- printf ("%s-next-nextstep%s\n", __ARCHITECTURE__, version==2 ? "2" : "3");
+ printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
exit (0);
#endif
@@ -427,7 +632,7 @@ main ()
#endif
#if defined (__386BSD__)
- printf ("i386-unknown-bsd\n"); exit (0);
+ printf ("i386-pc-bsd\n"); exit (0);
#endif
#if defined (sequent)
@@ -440,7 +645,18 @@ main ()
#endif
#if defined (_SEQUENT_)
- printf ("i386-sequent-ptx\n"); exit (0);
+ struct utsname un;
+
+ uname(&un);
+
+ if (strncmp(un.version, "V2", 2) == 0) {
+ printf ("i386-sequent-ptx2\n"); exit (0);
+ }
+ if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
+ printf ("i386-sequent-ptx1\n"); exit (0);
+ }
+ printf ("i386-sequent-ptx\n"); exit (0);
+
#endif
#if defined (vax)
diff --git a/config.sub b/config.sub
index 5641cc1ce..cd3425354 100755
--- a/config.sub
+++ b/config.sub
@@ -1,9 +1,9 @@
#! /bin/sh
# Configuration validation subroutine script, version 1.1.
-# Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+# Copyright (C) 1991, 92, 93, 94, 95, 1996 Free Software Foundation, Inc.
# This file is (in principle) common to ALL GNU software.
# The presence of a machine in this file suggests that SOME GNU software
-# can handle that machine. It does not imply ALL GNU software can.
+# can handle that machine. It does not imply ALL GNU software can.
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -17,7 +17,8 @@
#
# 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+# Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
@@ -40,6 +41,8 @@
# The goal of this file is to map all the various variations of a given
# machine specification into a single specification in the form:
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
+# or in some cases, the newer four-part form:
+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
# It is wrong to echo any other type of specification.
if [ x$1 = x ]
@@ -61,11 +64,21 @@ case $1 in
;;
esac
-# Separate what the user gave into CPU-COMPANY and OS (if any).
-basic_machine=`echo $1 | sed 's/-[^-]*$//'`
-if [ $basic_machine != $1 ]
-then os=`echo $1 | sed 's/.*-/-/'`
-else os=; fi
+# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
+# Here we must recognize all the valid KERNEL-OS combinations.
+maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
+case $maybe_os in
+ linux-gnu*)
+ os=-$maybe_os
+ basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
+ ;;
+ *)
+ basic_machine=`echo $1 | sed 's/-[^-]*$//'`
+ if [ $basic_machine != $1 ]
+ then os=`echo $1 | sed 's/.*-/-/'`
+ else os=; fi
+ ;;
+esac
### Let's recognize common machines as not being operating systems so
### that things like config.sub decstation-3100 work. We also
@@ -80,38 +93,43 @@ case $os in
-unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
-convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
-c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
- -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp )
+ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
+ -apple)
os=
basic_machine=$1
;;
-hiux*)
os=-hiuxwe2
;;
+ -sco5)
+ os=sco3.2v5
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
-sco4)
os=-sco3.2v4
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco3.2.[4-9]*)
os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco3.2v[4-9]*)
# Don't forget version if it is 3.2v4 or newer.
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco*)
os=-sco3.2v2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-isc)
os=-isc2.2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-clix*)
basic_machine=clipper-intergraph
;;
-isc*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-lynx*)
os=-lynxos
@@ -122,34 +140,44 @@ case $os in
-windowsnt*)
os=`echo $os | sed -e 's/windowsnt/winnt/'`
;;
+ -psos*)
+ os=-psos
+ ;;
esac
# Decode aliases for certain CPU-COMPANY combinations.
case $basic_machine in
# Recognize the basic CPU types without company name.
# Some are omitted here because they have special meanings below.
- tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm | pyramid \
- | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \
- | alpha | we32k | ns16k | clipper | sparclite | i370 | sh \
- | powerpc | sparc64 | 1750a | dsp16xx | mips64 | mipsel \
+ tahoe | i860 | m68k | m68000 | m88k | ns32k | arm \
+ | arme[lb] | pyramid \
+ | tron | a29k | 580 | i960 | h8300 | hppa | hppa1.0 | hppa1.1 \
+ | alpha | we32k | ns16k | clipper | i370 | sh \
+ | powerpc | powerpcle | 1750a | dsp16xx | mips64 | mipsel \
| pdp11 | mips64el | mips64orion | mips64orionel \
- | sparc)
+ | sparc | sparclet | sparclite | sparc64)
basic_machine=$basic_machine-unknown
;;
+ # We use `pc' rather than `unknown'
+ # because (1) that's what they normally are, and
+ # (2) the word "unknown" tends to confuse beginning users.
+ i[3456]86)
+ basic_machine=$basic_machine-pc
+ ;;
# Object if more than one company name word.
*-*-*)
echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
exit 1
;;
# Recognize the basic CPU types with company name.
- vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \
+ vax-* | tahoe-* | i[3456]86-* | i860-* | m68k-* | m68000-* | m88k-* \
| sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \
- | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \
+ | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* | power-* \
| none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \
- | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \
+ | hppa-* | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \
| pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \
- | pdp11-* | sh-* | powerpc-* | sparc64-* | mips64-* | mipsel-* \
- | mips64el-* | mips64orion-* | mips64orionel-*)
+ | pdp11-* | sh-* | powerpc-* | powerpcle-* | sparc64-* | mips64-* | mipsel-* \
+ | mips64el-* | mips64orion-* | mips64orionel-* | f301-*)
;;
# Recognize the various machine names and aliases which stand
# for a CPU type and a company and sometimes even an OS.
@@ -188,6 +216,10 @@ case $basic_machine in
basic_machine=m68k-apollo
os=-sysv
;;
+ aux)
+ basic_machine=m68k-apple
+ os=-aux
+ ;;
balance)
basic_machine=ns32k-sequent
os=-dynix
@@ -220,6 +252,10 @@ case $basic_machine in
basic_machine=cray2-cray
os=-unicos
;;
+ [ctj]90-cray)
+ basic_machine=c90-cray
+ os=-unicos
+ ;;
crds | unos)
basic_machine=m68k-crds
;;
@@ -301,25 +337,28 @@ case $basic_machine in
hp9k8[0-9][0-9] | hp8[0-9][0-9])
basic_machine=hppa1.0-hp
;;
+ hppa-next)
+ os=-nextstep3
+ ;;
i370-ibm* | ibm*)
basic_machine=i370-ibm
os=-mvs
;;
# I'm not sure what "Sysv32" means. Should this be sysv3.2?
- i[345]86v32)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
+ i[3456]86v32)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv32
;;
- i[345]86v4*)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
+ i[3456]86v4*)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv4
;;
- i[345]86v)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
+ i[3456]86v)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv
;;
- i[345]86sol2)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
+ i[3456]86sol2)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-solaris2
;;
iris | iris4d)
@@ -350,6 +389,14 @@ case $basic_machine in
miniframe)
basic_machine=m68000-convergent
;;
+ mipsel*-linux*)
+ basic_machine=mipsel-unknown
+ os=-linux
+ ;;
+ mips*-linux*)
+ basic_machine=mips-unknown
+ os=-linux
+ ;;
mips3*-*)
basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
;;
@@ -417,14 +464,41 @@ case $basic_machine in
pc532 | pc532-*)
basic_machine=ns32k-pc532
;;
- pentium-*)
- # We will change tis to say i586 once there has been
- # time for various packages to start to recognize that.
- basic_machine=i486-`echo $basic_machine | sed 's/^[^-]*-//'`
+ pentium | p5)
+ basic_machine=i586-intel
+ ;;
+ pentiumpro | p6)
+ basic_machine=i686-intel
+ ;;
+ pentium-* | p5-*)
+ basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentiumpro-* | p6-*)
+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ k5)
+ # We don't have specific support for AMD's K5 yet, so just call it a Pentium
+ basic_machine=i586-amd
+ ;;
+ nexen)
+ # We don't have specific support for Nexgen yet, so just call it a Pentium
+ basic_machine=i586-nexgen
;;
pn)
basic_machine=pn-gould
;;
+ power) basic_machine=rs6000-ibm
+ ;;
+ ppc) basic_machine=powerpc-unknown
+ ;;
+ ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppcle | powerpclittle | ppc-le | powerpc-little)
+ basic_machine=powerpcle-unknown
+ ;;
+ ppcle-* | powerpclittle-*)
+ basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
ps2)
basic_machine=i386-ibm
;;
@@ -511,6 +585,9 @@ case $basic_machine in
basic_machine=vax-dec
os=-vms
;;
+ vpp*|vx|vx-*)
+ basic_machine=f301-fujitsu
+ ;;
vxworks960)
basic_machine=i960-wrs
os=-vxworks
@@ -519,6 +596,10 @@ case $basic_machine in
basic_machine=m68k-wrs
os=-vxworks
;;
+ vxworks29k)
+ basic_machine=a29k-wrs
+ os=-vxworks
+ ;;
xmp)
basic_machine=xmp-cray
os=-unicos
@@ -534,7 +615,11 @@ case $basic_machine in
# Here we handle the default manufacturer of certain CPU types. It is in
# some cases the only manufacturer, in others, it is the most popular.
mips)
- basic_machine=mips-mips
+ if [ x$os = x-linux ]; then
+ basic_machine=mips-unknown
+ else
+ basic_machine=mips-mips
+ fi
;;
romp)
basic_machine=romp-ibm
@@ -586,6 +671,8 @@ esac
if [ x"$os" != x"" ]
then
case $os in
+ # First match some system type aliases
+ # that might get confused with valid system types.
# -solaris* is a basic system type, with this one exception.
-solaris1 | -solaris1.*)
os=`echo $os | sed -e 's|solaris1|sunos4|'`
@@ -597,21 +684,28 @@ case $os in
os=-sysv4
;;
-gnu/linux*)
- os=`echo $os | sed -e 's|gnu/linux|linux|'`
+ os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
;;
# First accept the basic system types.
# The portable systems comes first.
- # Each alternative must end in a *, to match a version number.
+ # Each alternative MUST END IN A *, to match a version number.
# -sysv* is not here because it comes later, after sysvr4.
-gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
- | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \
+ | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
| -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
- | -amigados* | -msdos* | -newsos* | -unicos* | -aos* \
- | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \
- | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \
- | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \
+ | -amigados* | -msdos* | -newsos* | -unicos* | -aof* | -aos* \
+ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
+ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
+ | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \
| -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \
- | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta | -udi | -eabi)
+ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
+ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
+ | -cygwin32* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
+ | -linux-gnu* | -uxpv*)
+ # Remember, each alternative MUST END IN *, to match a version number.
+ ;;
+ -linux*)
+ os=`echo $os | sed -e 's|linux|linux-gnu|'`
;;
-sunos5*)
os=`echo $os | sed -e 's|sunos5|solaris2|'`
@@ -637,6 +731,9 @@ case $os in
-ctix* | -uts*)
os=-sysv
;;
+ -ns2 )
+ os=-nextstep2
+ ;;
# Preserve the version number of sinix5.
-sinix5.*)
os=`echo $os | sed -e 's|sinix|sysv|'`
@@ -690,6 +787,9 @@ case $basic_machine in
*-acorn)
os=-riscix1.2
;;
+ arm*-semi)
+ os=-aout
+ ;;
pdp11-*)
os=-none
;;
@@ -741,6 +841,9 @@ case $basic_machine in
m88k-omron*)
os=-luna
;;
+ *-next )
+ os=-nextstep
+ ;;
*-sequent)
os=-ptx
;;
@@ -774,6 +877,9 @@ case $basic_machine in
*-masscomp)
os=-rtu
;;
+ f301-fujitsu)
+ os=-uxpv
+ ;;
*)
os=-none
;;
@@ -792,9 +898,6 @@ case $basic_machine in
-sunos*)
vendor=sun
;;
- -lynxos*)
- vendor=lynx
- ;;
-aix*)
vendor=ibm
;;
@@ -822,9 +925,12 @@ case $basic_machine in
-ptx*)
vendor=sequent
;;
- -vxworks*)
+ -vxsim* | -vxworks*)
vendor=wrs
;;
+ -aux*)
+ vendor=apple
+ ;;
esac
basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
;;
diff --git a/configure b/configure
index 098617faf..22998ac41 100755
--- a/configure
+++ b/configure
@@ -1,7 +1,7 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.9
+# Generated automatically using autoconf version 2.12
# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
#
# This configure script is free software; the Free Software Foundation
@@ -11,6 +11,9 @@
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
+ac_help="$ac_help
+ --enable-maintainer-mode enable make rules and dependencies not useful
+ (and sometimes confusing) to the casual installer"
# Initialize some variables set by options.
# The variables have the same names as the options, with
@@ -49,6 +52,8 @@ mandir='${prefix}/man'
# Initialize some other variables.
subdirs=
MFLAGS= MAKEFLAGS=
+# Maximum number of lines to put in a shell here document.
+ac_max_here_lines=12
ac_prev=
for ac_option
@@ -330,7 +335,7 @@ EOF
verbose=yes ;;
-version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.9"
+ echo "configure generated by autoconf version 2.12"
exit 0 ;;
-with-* | --with-*)
@@ -432,11 +437,14 @@ do
done
# NLS nuisances.
-# Only set LANG and LC_ALL to C if already set.
-# These must not be set unconditionally because not all systems understand
-# e.g. LANG=C (notably SCO).
-if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+# Only set these to C if already set. These must not be set unconditionally
+# because not all systems understand e.g. LANG=C (notably SCO).
+# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
+# Non-C LC_CTYPE values break the ctype check.
if test "${LANG+set}" = set; then LANG=C; export LANG; fi
+if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
+if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -rf conftest* confdefs.h
@@ -498,6 +506,7 @@ ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
# Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
@@ -512,10 +521,7 @@ else
fi
-
-all_subdirs=`cat $srcdir/*/PLUGIN/REQ $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo`
-req_subdirs=`cat $srcdir/*/PLUGIN/REQ /dev/null | tsort | xargs echo`
-opt_subdirs=`cat $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo`
+. $srcdir/GUILE-VERSION
ac_aux_dir=
for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
if test -f $ac_dir/install-sh; then
@@ -535,50 +541,255 @@ ac_config_guess=$ac_aux_dir/config.guess
ac_config_sub=$ac_aux_dir/config.sub
ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
+# Find a good install program. We prefer a C program (faster),
+# so one script is as good as another. But avoid the broken or
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# ./install, which can be erroneously created by make from ./install.sh.
+echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
+echo "configure:556: checking for a BSD compatible install" >&5
+if test -z "$INSTALL"; then
+if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:"
+ for ac_dir in $PATH; do
+ # Account for people who put trailing slashes in PATH elements.
+ case "$ac_dir/" in
+ /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
+ *)
+ # OSF1 and SCO ODT 3.0 have their own names for install.
+ for ac_prog in ginstall installbsd scoinst install; do
+ if test -f $ac_dir/$ac_prog; then
+ if test $ac_prog = install &&
+ grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
+ # AIX install. It has an incompatible calling convention.
+ # OSF/1 installbsd also uses dspmsg, but is usable.
+ :
+ else
+ ac_cv_path_install="$ac_dir/$ac_prog -c"
+ break 2
+ fi
+ fi
+ done
+ ;;
+ esac
+ done
+ IFS="$ac_save_IFS"
+
+fi
+ if test "${ac_cv_path_install+set}" = set; then
+ INSTALL="$ac_cv_path_install"
+ else
+ # As a last resort, use the slow shell script. We don't cache a
+ # path for INSTALL within a source directory, because that will
+ # break other packages using the cache if that directory is
+ # removed, or if the path is relative.
+ INSTALL="$ac_install_sh"
+ fi
+fi
+echo "$ac_t""$INSTALL" 1>&6
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+
+
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
+
+
+PACKAGE=$PACKAGE
+
+VERSION=$VERSION
+
+cat >> confdefs.h <<EOF
+#define PACKAGE "$PACKAGE"
+EOF
+
+cat >> confdefs.h <<EOF
+#define VERSION "$VERSION"
+EOF
+
+echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6
+echo "configure:622: checking whether build environment is sane" >&5
+# Just in case
+sleep 1
+echo timestamp > conftestfile
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments. Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+ set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
+ if test "" = "X"; then
+ # -L didn't work.
+ set X `ls -t $srcdir/configure conftestfile`
+ fi
+ test "$2" = conftestfile
+ )
+then
+ # Ok.
+ :
+else
+ { echo "configure: error: newly created file is older than distributed files!
+Check your system clock" 1>&2; exit 1; }
+fi
+rm -f conftest*
+echo "$ac_t""yes" 1>&6
+if test "$program_transform_name" = s,x,x,; then
+ program_transform_name=
+else
+ # Double any \ or $. echo might interpret backslashes.
+ cat <<\EOF_SED > conftestsed
+s,\\,\\\\,g; s,\$,$$,g
+EOF_SED
+ program_transform_name="`echo $program_transform_name|sed -f conftestsed`"
+ rm -f conftestsed
+fi
+test "$program_prefix" != NONE &&
+ program_transform_name="s,^,${program_prefix},; $program_transform_name"
+# Use a double $ so make ignores it.
+test "$program_suffix" != NONE &&
+ program_transform_name="s,\$\$,${program_suffix},; $program_transform_name"
+
+# sed with no file args requires a program.
+test "$program_transform_name" = "" && program_transform_name="s,x,x,"
+
+missing_dir=`cd $ac_aux_dir && pwd`
+echo $ac_n "checking for working aclocal""... $ac_c" 1>&6
+echo "configure:669: checking for working aclocal" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (aclocal --version) > /dev/null 2>&1; then
+ ACLOCAL=aclocal
+ echo "$ac_t""found" 1>&6
+else
+ ACLOCAL="$missing_dir/missing aclocal"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working autoconf""... $ac_c" 1>&6
+echo "configure:681: checking for working autoconf" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (autoconf --version) > /dev/null 2>&1; then
+ AUTOCONF=autoconf
+ echo "$ac_t""found" 1>&6
+else
+ AUTOCONF="$missing_dir/missing autoconf"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working automake""... $ac_c" 1>&6
+echo "configure:693: checking for working automake" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (automake --version) > /dev/null 2>&1; then
+ AUTOMAKE=automake
+ echo "$ac_t""found" 1>&6
+else
+ AUTOMAKE="$missing_dir/missing automake"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working autoheader""... $ac_c" 1>&6
+echo "configure:705: checking for working autoheader" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (autoheader --version) > /dev/null 2>&1; then
+ AUTOHEADER=autoheader
+ echo "$ac_t""found" 1>&6
+else
+ AUTOHEADER="$missing_dir/missing autoheader"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working makeinfo""... $ac_c" 1>&6
+echo "configure:717: checking for working makeinfo" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (makeinfo --version) > /dev/null 2>&1; then
+ MAKEINFO=makeinfo
+ echo "$ac_t""found" 1>&6
+else
+ MAKEINFO="$missing_dir/missing makeinfo"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
+echo "configure:729: checking whether ${MAKE-make} sets \${MAKE}" >&5
+set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftestmake <<\EOF
+all:
+ @echo 'ac_maketemp="${MAKE}"'
+EOF
+# GNU make sometimes prints "make[1]: Entering...", which would confuse us.
+eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=`
+if test -n "$ac_maketemp"; then
+ eval ac_cv_prog_make_${ac_make}_set=yes
+else
+ eval ac_cv_prog_make_${ac_make}_set=no
+fi
+rm -f conftestmake
+fi
+if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ SET_MAKE=
+else
+ echo "$ac_t""no" 1>&6
+ SET_MAKE="MAKE=${MAKE-make}"
+fi
+
+echo $ac_n "checking whether to enable maintainer-specific portions of Makefiles""... $ac_c" 1>&6
+echo "configure:756: checking whether to enable maintainer-specific portions of Makefiles" >&5
+ # Check whether --enable-maintainer-mode or --disable-maintainer-mode was given.
+if test "${enable_maintainer_mode+set}" = set; then
+ enableval="$enable_maintainer_mode"
+ USE_MAINTAINER_MODE=$enableval
+else
+ USE_MAINTAINER_MODE=no
+fi
+
+ echo "$ac_t""$USE_MAINTAINER_MODE" 1>&6
+ if test $USE_MAINTAINER_MODE = yes; then
+ MAINT=
+ else
+ MAINT='#M#'
+ fi
+
+
+
+all_subdirs=`cat $srcdir/*/PLUGIN/REQ $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo`
+req_subdirs=`cat $srcdir/*/PLUGIN/REQ /dev/null | tsort | xargs echo`
+opt_subdirs=`cat $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo`
+
subdirs="$all_subdirs"
-existingdirs=
for d in $all_subdirs; do
if test -d $srcdir/$d ; then
existingdirs="$existingdirs $d"
- if test "x$verbose" = xyes; then
- if test -f $srcdir/$d/PLUGIN/greet ; then
- cat $srcdir/$d/PLUGIN/greet
- else
- echo ===
- echo === Configuring plug-in component $d
- echo ===
- fi
- fi
+ test -n "$silent" || echo Configuring plug-in component $d
fi
done
for d in $req_subdirs; do
- if test ! -d $srcdir/$d ; then
- echo "*******"
- echo "*******"
- echo "**\+/**"
- echo "**=*=**" ERROR: Missing required package: $d
- echo "**/+\**"
- echo "*******"
- echo "*******"
- exit 1
- fi
+ test -d $srcdir/$d || {
+ echo ERROR: Missing required package: $d 1>&2
+ exit 1
+ }
done
-if test "x$verbose" = xyes; then
- for d in $opt_subdirs; do
- if test ! -d $srcdir/$d ; then
- echo "*****"
- echo "*===*"
- echo "*=*=*" WARNING: Missing suggested package: $d
- echo "*===*"
- echo "*****"
- fi
- done
-fi
-
-
trap '' 1 2 15
cat > confcache <<\EOF
@@ -597,11 +808,25 @@ cat > confcache <<\EOF
# --recheck option to rerun configure.
#
EOF
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, don't put newlines in cache variables' values.
# Ultrix sh set writes to stderr and can't be redirected directly,
# and sets the high bit in the cache file unless we assign to the vars.
(set) 2>&1 |
- sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \
- >> confcache
+ case `(ac_space=' '; set) 2>&1` in
+ *ac_space=\ *)
+ # `set' does not quote correctly, so add quotes (double-quote substitution
+ # turns \\\\ into \\, and sed turns \\ into \).
+ sed -n \
+ -e "s/'/'\\\\''/g" \
+ -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
+ ;;
+ *)
+ # `set' quotes correctly as required by POSIX, so do not add quotes.
+ sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
+ ;;
+ esac >> confcache
if cmp -s $cache_file confcache; then
:
else
@@ -668,7 +893,7 @@ do
echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
-version | --version | --versio | --versi | --vers | --ver | --ve | --v)
- echo "$CONFIG_STATUS generated by autoconf version 2.9"
+ echo "$CONFIG_STATUS generated by autoconf version 2.12"
exit 0 ;;
-help | --help | --hel | --he | --h)
echo "\$ac_cs_usage"; exit 0 ;;
@@ -677,8 +902,9 @@ do
done
ac_given_srcdir=$srcdir
+ac_given_INSTALL="$INSTALL"
-trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
+trap 'rm -fr `echo "Makefile newdoc/Makefile newdoc/ref/Makefile newdoc/tutorial/Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
EOF
cat >> $CONFIG_STATUS <<EOF
@@ -708,25 +934,73 @@ s%@includedir@%$includedir%g
s%@oldincludedir@%$oldincludedir%g
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g
+s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
+s%@INSTALL_DATA@%$INSTALL_DATA%g
+s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g
+s%@PACKAGE@%$PACKAGE%g
+s%@VERSION@%$VERSION%g
+s%@ACLOCAL@%$ACLOCAL%g
+s%@AUTOCONF@%$AUTOCONF%g
+s%@AUTOMAKE@%$AUTOMAKE%g
+s%@AUTOHEADER@%$AUTOHEADER%g
+s%@MAKEINFO@%$MAKEINFO%g
+s%@SET_MAKE@%$SET_MAKE%g
+s%@MAINT@%$MAINT%g
s%@subdirs@%$subdirs%g
s%@existingdirs@%$existingdirs%g
CEOF
EOF
+
+cat >> $CONFIG_STATUS <<\EOF
+
+# Split the substitutions into bite-sized pieces for seds with
+# small command number limits, like on Digital OSF/1 and HP-UX.
+ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
+ac_file=1 # Number of current file.
+ac_beg=1 # First line for current file.
+ac_end=$ac_max_sed_cmds # Line after last line for current file.
+ac_more_lines=:
+ac_sed_cmds=""
+while $ac_more_lines; do
+ if test $ac_beg -gt 1; then
+ sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
+ else
+ sed "${ac_end}q" conftest.subs > conftest.s$ac_file
+ fi
+ if test ! -s conftest.s$ac_file; then
+ ac_more_lines=false
+ rm -f conftest.s$ac_file
+ else
+ if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds="sed -f conftest.s$ac_file"
+ else
+ ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
+ fi
+ ac_file=`expr $ac_file + 1`
+ ac_beg=$ac_end
+ ac_end=`expr $ac_end + $ac_max_sed_cmds`
+ fi
+done
+if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds=cat
+fi
+EOF
+
cat >> $CONFIG_STATUS <<EOF
-CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
+CONFIG_FILES=\${CONFIG_FILES-"Makefile newdoc/Makefile newdoc/ref/Makefile newdoc/tutorial/Makefile"}
EOF
cat >> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile]", defaulting infile="outfile.in".
+ # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
+ *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
*) ac_file_in="${ac_file}.in" ;;
esac
- # Adjust relative srcdir, etc. for subdirectories.
+ # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
# Remove last slash and all that follows it. Not all systems have dirname.
ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
@@ -750,6 +1024,11 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
top_srcdir="$ac_dots$ac_given_srcdir" ;;
esac
+ case "$ac_given_INSTALL" in
+ [/$]*) INSTALL="$ac_given_INSTALL" ;;
+ *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
+ esac
+
echo creating "$ac_file"
rm -f "$ac_file"
configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
@@ -758,15 +1037,22 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
# $configure_input" ;;
*) ac_comsub= ;;
esac
+
+ ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
sed -e "$ac_comsub
s%@configure_input@%$configure_input%g
s%@srcdir@%$srcdir%g
s%@top_srcdir@%$top_srcdir%g
-" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file
+s%@INSTALL@%$INSTALL%g
+" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
fi; done
-rm -f conftest.subs
+rm -f conftest.s*
+EOF
+cat >> $CONFIG_STATUS <<EOF
+EOF
+cat >> $CONFIG_STATUS <<\EOF
exit 0
EOF
@@ -822,13 +1108,16 @@ if test "$no_recursion" != yes; then
ac_popdir=`pwd`
cd $ac_config_dir
+ # A "../" for each directory in /$ac_config_dir.
+ ac_dots=`echo $ac_config_dir|sed -e 's%^\./%%' -e 's%[^/]$%&/%' -e 's%[^/]*/%../%g'`
+
case "$srcdir" in
.) # No --srcdir option. We are building in place.
ac_sub_srcdir=$srcdir ;;
/*) # Absolute path.
ac_sub_srcdir=$srcdir/$ac_config_dir ;;
*) # Relative path.
- ac_sub_srcdir=../$srcdir/$ac_config_dir ;;
+ ac_sub_srcdir=$ac_dots$srcdir/$ac_config_dir ;;
esac
# Check for guested configure; otherwise get Cygnus style configure.
@@ -845,13 +1134,15 @@ if test "$no_recursion" != yes; then
if test -n "$ac_sub_configure"; then
# Make the cache file name correct relative to the subdirectory.
- # A "../" for each directory in /$ac_config_dir.
- ac_dots=`echo $ac_config_dir|sed -e 's%^\./%%' -e 's%[^/]$%&/%' -e 's%[^/]*/%../%g'`
case "$cache_file" in
/*) ac_sub_cache_file=$cache_file ;;
*) # Relative path.
ac_sub_cache_file="$ac_dots$cache_file" ;;
esac
+ case "$ac_given_INSTALL" in
+ [/$]*) INSTALL="$ac_given_INSTALL" ;;
+ *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
+ esac
echo "running ${CONFIG_SHELL-/bin/sh} $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_sub_srcdir"
# The eval makes quoting arguments work.
diff --git a/configure.in b/configure.in
index 6ea5ef4c6..0dfd707a6 100644
--- a/configure.in
+++ b/configure.in
@@ -1,50 +1,28 @@
+dnl Process this file with autoconf to produce configure.
AC_INIT(Makefile.in)
+. $srcdir/GUILE-VERSION
+AM_INIT_AUTOMAKE($PACKAGE, $VERSION)
+AM_MAINTAINER_MODE
+dnl FIXME: tsort, xargs not GNU standard.
all_subdirs=`cat $srcdir/*/PLUGIN/REQ $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo`
req_subdirs=`cat $srcdir/*/PLUGIN/REQ /dev/null | tsort | xargs echo`
opt_subdirs=`cat $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo`
+
AC_CONFIG_SUBDIRS($all_subdirs)
-existingdirs=
for d in $all_subdirs; do
if test -d $srcdir/$d ; then
existingdirs="$existingdirs $d"
- if test "x$verbose" = xyes; then
- if test -f $srcdir/$d/PLUGIN/greet ; then
- cat $srcdir/$d/PLUGIN/greet
- else
- echo ===
- echo === Configuring plug-in component $d
- echo ===
- fi
- fi
+ test -n "$silent" || echo Configuring plug-in component $d
fi
done
for d in $req_subdirs; do
- if test ! -d $srcdir/$d ; then
- echo "*******"
- echo "*******"
- echo "**\+/**"
- echo "**=*=**" ERROR: Missing required package: $d
- echo "**/+\**"
- echo "*******"
- echo "*******"
- exit 1
- fi
+ test -d $srcdir/$d || {
+ echo ERROR: Missing required package: $d 1>&2
+ exit 1
+ }
done
-if test "x$verbose" = xyes; then
- for d in $opt_subdirs; do
- if test ! -d $srcdir/$d ; then
- echo "*****"
- echo "*===*"
- echo "*=*=*" WARNING: Missing suggested package: $d
- echo "*===*"
- echo "*****"
- fi
- done
-fi
-
-
AC_SUBST(existingdirs)
-AC_OUTPUT(Makefile)
+AC_OUTPUT(Makefile newdoc/Makefile newdoc/ref/Makefile newdoc/tutorial/Makefile)
diff --git a/guile.m4 b/guile.m4
new file mode 100644
index 000000000..d4e06e043
--- /dev/null
+++ b/guile.m4
@@ -0,0 +1,13 @@
+## An m4 macro to initialize a guile module.
+## Enhance as required.
+
+dnl Usage: AM_INIT_GUILE_MODULE(module-name)
+dnl This macro will automatically get the guile version from the
+dnl top-level srcdir, and will initialize automake. It also
+dnl defines the `module' variable.
+AC_DEFUN([AM_INIT_GUILE_MODULE],[
+. $srcdir/../GUILE-VERSION
+AM_INIT_AUTOMAKE($PACKAGE, $VERSION, no-define)
+AC_CONFIG_AUX_DIR(..)
+module=[$1]
+AC_SUBST(module)])
diff --git a/ice-9/.cvsignore b/ice-9/.cvsignore
new file mode 100644
index 000000000..16b8c4510
--- /dev/null
+++ b/ice-9/.cvsignore
@@ -0,0 +1,3 @@
+Makefile
+config.log
+config.status
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index fe69f1e0b..6af2697c1 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,705 @@
+Sat Apr 12 08:27:05 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (log10): defined.
+
+Tue Apr 1 17:46:49 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * expect.scm (expect-select): correct the millisecond timeout
+ arithmetic (from Marko.Kohtala@ntc.nokia.com).
+
+Mon Mar 31 03:23:19 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (open-input-pipe, open-output-pipe): defined here
+ instead of in libguile.
+ (tm:sec etc.) new accessors for broken-down time.
+ (set-tm:sec etc.) new setters for broken-down time.
+
+Thu Mar 27 05:06:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (netent:addrtype, servent:port): added missing
+ procedures.
+ (netent:net, servent:proto): repaired.
+ (utsname:sysname etc.): new accessors for uname.
+
+Tue Mar 25 03:04:03 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (sockaddr:fam, sockaddr:path, sockaddr:addr,
+ sockaddr:port): new functions.
+
+Wed Mar 19 04:50:34 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: define accessor procedures for the objects returned
+ by getpw, getgr, gethost, getnet, getproto, getserv (e.g.,
+ passwd:name, where the first component is the name of the C structure
+ and the second is the unprefixed C member name.)
+
+Tue Mar 18 18:39:31 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+* * boot-9.scm (setpwent, setgrent, sethostent, setnetent, setprotoent,
+ setservent): no longer take an argument, it was bogus.
+
+Thu Mar 13 00:13:41 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (scm-error): deleted, reimplemented in C.
+
+Mon Mar 10 15:48:31 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (process-define-module): Modified to handle both
+ keywords and symbols.
+
+Sat Mar 8 04:32:44 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * slib.scm: update read usage.
+
+ * r4rs.scm: update primitive-load usage.
+ Don't define read-sharp.
+
+ * boot-9.scm: use read-hash-extend to install extra read syntax.
+ (read-sharp): removed.
+ Adjust usage of primitive-load-path, read, which no longer take
+ case_i or read-sharp arguments.
+
+Sat Mar 8 00:07:54 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Added loading of session support module.
+
+ * debug.scm: Removed `display-application'. (Replaced by
+ primitive procedure.)
+
+ * boot-9.scm (beautify-user-module!): Don't add the root module
+ interface to the end of the use-list of the root module.
+
+Thu Mar 6 07:26:34 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: repl-quit, repl-abort: obsolete variables deleted.
+
+Wed Mar 5 20:30:24 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: check use-emacs-interface for emacs support.
+
+Sun Mar 2 19:47:14 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (scm-style-repl): call repl-report-start-timing if
+ read gets EOF.
+ * (exit): alias for quit.
+
+Sun Mar 2 05:25:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (error-catching-loop thunk): use a status variable to
+ return the quit args.
+ (scm-style-repl): call -quit, passing return value from
+ error-catching-repl. Make -quit return its args.
+ stand-alone-repl: comment out, since it seems unused.
+
+ (error-catching-loop thunk): discard trailing junk after a (quit).
+
+Sat Mar 1 15:24:39 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Removed the old printer code.
+
+ * r4rs.scm (apply, call-with-current-continuation): Added comment
+ explaining why apply and call/cc need to be closures.
+
+ * boot-9.scm (apply, call-with-current-continuation): Bugfix:
+ Removed. These definitions are already present in r4rs.scm.
+
+ * debug.scm (trace-entry, trace-exit): Check that we're on a repl
+ stack before printing traced frames; Re-enable trace flag at end
+ of handlers.
+
+Sat Mar 1 00:10:38 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.scm: Add hook for reset of trace level at abort.
+
+ * boot-9.scm (run-hooks): New procedure.
+ (add-hooks!): New macro.
+ Change hooks to use these functions.
+
+* * debug.scm: *Warning* This feature is a bit premature. I add
+ it anyway because 1. it is very useful, and, 2. you can start
+ making it less premature by complaining to me and by modifying
+ the source! :-)
+ (trace): Given one or more procedure objects, trace each one.
+ Given no arguments, show all traced procedures.
+ (untrace): Given one or more procedure objects, untrace each one.
+ Given no arguments, untrace all traced procedures. The tracing in
+ Guile have an advantage to most other systems: We don't create new
+ procedure objects, but mark the procedure objects themselves.
+ This means that also anonymous and internal procedures can be
+ traced.
+
+ * boot-9.scm (error-catching-loop): Added handling of apply-frame
+ and exit-frame exceptions.
+
+* * boot-9.scm (assert-repl-prompt, the-prompt-string): Removed.
+ (set-repl-prompt!): Setter for repl prompt.
+ (scm-style-repl): If prompt is #f, don't prompt; if prompt is a
+ string, display it; if prompt is a thunk, call it and display its
+ result; otherwise display "> ".
+ (Change suggested by Roland Orre <orre@nada.kth.se>.)
+
+ * r4rs.scm (%load-verbosely): Reverted change to
+ `module-defined?', since the module system isn't bootstrapped when
+ we load r4rs.scm. This is just a temporary fix to make the
+ repository version runnable.
+
+Thu Feb 27 23:25:47 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Removed the enabling of debug evaluator and
+ recording of source code positions. This was placed there for our
+ convenience, but it has already sneaked into the distribution
+ once... so we'd better add this in our local copies instead when
+ we need it. (These options are normally enabled at the end of
+ boot-9.scm when loading the debug module.)
+
+Thu Feb 27 16:04:45 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (module-defined?): New function.
+ (macroexpand-1, macroexpand): Use local-ref instead of defined?
+ and eval.
+ * r4rs.scm (%load-verbosely): Use "module-defined?" instead of
+ "defined?".
+ * slib.scm (defined?): New function to take the place of the
+ builtin "defined?". It allways examines the slib module.
+
+Mon Feb 24 21:46:15 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Sat Feb 15 04:51:20 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (read-sharp): define directly, don't go through a
+ %read-sharp layer.
+
+Tue Feb 11 08:45:48 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (uniform-vector-set!): use uniform-array-set1!, not
+ uniform-vector-set1! which doesn't exist.
+
+Mon Feb 10 03:01:48 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (backtrace): Removed. (A C version now exists in
+ backtrace.c.)
+
+Fri Jan 24 06:05:36 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (read-line!, read-delimited!, read-delimited,
+ read-line): new procedures, see libguile/ChangeLog.
+
+Thu Jan 16 17:07:03 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Added dynamic linking of modules. See libguile/DYNAMIC-LINKING.
+
+ * boot-9.scm (split-c-module-name, convert-c-registered-modules,
+ init-dynamic-module, dynamic-maybe-call,
+ find-and-link-dynamic-module, link-dynamic-module,
+ try-module-dynamic-link, registered-modules): New definitions for
+ dynamic linking of modules.
+ (resolve-module): Try to dynamically link the requested module
+ after failing to load it as Scheme code.
+
+Wed Jan 8 05:50:14 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (getservbyport, getservbyname): remove stray %.
+
+Tue Jan 7 20:02:24 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (and=>): Rename THUNK argument to PROCEDURE, 'cos
+ that's what it is.
+
+ * lineio.scm (make-line-buffering-input-port): Properly test for
+ the case of an empty buffer list. The old code assumed that '()
+ was false.
+
+Mon Jan 6 01:13:53 1997 Mikael Djurfeldt <mdj@kenneth>
+
+* * boot-9.scm (use-modules): New macro (from Marius Vollmer).
+ (use-modules <module name> ...) Put the the modules named by
+ <module name> ... on the use list of the current module.
+
+Sun Jan 5 15:52:59 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (error-catching-loop): Remove message saying that
+ typing "$" will put you in the debugger. This isn't implemented
+ yet.
+
+Sun Dec 22 23:27:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (delq-all!): Function deleted; delq!'s semantics have
+ been fixed, so this function is superfluous.
+ (transform-usage-lambda): Use delq!, not delq-all!.
+
+Tue Dec 17 20:36:45 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (resolve-module): New optional parameter that
+ controls whether autoloading is attempted or not. Default is #t.
+ (process-define-module): Don't autoload the defined module.
+ (try-module-autoload): Don't autoload the directory modules.
+
+ * boot-9.scm (process-define-module): Ensure that the-scm-module
+ is last in the `uses' list to allow shadowing builtin
+ bindings. All :use-module options are added in the order they
+ appear in the arguments but before anything already on the list
+ (such as the-scm-module).
+
+Wed Dec 11 21:06:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * slib.scm (slib-parent-dir): throw error if #f returned from
+ %search-load-path.
+
+Sat Nov 30 23:57:28 1996 Tom Tromey <tromey@cygnus.com>
+
+ * PLUGIN/greet, PLUGIN/split.sed, PLUGIN/this.configure: Removed.
+ * Makefile.am, aclocal.m4: New files.
+ * configure.in: Updated for Automake.
+
+Wed Nov 27 14:16:14 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (macroexpand-1, macroexpand), slib.scm
+ (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a
+ function, use it accordingly.
+
+Thu Nov 21 11:12:10 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ It's an "eval closure", not an "eval thunk." A thunk is a
+ function of no arguments.
+ * boot-9.scm (module-type): Rename module field.
+ (make-module, eval-in-module, make-root-module,
+ set-current-module): Uses changed.
+ (module-eval-closure, set-module-eval-closure!,
+ root-module-closure): Renamed from module-eval-thunk,
+ set-module-eval-thunk!, root-module-thunk.
+ (set-current-module): Change uses of *top-level-lookup-thunk* to
+ *top-level-eval-closure*.
+
+Wed Nov 20 14:45:27 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * slib.scm (slib-parent-dir): Use string-length, not length.
+ (Thanks to Bernard Urban.)
+
+Sat Nov 2 20:00:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: The debugging evaluator and recording of positions
+ aren't enabled by default any longer (they are switched on in
+ debug.scm). But during development we want to have them also
+ *inside* boot-9.scm. Therefore, two lines are added at the
+ beginning of boot-9.scm to enable these.
+
+ Call `provide' so that `records' are included among the
+ `*features*'.
+
+ The scheme for saving the stack has been adjusted: save-stack is
+ now commonly available for saving the stack. Calling `save-stack'
+ sets a flag `stack-saved?' which prevents overwriting the stack.
+ `stack-saved?' is reset at `abort'.
+
+ Spelling correction: seperate --> separate.
+
+ Removed `:'s that had creeped into some comments.
+
+ The repl now doesn't print #<unspecified> results any longer
+ If the user wants to see this, he can do
+ (assert-repl-print-unspecified #t) in his startup file.
+
+ The user now gets a friendly message instead of a backtrace at
+ error.
+
+ Added `before-read-hook'.
+
+ Load module (ice-9 emacs) if option `-e' was specified.
+
+ (provide): New function.
+
+ (error): Save stack at entry, so that Guile entrails won't show up
+ in backtraces.
+
+ (backtrace): New function.
+
+ (save-stack): Can now take arbitrary number of stack narrowing
+ specifier pairs. The first specifier in a pair controls inner
+ border, the second the outer border. A number means cut that
+ number of frames, a procedure object means cut until that object
+ is found in operator position in a frame.
+
+ * debug.scm: Enable debugging evaluator and recording of positions
+ by default.
+
+ * slib.scm (slib:load): Adapt to the new behavior of
+ primitive-load: It doesn't any longer try both with and without
+ ".scm" extension. (We don't want to use %search-load-path here.)
+
+ (implementation-vicinity): New function. slib requires it
+
+ (library-vicinity): Updated.
+
+ Load "require.scm" in the library-vicinity.
+
+ (install-require-vicinity, install-require-module): New functions.
+
+Mon Oct 28 17:56:29 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (load-from-path): New function.
+
+ * boot-9.scm (try-load, basic-try-load, try-load-module,
+ try-load): Deleted. I don't think they're being used.
+
+ * Makefile.in (scm_files): Add r4rs.scm and test.scm to this list,
+ so they'll get distributed.
+
+ Get Guile to be a little less chatty by default. The new user
+ should see as little clutter as possible.
+ * r4rs.scm (%load-verbosely): Make this #f by default.
+ * boot-9.scm (scm-repl-verbose): Make this #f by default.
+ (scm-style-repl): Don't run 'pk' on the value passed to quit.
+
+ * r4rs.scm: New file.
+ * boot-9.scm: Load r4rs.scm, first thing.
+ (OPEN_READ, OPEN_WRITE, OPEN_BOTH, *null-device*, open-input-file,
+ open-output-file, open-io-file, close-input-port,
+ close-output-port, close-io-port, call-with-input-file,
+ call-with-output-file, with-input-from-port, with-output-to-port,
+ with-error-to-port, with-input-from-file, with-output-to-file,
+ with-error-to-file, with-input-from-string, with-output-to-string,
+ with-error-to-string, the-eof-object): Definitions moved to
+ r4rs.scm. Not all of them are R4RS, but those that are use those
+ that are not.
+ (load, %load-verbosely, %load-announce): Moved, along with code to
+ set %load-hook, to r4rs.scm.
+
+ * test.scm: New file.
+
+ * boot-9.scm (integer?): Definition deleted, in favor of the one
+ present in libguile (which used to be called int?). I have no
+ idea why integer? didn't just call int? to begin with.
+
+ * boot-9.scm (<, <=, =, >, >=): Definitions in terms of <?, <=?,
+ =?, >?, and >=? deleted; they're defined that way by libguile now.
+
+ * boot-9.scm (load): Simplified; primitive-load does most of this
+ work now.
+ (%load-announce-win): Removed; no longer used. Set %load-hook to
+ call %load-announce.
+
+Sun Oct 27 07:47:03 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (stat:dev, stat:ino, stat:mode, stat:nlink, stat:uid,
+ stat:gid, stat:rdev, stat:size, stat:atime, stat:mtime,
+ stat:ctime, stat:blksize, stat:blocks) accessor functions for stat
+ components.
+ (file-is-directory?): use stat:type.
+
+Fri Oct 25 03:34:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (%read-sharp): Don't recognize the `#!' syntax here;
+ that's now taken care of in libguile, and in a way compatible with
+ SCSH (which this isn't).
+
+Mon Oct 21 18:52:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm: Formatting tweaks.
+
+Fri Oct 18 01:03:08 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (handle-system-error): Added hooks before-error-hook,
+ after-error-hook, before-backtrace-hook and after-backtrace-hook
+ to the error handler. E.g.: fancy emacs support could plug into
+ these.
+ (save-stack): New function. The stack is now made differently
+ depending on the stack id. (The motivation is to make a better
+ choice regarding what stack frames to present to the user.)
+ (error-catching-loop): Stack handling code moved outside into
+ save-stack.
+
+Thu Oct 17 20:33:08 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Makefile.in (scm_files): add expect.scm.
+
+ * expect.scm: new file ported from guile-iii.
+
+ * boot-9.scm: remove handle-system-error, after moving the code into
+ error-catching-loop.
+ Don't set 'throw-handler-default property on error keys.
+ Just interpret (almost) any throw with 4 args as an error throw.
+ Delete some try-load stuff that was already commented out.
+
+ Second thoughts, keep handle-system-error but call it from
+ error-catching-loop.
+
+Tue Oct 15 17:07:20 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm: Doc fixes.
+ (make-module): Rework for readability.
+ (make-root-module, make-scm-module): USES argument to make-module
+ should be '(), not #f.
+
+ * boot-9.scm (try-load): %sys-load-path has been renamed to
+ primitive-load-path; adjust call here.
+
+Tue Oct 15 14:25:01 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (signal-handler): Bugfix: Moved the recording of
+ the stack to the correct place: when it is decided to generate an
+ error-signal.
+
+Mon Oct 14 22:20:30 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (error-catching-loop, signal-handler,
+ handle-system-error): Backtracing now works for signals aswell;
+ Backtracing mechanism can now identify the stack root created by
+ start-stack so that the user isn't exposed to system stack frames.
+
+Mon Oct 14 06:05:42 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * Makefile.in: Added threads.scm.
+
+Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.scm (make-enable, make-disable): Simplified.
+
+ * boot-9.scm: Renamed %%throw-handler-default -->
+ throw-handler-default.
+ ((handle-system-error key . arg-list)): Changed the way errors are
+ reported.
+ ((scm-style-repl)): Wrap up the call to eval in a start-stack
+ acro.
+ ((error-catching-loop thunk)): Introduce a lazy-catch into
+ error-catching-loop so that the stack can be captured.
+
+Thu Oct 10 22:27:32 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * mapping.scm (hash-table-mapping): Explicitly request that
+ make-vector fill new vectors with '(); this will make it easier to
+ port Guile Scheme code to other Schemes.
+ * boot-9.scm (make-print-style, make-print-table): Same.
+
+Sun Oct 6 03:54:59 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (load): rewritten again.
+ Append "." to the default %load-path.
+ (feature?): new function: checks for a symbol in the features list.
+ (module-local-variable): remove apparently useless (caddr (list m v
+ ...))
+ (%load-announce): minor formatting change.
+ (file-exists?): use access? if posix is featured.
+ (file-is-directory?): use stat if i/o-extensions is featured.
+ (try-module-autoload module-name): use file-exists? before
+ file-is-directory?
+
+Sat Oct 5 18:54:03 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm: Added conditional loading of threads.scm.
+
+ * threads.scm: New file. Modified from the Cygnus-r0.3
+ distribution.
+
+ * boot-9.scm (error-catching-loop): Added handling of key
+ `switch-repl'.
+
+ * boot-9.scm: Name change %%bad-throw --> bad-throw.
+
+Wed Oct 2 23:38:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (make-record-type, record-constructor): Don't assume
+ the empty list is false when parsing the argument list.
+
+Mon Sep 30 22:15:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (signal-handler): Clean up logic.
+
+ * boot-9.scm (load): Assume %load-path is always bound.
+
+Sat Sep 28 00:15:37 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (error): replace another throw with scm-error. Throw
+ to 'misc-error instead of 'error (no need to distinguish these.)
+ Don't set up 'error as a key.
+ Set up regex-error as a key, if regex is available.
+ (signal-handler): use scm-error, not throw.
+
+ (%try-load, try-load-with-path, %load, load-with-path,
+ basic-try-load-with-path, basic-load-with-path,
+ try-load-module-with-path,load-module-with-path): deleted, since
+ they seem redundant.
+ (try-load): define using %try-load, not try-load-with-path.
+ (load): rewritten. load tries to open the file directly and
+ with a .scm extension before searching the library directories
+ (should "." be added to %load-path? then load could still open
+ directly files starting with "/").
+ (try-module-autoload): use load, not load-with-path.
+ (%load-indent): deleted, -2 was causing errors.
+
+ (%read-sharp): use port-line, not line-number.
+
+Fri Sep 27 16:23:51 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (%%bad-throw): Delete definition. 1) It's very
+ straightforward to provide the equivalent functionality using
+ (catch #t ...), so there's no need for the extra complexity. 2)
+ Outside the context of a read-eval-print loop (which Guile should
+ not require) it's not clear we should do anything more complicated
+ than print an error and exit; the user or REPL can establish
+ something better if it wants. 3) In that case, it's much more
+ robust to just do it in the C code.
+
+Tue Sep 24 06:53:04 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%try-load): define using primitive-load. Previously
+ %try-load itself was the primitive.
+ (load-with-path): use scm-error instead of %load-announce-lossage.
+ Errors are thrown to 'misc-error instead of 'could-not-load.
+ (%load-announce-lossage): deleted.
+
+Mon Sep 23 00:16:31 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (warn, scm-style-repl): Use C printer instead of `print'.
+ (make-record-type type-name fields): Temporarily remove support
+ for printing of records (not possible yet with C printer).
+
+Fri Sep 20 00:24:27 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (file-exists?, file-is-directory): catch only
+ system-error, not every kind of error.
+ (scm-error): new procedure.
+
+Thu Sep 19 16:02:46 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm: Formatting tweaks.
+
+Wed Sep 18 09:07:37 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error key): remove the code for
+ SCM-style errors. handle the case that an unexpected number
+ of args are supplied.
+ (%%system-errors): removed.
+ (error): redefine using a throw with key and 4 args.
+ ('error): associate 'error, 'error-signal keys with
+ %%handle-system-error.
+ (%%default-error-handler): removed.
+ (signal-handler): throw with 4 args and use the error-signal key.
+ Create an error message instead of using numerical codes.
+ (%%bad-throw): call error instead of throw if key not found.
+
+Tue Sep 17 04:11:28 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: initialize new error keys (see libguile/ChangeLog).
+ (%%handle-system-error key): check subr is not #f before printing.
+ Recognize %s (embed an argument using "display") and
+ %S (embed an argument using "write").
+
+Sun Sep 15 03:55:35 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error key): set args and rest to
+ the empty list if they are #f.
+ Initialize out-of-range as an error key.
+
+Sat Sep 14 03:41:15 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * PLUGIN/REQ: remove the "ice-9 lgh" line which causes a cycle.
+
+ * boot-9.scm: remove leading %% from references to '%%system-error.
+ (%%handle-system-error): don't pass all the thrown arguments when
+ aborting, just the key and subr.
+ Remove the code to "Install default handlers for built-in errors."
+ Remove the definition of the syserror procedure.
+ Associate 'numerical-overflow with default handler.
+
+Fri Sep 13 04:58:11 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm: Name change: value-ref --> local-ref
+ resolved-ref --> nested-ref Motivation: conformance to the other
+ dictionary operators: list-ref operates on list, vector-ref
+ operates on vector, nested-ref operates on nested namespace,
+ local-ref operates on the local nested namespace.
+
+Sat Sep 7 06:44:47 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error): recognise errors thrown
+ by lgh-error (fill-message etc.)
+ (fill-message): check first whether args is null.
+ (fill-message): bug fix and check that args is a list.
+
+Thu Sep 5 11:33:41 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm: %load-path is initialized in C code now.
+ (implementation-vicinity, parse-path): Deleted, along with code to
+ initialize %load-path.
+
+ * boot-9.scm (in-vicinity): If the vicinity doesn't end with a
+ "/", use one to separate it from the file.
+
+Thu Aug 29 23:05:11 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu>
+
+ * boot-9.scm (%load-path): Add the site directory.
+ Add the directory named after the version number.
+ Prepend the version number to the other directories in the path.
+ Simplify by mapping the common prefix onto each item.
+ * Makefile.in (datadir, pkgdatadir, pkgverdatadir, subpkgdatadir,
+ sitedatadir): New definitions.
+ (libparent, libdir, install_path): Replaced by above.
+ (install): Create the above directories.
+ Put the source files into subpkgdatadir.
+ (uninstall): Remove the above directories.
+
+Thu Aug 29 21:48:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Don't use the PLUGIN system to gather information for the
+ Makefile's distribution and installation targets; just put it all
+ in the Makefile directly.
+ * PLUGIN/this.configure (scm_files, aux_files): Remove sections
+ for these.
+ * configure.in: Remove code that gets and substitutes scm_files and
+ aux_files.
+ * Makefile.in (scm_files, aux_files): Write out the list of files
+ here, where people expect to find them.
+
+Fri Aug 23 06:44:36 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm: Preliminary solution: optionally load the debug
+ module. Changed "gls" to "guile1.0b3".
+
+ * debug.scm: New file: debug extensions.
+
+Wed Aug 21 13:06:56 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (print-vector): Renamed weak-hash-table? -->
+ weak-key-hash-table?. (Again!)
+
+Tue Aug 20 07:31:39 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (print-vector, macro-table, xformer-table):
+ Renamed weak-hash-table --> weak-key-hash-table.
+
+ * poe.scm (funcq-memo): Renamed weak-hash-table -->
+ weak-key-hash-table.
+
+Sat Aug 3 06:16:35 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (*null-device*): global constant from goonix.
+ (move->fdes): adjusted for boolean primitive-move->fdes. return
+ the modified port, always set revealed count to 1 (SCSH compatible).
+ (release-port-handle port): from goonix (SCSH compatible).
+ (%open-file): removed.
+ (open-input-file, open-output-file, file-exists?, file-is-directory?):
+ modified for open-file change (does not return #f).
+
+Thu Aug 1 02:52:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in (dist-dir): New target for new dist system.
+ (manifest): Deleted.
+ * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a
+ directory, and needs special treatment in the dist-dir target.
+
+Thu Aug 1 09:00:21 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: remove the wrappers for '%' system primitives,
+ now that they throw errors directly.
+ remove make-simple-wrapper and similar functions.
+ protect a call to getenv which may now throw an exception.
+
+Wed Jul 31 23:44:42 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (false-if-exception): new macro.
+
Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive>
* The more things change...
diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
new file mode 100644
index 000000000..1647cffcc
--- /dev/null
+++ b/ice-9/Makefile.am
@@ -0,0 +1,10 @@
+## Process this file with automake to produce Makefile.in.
+
+AUTOMAKE_OPTIONS = foreign
+
+subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@
+subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
+mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
+
+## test.scm is not currently installed.
+EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm
diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in
index 318dc4a56..7ae7dd7f6 100644
--- a/ice-9/Makefile.in
+++ b/ice-9/Makefile.in
@@ -1,71 +1,220 @@
-# Copyright (C) 1995 Free Software Foundation, Inc.
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-#
-
-
+# Makefile.in generated automatically by automake 1.1n from Makefile.am
+
+# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
SHELL = /bin/sh
srcdir = @srcdir@
+top_srcdir = @top_srcdir@
VPATH = @srcdir@
prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = .
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = true
+PRE_INSTALL = true
+POST_INSTALL = true
+NORMAL_UNINSTALL = true
+PRE_UNINSTALL = true
+POST_UNINSTALL = true
+MAINT = @MAINT@
+PACKAGE = @PACKAGE@
+VERSION = @VERSION@
+module = @module@
+
+AUTOMAKE_OPTIONS = foreign
+
+subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@
+subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
+mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
+
+EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_CLEAN_FILES =
+DATA = $(subpkgdata_DATA)
+
+DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in aclocal.m4 \
+configure configure.in
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = tar
+GZIP = --best
+default: all
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
+ cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile
+
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
+ cd $(top_builddir) \
+ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+$(srcdir)/aclocal.m4: @MAINT@ configure.in
+ cd $(srcdir) && $(ACLOCAL)
+
+config.status: configure
+ $(SHELL) ./config.status --recheck
+$(srcdir)/configure: @MAINT@configure.in $(ACLOCAL_M4) $(CONFIGURE_DEPENDENCIES)
+ cd $(srcdir) && $(AUTOCONF)
+
+install-subpkgdataDATA: $(subpkgdata_DATA)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(subpkgdatadir)
+ @list='$(subpkgdata_DATA)'; for p in $$list; do \
+ if test -f $(srcdir)/$$p; then \
+ echo " $(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p"; \
+ $(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p; \
+ else if test -f $$p; then \
+ echo " $(INSTALL_DATA) $$p $(subpkgdatadir)/$$p"; \
+ $(INSTALL_DATA) $$p $(subpkgdatadir)/$$p; \
+ fi; fi; \
+ done
-VERSION=@GUILE_VERSION@
+uninstall-subpkgdataDATA:
+ $(NORMAL_UNINSTALL)
+ list='$(subpkgdata_DATA)'; for p in $$list; do \
+ rm -f $(subpkgdatadir)/$$p; \
+ done
+tags: TAGS
+TAGS:
+
+
+distdir = $(PACKAGE)-$(VERSION)
+# This target untars the dist file and tries a VPATH configuration. Then
+# it guarantees that the distribution is self-contained by making another
+# tarfile.
+distcheck: dist
+ rm -rf $(distdir)
+ GZIP=$(GZIP) $(TAR) zxf $(distdir).tar.gz
+ mkdir $(distdir)/=build
+ mkdir $(distdir)/=inst
+ dc_install_base=`cd $(distdir)/=inst && pwd`; \
+ cd $(distdir)/=build \
+ && ../configure --srcdir=.. --prefix=$$dc_install_base \
+ && $(MAKE) \
+ && $(MAKE) dvi \
+ && $(MAKE) check \
+ && $(MAKE) install \
+ && $(MAKE) installcheck \
+ && $(MAKE) dist
+ rm -rf $(distdir)
+ @echo "========================"; \
+ echo "$(distdir).tar.gz is ready for distribution"; \
+ echo "========================"
+dist: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+dist-all: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+distdir: $(DISTFILES)
+ rm -rf $(distdir)
+ mkdir $(distdir)
+ -chmod 755 $(distdir)
+ here=`pwd`; distdir=`cd $(distdir) && pwd` \
+ && cd $(srcdir) \
+ && $(AUTOMAKE) --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign
+ $(mkinstalldirs) $(distdir)/PLUGIN
+ @for file in $(DISTFILES); do \
+ d=$(srcdir); \
+ test -f $(distdir)/$$file \
+ || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+ || cp -p $$d/$$file $(distdir)/$$file; \
+ done
+info:
+dvi:
+check: all
+ $(MAKE)
+installcheck:
+install-exec:
+ @$(NORMAL_INSTALL)
-libparent=$(prefix)/lib
-libdir=$(libparent)/guile$(VERSION)
-install_path=$(libdir)/@library_name@
+install-data: install-subpkgdataDATA
+ @$(NORMAL_INSTALL)
-INSTALL = $(srcdir)/../install-sh -c
-INSTALL_DATA = $(INSTALL) -m 644
+install: install-exec install-data all
+ @:
-scm_files= @scm_files@
-aux_files = @aux_files@
+uninstall: uninstall-subpkgdataDATA
-all:
+all: $(DATA) Makefile
-install: all
- test -d $(libparent) || mkdir $(libparent)
- test -d $(libdir) || mkdir $(libdir)
- test -d $(install_path) || mkdir $(install_path)
- cd $(srcdir); \
- for file in $(scm_files); do \
- $(INSTALL_DATA) $$file $(install_path); \
- done
+install-strip:
+ $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
+installdirs:
+ $(mkinstalldirs) $(subpkgdatadir)
-uninstall:
- for file in $(scm_files) ; do \
- rm -f $(install_path)/$$file; \
- done;
- -rmdir $(install_path)
- -rmdir $(libdir)
+mostlyclean-generic:
+ test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
-SUBDIR=.
-manifest:
- srcdir=./$(SUBDIR) ; \
- . $(SUBDIR)/PLUGIN/this.configure; \
- for file in $$scm_files $$aux_files ; \
- do echo $(SUBDIR)/$$file ; \
- done
+clean-generic:
+ test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ rm -f Makefile $(DISTCLEANFILES)
+ rm -f config.cache config.log stamp-h
+ test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+
+maintainer-clean-generic:
+ test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+ test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+mostlyclean: mostlyclean-generic
+
+clean: clean-generic mostlyclean
+
+distclean: distclean-generic clean
+ rm -f config.status
-clean:
+maintainer-clean: maintainer-clean-generic distclean
+ @echo "This command is intended for maintainers to use;"
+ @echo "it deletes files that may require special tools to rebuild."
+ rm -f config.status
-distclean:
- -rm -f config.log config.status Makefile
+.PHONY: default uninstall-subpkgdataDATA install-subpkgdataDATA tags \
+distdir info dvi installcheck install-exec install-data install \
+uninstall all installdirs mostlyclean-generic distclean-generic \
+clean-generic maintainer-clean-generic clean mostlyclean distclean \
+maintainer-clean
-realclean:
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/libguile/__scm.hd b/ice-9/aclocal.m4
index e69de29bb..e69de29bb 100644
--- a/libguile/__scm.hd
+++ b/ice-9/aclocal.m4
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index fa55e9a1d..414b1e0d8 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -26,8 +26,20 @@
;;;
+;;; {Features}
+;;
+
+(define (provide sym)
+ (if (not (memq sym *features*))
+ (set! *features* (cons sym *features*))))
+
+
+;;; {R4RS compliance}
-;; {Simple Debugging Tools}
+(primitive-load-path "ice-9/r4rs.scm")
+
+
+;;; {Simple Debugging Tools}
;;
@@ -54,24 +66,22 @@
(lambda ()
(newline)
(display ";;; WARNING ")
- (print stuff)
+ (display stuff)
(newline)
(car (last-pair stuff)))))
-;;; {apply and call-with-current-continuation}
+;;; {Trivial Functions}
;;;
-;;; These turn syntax, @apply and @call-with-current-continuation,
-;;; into procedures.
-;;;
-
-(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
-(define (call-with-current-continuation proc) (@call-with-current-continuation proc))
+(define (id x) x)
+(define (1+ n) (+ n 1))
+(define (-1+ n) (+ n -1))
+(define 1- -1+)
+(define return-it noop)
+(define (and=> value procedure) (and value (procedure value)))
+(define (make-hash-table k) (make-vector k '()))
-
-;;; {apply-to-args}
-;;;
;;; apply-to-args is functionally redunant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
;;;
@@ -87,28 +97,9 @@
(define (apply-to-args args fn) (apply fn args))
-;;; {Silly Naming Cleanups and Trivial Functions}
-;;;
-
-(define %open-file open-file)
-(define (id x) x)
-(define < <?)
-(define <= <=?)
-(define = =?)
-(define > >?)
-(define >= >=?)
-(define (1+ n) (+ n 1))
-(define (-1+ n) (+ n -1))
-(define 1- -1+)
-(define return-it noop)
-(define (and=> value thunk) (and value (thunk value)))
-(define (make-hash-table k) (make-vector k '()))
-
;;; {Integer Math}
;;;
-(define (integer? x) (and (number? x) (= x (inexact->exact x))))
-
(define (ipow-by-squaring x k acc proc)
(cond ((zero? k) acc)
((= 1 k) (proc acc x))
@@ -131,102 +122,6 @@
(else (apply logior args))))
-;;; {Basic Port Code}
-;;;
-;;; Specificly, the parts of the low-level port code that are written in
-;;; Scheme rather than C.
-;;;
-;;; WARNING: the parts of this interface that refer to file ports
-;;; is going away. It would be gone already except that it is used
-;;; "internally" in a few places.
-;;;
-
-
-;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
-;; mode to open files in. MSDOS does carraige return - newline
-;; translation if not opened in `b' mode.
-;;
-(define OPEN_READ (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "rb")
- (else "r")))
-(define OPEN_WRITE (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "wb")
- (else "w")))
-(define OPEN_BOTH (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "r+b")
- (else "r+")))
-
-(define (open-input-file str)
- (or (open-file str OPEN_READ)
- (error "OPEN-INPUT-FILE couldn't find file " str)))
-
-(define (open-output-file str)
- (or (open-file str OPEN_WRITE)
- (error "OPEN-OUTPUT-FILE couldn't find file " str)))
-
-(define (open-io-file str) (open-file str OPEN_BOTH))
-(define close-input-port close-port)
-(define close-output-port close-port)
-(define close-io-port close-port)
-
-(define (call-with-input-file str proc)
- (let* ((file (open-input-file str))
- (ans (proc file)))
- (close-input-port file)
- ans))
-
-(define (call-with-output-file str proc)
- (let* ((file (open-output-file str))
- (ans (proc file)))
- (close-output-port file)
- ans))
-
-(define (with-input-from-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-output-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-error-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-input-from-file file thunk)
- (let* ((nport (open-input-file file))
- (ans (with-input-from-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-output-to-file file thunk)
- (let* ((nport (open-output-file file))
- (ans (with-output-to-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-error-to-file file thunk)
- (let* ((nport (open-output-file file))
- (ans (with-error-to-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-input-from-string string thunk)
- (call-with-input-string string
- (lambda (p) (with-input-from-port p thunk))))
-
-(define (with-output-to-string thunk)
- (call-with-output-string
- (lambda (p) (with-output-to-port p thunk))))
-
-(define (with-error-to-string thunk)
- (call-with-output-string
- (lambda (p) (with-error-to-port p thunk))))
-
-(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
-
-
-
;;; {Symbol Properties}
;;;
@@ -246,6 +141,122 @@
(symbol-pset! sym (delq! pair (symbol-pref sym))))))
+
+;;; {Line and Delimited I/O}
+
+;;; corresponds to SCM_LINE_INCREMENTORS in libguile.
+(define scm-line-incrementors "\n")
+
+(define (read-line! string . maybe-port)
+ (let* ((port (if (pair? maybe-port)
+ (car maybe-port)
+ (current-input-port))))
+ (let* ((rv (%read-delimited! scm-line-incrementors
+ string
+ #t
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((and (= nchars 0)
+ (eof-object? terminator))
+ terminator)
+ ((not terminator) #f)
+ (else nchars)))))
+
+(define (read-delimited! delims buf . args)
+ (let* ((num-args (length args))
+ (port (if (> num-args 0)
+ (car args)
+ (current-input-port)))
+ (handle-delim (if (> num-args 1)
+ (cadr args)
+ 'trim))
+ (start (if (> num-args 2)
+ (caddr args)
+ 0))
+ (end (if (> num-args 3)
+ (cadddr args)
+ (string-length buf))))
+ (let* ((rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port
+ start
+ end))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((or (not terminator) ; buffer filled
+ (eof-object? terminator))
+ (if (zero? nchars)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons nchars terminator)
+ nchars)))
+ (else
+ (case handle-delim
+ ((trim peek) nchars)
+ ((concat) (string-set! buf nchars terminator)
+ (+ nchars 1))
+ ((split) (cons nchars terminator))
+ (else (error "unexpected handle-delim value: "
+ handle-delim))))))))
+
+(define (read-delimited delims . args)
+ (let* ((port (if (pair? args)
+ (let ((pt (car args)))
+ (set! args (cdr args))
+ pt)
+ (current-input-port)))
+ (handle-delim (if (pair? args)
+ (car args)
+ 'trim)))
+ (let loop ((substrings ())
+ (total-chars 0)
+ (buf-size 100)) ; doubled each time through.
+ (let* ((buf (make-string buf-size))
+ (rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv))
+ (join-substrings
+ (lambda ()
+ (apply string-append
+ (reverse
+ (cons (if (and (eq? handle-delim 'concat)
+ (not (eof-object? terminator)))
+ (string terminator)
+ "")
+ (cons (make-shared-substring buf 0 nchars)
+ substrings))))))
+ (new-total (+ total-chars nchars)))
+ (cond ((not terminator)
+ ;; buffer filled.
+ (loop (cons (substring buf 0 nchars) substrings)
+ new-total
+ (* buf-size 2)))
+ ((eof-object? terminator)
+ (if (zero? new-total)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons (join-substrings) terminator)
+ (join-substrings))))
+ (else
+ (case handle-delim
+ ((trim peek concat) (join-substrings))
+ ((split) (cons (join-substrings) terminator))
+ (else (error "unexpected handle-delim value: "
+ handle-delim)))))))))
+
+(define (read-line . args)
+ (apply read-delimited scm-line-incrementors args))
+
+
;;; {Arrays}
;;;
@@ -254,7 +265,7 @@
(define make-uniform-vector dimensions->uniform-array)
; (define uniform-vector-ref array-ref)
(define (uniform-vector-set! u i o)
- (uniform-vector-set1! u o i))
+ (uniform-array-set1! u o i))
(define uniform-vector-fill! array-fill!)
(define uniform-vector-read! uniform-array-read!)
(define uniform-vector-write uniform-array-write)
@@ -287,100 +298,6 @@
(and rem (pair? (cdr rem)) (cadr rem))))
-
-;;; {Print}
-;;;
-
-(define (print obj . args)
- (let ((default-args (list (current-output-port) 0 0 default-print-style #f)))
- (apply-to-args (append args (list-cdr-ref default-args (length args)))
- (lambda (port depth length style table)
- (cond
- ((and table (print-table-ref table obj)) ((print-style-tag-hook style 'eq-val)
- obj port depth length style table))
- (else
- (and table (print-table-add! table obj))
- (cond
- ((print-style-max-depth? style depth) ((print-style-excess-depth-hook style)))
- ((print-style-max-length? style length) ((print-style-excess-length-hook style)))
- (else ((print-style-hook style obj)
- obj port depth length style table)))))))))
-
-(define (make-print-style) (make-vector 59))
-
-(define (extend-print-style! style utag printer) (hashq-set! style utag printer))
-
-(define (print-style-hook style obj)
- (let ((type-tag (tag obj)))
- (or (hashq-ref style type-tag)
- (hashq-ref style (logand type-tag 255))
- print-obj)))
-
-(define (print-style-tag-hook style type-tag)
- (or (hashq-ref style type-tag)
- print-obj))
-
-(define (print-style-max-depth? style d) #f)
-(define (print-style-max-length? style l) #f)
-(define (print-style-excess-length-hook style) (hashq-ref style 'excess-length-hook))
-(define (print-style-excess-depth-hook style) (hashq-ref style 'excess-depth-hook))
-
-(define (make-print-table) (make-vector 59))
-(define (print-table-ref table obj) (hashq-ref table obj))
-(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref)))
-
-(define (print-obj obj port depth length style table) (write obj port))
-
-(define (print-pair pair port depth length style table)
- (if (= 0 length)
- (display #\( port))
-
- (print (car pair) port (+ 1 depth) 0 style table)
-
- (cond
- ((and (pair? (cdr pair))
- (or (not table)
- (not (print-table-ref table (cdr pair)))))
-
- (display #\space port)
- (print (cdr pair) port depth (+ 1 length) style table))
-
- ((null? (cdr pair)) (display #\) port))
-
- (else (display " . " port)
- (print (cdr pair) port (+ 1 depth) 0 style table)
- (display #\) port))))
-
-(define (print-vector obj port depth length style table)
- (if (= 0 length)
- (cond
- ((weak-hash-table? obj) (display "#wh(" port))
- ((weak-value-hash-table? obj) (display "#whv(" port))
- ((doubly-weak-hash-table? obj) (display "#whd(" port))
- (else (display "#(" port))))
-
- (if (< length (vector-length obj))
- (print (vector-ref obj length) port (+ 1 depth) 0 style table))
-
- (cond
- ((>= (+ 1 length) (vector-length obj)) (display #\) port))
- (else (display #\space port)
- (print obj port depth (+ 1 length) style table))))
-
-(define default-print-style (make-print-style))
-
-(extend-print-style! default-print-style utag_vector print-vector)
-(extend-print-style! default-print-style utag_wvect print-vector)
-(extend-print-style! default-print-style utag_pair print-pair)
-(extend-print-style! default-print-style 'eq-val
- (lambda (obj port depth length style table)
- (if (symbol? obj)
- (display obj)
- (begin
- (display "##" port)
- (display (print-table-ref table obj))))))
-
-
;;; {Records}
;;;
@@ -390,16 +307,20 @@
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
(define (make-record-type type-name fields . opt)
- (let ((printer-fn (and opt (car opt))))
+ (let ((printer-fn (and (pair? opt) (car opt))))
(let ((struct (make-struct record-type-vtable 0
- (make-struct-layout (apply symbol-append (map (lambda (f) "pw") fields)))
+ (make-struct-layout
+ (apply symbol-append
+ (map (lambda (f) "pw") fields)))
type-name
(copy-tree fields))))
;; !!! leaks printer functions
- (if printer-fn
- (extend-print-style! default-print-style
- (logior utag_struct_base (ash (struct-vtable-tag struct) 8))
- printer-fn))
+ ;; MDJ 960919 <djurfeldt@nada.kth.se>: *fixme* need to make it
+ ;; possible to print records nicely.
+ ;(if printer-fn
+; (extend-print-style! default-print-style
+; (logior utag_struct_base (ash (struct-vtable-tag struct) 8))
+; printer-fn))
struct)))
(define (record-type-name obj)
@@ -413,7 +334,7 @@
(error 'not-a-record-type obj)))
(define (record-constructor rtd . opt)
- (let ((field-names (if opt (car opt) (record-type-fields rtd))))
+ (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
(eval `(lambda ,field-names
(make-struct ',rtd 0 ,@(map (lambda (f)
(if (memq f field-names)
@@ -449,6 +370,8 @@
(struct-vtable obj)
(error 'not-a-record obj)))
+(provide 'record)
+
;;; {Booleans}
;;;
@@ -548,19 +471,69 @@
(map-in-order fn (cdr l)))))
+;;; {Hooks}
+(define (run-hooks hook)
+ (for-each (lambda (thunk) (thunk)) hook))
+
+(define add-hook!
+ (procedure->macro
+ (lambda (exp env)
+ `(let ((thunk ,(caddr exp)))
+ (if (not (memq thunk ,(cadr exp)))
+ (set! ,(cadr exp)
+ (cons thunk ,(cadr exp))))))))
+
+
;;; {Files}
;;; !!!! these should be implemented using Tcl commands, not fports.
;;;
-(define (file-exists? str)
- (let ((port (open-file str OPEN_READ)))
- (if port (begin (close-port port) #t)
- #f)))
-
-(define (file-is-directory? str)
- (let ((port (open-file (string-append str "/.") OPEN_READ)))
- (if port (begin (close-port port) #t)
- #f)))
+(define (feature? feature)
+ (and (memq feature *features*) #t))
+
+;; Using the vector returned by stat directly is probably not a good
+;; idea (it could just as well be a record). Hence some accessors.
+(define (stat:dev f) (vector-ref f 0))
+(define (stat:ino f) (vector-ref f 1))
+(define (stat:mode f) (vector-ref f 2))
+(define (stat:nlink f) (vector-ref f 3))
+(define (stat:uid f) (vector-ref f 4))
+(define (stat:gid f) (vector-ref f 5))
+(define (stat:rdev f) (vector-ref f 6))
+(define (stat:size f) (vector-ref f 7))
+(define (stat:atime f) (vector-ref f 8))
+(define (stat:mtime f) (vector-ref f 9))
+(define (stat:ctime f) (vector-ref f 10))
+(define (stat:blksize f) (vector-ref f 11))
+(define (stat:blocks f) (vector-ref f 12))
+
+;; derived from stat mode.
+(define (stat:type f) (vector-ref f 13))
+(define (stat:perms f) (vector-ref f 14))
+
+(define file-exists?
+ (if (feature? 'posix)
+ (lambda (str)
+ (access? str F_OK))
+ (lambda (str)
+ (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
+
+(define file-is-directory?
+ (if (feature? 'i/o-extensions)
+ (lambda (str)
+ (eq? (stat:type (stat str)) 'directory))
+ (lambda (str)
+ (display str)
+ (newline)
+ (let ((port (catch 'system-error
+ (lambda () (open-file (string-append str "/.")
+ OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
(define (has-suffix? str suffix)
(let ((sufl (string-length suffix))
@@ -568,89 +541,61 @@
(and (> sl sufl)
(string=? (substring str (- sl sufl) sl) suffix))))
-
-
;;; {Error Handling}
;;;
-
-;; (error . args) is short for (throw (quote error) . args)
-;;
(define (error . args)
- (apply throw 'error args))
-
-
-
-
-;; Error handling a la SCM.
-;;
-(define (%%default-error-handler tag . args)
- (define cep (current-error-port))
- (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)
- (force-output cep)
- (apply throw 'abort tag args))
-
-
-
-;; Install SCM error handling as the default.
-;;
-(set-symbol-property! 'error
- 'throw-handler-default
- %%default-error-handler)
-
-
-
-
-
-;; %%bad-throw is the hook that is called upon a throw to a an unhandled
-;; key. If the key has a default handler (a throw-handler-default property),
+ (save-stack)
+ (if (null? args)
+ (scm-error 'misc-error #f "?" #f #f)
+ (let loop ((msg "%s")
+ (rest (cdr args)))
+ (if (not (null? rest))
+ (loop (string-append msg " %S")
+ (cdr rest))
+ (scm-error 'misc-error #f msg args #f)))))
+
+;; bad-throw is the hook that is called upon a throw to a an unhandled
+;; key (unless the throw has four arguments, in which case
+;; it's usually interpreted as an error throw.)
+;; If the key has a default handler (a throw-handler-default property),
;; it is applied to the throw.
;;
-(define (%%bad-throw key . args)
+(define (bad-throw key . args)
(let ((default (symbol-property key 'throw-handler-default)))
(or (and default (apply default key args))
- (throw 'error 'unhandled-exception key args))))
+ (apply error "unhandled-exception:" key args))))
-
-
-
-
-;; A number of internally defined error types are represented
+;; mostly obsolete.
+;; A number of internally defined error types were represented
;; as integers. Here is the mapping to symbolic names
;; and error messages.
;;
-(define %%system-errors
- '((-1 UNKNOWN "Unknown error")
- (0 ARGn "Wrong type argument to ")
- (1 ARG1 "Wrong type argument in position 1 to ")
- (2 ARG2 "Wrong type argument in position 2 to ")
- (3 ARG3 "Wrong type argument in position 3 to ")
- (4 ARG4 "Wrong type argument in position 4 to ")
- (5 ARG5 "Wrong type argument in position 5 to ")
- (6 ARG5 "Wrong type argument in position 5 to ")
- (7 ARG5 "Wrong type argument in position 5 to ")
- (8 WNA "Wrong number of arguments to ")
- (9 OVFLOW "Numerical overflow to ")
- (10 OUTOFRANGE "Argument out of range to ")
- (11 NALLOC "Could not allocate to ")
- (12 STACK_OVFLOW "Stack overflow")
- (13 EXIT "Exit (internal error?).")
- (14 HUP_SIGNAL "hang-up")
- (15 INT_SIGNAL "user interrupt")
- (16 FPE_SIGNAL "arithmetic error")
- (17 BUS_SIGNAL "bus error")
- (18 SEGV_SIGNAL "segmentation violation")
- (19 ALRM_SIGNAL "alarm")
- (20 GC_SIGNAL "gc")
- (21 TICK_SIGNAL "tick")))
+;(define %%system-errors
+; '((-1 UNKNOWN "Unknown error")
+; (0 ARGn "Wrong type argument to ")
+; (1 ARG1 "Wrong type argument in position 1 to ")
+; (2 ARG2 "Wrong type argument in position 2 to ")
+; (3 ARG3 "Wrong type argument in position 3 to ")
+; (4 ARG4 "Wrong type argument in position 4 to ")
+; (5 ARG5 "Wrong type argument in position 5 to ")
+; (6 ARG5 "Wrong type argument in position 5 to ")
+; (7 ARG5 "Wrong type argument in position 5 to ")
+; (8 WNA "Wrong number of arguments to ")
+; (9 OVFLOW "Numerical overflow to ")
+; (10 OUTOFRANGE "Argument out of range to ")
+; (11 NALLOC "Could not allocate to ")
+; (12 STACK_OVFLOW "Stack overflow")
+; (13 EXIT "Exit (internal error?).")
+; (14 HUP_SIGNAL "hang-up")
+; (15 INT_SIGNAL "user interrupt")
+; (16 FPE_SIGNAL "arithmetic error")
+; (17 BUS_SIGNAL "bus error")
+; (18 SEGV_SIGNAL "segmentation violation")
+; (19 ALRM_SIGNAL "alarm")
+; (20 GC_SIGNAL "gc")
+; (21 TICK_SIGNAL "tick")))
(define (timer-thunk) #t)
@@ -658,333 +603,186 @@
(define (alarm-thunk) #t)
(define (signal-handler n)
- (cond
- ((= n 21) (unmask-signals) (timer-thunk))
- ((= n 20) (unmask-signals) (gc-thunk))
- ((= n 19) (unmask-signals) (alarm-thunk))
- (else (unmask-signals) (throw '%%system-error n #f))))
-
-
-;; The default handler for built-in error types when
-;; thrown by their symbolic name. The action is to
-;; convert the error into a generic error, building
-;; a descriptive message for the error.
-;;
-(define (%%handle-system-error ignored desc proc . args)
- (let* ((b (assoc desc %%system-errors))
- (msghead (cond
- (b (caddr b))
- ((or (symbol? desc) (string? desc))
- (string-append desc " "))
- (#t "Unknown error")))
- (msg (if (symbol? proc)
- (string-append msghead proc ":")
- msghead))
- (rest (if (and proc (not (symbol? proc)))
- (cons proc args)
- args))
- (fixed-args (cons msg rest)))
- (apply error fixed-args)))
-
-
-(set-symbol-property! '%%system-error
- 'throw-handler-default
- %%handle-system-error)
-
-
-;; Install default handlers for built-in errors.
-;;
-(map (lambda (err)
- (set-symbol-property! (cadr err)
- 'throw-handler-default
- %%handle-system-error))
- (cdr %%system-errors))
-
-
-
-
-(define ((make-simple-wrapper func) . args)
- (or (apply func args)
- (apply throw 'syserror func (errno) args)))
-
-(define ((make-eof-wrapper func) . args)
- (let ((rv (apply func args)))
- (if (eof-object? rv)
- (apply throw 'syserror func (errno) args)
- rv)))
-
-(define ((make-errno-wrapper func) . args)
- (let ((rv (apply func args)))
- (if (number? rv)
- (apply throw 'syserror func rv args)
- rv)))
-
-(define ((make-errpair-wrapper func) . args)
- (let ((rv (apply func args)))
- (if (and (pair? rv)
- (number? (car rv))
- (null? (cdr rv)))
- (apply throw 'syserror func (car rv) args)
- rv)))
-
-(begin
- (define (syserror key fn err . args)
- (errno err)
- (apply error (cons fn args)))
- (set-symbol-property! 'syserror 'throw-handler-default syserror))
-
-
-(define (%getgrnam name) (%getgr name))
-(define (%getgrgid id) (%getgr id))
-(define (%gethostbyaddr addr) (%gethost addr))
-(define (%gethostbyname name) (%gethost name))
-(define (%getnetbyaddr addr) (%getnet addr))
-(define (%getnetbyname name) (%getnet name))
-(define (%getprotobyname name) (%getproto name))
-(define (%getprotobynumber addr) (%getproto addr))
-(define (%getpwnam name) (%getpw name))
-(define (%getpwuid uid) (%getpw uid))
-(define (%getservbyname name proto) (%getserv name proto))
-(define (%getservbyport port proto) (%getserv port proto))
+ (let* (
+ ;; these numbers are set in libguile, not the same as those
+ ;; interned in posix.c for SIGSEGV etc.
+ ;;
+ (signal-messages `((14 . "hang-up")
+ (15 . "user interrupt")
+ (16 . "arithmetic error")
+ (17 . "bus error")
+ (18 . "segmentation violation"))))
+ (cond
+ ((= n 21) (unmask-signals) (timer-thunk))
+ ((= n 20) (unmask-signals) (gc-thunk))
+ ((= n 19) (unmask-signals) (alarm-thunk))
+ (else (set! the-last-stack
+ (make-stack #t
+ (list-ref (list %hup-thunk
+ %int-thunk
+ %fpe-thunk
+ %bus-thunk
+ %segv-thunk)
+ (- n 14))
+ 1))
+ (set! stack-saved? #t)
+ (if (not (and (memq 'debug (debug-options-interface))
+ (eq? (stack-id the-last-stack) 'repl-stack)))
+ (set! the-last-stack #f))
+ (unmask-signals)
+ (let ((sig-pair (assoc n signal-messages)))
+ (scm-error 'error-signal #f
+ (cdr (or sig-pair
+ (cons n "Unknown signal: %s")))
+ (if sig-pair
+ #f
+ (list n))
+ (list n)))))))
+
+
+;;; {Non-polymorphic versions of POSIX functions}
+
+(define (getgrnam name) (getgr name))
+(define (getgrgid id) (getgr id))
+(define (gethostbyaddr addr) (gethost addr))
+(define (gethostbyname name) (gethost name))
+(define (getnetbyaddr addr) (getnet addr))
+(define (getnetbyname name) (getnet name))
+(define (getprotobyname name) (getproto name))
+(define (getprotobynumber addr) (getproto addr))
+(define (getpwnam name) (getpw name))
+(define (getpwuid uid) (getpw uid))
+(define (getservbyname name proto) (getserv name proto))
+(define (getservbyport port proto) (getserv port proto))
(define (endgrent) (setgr))
(define (endhostent) (sethost))
(define (endnetent) (setnet))
(define (endprotoent) (setproto))
(define (endpwent) (setpw))
(define (endservent) (setserv))
+(define (getgrent) (getgr))
+(define (gethostent) (gethost))
+(define (getnetent) (getnet))
+(define (getprotoent) (getproto))
+(define (getpwent) (getpw))
+(define (getservent) (getserv))
+(define (reopen-file . args) (apply freopen args))
+(define (setgrent) (setgr #f))
+(define (sethostent) (sethost #t))
+(define (setnetent) (setnet #t))
+(define (setprotoent) (setproto #t))
+(define (setpwent) (setpw #t))
+(define (setservent) (setserv #t))
+
+(define (passwd:name obj) (vector-ref obj 0))
+(define (passwd:passwd obj) (vector-ref obj 1))
+(define (passwd:uid obj) (vector-ref obj 2))
+(define (passwd:gid obj) (vector-ref obj 3))
+(define (passwd:gecos obj) (vector-ref obj 4))
+(define (passwd:dir obj) (vector-ref obj 5))
+(define (passwd:shell obj) (vector-ref obj 6))
+
+(define (group:name obj) (vector-ref obj 0))
+(define (group:passwd obj) (vector-ref obj 1))
+(define (group:gid obj) (vector-ref obj 2))
+(define (group:mem obj) (vector-ref obj 3))
+
+(define (hostent:name obj) (vector-ref obj 0))
+(define (hostent:aliases obj) (vector-ref obj 1))
+(define (hostent:addrtype obj) (vector-ref obj 2))
+(define (hostent:length obj) (vector-ref obj 3))
+(define (hostent:addr-list obj) (vector-ref obj 4))
+
+(define (netent:name obj) (vector-ref obj 0))
+(define (netent:aliases obj) (vector-ref obj 1))
+(define (netent:addrtype obj) (vector-ref obj 2))
+(define (netent:net obj) (vector-ref obj 3))
+
+(define (protoent:name obj) (vector-ref obj 0))
+(define (protoent:aliases obj) (vector-ref obj 1))
+(define (protoent:proto obj) (vector-ref obj 2))
+
+(define (servent:name obj) (vector-ref obj 0))
+(define (servent:aliases obj) (vector-ref obj 1))
+(define (servent:port obj) (vector-ref obj 2))
+(define (servent:proto obj) (vector-ref obj 3))
+
+(define (sockaddr:fam obj) (vector-ref obj 0))
+(define (sockaddr:path obj) (vector-ref obj 1))
+(define (sockaddr:addr obj) (vector-ref obj 1))
+(define (sockaddr:port obj) (vector-ref obj 2))
+
+(define (utsname:sysname obj) (vector-ref obj 0))
+(define (utsname:nodename obj) (vector-ref obj 1))
+(define (utsname:release obj) (vector-ref obj 2))
+(define (utsname:version obj) (vector-ref obj 3))
+(define (utsname:machine obj) (vector-ref obj 4))
+
+(define (tm:sec obj) (vector-ref obj 0))
+(define (tm:min obj) (vector-ref obj 1))
+(define (tm:hour obj) (vector-ref obj 2))
+(define (tm:mday obj) (vector-ref obj 3))
+(define (tm:mon obj) (vector-ref obj 4))
+(define (tm:year obj) (vector-ref obj 5))
+(define (tm:wday obj) (vector-ref obj 6))
+(define (tm:yday obj) (vector-ref obj 7))
+(define (tm:isdst obj) (vector-ref obj 8))
+(define (tm:gmtoff obj) (vector-ref obj 9))
+(define (tm:zone obj) (vector-ref obj 10))
+
+(define (set-tm:sec obj val) (vector-set! obj 0 val))
+(define (set-tm:min obj val) (vector-set! obj 1 val))
+(define (set-tm:hour obj val) (vector-set! obj 2 val))
+(define (set-tm:mday obj val) (vector-set! obj 3 val))
+(define (set-tm:mon obj val) (vector-set! obj 4 val))
+(define (set-tm:year obj val) (vector-set! obj 5 val))
+(define (set-tm:wday obj val) (vector-set! obj 6 val))
+(define (set-tm:yday obj val) (vector-set! obj 7 val))
+(define (set-tm:isdst obj val) (vector-set! obj 8 val))
+(define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
+(define (set-tm:zone obj val) (vector-set! obj 10 val))
+
(define (file-position . args) (apply ftell args))
(define (file-set-position . args) (apply fseek args))
-(define (getgrent) (%getgr))
-(define (gethostent) (%gethost))
-(define (getnetent) (%getnet))
-(define (getprotoent) (%getproto))
-(define (getpwent) (%getpw))
-(define (getservent) (%getserv))
-(define (reopen-file . args) (apply freopen args))
-(define (setgrent arg) (setgr arg))
-(define (sethostent arg) (sethost arg))
-(define (setnetent arg) (setnet arg))
-(define (setprotoent arg) (setproto arg))
-(define (setpwent arg) (setpw arg))
-(define (setservent arg) (setserv arg))
-(define (%move->fdes port fd)
- (if (= 1 (primitive-move->fdes port fd))
- (set-port-revealed! port 1)
- #t))
-
-(define accept (make-errno-wrapper %accept))
-(define bind (make-errno-wrapper %bind))
-(define chdir (make-errno-wrapper %chdir))
-(define chmod (make-errno-wrapper %chmod))
-(define chown (make-errno-wrapper %chown))
-(define close (make-errno-wrapper %close))
-(define closedir (make-errno-wrapper %closedir))
-(define connect (make-errno-wrapper %connect))
-(define copy-file (make-simple-wrapper %copy-file))
-(define ctermid (make-simple-wrapper %ctermid))
-(define delete-file (make-errno-wrapper %delete-file))
-(define duplicate-port (make-simple-wrapper %duplicate-port))
-(define execl (make-errno-wrapper %execl))
-(define execlp (make-errno-wrapper %execlp))
-(define fdopen (make-errno-wrapper %fdopen))
-(define fileno (make-simple-wrapper %fileno))
-(define fork (make-simple-wrapper %fork))
-(define freopen (make-errno-wrapper %freopen))
-(define fseek (make-errno-wrapper %fseek))
-(define ftell (make-errno-wrapper %ftell))
-(define getcwd (make-errno-wrapper %getcwd))
-(define getenv (make-simple-wrapper %getenv))
-(define getgrgid (make-errno-wrapper %getgrgid))
-(define getgrnam (make-errno-wrapper %getgrnam))
-(define getgroups (make-errno-wrapper %getgroups))
-(define gethostbyaddr (make-simple-wrapper %gethostbyaddr))
-(define gethost (make-simple-wrapper %gethost))
-(define gethostbyname (make-simple-wrapper %gethostbyname))
-(define getnetbyaddr (make-simple-wrapper %getnetbyaddr))
-(define getnetbyname (make-simple-wrapper %getnetbyname))
-(define getpeername (make-errno-wrapper %getpeername))
-(define getprotobyname (make-simple-wrapper %getprotobyname))
-(define getprotobynumber (make-simple-wrapper %getprotobynumber))
-(define getpwnam (make-simple-wrapper %getpwnam))
-(define getpwuid (make-simple-wrapper %getpwuid))
-(define getservbyname (make-simple-wrapper %getservbyname))
-(define getservbyport (make-simple-wrapper %getservbyport))
-(define getsockname (make-errno-wrapper %getsockname))
-(define getsockopt (make-errpair-wrapper %getsockopt))
-(define inet-aton (make-simple-wrapper %inet-aton))
-(define isatty? (make-errno-wrapper %isatty?))
-(define kill (make-errno-wrapper %kill))
-(define link (make-errno-wrapper %link))
-(define listen (make-errno-wrapper %listen))
-(define lstat (make-errno-wrapper %lstat))
-(define mkdir (make-errno-wrapper %mkdir))
-(define mknod (make-errno-wrapper %mknod))
-(define nice (make-errno-wrapper %nice))
-(define opendir (make-errno-wrapper %opendir))
-(define pipe (make-errno-wrapper %pipe))
-(define primitive-move->fdes (make-simple-wrapper %primitive-move->fdes))
-(define putenv (make-errno-wrapper %putenv))
-(define read-fd (make-errpair-wrapper %read-fd))
-(define readdir (make-errno-wrapper %readdir))
-(define readlink (make-errno-wrapper %readlink))
-(define recv (make-errno-wrapper %recv))
-(define recvfrom (make-errno-wrapper %recvfrom))
-(define redirect-port (make-errno-wrapper %redirect-port))
-(define rename-file (make-errno-wrapper %rename-file))
-(define rmdir (make-errno-wrapper %rmdir))
-(define select (make-errno-wrapper %select))
-(define send (make-errpair-wrapper %send))
-(define sendto (make-errpair-wrapper %sendto))
-(define setegid (make-errno-wrapper %setegid))
-(define seteuid (make-errno-wrapper %seteuid))
-(define setgid (make-errno-wrapper %setgid))
-(define setlocale (make-errno-wrapper %setlocale))
-(define setpgid (make-errno-wrapper %setpgid))
-(define setsid (make-simple-wrapper %setsid))
-(define setsockopt (make-errno-wrapper %setsockopt))
-(define setuid (make-errno-wrapper %setuid))
-(define shutdown (make-errno-wrapper %shutdown))
-(define socket (make-errno-wrapper %socket))
-(define socketpair (make-errno-wrapper %socketpair))
-(define stat (make-errno-wrapper %stat))
-(define strptime (make-simple-wrapper %strptime))
-(define symlink (make-simple-wrapper %symlink))
-(define tcgetpgrp (make-simple-wrapper %tcgetpgrp))
-(define tcsetpgrp (make-simple-wrapper %tcsetpgrp))
-(define ttyname (make-errno-wrapper %ttyname))
-(define uname (make-errno-wrapper %uname))
-(define utime (make-errno-wrapper %utime))
-(define waitpid (make-errno-wrapper %waitpid))
-(define write-fd (make-errpair-wrapper %write-fd))
-(define move->fdes (make-simple-wrapper %move->fdes))
+
+(define (open-input-pipe command) (open-pipe command OPEN_READ))
+(define (open-output-pipe command) (open-pipe command OPEN_WRITE))
+
+(define (move->fdes port fd)
+ (primitive-move->fdes port fd)
+ (set-port-revealed! port 1)
+ port)
+
+(define (release-port-handle port)
+ (let ((revealed (port-revealed port)))
+ (if (> revealed 0)
+ (set-port-revealed! port (- revealed 1)))))
;;; {Load Paths}
;;;
-(define implementation-vicinity compiled-library-path)
-
;;; Here for backward compatability
;;
(define scheme-file-suffix (lambda () ".scm"))
-(define in-vicinity string-append)
-
-(define (parse-path env_path)
- (cond ((string? env_path)
- (let loop ((curdir "") (env env_path) (path '()))
- (cond ((= (string-length env) 0)
- (if (> (string-length curdir) 0)
- (append path (list curdir))
- path))
- ((char=? (string-ref env 0) #\:)
- (loop ""
- (substring env 1 (string-length env))
- (append path (list curdir))))
- (#t
- (loop (string-append curdir (substring env 0 1))
- (substring env 1 (string-length env))
- path)))))
- (#t '())))
-
-(define %load-path (append (parse-path (%getenv "SCHEME_LOAD_PATH"))
- (list ""
- (in-vicinity (implementation-vicinity) "gls/guile/")
- (in-vicinity (implementation-vicinity) "gls/")
- (in-vicinity (implementation-vicinity) "slib/"))))
-
-;;; {try-load}
-;;;
-
-(define (try-load-with-path file-name path)
- (or-map (lambda (d)
- (let ((f (in-vicinity d file-name)))
- (and (not (file-is-directory? f))
- (%try-load f #t read-sharp))))
- path))
+(define (in-vicinity vicinity file)
+ (let ((tail (let ((len (string-length vicinity)))
+ (if (zero? len) #f
+ (string-ref vicinity (- len 1))))))
+ (string-append vicinity
+ (if (eq? tail #\/) "" "/")
+ file)))
-(define (try-load name)
- (if (eval '(defined? %load-path))
- (try-load-with-path name (eval '%load-path))
- (%try-load name #t read-sharp)))
-;;; {Load}
-;;;
-
-(define %load-verbosely #t)
-(define (assert-load-verbosity v) (set! %load-verbosely v))
-(define %load-indent -2)
-
-(define (%load f)
- (current-module)
- (or (and (not (file-is-directory? f))
- (%try-load f #t read-sharp))
- (and (not (has-suffix? f (scheme-file-suffix)))
- (%try-load (string-append f (scheme-file-suffix)) #t read-sharp))))
-
-(define (%load-announce file)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display (make-string %load-indent #\ ))
- (display "loading ")
- (display file)
- (display "...")
- (newline)
- (force-output)))))
-
-(define (%load-announce-win file)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display (make-string %load-indent #\ ))
- (display "...loaded ")
- (display file)
- (display ".")
- (newline)
- (force-output)))))
-
-(define (%load-announce-lossage file path)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display (make-string %load-indent #\ ))
- (display "...COULD NOT LOAD ")
- (display file)
- (display " from ")
- (write path)
- (newline)
- (force-output))))
- (throw 'could-not-load file path))
-
-
-(define (load-with-path name path)
- (define (do-load)
- (%load-announce name)
- (if (not (or-map (lambda (d)
- (if (%load (in-vicinity d name))
- (begin
- (%load-announce-win (in-vicinity d name))
- #t)
- #f))
- path))
- (%load-announce-lossage name path)))
-
- (let ((indent %load-indent))
- (dynamic-wind
- (lambda () (set! %load-indent (modulo (+ indent 2) 16)))
- do-load
- (lambda () (set! %load-indent indent))))
- #t)
-
-
-(define (load name)
- (if (eval '(defined? %load-path))
- (load-with-path name (eval '%load-path))
- (load-with-path name '())))
+;;; {Loading by paths}
+
+;;; Load a Scheme source file named NAME, searching for it in the
+;;; directories listed in %load-path, and applying each of the file
+;;; name extensions listed in %load-extensions.
+(define (load-from-path name)
+ (start-stack 'load-stack
+ (primitive-load-path name)))
@@ -1086,6 +884,9 @@
(set! abs magnitude)
+(define (log10 arg)
+ (/ (log arg) (log 10)))
+
;;; {User Settable Hooks}
;;;
@@ -1100,7 +901,6 @@
(define end-of-program #f)
(define hang-up #f)
(define arithmetic-error #f)
-(define read-sharp #f)
@@ -1111,7 +911,7 @@
;;;
(define (parse-path-symbol s)
- (define (seperate-fields-discarding-char ch str ret)
+ (define (separate-fields-discarding-char ch str ret)
(let loop ((fields '())
(str str))
(cond
@@ -1119,41 +919,68 @@
=> (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields)
(make-shared-substring str 0 pos))))
(else (ret (cons str fields))))))
- (seperate-fields-discarding-char #\/
+ (separate-fields-discarding-char #\/
s
(lambda (fields)
(map string->symbol fields))))
-(define (%read-sharp c port)
- (define (barf)
- (error "unknown # object" c))
-
- (case c
- ((#\/) (let ((look (peek-char port)))
- (if (or (eof-object? look)
- (and (char? look)
- (or (char-whitespace? look)
- (string-index ")" look))))
- '()
- (parse-path-symbol (read port #t read-sharp)))))
- ((#\') (read port #t read-sharp))
- ((#\.) (eval (read port #t read-sharp)))
- ((#\b) (read:uniform-vector #t port))
- ((#\a) (read:uniform-vector #\a port))
- ((#\u) (read:uniform-vector 1 port))
- ((#\e) (read:uniform-vector -1 port))
- ((#\s) (read:uniform-vector 1.0 port))
- ((#\i) (read:uniform-vector 1/3 port))
- ((#\c) (read:uniform-vector 0+i port))
- ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
- (read:array c port))
- ((#\!) (if (= 1 (line-number))
- (let skip () (if (eq? #\newline (peek-char port))
- (read port #t read-sharp)
- (begin (read-char port) (skip))))
- (barf)))
- (else (barf))))
+(read-hash-extend #\' (lambda (c port)
+ (read port)))
+(read-hash-extend #\. (lambda (c port)
+ (eval (read port))))
+
+(if (feature? 'array)
+ (begin
+ (let ((make-array-proc (lambda (template)
+ (lambda (c port)
+ (read:uniform-vector template port)))))
+ (for-each (lambda (char template)
+ (read-hash-extend char
+ (make-array-proc template)))
+ '(#\b #\a #\u #\e #\s #\i #\c)
+ '(#t #\a 1 -1 1.0 1/3 0+i)))
+ (let ((array-proc (lambda (c port)
+ (read:array c port))))
+ (for-each (lambda (char) (read-hash-extend char array-proc))
+ '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))))
+
+;; pushed to the beginning of the alist since it's used more than the
+;; others at present.
+(read-hash-extend #\/
+ (lambda (c port)
+ (let ((look (peek-char port)))
+ (if (or (eof-object? look)
+ (and (char? look)
+ (or (char-whitespace? look)
+ (string-index ")" look))))
+ '()
+ (parse-path-symbol (read port))))))
+
+;(define (read-sharp c port)
+; (define (barf)
+; (error "unknown # object" c))
+
+; (case c
+; ((#\/) (let ((look (peek-char port)))
+; (if (or (eof-object? look)
+; (and (char? look)
+; (or (char-whitespace? look)
+; (string-index ")" look))))
+; '()
+; (parse-path-symbol (read port #t read-sharp)))))
+; ((#\') (read port #t read-sharp))
+; ((#\.) (eval (read port #t read-sharp)))
+; ((#\b) (read:uniform-vector #t port))
+; ((#\a) (read:uniform-vector #\a port))
+; ((#\u) (read:uniform-vector 1 port))
+; ((#\e) (read:uniform-vector -1 port))
+; ((#\s) (read:uniform-vector 1.0 port))
+; ((#\i) (read:uniform-vector 1/3 port))
+; ((#\c) (read:uniform-vector 0+i port))
+; ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+; (read:array c port))
+; (else (barf))))
(define (read:array digit port)
(define chr0 (char->integer #\0))
@@ -1174,27 +1001,14 @@
((#\c) 0+i)
(else (error "read:array unknown option " c)))))))
(if (eq? (peek-char port) #\()
- (list->uniform-array rank prot (read port #t read-sharp))
+ (list->uniform-array rank prot (read port))
(error "read:array list not found"))))
(define (read:uniform-vector proto port)
(if (eq? #\( (peek-char port))
- (list->uniform-array 1 proto (read port #t read-sharp))
+ (list->uniform-array 1 proto (read port))
(error "read:uniform-vector list not found")))
-
-(define read-sharp (lambda a (apply %read-sharp a)))
-
-
-
-;;; {Dynamic Roots}
-;;;
-
-; mystery integers passed dynamic root error handlers
-(define repl-quit -1)
-(define repl-abort -2)
-
-
;;; {Command Line Options}
;;;
@@ -1284,15 +1098,6 @@
-(define (delq-all! obj l)
- (let ((answer (cons '() l)))
- (let loop ((pos answer))
- (cond
- ((null? (cdr pos)) (cdr answer))
- ((eq? (cadr pos) obj) (set-cdr! pos (cddr pos))
- (loop pos))
- (else (loop (cdr pos)))))))
-
(define (transform-usage-lambda cases)
(let* ((raw-usage (delq! 'else (map car cases)))
(usage-sans-specials (map (lambda (x)
@@ -1301,7 +1106,7 @@
(and (boolean? (car x)) #t)
x))
raw-usage))
- (usage-desc (delq-all! #t usage-sans-specials))
+ (usage-desc (delq! #t usage-sans-specials))
(kw-desc (map car usage-desc))
(kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
(kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
@@ -1359,8 +1164,8 @@
;;;
-;; This is how modules are printed.
-;; You can re-define it.
+;;; {Printing Modules}
+;; This is how modules are printed. You can re-define it.
;;
(define (%print-module mod port depth length style table)
(display "#<" port)
@@ -1379,85 +1184,74 @@
;; A module is characterized by an obarray in which local symbols
;; are interned, a list of modules, "uses", from which non-local
;; bindings can be inherited, and an optional lazy-binder which
-;; is a (THUNK module symbol) which, as a last resort, can provide
+;; is a (CLOSURE module symbol) which, as a last resort, can provide
;; bindings that would otherwise not be found locally in the module.
;;
(define module-type
- (make-record-type 'module '(obarray uses binder eval-thunk name kind) %print-module))
+ (make-record-type 'module '(obarray uses binder eval-closure name kind)
+ %print-module))
-;; make-module &opt size uses
+;; make-module &opt size uses binder
;;
-;; Create a new module, perhaps with a particular size of obarray
-;; or initial uses list.
+;; Create a new module, perhaps with a particular size of obarray,
+;; initial uses list, or binding procedure.
;;
-(define module-constructor (record-constructor module-type))
-
(define make-module
(lambda args
- (let* ((size 1021)
- (uses '())
- (binder #f)
- (answer #f)
- (eval-thunk
- (lambda (symbol define?)
- (if define?
- (module-make-local-var! answer symbol)
- (module-variable answer symbol)))))
-
- (if (> (length args) 0)
- (begin
- (set! size (or (car args) size))
- (set! args (cdr args))))
- (if (> (length args) 0)
- (begin
- (set! uses (or (car args) uses))
- (set! args (cdr args))))
+ (define (parse-arg index default)
+ (if (> (length args) index)
+ (list-ref args index)
+ default))
- (if (> (length args) 0)
- (begin
- (set! binder (or (car args) binder))
- (set! args (cdr args))))
+ (if (> (length args) 3)
+ (error "Too many args to make-module." args))
- (if (not (null? args))
- (error "Too many args to make-module." args))
+ (let ((size (parse-arg 0 1021))
+ (uses (parse-arg 1 '()))
+ (binder (parse-arg 2 #f)))
(if (not (integer? size))
(error "Illegal size to make-module." size))
-
- (and (list? uses)
- (or (and-map module? uses)
- (error "Incorrect use list." uses)))
-
+ (if (not (and (list? uses)
+ (and-map module? uses)))
+ (error "Incorrect use list." uses))
(if (and binder (not (procedure? binder)))
(error
"Lazy-binder expected to be a procedure or #f." binder))
- (set! answer
- (module-constructor (make-vector size '())
- uses
- binder
- eval-thunk
- #f
- #f))
- answer)))
+ (let ((module (module-constructor (make-vector size '())
+ uses binder #f #f #f)))
+ ;; We can't pass this as an argument to module-constructor,
+ ;; because we need it to close over a pointer to the module
+ ;; itself.
+ (set-module-eval-closure! module
+ (lambda (symbol define?)
+ (if define?
+ (module-make-local-var! module symbol)
+ (module-variable module symbol))))
+
+ module))))
+
+(define module-constructor (record-constructor module-type))
(define module-obarray (record-accessor module-type 'obarray))
(define set-module-obarray! (record-modifier module-type 'obarray))
(define module-uses (record-accessor module-type 'uses))
(define set-module-uses! (record-modifier module-type 'uses))
(define module-binder (record-accessor module-type 'binder))
(define set-module-binder! (record-modifier module-type 'binder))
-(define module-eval-thunk (record-accessor module-type 'eval-thunk))
-(define set-module-eval-thunk! (record-modifier module-type 'eval-thunk))
+(define module-eval-closure (record-accessor module-type 'eval-closure))
+(define set-module-eval-closure! (record-modifier module-type 'eval-closure))
(define module-name (record-accessor module-type 'name))
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define set-module-kind! (record-modifier module-type 'kind))
(define module? (record-predicate module-type))
+
(define (eval-in-module exp module)
- (eval2 exp (module-eval-thunk module)))
+ (eval2 exp (module-eval-closure module)))
;;; {Module Searching in General}
@@ -1581,12 +1375,13 @@
;;; If the symbol is not found at all, return #f.
;;;
(define (module-local-variable m v)
- (caddr
- (list m v
+; (caddr
+; (list m v
(let ((b (module-obarray-ref (module-obarray m) v)))
(or (and (variable? b) b)
(and (module-binder m)
- ((module-binder m) m v #f)))))))
+ ((module-binder m) m v #f)))))
+;))
;; module-variable module symbol
;;
@@ -1711,13 +1506,13 @@
;; make-root-module
-:; A root module uses the symhash table (the system's privileged
+;; A root module uses the symhash table (the system's privileged
;; obarray). Being inside a root module is like using SCM without
;; any module system.
;;
-(define (root-module-thunk m s define?)
+(define (root-module-closure m s define?)
(let ((bi (and (symbol-interned? #f s)
(builtin-variable s))))
(and bi
@@ -1727,7 +1522,7 @@
bi))))
(define (make-root-module)
- (make-module 1019 #f root-module-thunk))
+ (make-module 1019 '() root-module-closure))
;; make-scm-module
@@ -1740,7 +1535,7 @@
;;
(define (make-scm-module)
- (make-module 1019 #f
+ (make-module 1019 '()
(lambda (m s define?)
(let ((bi (and (symbol-interned? #f s)
(builtin-variable s))))
@@ -1764,8 +1559,8 @@
(define (set-current-module m)
(set! the-module m)
(if m
- (set! *top-level-lookup-thunk* (module-eval-thunk the-module))
- (set! *top-level-lookup-thunk* #f)))
+ (set! *top-level-lookup-closure* (module-eval-closure the-module))
+ (set! *top-level-lookup-closure* #f)))
;; current-module
@@ -1790,28 +1585,14 @@
(set-current-module outer-module)
(set! outer-module #f)))))
-(define basic-try-load-with-path try-load-with-path)
-(define basic-try-load try-load)
-(define basic-load-with-path load-with-path)
(define basic-load load)
-
-(define (try-load-module-with-path . args)
- (save-module-excursion (lambda () (apply basic-try-load-with-path args))))
-
-(define (try-load-module . args)
- (save-module-excursion (lambda () (apply basic-try-load args))))
-
-(define (load-module-with-path . args)
- (save-module-excursion (lambda () (apply basic-load-with-path args))))
-
(define (load-module . args)
(save-module-excursion (lambda () (apply basic-load args))))
-
-;; MODULE-REF -- exported
+;;; {MODULE-REF -- exported}
;;
;; Returns the value of a variable called NAME in MODULE or any of its
;; used modules. If there is no such variable, then if the optional third
@@ -1848,6 +1629,15 @@
(variable-set! variable value)
(module-add! module name (make-variable value name)))))
+;; MODULE-DEFINED? -- exported
+;;
+;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
+;; uses)
+;;
+(define (module-defined? module name)
+ (let ((variable (module-variable module name)))
+ (and variable (variable-bound? variable))))
+
;; MODULE-USE! module interface
;;
;; Add INTERFACE to the list of interfaces used by MODULE.
@@ -1857,9 +1647,6 @@
(cons interface (delq! interface (module-uses module)))))
-
-
-;;;;
;;; {Recursive Namespaces}
;;;
;;;
@@ -1870,7 +1657,7 @@
;;; Each variable name is a list of elements, looked up in successively nested
;;; modules.
;;;
-;;; (resolved-ref some-root-module '(foo bar baz))
+;;; (nested-ref some-root-module '(foo bar baz))
;;; => <value of a variable named baz in the module bound to bar in
;;; the module bound to foo in some-root-module>
;;;
@@ -1880,23 +1667,23 @@
;;; ;; a-root is a module
;;; ;; name is a list of symbols
;;;
-;;; resolved-ref a-root name
-;;; resolved-set! a-root name val
-;;; resolved-define! a-root name val
-;;; resolved-remove! a-root name
+;;; nested-ref a-root name
+;;; nested-set! a-root name val
+;;; nested-define! a-root name val
+;;; nested-remove! a-root name
;;;
;;;
;;; (current-module) is a natural choice for a-root so for convenience there are
;;; also:
;;;
-;;; value-ref name == resolved-ref (current-module) name
-;;; value-set! name val == resolved-set! (current-module) name val
-;;; value-define! name val == resolved-define! (current-module) name val
-;;; value-remove! name == resolved-remove! (current-module) name
+;;; local-ref name == nested-ref (current-module) name
+;;; local-set! name val == nested-set! (current-module) name val
+;;; local-define! name val == nested-define! (current-module) name val
+;;; local-remove! name == nested-remove! (current-module) name
;;;
-(define (resolved-ref root names)
+(define (nested-ref root names)
(let loop ((cur root)
(elts names))
(cond
@@ -1904,37 +1691,35 @@
((not (module? cur)) #f)
(else (loop (module-ref cur (car elts) #f) (cdr elts))))))
-(define (resolved-set! root names val)
+(define (nested-set! root names val)
(let loop ((cur root)
(elts names))
(if (null? (cdr elts))
(module-set! cur (car elts) val)
(loop (module-ref cur (car elts)) (cdr elts)))))
-(define (resolved-define! root names val)
+(define (nested-define! root names val)
(let loop ((cur root)
(elts names))
(if (null? (cdr elts))
(module-define! cur (car elts) val)
(loop (module-ref cur (car elts)) (cdr elts)))))
-(define (resolved-remove! root names)
+(define (nested-remove! root names)
(let loop ((cur root)
(elts names))
(if (null? (cdr elts))
(module-remove! cur (car elts))
(loop (module-ref cur (car elts)) (cdr elts)))))
-(define (value-ref names) (resolved-ref (current-module) names))
-(define (value-set! names val) (resolved-set! (current-module) names val))
-(define (value-define names val) (resolved-define! (current-module) names val))
-(define (value-remove names) (resolved-remove! (current-module) names))
+(define (local-ref names) (nested-ref (current-module) names))
+(define (local-set! names val) (nested-set! (current-module) names val))
+(define (local-define names val) (nested-define! (current-module) names val))
+(define (local-remove names) (nested-remove! (current-module) names))
-
-;;;;
-;;; #/app
+;;; {#/app}
;;;
;;; The root of conventionally named objects not directly in the top level.
;;;
@@ -1955,17 +1740,19 @@
(set-current-module the-root-module)
(define app (make-module 31))
-(value-define '(app modules) (make-module 31))
-(value-define '(app modules guile) the-root-module)
+(local-define '(app modules) (make-module 31))
+(local-define '(app modules guile) the-root-module)
;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
-(define (resolve-module name)
+(define (resolve-module name . maybe-autoload)
(let ((full-name (append '(app modules) name)))
- (let ((already (value-ref full-name)))
+ (let ((already (local-ref full-name)))
(or already
(begin
- (try-module-autoload name)
+ (if (or (null? maybe-autoload) (car maybe-autoload))
+ (or (try-module-autoload name)
+ (try-module-dynamic-link name)))
(make-modules-in (current-module) full-name))))))
(define (beautify-user-module! module)
@@ -1974,7 +1761,8 @@
(set-module-name! interface (module-name module))
(set-module-kind! interface 'interface)
(set-module-public-interface! module interface)))
- (if (not (memq the-scm-module (module-uses module)))
+ (if (and (not (memq the-scm-module (module-uses module)))
+ (not (eq? module the-root-module)))
(set-module-uses! module (append (module-uses module) (list the-scm-module)))))
(define (make-modules-in module name)
@@ -1997,43 +1785,51 @@
(define (process-define-module args)
(let* ((module-id (car args))
- (module (resolve-module module-id))
+ (module (resolve-module module-id #f))
(kws (cdr args)))
(beautify-user-module! module)
- (let loop ((kws kws))
- (and (not (null? kws))
- (case (car kws)
- ((:use-module)
- (if (not (pair? (cdr kws)))
- (error "unrecognized defmodule argument" kws))
- (let* ((used-name (cadr kws))
- (used-module (resolve-module used-name)))
- (if (not (module-ref used-module '%module-public-interface #f))
- (begin
- ((if %autoloader-developer-mode warn error) "no code for module" used-module)
- (beautify-user-module! used-module)))
- (let ((interface (module-ref used-module '%module-public-interface #f)))
- (if (not interface)
- (error "missing interface for use-module" used-module))
- (set-module-uses! module
- (append! (delq! interface (module-uses module))
- (list interface)))))
- (loop (cddr kws)))
-
- (else (error "unrecognized defmodule argument" kws)))))
+ (let loop ((kws kws)
+ (reversed-interfaces '()))
+ (if (null? kws)
+ (for-each (lambda (interface)
+ (module-use! module interface))
+ reversed-interfaces)
+ (case (cond ((keyword? (car kws))
+ (keyword->symbol (car kws)))
+ ((and (symbol? (car kws))
+ (eq? (string-ref (car kws) 0) #\:))
+ (string->symbol (substring (car kws) 1)))
+ (else #f))
+ ((use-module)
+ (if (not (pair? (cdr kws)))
+ (error "unrecognized defmodule argument" kws))
+ (let* ((used-name (cadr kws))
+ (used-module (resolve-module used-name)))
+ (if (not (module-ref used-module '%module-public-interface #f))
+ (begin
+ ((if %autoloader-developer-mode warn error)
+ "no code for module" (module-name used-module))
+ (beautify-user-module! used-module)))
+ (let ((interface (module-public-interface used-module)))
+ (if (not interface)
+ (error "missing interface for use-module" used-module))
+ (loop (cddr kws) (cons interface reversed-interfaces)))))
+ (else
+ (error "unrecognized defmodule argument" kws)))))
module))
+;;; {Autoloading modules}
(define autoloads-in-progress '())
(define (try-module-autoload module-name)
-
+
(define (sfx name) (string-append name (scheme-file-suffix)))
(let* ((reverse-name (reverse module-name))
(name (car reverse-name))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name))))
- (resolve-module dir-hint-module-name)
+ (resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
(let ((didit #f))
(dynamic-wind
@@ -2051,13 +1847,13 @@
(and (or-map (lambda (f)
(let ((full (in-vicinity d f)))
full
- (and (not (file-is-directory? full))
- (file-exists? full)
+ (and (file-exists? full)
+ (not (file-is-directory? full))
(begin
(save-module-excursion
(lambda ()
- (list f d)
- (load-with-path f (list d))))
+ (load (string-append
+ d "/" f))))
#t))))
trys)
(begin
@@ -2067,6 +1863,156 @@
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
+;;; Dynamic linking of modules
+
+;; Initializing a module that is written in C is a two step process.
+;; First the module's `module init' function is called. This function
+;; is expected to call `scm_register_module_xxx' to register the `real
+;; init' function. Later, when the module is referenced for the first
+;; time, this real init function is called in the right context. See
+;; gtcltk-lib/gtcltk-module.c for an example.
+;;
+;; The code for the module can be in a regular shared library (so that
+;; the `module init' function will be called when libguile is
+;; initialized). Or it can be dynamically linked.
+;;
+;; You can safely call `scm_register_module_xxx' before libguile
+;; itself is initialized. You could call it from an C++ constructor
+;; of a static object, for example.
+;;
+;; To make your Guile extension into a dynamic linkable module, follow
+;; these easy steps:
+;;
+;; - Find a name for your module, like #/ice-9/gtcltk
+;; - Write a function with a name like
+;;
+;; scm_init_ice_9_gtcltk_module
+;;
+;; This is your `module init' function. It should call
+;;
+;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk);
+;;
+;; "ice-9 gtcltk" is the C version of the module name. Slashes are
+;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is
+;; the real init function that executes the usual initializations
+;; like making new smobs, etc.
+;;
+;; - Make a shared library with your code and a name like
+;;
+;; ice-9/libgtcltk.so
+;;
+;; and put it somewhere in %load-path.
+;;
+;; - Then you can simply write `:use-module #/ice-9/gtcltk' and it
+;; will be linked automatically.
+;;
+;; This is all very experimental.
+
+(define (split-c-module-name str)
+ (let loop ((rev '())
+ (start 0)
+ (pos 0)
+ (end (string-length str)))
+ (cond
+ ((= pos end)
+ (reverse (cons (string->symbol (substring str start pos)) rev)))
+ ((eq? (string-ref str pos) #\space)
+ (loop (cons (string->symbol (substring str start pos)) rev)
+ (+ pos 1)
+ (+ pos 1)
+ end))
+ (else
+ (loop rev start (+ pos 1) end)))))
+
+(define (convert-c-registered-modules dynobj)
+ (let ((res (map (lambda (c)
+ (list (split-c-module-name (car c)) (cdr c) dynobj))
+ (c-registered-modules))))
+ (c-clear-registered-modules)
+ res))
+
+(define registered-modules (convert-c-registered-modules #f))
+
+(define (init-dynamic-module modname)
+ (or-map (lambda (modinfo)
+ (if (equal? (car modinfo) modname)
+ (let ((mod (resolve-module modname #f)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module mod)
+ (dynamic-call (cadr modinfo) (caddr modinfo))
+ (set-module-public-interface! mod mod)))
+ (set! registered-modules (delq! modinfo registered-modules))
+ #t)
+ #f))
+ registered-modules))
+
+(define (dynamic-maybe-call name dynobj)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-call name dynobj))
+ (lambda args
+ #f)))
+
+(define (dynamic-maybe-link filename)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-link filename))
+ (lambda args
+ #f)))
+
+(define (find-and-link-dynamic-module module-name)
+ (define (make-init-name mod-name)
+ (string-append 'scm_init
+ (list->string (map (lambda (c)
+ (if (or (char-alphabetic? c)
+ (char-numeric? c))
+ c
+ #\_))
+ (string->list mod-name)))
+ '_module))
+ (let ((libname
+ (let loop ((dirs "")
+ (syms module-name))
+ (cond
+ ((null? (cdr syms))
+ (string-append dirs "lib" (car syms) ".so"))
+ (else
+ (loop (string-append dirs (car syms) "/") (cdr syms))))))
+ (init (make-init-name (apply string-append
+ (map (lambda (s)
+ (string-append "_" s))
+ module-name)))))
+ ;; (pk 'libname libname 'init init)
+ (or-map
+ (lambda (dir)
+ (let ((full (in-vicinity dir libname)))
+ ;; (pk 'trying full)
+ (if (file-exists? full)
+ (begin
+ (link-dynamic-module full init)
+ #t)
+ #f)))
+ %load-path)))
+
+(define (link-dynamic-module filename initname)
+ (let ((dynobj (dynamic-maybe-link filename)))
+ (if dynobj
+ (if (dynamic-maybe-call initname dynobj)
+ (set! registered-modules
+ (append! (convert-c-registered-modules dynobj)
+ registered-modules))
+ (begin
+ (pk 'no_init)
+ (dynamic-unlink dynobj))))))
+
+(define (try-module-dynamic-link module-name)
+ (or (init-dynamic-module module-name)
+ (and (find-and-link-dynamic-module module-name)
+ (init-dynamic-module module-name))))
+
+
+
(define autoloads-done '((guile . guile)))
(define (autoload-done-or-in-progress? p m)
@@ -2101,8 +2047,8 @@
;;; {Macros}
;;;
-(define macro-table (make-weak-hash-table 523))
-(define xformer-table (make-weak-hash-table 523))
+(define macro-table (make-weak-key-hash-table 523))
+(define xformer-table (make-weak-key-hash-table 523))
(define (defmacro? m) (hashq-ref macro-table m))
(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
@@ -2135,10 +2081,14 @@
(lambda (exp env)
(copy-tree (apply f (cdr exp)))))))
+
+;; XXX - should the definition of the car really be looked up in the
+;; current module?
+
(define (macroexpand-1 e)
(cond
((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
+ (val (and (symbol? a) (local-ref (list a)))))
(if (defmacro? val)
(apply (defmacro-transformer val) (cdr e))
e)))
@@ -2147,7 +2097,7 @@
(define (macroexpand e)
(cond
((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
+ (val (and (symbol? a) (local-ref (list a)))))
(if (defmacro? val)
(macroexpand (apply (defmacro-transformer val) (cdr e)))
e)))
@@ -2167,72 +2117,194 @@
;;;
(define (repl read evaler print)
- (let loop ((source (read (current-input-port) #t read-sharp)))
+ (let loop ((source (read (current-input-port))))
(print (evaler source))
- (loop (read (current-input-port) #t read-sharp))))
+ (loop (read (current-input-port)))))
;; A provisional repl that acts like the SCM repl:
;;
(define scm-repl-silent #f)
(define (assert-repl-silence v) (set! scm-repl-silent v))
-(define scm-repl-verbose #t)
+(define *unspecified* (if #f #f))
+(define (unspecified? v) (eq? v *unspecified*))
+
+(define scm-repl-print-unspecified #f)
+(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
+
+(define scm-repl-verbose #f)
(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
-(define scm-repl-prompt #t)
-(define (assert-repl-prompt v) (set! scm-repl-prompt v))
+(define scm-repl-prompt "guile> ")
+
+(define (set-repl-prompt! v) (set! scm-repl-prompt v))
+
+(define (default-lazy-handler key . args)
+ (save-stack lazy-handler-dispatch)
+ (apply throw key args))
+
+(define apply-frame-handler default-lazy-handler)
+(define exit-frame-handler default-lazy-handler)
-(define the-prompt-string "guile> ")
+(define (lazy-handler-dispatch key . args)
+ (case key
+ ((apply-frame)
+ (apply apply-frame-handler key args))
+ ((exit-frame)
+ (apply exit-frame-handler key args))
+ (else
+ (apply default-lazy-handler key args))))
+
+(define abort-hook '())
(define (error-catching-loop thunk)
- (define (loop first)
- (let ((next
- (catch #t
- (lambda ()
- (dynamic-wind
- (lambda () (unmask-signals))
- (lambda ()
- (first)
-
- ;; This line is needed because mark doesn't do closures quite right.
- ;; Unreferenced locals should be collected.
- ;;
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)
- (lambda () (mask-signals))))
-
- (lambda (key . args)
- (case key
- ((quit) (force-output)
- (pk 'quit args)
- #f)
-
- ((abort) ;; This is one of the closures that require (set! first #f)
- ;; above
- ;;
- (lambda ()
- (force-output)
- (display "ABORT: " (current-error-port))
- (write args (current-error-port))
- (newline (current-error-port))))
-
- (else ;; This is the other cons-leak closure...
- (lambda ()
- (apply %%bad-throw key args))))))))
- (and next (loop next))))
- (loop (lambda () #t)))
+ (let ((status #f))
+ (define (loop first)
+ (let ((next
+ (catch #t
+
+ (lambda ()
+ (lazy-catch #t
+ (lambda ()
+ (dynamic-wind
+ (lambda () (unmask-signals))
+ (lambda ()
+ (first)
+
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ ;;
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)
+ (lambda () (mask-signals))))
+
+ lazy-handler-dispatch))
+
+ (lambda (key . args)
+ (case key
+ ((quit)
+ (read-line) ; discard trailing junk and linefeed.
+ (force-output)
+ (set! status args)
+ #f)
+
+ ((switch-repl)
+ (apply throw 'switch-repl args))
+
+ ((abort)
+ ;; This is one of the closures that require
+ ;; (set! first #f) above
+ ;;
+ (lambda ()
+ (run-hooks abort-hook)
+ (force-output)
+ (display "ABORT: " (current-error-port))
+ (write args (current-error-port))
+ (newline (current-error-port))
+ (if (and (not has-shown-debugger-hint?)
+ (not (memq 'backtrace
+ (debug-options-interface)))
+ (stack? the-last-stack))
+ (begin
+ (newline (current-error-port))
+ (display
+ "Type \"(backtrace)\" to get more information.\n"
+ (current-error-port))
+ (set! has-shown-debugger-hint? #t)))
+ (set! stack-saved? #f)))
+
+ (else
+ ;; This is the other cons-leak closure...
+ (lambda ()
+ (cond ((= (length args) 4)
+ (apply handle-system-error key args))
+ (else
+ (apply bad-throw key args))))))))))
+ (if next (loop next) status)))
+ (loop (lambda () #t))))
+
+;;(define the-last-stack #f) Defined by scm_init_backtrace ()
+(define stack-saved? #f)
+
+(define (save-stack . narrowing)
+ (cond (stack-saved?)
+ ((not (memq 'debug (debug-options-interface)))
+ (set! the-last-stack #f)
+ (set! stack-saved? #t))
+ (else
+ (set! the-last-stack
+ (case (stack-id #t)
+ ((repl-stack)
+ (apply make-stack #t save-stack eval narrowing))
+ ((load-stack)
+ (apply make-stack #t save-stack gsubr-apply narrowing))
+ ((tk-stack)
+ (apply make-stack #t save-stack tk-stack-mark narrowing))
+ ((#t)
+ (apply make-stack #t save-stack 0 1 narrowing))
+ (else (let ((id (stack-id #t)))
+ (and (procedure? id)
+ (apply make-stack #t save-stack id narrowing))))))
+ (set! stack-saved? #t))))
+
+(define before-error-hook '())
+(define after-error-hook '())
+(define before-backtrace-hook '())
+(define after-backtrace-hook '())
+
+(define has-shown-debugger-hint? #f)
+
+(define (handle-system-error key . args)
+ (let ((cep (current-error-port)))
+ (cond ((not (stack? the-last-stack)))
+ ((memq 'backtrace (debug-options-interface))
+ (run-hooks before-backtrace-hook)
+ (newline cep)
+ (display-backtrace the-last-stack cep)
+ (newline cep)
+ (run-hooks after-backtrace-hook)))
+ (run-hooks before-error-hook)
+ (apply display-error the-last-stack cep args)
+ (run-hooks after-error-hook)
+ (force-output cep)
+ (throw 'abort key)))
(define (quit . args)
(apply throw 'quit args))
+(define exit quit)
+
+;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
+
+;; Replaced by C code:
+;;(define (backtrace)
+;; (if the-last-stack
+;; (begin
+;; (newline)
+;; (display-backtrace the-last-stack (current-output-port))
+;; (newline)
+;; (if (and (not has-shown-backtrace-hint?)
+;; (not (memq 'backtrace (debug-options-interface))))
+;; (begin
+;; (display
+;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
+;;automatically if an error occurs in the future.\n")
+;; (set! has-shown-backtrace-hint? #t))))
+;; (display "No backtrace available.\n")))
+
(define (error-catching-repl r e p)
(error-catching-loop (lambda () (p (e (r))))))
(define (gc-run-time)
(cdr (assq 'gc-time-taken (gc-stats))))
+(define before-read-hook '())
+(define after-read-hook '())
+
(define (scm-style-repl)
(letrec (
(start-gc-rt #f)
@@ -2254,12 +2326,19 @@
(-read (lambda ()
(if scm-repl-prompt
(begin
- (display the-prompt-string)
+ (display (cond ((string? scm-repl-prompt)
+ scm-repl-prompt)
+ ((thunk? scm-repl-prompt)
+ (scm-repl-prompt))
+ (else "> ")))
(force-output)
(repl-report-reset)))
- (let ((val (read (current-input-port) #t read-sharp)))
+ (run-hooks before-read-hook)
+ (let ((val (read (current-input-port))))
+ (run-hooks after-read-hook)
(if (eof-object? val)
(begin
+ (repl-report-start-timing)
(if scm-repl-verbose
(begin
(newline)
@@ -2270,24 +2349,27 @@
(-eval (lambda (sourc)
(repl-report-start-timing)
- (eval sourc)))
+ (start-stack 'repl-stack (eval sourc))))
(-print (lambda (result)
(if (not scm-repl-silent)
(begin
- (print result)
- (newline)
+ (if (or scm-repl-print-unspecified
+ (not (unspecified? result)))
+ (begin
+ (write result)
+ (newline)))
(if scm-repl-verbose
(repl-report))
(force-output)))))
- (-quit (lambda ()
+ (-quit (lambda (args)
(if scm-repl-verbose
(begin
(display ";;; QUIT executed, repl exitting")
(newline)
(repl-report)))
- #t))
+ args))
(-abort (lambda ()
(if scm-repl-verbose
@@ -2297,19 +2379,21 @@
(repl-report)))
(repl -read -eval -print))))
- (error-catching-repl -read
- -eval
- -print)))
+ (let ((status (error-catching-repl -read
+ -eval
+ -print)))
+ (-quit status))))
+
-(define (stand-alone-repl)
- (let ((oport (current-input-port)))
- (set-current-input-port *stdin*)
- (scm-style-repl)
- (set-current-input-port oport)))
+;(define (stand-alone-repl)
+; (let ((oport (current-input-port)))
+; (set-current-input-port *stdin*)
+; (scm-style-repl)
+; (set-current-input-port oport)))
-
+;;; {IOTA functions: generating lists of numbers}
(define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
(define (iota n) (list-reverse! (reverse-iota n)))
@@ -2364,6 +2448,12 @@
(set-current-module module)
module))
+(defmacro use-modules modules
+ `(for-each (lambda (module)
+ (module-use! (current-module)
+ (resolve-interface module)))
+ (reverse ',modules)))
+
(define define-private define)
(defmacro define-public args
@@ -2426,13 +2516,13 @@
-(define try-load-with-path try-load-module-with-path)
-(define try-load try-load-module)
-(define load-with-path load-module-with-path)
(define load load-module)
+;(define (load . args)
+; (start-stack 'load-stack (apply load-module args)))
+;;; {I/O functions for Tcl channels (disabled)}
;; (define in-ch (get-standard-channel TCL_STDIN))
;; (define out-ch (get-standard-channel TCL_STDOUT))
@@ -2467,13 +2557,18 @@
;; (set-current-output-port outp)
;; (set-current-error-port errp)
-(define (top-repl) (scm-style-repl))
+(define (top-repl)
+ (scm-style-repl))
+
+(defmacro false-if-exception (expr)
+ `(catch #t (lambda () ,expr)
+ (lambda args #f)))
+;;; {Calling Conventions}
(define-module (ice-9 calling))
;;;;
-;;; {Calling Conventions}
;;;
;;; This file contains a number of macros that support
;;; common calling conventions.
@@ -2771,6 +2866,8 @@
+;;; {Implementation of COMMON LISP list functions for Scheme}
+
(define-module (ice-9 common-list))
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
@@ -2792,9 +2889,6 @@
;promotional, or sales literature without prior written consent in
;each case.
-
-
-
;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define-public (make-list k . init)
(set! init (if (pair? init) (car init)))
@@ -2953,35 +3047,38 @@
(cons (car l) u)))))
+;;; {Functions for browsing modules}
+
(define-module (ice-9 ls)
:use-module (ice-9 common-list))
-
-
;;;;
;;; local-definitions-in root name
-;;; Returns a list of names defined locally in the named subdirectory of root.
+;;; Returns a list of names defined locally in the named
+;;; subdirectory of root.
;;; definitions-in root name
-;;; Returns a list of all names defined in the named subdirectory of root.
-;;; The list includes alll locally defined names as well as all names inherited
-;;; from a member of a use-list.
+;;; Returns a list of all names defined in the named
+;;; subdirectory of root. The list includes alll locally
+;;; defined names as well as all names inherited from a
+;;; member of a use-list.
;;;
;;; A convenient interface for examining the nature of things:
;;;
;;; ls . various-names
;;;
-;;; With just one argument, interpret that argument as the name of a subdirectory
-;;; of the current module and return a list of names defined there.
+;;; With just one argument, interpret that argument as the
+;;; name of a subdirectory of the current module and
+;;; return a list of names defined there.
;;;
-;;; With more than one argument, still compute subdirectory lists, but
-;;; return a list:
+;;; With more than one argument, still compute
+;;; subdirectory lists, but return a list:
;;; ((<subdir-name> . <names-defined-there>)
;;; (<subdir-name> . <names-defined-there>)
;;; ...)
;;;
(define-public (local-definitions-in root names)
- (let ((m (resolved-ref root names))
+ (let ((m (nested-ref root names))
(answer '()))
(if (not (module? m))
(set! answer m)
@@ -2989,12 +3086,13 @@
answer))
(define-public (definitions-in root names)
- (let ((m (resolved-ref root names)))
+ (let ((m (nested-ref root names)))
(if (not (module? m))
m
(reduce union
(cons (local-definitions-in m '())
- (map (lambda (m2) (definitions-in m2 '())) (module-uses m)))))))
+ (map (lambda (m2) (definitions-in m2 '()))
+ (module-uses m)))))))
(define-public (ls . various-refs)
(and various-refs
@@ -3012,11 +3110,13 @@
various-refs)
(local-definitions-in (current-module) (car various-refs)))))
-(define-public (recursive-value-define name value)
+(define-public (recursive-local-define name value)
(let ((parent (reverse! (cdr (reverse name)))))
(and parent (make-modules-in (current-module) parent))
- (value-define name value)))
+ (local-define name value)))
+;;; {Queues}
+
(define-module (ice-9 q))
;;;; Copyright (C) 1995 Free Software Foundation, Inc.
@@ -3036,7 +3136,6 @@
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;
-
;;;;
;;; Q: Based on the interface to
;;;
@@ -3044,7 +3143,6 @@
;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
;;;
-
;;;;
;;; {Q}
;;;
@@ -3156,12 +3254,11 @@
-;;; installed-scm-file
+;;; {The runq data structure}
+
(define-module (ice-9 runq)
:use-module (ice-9 q))
-
-
;;;; Copyright (C) 1996 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
@@ -3179,10 +3276,7 @@
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;
-
-
;;;;
-;;; {The runq data structure}
;;;
;;; One way to schedule parallel computations in a serial environment is
;;; to explicitly divide each task up into small, finite execution time,
@@ -3400,21 +3494,17 @@
st))
+;;; {String Fun}
-;;; installed-scm-file
-
(define-module (ice-9 string-fun))
-
;;;;
-;;; {String Fun}
;;;
;;; Various string funcitons, particularly those that take
;;; advantage of the "shared substring" capability.
;;;
-;;;;
-;;; {Dividing Strings Into Fields}
+;;; {String Fun: Dividing Strings Into Fields}
;;;
;;; The names of these functions are very regular.
;;; Here is a grammar of a call to one of these:
@@ -3538,7 +3628,7 @@
(else (ret (make-shared-substring str 0 n)
(make-shared-substring str (1+ n)))))))
-(define-public (seperate-fields-discarding-char ch str ret)
+(define-public (separate-fields-discarding-char ch str ret)
(let loop ((fields '())
(str str))
(cond
@@ -3547,7 +3637,7 @@
(make-shared-substring str 0 w))))
(else (ret (cons str fields))))))
-(define-public (seperate-fields-after-char ch str ret)
+(define-public (separate-fields-after-char ch str ret)
(let loop ((fields '())
(str str))
(cond
@@ -3556,7 +3646,7 @@
(make-shared-substring str 0 (+ 1 w)))))
(else (ret (cons str fields))))))
-(define-public (seperate-fields-before-char ch str ret)
+(define-public (separate-fields-before-char ch str ret)
(let loop ((fields '())
(str str))
(cond
@@ -3566,12 +3656,11 @@
(else (ret (cons str fields))))))
-;;;;
-;;; {String Prefix Predicates}
+;;; {String Fun: String Prefix Predicates}
;;;
;;; Very simple:
;;;
-:;; (define-public ((string-prefix-predicate pred?) prefix str)
+;;; (define-public ((string-prefix-predicate pred?) prefix str)
;;; (and (<= (length prefix) (length str))
;;; (pred? prefix (make-shared-substring str 0 (length prefix)))))
;;;
@@ -3585,8 +3674,7 @@
(define-public string-prefix=? (string-prefix-predicate string=?))
-;;;;
-;;; {Strippers}
+;;; {String Fun: Strippers}
;;;
;;; <stripper> = sans-<removable-part>
;;;
@@ -3639,8 +3727,7 @@
(else str)))
-;;;;
-;;; {has-trailing-newline?}
+;;; {String Fun: has-trailing-newline?}
;;;
(define-public (has-trailing-newline? str)
@@ -3649,7 +3736,7 @@
-
+;;; {String Fun: with-regexp-parts}
(define-public (with-regexp-parts regexp fields str return fail)
(let ((parts (regexec regexp str fields)))
@@ -3658,6 +3745,44 @@
(apply return parts))))
+;;; {Load debug extension code if debug extensions present.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (memq 'debug-extensions *features*)
+ (define-module (guile) :use-module (ice-9 debug)))
+
+
+;;; {Load session support if present.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (%search-load-path "ice-9/session.scm")
+ (define-module (guile) :use-module (ice-9 session)))
+
+
+;;; {Load thread code if threads are present.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (memq 'threads *features*)
+ (define-module (guile) :use-module (ice-9 threads)))
+
+
+;;; {Load emacs interface support if emacs option is given.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (and (module-defined? the-root-module 'use-emacs-interface)
+ use-emacs-interface)
+ (define-module (guile) :use-module (ice-9 emacs)))
+
+
(define-module (guile))
+(append! %load-path (cons "." ()))
diff --git a/ice-9/configure b/ice-9/configure
index 25b98d1a0..e69de29bb 100755
--- a/ice-9/configure
+++ b/ice-9/configure
@@ -1,722 +0,0 @@
-#! /bin/sh
-
-# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.9
-# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
-#
-# This configure script is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-
-# Defaults:
-ac_help=
-ac_default_prefix=/usr/local
-# Any additions from configure.in:
-
-# Initialize some variables set by options.
-# The variables have the same names as the options, with
-# dashes changed to underlines.
-build=NONE
-cache_file=./config.cache
-exec_prefix=NONE
-host=NONE
-no_create=
-nonopt=NONE
-no_recursion=
-prefix=NONE
-program_prefix=NONE
-program_suffix=NONE
-program_transform_name=s,x,x,
-silent=
-site=
-srcdir=
-target=NONE
-verbose=
-x_includes=NONE
-x_libraries=NONE
-bindir='${exec_prefix}/bin'
-sbindir='${exec_prefix}/sbin'
-libexecdir='${exec_prefix}/libexec'
-datadir='${prefix}/share'
-sysconfdir='${prefix}/etc'
-sharedstatedir='${prefix}/com'
-localstatedir='${prefix}/var'
-libdir='${exec_prefix}/lib'
-includedir='${prefix}/include'
-oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
-
-# Initialize some other variables.
-subdirs=
-MFLAGS= MAKEFLAGS=
-
-ac_prev=
-for ac_option
-do
-
- # If the previous option needs an argument, assign it.
- if test -n "$ac_prev"; then
- eval "$ac_prev=\$ac_option"
- ac_prev=
- continue
- fi
-
- case "$ac_option" in
- -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
- *) ac_optarg= ;;
- esac
-
- # Accept the important Cygnus configure options, so we can diagnose typos.
-
- case "$ac_option" in
-
- -bindir | --bindir | --bindi | --bind | --bin | --bi)
- ac_prev=bindir ;;
- -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
- bindir="$ac_optarg" ;;
-
- -build | --build | --buil | --bui | --bu)
- ac_prev=build ;;
- -build=* | --build=* | --buil=* | --bui=* | --bu=*)
- build="$ac_optarg" ;;
-
- -cache-file | --cache-file | --cache-fil | --cache-fi \
- | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
- ac_prev=cache_file ;;
- -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
- | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
- cache_file="$ac_optarg" ;;
-
- -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
- ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
- | --da=*)
- datadir="$ac_optarg" ;;
-
- -disable-* | --disable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- eval "enable_${ac_feature}=no" ;;
-
- -enable-* | --enable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "enable_${ac_feature}='$ac_optarg'" ;;
-
- -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
- | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
- | --exec | --exe | --ex)
- ac_prev=exec_prefix ;;
- -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
- | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
- | --exec=* | --exe=* | --ex=*)
- exec_prefix="$ac_optarg" ;;
-
- -gas | --gas | --ga | --g)
- # Obsolete; use --with-gas.
- with_gas=yes ;;
-
- -help | --help | --hel | --he)
- # Omit some internal or obsolete options to make the list less imposing.
- # This message is too long to be a string in the A/UX 3.1 sh.
- cat << EOF
-Usage: configure [options] [host]
-Options: [defaults in brackets after descriptions]
-Configuration:
- --cache-file=FILE cache test results in FILE
- --help print this message
- --no-create do not create output files
- --quiet, --silent do not print \`checking...' messages
- --version print the version of autoconf that created configure
-Directory and file names:
- --prefix=PREFIX install architecture-independent files in PREFIX
- [$ac_default_prefix]
- --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [same as prefix]
- --bindir=DIR user executables in DIR [EPREFIX/bin]
- --sbindir=DIR system admin executables in DIR [EPREFIX/sbin]
- --libexecdir=DIR program executables in DIR [EPREFIX/libexec]
- --datadir=DIR read-only architecture-independent data in DIR
- [PREFIX/share]
- --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc]
- --sharedstatedir=DIR modifiable architecture-independent data in DIR
- [PREFIX/com]
- --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var]
- --libdir=DIR object code libraries in DIR [EPREFIX/lib]
- --includedir=DIR C header files in DIR [PREFIX/include]
- --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include]
- --infodir=DIR info documentation in DIR [PREFIX/info]
- --mandir=DIR man documentation in DIR [PREFIX/man]
- --srcdir=DIR find the sources in DIR [configure dir or ..]
- --program-prefix=PREFIX prepend PREFIX to installed program names
- --program-suffix=SUFFIX append SUFFIX to installed program names
- --program-transform-name=PROGRAM
- run sed PROGRAM on installed program names
-EOF
- cat << EOF
-Host type:
- --build=BUILD configure for building on BUILD [BUILD=HOST]
- --host=HOST configure for HOST [guessed]
- --target=TARGET configure for TARGET [TARGET=HOST]
-Features and packages:
- --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
- --enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --x-includes=DIR X include files are in DIR
- --x-libraries=DIR X library files are in DIR
-EOF
- if test -n "$ac_help"; then
- echo "--enable and --with options recognized:$ac_help"
- fi
- exit 0 ;;
-
- -host | --host | --hos | --ho)
- ac_prev=host ;;
- -host=* | --host=* | --hos=* | --ho=*)
- host="$ac_optarg" ;;
-
- -includedir | --includedir | --includedi | --included | --include \
- | --includ | --inclu | --incl | --inc)
- ac_prev=includedir ;;
- -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
- | --includ=* | --inclu=* | --incl=* | --inc=*)
- includedir="$ac_optarg" ;;
-
- -infodir | --infodir | --infodi | --infod | --info | --inf)
- ac_prev=infodir ;;
- -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
- infodir="$ac_optarg" ;;
-
- -libdir | --libdir | --libdi | --libd)
- ac_prev=libdir ;;
- -libdir=* | --libdir=* | --libdi=* | --libd=*)
- libdir="$ac_optarg" ;;
-
- -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
- | --libexe | --libex | --libe)
- ac_prev=libexecdir ;;
- -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
- | --libexe=* | --libex=* | --libe=*)
- libexecdir="$ac_optarg" ;;
-
- -localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst \
- | --locals | --local | --loca | --loc | --lo)
- ac_prev=localstatedir ;;
- -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* \
- | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
- localstatedir="$ac_optarg" ;;
-
- -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
- ac_prev=mandir ;;
- -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
- mandir="$ac_optarg" ;;
-
- -nfp | --nfp | --nf)
- # Obsolete; use --without-fp.
- with_fp=no ;;
-
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c)
- no_create=yes ;;
-
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
- no_recursion=yes ;;
-
- -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
- | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
- | --oldin | --oldi | --old | --ol | --o)
- ac_prev=oldincludedir ;;
- -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
- | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
- | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
- oldincludedir="$ac_optarg" ;;
-
- -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
- ac_prev=prefix ;;
- -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
- prefix="$ac_optarg" ;;
-
- -program-prefix | --program-prefix | --program-prefi | --program-pref \
- | --program-pre | --program-pr | --program-p)
- ac_prev=program_prefix ;;
- -program-prefix=* | --program-prefix=* | --program-prefi=* \
- | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
- program_prefix="$ac_optarg" ;;
-
- -program-suffix | --program-suffix | --program-suffi | --program-suff \
- | --program-suf | --program-su | --program-s)
- ac_prev=program_suffix ;;
- -program-suffix=* | --program-suffix=* | --program-suffi=* \
- | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
- program_suffix="$ac_optarg" ;;
-
- -program-transform-name | --program-transform-name \
- | --program-transform-nam | --program-transform-na \
- | --program-transform-n | --program-transform- \
- | --program-transform | --program-transfor \
- | --program-transfo | --program-transf \
- | --program-trans | --program-tran \
- | --progr-tra | --program-tr | --program-t)
- ac_prev=program_transform_name ;;
- -program-transform-name=* | --program-transform-name=* \
- | --program-transform-nam=* | --program-transform-na=* \
- | --program-transform-n=* | --program-transform-=* \
- | --program-transform=* | --program-transfor=* \
- | --program-transfo=* | --program-transf=* \
- | --program-trans=* | --program-tran=* \
- | --progr-tra=* | --program-tr=* | --program-t=*)
- program_transform_name="$ac_optarg" ;;
-
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- silent=yes ;;
-
- -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
- ac_prev=sbindir ;;
- -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
- | --sbi=* | --sb=*)
- sbindir="$ac_optarg" ;;
-
- -sharedstatedir | --sharedstatedir | --sharedstatedi \
- | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
- | --sharedst | --shareds | --shared | --share | --shar \
- | --sha | --sh)
- ac_prev=sharedstatedir ;;
- -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
- | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
- | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
- | --sha=* | --sh=*)
- sharedstatedir="$ac_optarg" ;;
-
- -site | --site | --sit)
- ac_prev=site ;;
- -site=* | --site=* | --sit=*)
- site="$ac_optarg" ;;
-
- -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
- ac_prev=srcdir ;;
- -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
- srcdir="$ac_optarg" ;;
-
- -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
- | --syscon | --sysco | --sysc | --sys | --sy)
- ac_prev=sysconfdir ;;
- -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
- | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
- sysconfdir="$ac_optarg" ;;
-
- -target | --target | --targe | --targ | --tar | --ta | --t)
- ac_prev=target ;;
- -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
- target="$ac_optarg" ;;
-
- -v | -verbose | --verbose | --verbos | --verbo | --verb)
- verbose=yes ;;
-
- -version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.9"
- exit 0 ;;
-
- -with-* | --with-*)
- ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "with_${ac_package}='$ac_optarg'" ;;
-
- -without-* | --without-*)
- ac_package=`echo $ac_option|sed -e 's/-*without-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- eval "with_${ac_package}=no" ;;
-
- --x)
- # Obsolete; use --with-x.
- with_x=yes ;;
-
- -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
- | --x-incl | --x-inc | --x-in | --x-i)
- ac_prev=x_includes ;;
- -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
- | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
- x_includes="$ac_optarg" ;;
-
- -x-libraries | --x-libraries | --x-librarie | --x-librari \
- | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
- ac_prev=x_libraries ;;
- -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
- | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
- x_libraries="$ac_optarg" ;;
-
- -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
- ;;
-
- *)
- if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
- echo "configure: warning: $ac_option: invalid host type" 1>&2
- fi
- if test "x$nonopt" != xNONE; then
- { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
- fi
- nonopt="$ac_option"
- ;;
-
- esac
-done
-
-if test -n "$ac_prev"; then
- { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
-fi
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-# File descriptor usage:
-# 0 standard input
-# 1 file creation
-# 2 errors and warnings
-# 3 some systems may open it to /dev/tty
-# 4 used on the Kubota Titan
-# 6 checking for... messages and results
-# 5 compiler messages saved in config.log
-if test "$silent" = yes; then
- exec 6>/dev/null
-else
- exec 6>&1
-fi
-exec 5>./config.log
-
-echo "\
-This file contains any messages produced by compilers while
-running configure, to aid debugging if configure makes a mistake.
-" 1>&5
-
-# Strip out --no-create and --no-recursion so they do not pile up.
-# Also quote any args containing shell metacharacters.
-ac_configure_args=
-for ac_arg
-do
- case "$ac_arg" in
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c) ;;
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
- ac_configure_args="$ac_configure_args '$ac_arg'" ;;
- *) ac_configure_args="$ac_configure_args $ac_arg" ;;
- esac
-done
-
-# NLS nuisances.
-# Only set LANG and LC_ALL to C if already set.
-# These must not be set unconditionally because not all systems understand
-# e.g. LANG=C (notably SCO).
-if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
-if test "${LANG+set}" = set; then LANG=C; export LANG; fi
-
-# confdefs.h avoids OS command line length limits that DEFS can exceed.
-rm -rf conftest* confdefs.h
-# AIX cpp loses on an empty file, so make sure it contains at least a newline.
-echo > confdefs.h
-
-# A filename unique to this package, relative to the directory that
-# configure is in, which we can look for to find out if srcdir is correct.
-ac_unique_file=boot-9.scm
-
-# Find the source files, if location was not specified.
-if test -z "$srcdir"; then
- ac_srcdir_defaulted=yes
- # Try the directory containing this script, then its parent.
- ac_prog=$0
- ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
- test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
- srcdir=$ac_confdir
- if test ! -r $srcdir/$ac_unique_file; then
- srcdir=..
- fi
-else
- ac_srcdir_defaulted=no
-fi
-if test ! -r $srcdir/$ac_unique_file; then
- if test "$ac_srcdir_defaulted" = yes; then
- { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
- else
- { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
- fi
-fi
-srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
-
-# Prefer explicitly selected file to automatically selected ones.
-if test -z "$CONFIG_SITE"; then
- if test "x$prefix" != xNONE; then
- CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
- else
- CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
- fi
-fi
-for ac_site_file in $CONFIG_SITE; do
- if test -r "$ac_site_file"; then
- echo "loading site script $ac_site_file"
- . "$ac_site_file"
- fi
-done
-
-if test -r "$cache_file"; then
- echo "loading cache $cache_file"
- . $cache_file
-else
- echo "creating cache $cache_file"
- > $cache_file
-fi
-
-ac_ext=c
-# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
-ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
-
-if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
- # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
- if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
- ac_n= ac_c='
-' ac_t=' '
- else
- ac_n=-n ac_c= ac_t=
- fi
-else
- ac_n= ac_c='\c' ac_t=
-fi
-
-
-
-. $srcdir/../GUILE-VERSION
-
-scm_files=""
-aux_files=""
-. $srcdir/PLUGIN/this.configure
-
-
-
-
-
-trap '' 1 2 15
-cat > confcache <<\EOF
-# This file is a shell script that caches the results of configure
-# tests run on this system so they can be shared between configure
-# scripts and configure runs. It is not useful on other systems.
-# If it contains results you don't want to keep, you may remove or edit it.
-#
-# By default, configure uses ./config.cache as the cache file,
-# creating it if it does not exist already. You can give configure
-# the --cache-file=FILE option to use a different cache file; that is
-# what configure does when it calls configure scripts in
-# subdirectories, so they share the cache.
-# Giving --cache-file=/dev/null disables caching, for debugging configure.
-# config.status only pays attention to the cache file if you give it the
-# --recheck option to rerun configure.
-#
-EOF
-# Ultrix sh set writes to stderr and can't be redirected directly,
-# and sets the high bit in the cache file unless we assign to the vars.
-(set) 2>&1 |
- sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \
- >> confcache
-if cmp -s $cache_file confcache; then
- :
-else
- if test -w $cache_file; then
- echo "updating cache $cache_file"
- cat confcache > $cache_file
- else
- echo "not updating unwritable cache $cache_file"
- fi
-fi
-rm -f confcache
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-test "x$prefix" = xNONE && prefix=$ac_default_prefix
-# Let make expand exec_prefix.
-test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
-
-# Any assignment to VPATH causes Sun make to only execute
-# the first set of double-colon rules, so remove it if not needed.
-# If there is a colon in the path, we need to keep it.
-if test "x$srcdir" = x.; then
- ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d'
-fi
-
-trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
-
-# Transform confdefs.h into DEFS.
-# Protect against shell expansion while executing Makefile rules.
-# Protect against Makefile macro expansion.
-cat > conftest.defs <<\EOF
-s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
-s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g
-s%\[%\\&%g
-s%\]%\\&%g
-s%\$%$$%g
-EOF
-DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
-rm -f conftest.defs
-
-
-# Without the "./", some shells look in PATH for config.status.
-: ${CONFIG_STATUS=./config.status}
-
-echo creating $CONFIG_STATUS
-rm -f $CONFIG_STATUS
-cat > $CONFIG_STATUS <<EOF
-#! /bin/sh
-# Generated automatically by configure.
-# Run this file to recreate the current configuration.
-# This directory was configured as follows,
-# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
-#
-# $0 $ac_configure_args
-#
-# Compiler output produced by configure, useful for debugging
-# configure, is in ./config.log if it exists.
-
-ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
-for ac_option
-do
- case "\$ac_option" in
- -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
- echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
- exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
- -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
- echo "$CONFIG_STATUS generated by autoconf version 2.9"
- exit 0 ;;
- -help | --help | --hel | --he | --h)
- echo "\$ac_cs_usage"; exit 0 ;;
- *) echo "\$ac_cs_usage"; exit 1 ;;
- esac
-done
-
-ac_given_srcdir=$srcdir
-
-trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-# Protect against being on the right side of a sed subst in config.status.
-sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
- s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
-$ac_vpsub
-$extrasub
-s%@CFLAGS@%$CFLAGS%g
-s%@CPPFLAGS@%$CPPFLAGS%g
-s%@CXXFLAGS@%$CXXFLAGS%g
-s%@DEFS@%$DEFS%g
-s%@LDFLAGS@%$LDFLAGS%g
-s%@LIBS@%$LIBS%g
-s%@exec_prefix@%$exec_prefix%g
-s%@prefix@%$prefix%g
-s%@program_transform_name@%$program_transform_name%g
-s%@bindir@%$bindir%g
-s%@sbindir@%$sbindir%g
-s%@libexecdir@%$libexecdir%g
-s%@datadir@%$datadir%g
-s%@sysconfdir@%$sysconfdir%g
-s%@sharedstatedir@%$sharedstatedir%g
-s%@localstatedir@%$localstatedir%g
-s%@libdir@%$libdir%g
-s%@includedir@%$includedir%g
-s%@oldincludedir@%$oldincludedir%g
-s%@infodir@%$infodir%g
-s%@mandir@%$mandir%g
-s%@scm_files@%$scm_files%g
-s%@aux_files@%$aux_files%g
-s%@library_name@%$library_name%g
-s%@info_files@%$info_files%g
-s%@GUILE_VERSION@%$GUILE_VERSION%g
-
-CEOF
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
-EOF
-cat >> $CONFIG_STATUS <<\EOF
-for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile]", defaulting infile="outfile.in".
- case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
- ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
- *) ac_file_in="${ac_file}.in" ;;
- esac
-
- # Adjust relative srcdir, etc. for subdirectories.
-
- # Remove last slash and all that follows it. Not all systems have dirname.
- ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
- if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
- # The file is in a subdirectory.
- test ! -d "$ac_dir" && mkdir "$ac_dir"
- ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
- # A "../" for each directory in $ac_dir_suffix.
- ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
- else
- ac_dir_suffix= ac_dots=
- fi
-
- case "$ac_given_srcdir" in
- .) srcdir=.
- if test -z "$ac_dots"; then top_srcdir=.
- else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
- /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
- *) # Relative path.
- srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
- top_srcdir="$ac_dots$ac_given_srcdir" ;;
- esac
-
- echo creating "$ac_file"
- rm -f "$ac_file"
- configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
- case "$ac_file" in
- *Makefile*) ac_comsub="1i\\
-# $configure_input" ;;
- *) ac_comsub= ;;
- esac
- sed -e "$ac_comsub
-s%@configure_input@%$configure_input%g
-s%@srcdir@%$srcdir%g
-s%@top_srcdir@%$top_srcdir%g
-" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file
-fi; done
-rm -f conftest.subs
-
-
-
-exit 0
-EOF
-chmod +x $CONFIG_STATUS
-rm -fr confdefs* $ac_clean_files
-test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
-
diff --git a/ice-9/configure.in b/ice-9/configure.in
index cb1926a87..e69de29bb 100644
--- a/ice-9/configure.in
+++ b/ice-9/configure.in
@@ -1,17 +0,0 @@
-#
-# Process this file with autoconf to produce a configure script.
-#
-
-AC_INIT(boot-9.scm)
-
-. $srcdir/../GUILE-VERSION
-
-scm_files=""
-aux_files=""
-. $srcdir/PLUGIN/this.configure
-AC_SUBST(scm_files)
-AC_SUBST(aux_files)
-AC_SUBST(library_name)
-AC_SUBST(info_files)
-AC_SUBST(GUILE_VERSION)
-AC_OUTPUT(Makefile)
diff --git a/ice-9/debug.scm b/ice-9/debug.scm
new file mode 100644
index 000000000..f5515d376
--- /dev/null
+++ b/ice-9/debug.scm
@@ -0,0 +1,195 @@
+;;;; Copyright (C) 1996 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+(define-module #/ice-9/debug)
+
+
+
+;;; {Run-time options}
+
+(define names '((debug-options-interface
+ (debug-options debug-enable debug-disable)
+ (debug-set!))
+
+ (evaluator-traps-interface
+ (traps trap-enable trap-disable)
+ (trap-set!))
+
+ (read-options-interface
+ (read-options read-enable read-disable)
+ (read-set!))
+
+ (print-options-interface
+ (print-options print-enable print-disable)
+ (print-set!))
+ ))
+
+(define option-name car)
+(define option-value cadr)
+(define option-documentation caddr)
+
+(define (print-option option)
+ (display (option-name option))
+ (if (< (string-length (symbol->string (option-name option))) 8)
+ (display #\tab))
+ (display #\tab)
+ (display (option-value option))
+ (display #\tab)
+ (display (option-documentation option))
+ (newline))
+
+;;; Below follows the macros defining the run-time option interfaces.
+;;; *fixme* These should not be macros, but need to be until module
+;;; system is improved.
+;;;
+
+(define (make-options interface)
+ `(lambda args
+ (cond ((null? args) (,interface))
+ ((pair? (car args)) (,interface (car args)) (,interface))
+ (else (for-each print-option (,interface #t))))))
+
+(define (make-enable interface)
+ `(lambda flags
+ (,interface (append flags (,interface)))
+ (,interface)))
+
+(define (make-disable interface)
+ `(lambda flags
+ (let ((options (,interface)))
+ (for-each (lambda (flag)
+ (set! options (delq! flag options)))
+ flags)
+ (,interface options)
+ (,interface))))
+
+(define (make-set! interface)
+ `((name exp)
+ (,'quasiquote
+ (begin (,interface (append (,interface)
+ (list '(,'unquote name)
+ (,'unquote exp))))
+ (,interface)))))
+
+(defmacro define-all ()
+ (cons 'begin
+ (apply append
+ (map (lambda (group)
+ (let ((interface (car group)))
+ (append (map (lambda (name constructor)
+ `(define-public ,name
+ ,(constructor interface)))
+ (cadr group)
+ (list make-options
+ make-enable
+ make-disable))
+ (map (lambda (name constructor)
+ `(defmacro-public ,name
+ ,@(constructor interface)))
+ (caddr group)
+ (list make-set!)))))
+ names))))
+
+(define-all)
+
+
+;;; {Trace}
+;;;
+;;; This code is just an experimental prototype (e. g., it is not
+;;; thread safe), but since it's at the same time useful, it's
+;;; included anyway.
+;;;
+(define traced-procedures '())
+
+(define-public (trace . args)
+ (if (null? args)
+ (nameify traced-procedures)
+ (begin
+ (for-each (lambda (proc)
+ (if (not (procedure? proc))
+ (error "trace: Wrong type argument:" proc))
+ (set-procedure-property! proc 'trace #t)
+ (if (not (memq proc traced-procedures))
+ (set! traced-procedures
+ (cons proc traced-procedures))))
+ args)
+ (set! apply-frame-handler trace-entry)
+ (set! exit-frame-handler trace-exit)
+ (set! trace-level 0)
+ (debug-enable 'trace)
+ (nameify args))))
+
+(define-public (untrace . args)
+ (if (and (null? args)
+ (not (null? traced-procedures)))
+ (apply untrace traced-procedures)
+ (begin
+ (for-each (lambda (proc)
+ (set-procedure-property! proc 'trace #f)
+ (set! traced-procedures (delq! proc traced-procedures)))
+ args)
+ (if (null? traced-procedures)
+ (debug-disable 'trace))
+ (nameify args))))
+
+(define (nameify ls)
+ (map (lambda (proc)
+ (let ((name (procedure-name proc)))
+ (or name proc)))
+ ls))
+
+(define trace-level 0)
+(add-hook! abort-hook (lambda () (set! trace-level 0)))
+
+(define (trace-entry key cont tail)
+ (if (eq? (stack-id cont) 'repl-stack)
+ (let ((cep (current-error-port))
+ (frame (last-stack-frame cont)))
+ (if (not tail)
+ (set! trace-level (+ trace-level 1)))
+ (let indent ((n trace-level))
+ (cond ((> n 1) (display "| " cep) (indent (- n 1)))))
+ (display-application frame cep)))
+ (debug-enable 'trace)
+ ;; It's not necessary to call the continuation since
+ ;; execution will continue if the handler returns
+ ;(cont #f)
+ )
+
+(define (trace-exit key cont retval)
+ (if (eq? (stack-id cont) 'repl-stack)
+ (let ((cep (current-error-port)))
+ (set! trace-level (- trace-level 1))
+ (let indent ((n trace-level))
+ (cond ((> n 0) (display "| " cep) (indent (- n 1)))))
+ (write retval cep)
+ (newline cep)))
+ (debug-enable 'trace))
+
+
+;;; A fix to get the error handling working together with the module system.
+;;;
+(variable-set! (builtin-variable 'debug-options) debug-options)
+
+
+
+(debug-enable 'debug)
+(read-enable 'positions)
diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm
new file mode 100644
index 000000000..c563200cc
--- /dev/null
+++ b/ice-9/emacs.scm
@@ -0,0 +1,163 @@
+;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+;;; {Session support for Emacs}
+;;;
+
+(define-module (ice-9 emacs)
+ :use-module (ice-9 threads)
+ :use-module (ice-9 nonblocking))
+
+(define emacs-escape-character #\sub)
+
+(define emacs-output-port (current-output-port))
+
+(define (make-emacs-command char)
+ (let ((cmd (list->string (list emacs-escape-character char))))
+ (lambda ()
+ (display cmd emacs-output-port))))
+
+(define enter-input-wait (make-emacs-command #\s))
+(define exit-input-wait (make-emacs-command #\f))
+(define enter-read-character #\r)
+(define sending-error (make-emacs-command #\F))
+(define sending-backtrace (make-emacs-command #\B))
+(define sending-result (make-emacs-command #\x))
+(define end-of-text (make-emacs-command #\.))
+
+;; {Error handling}
+;;
+
+(add-hook! before-backtrace-hook sending-backtrace)
+(add-hook! after-backtrace-hook end-of-text)
+(add-hook! before-error-hook sending-error)
+(add-hook! after-error-hook end-of-text)
+
+;; {Repl}
+;;
+
+(set-current-error-port emacs-output-port)
+
+(add-hook! before-read-hook
+ (lambda ()
+ (enter-input-wait)
+ (force-output emacs-output-port)))
+
+(add-hook! after-read-hook
+ (lambda ()
+ (exit-input-wait)
+ (force-output emacs-output-port)))
+
+;;; {Misc.}
+
+(define (make-emacs-load-port orig-port)
+ (letrec ((read-char-fn (lambda args
+ (let ((c (read-char orig-port)))
+ (if (eq? c #\soh)
+ (throw 'end-of-chunk)
+ c)))))
+
+ (make-soft-port
+ (vector #f #f #f
+ read-char-fn
+ (lambda () (close-port orig-port)))
+ "r")))
+
+(set! repl-input-port (make-emacs-load-port (current-input-port)))
+(set-current-input-port repl-input-port)
+
+(define (emacs-eval-request form)
+ (let ((port (current-output-port)))
+ (sending-result port)
+ (write (eval form) port)
+ (end-of-text port)
+ (force-output port)))
+
+(define load-acknowledge (make-emacs-command #\l))
+
+(define load-port (current-input-port))
+
+(define (flush-line port)
+ (let loop ((c (read-char port)))
+ (if (not (eq? c #\nl))
+ (loop (read-char port)))))
+
+(define whitespace-chars (list #\space #\tab #\nl))
+
+(define (flush-whitespace port)
+ (catch 'end-of-chunk
+ (lambda ()
+ (let loop ((c (read-char port)))
+ (cond ((eq? c the-eof-object)
+ (error "End of file while recieving Emacs data"))
+ ((memq c whitespace-chars) (loop (read-char port)))
+ ((eq? c #\;) (flush-line port) (loop (read-char port)))
+ (else (unread-char c port))))
+ #f)
+ (lambda args
+ (read-char port) ; Read final newline
+ #t)))
+
+(define (emacs-load filename linum)
+ (set-port-filename! %%load-port filename)
+ (set-port-line! %%load-port (- linum 1))
+ (set-port-column! %%load-port 0)
+ (lazy-catch #t
+ (lambda ()
+ (let loop ((endp (flush-whitespace %%load-port)))
+ (if (not endp)
+ (begin
+ (start-stack read-and-eval! (read-and-eval! %%load-port))
+ (loop (flush-whitespace %%load-port)))
+ (begin
+ (load-acknowledge))))
+ )
+ (lambda (key . args)
+ (cond ((eq? key 'end-of-chunk)
+ (set! the-last-stack #f)
+ (set! stack-saved? #t)
+ (scm-error 'misc-error
+ 'emacs-load
+ "Incomplete expression"
+ '()
+ '()))
+ ((eq? key 'exit))
+ (else
+ (save-stack)
+ (catch 'end-of-chunk
+ (lambda ()
+ (let loop ()
+ (read-char %%load-port)
+ (loop)))
+ (lambda args
+ #f))
+ (apply throw key args))))))
+
+;;; A fix to get the emacs interface to work together with the module system.
+;;;
+(variable-set! (builtin-variable '%%load-port) load-port)
+(variable-set! (builtin-variable '%%emacs-load) emacs-load)
diff --git a/ice-9/expect.scm b/ice-9/expect.scm
new file mode 100644
index 000000000..9ac851f89
--- /dev/null
+++ b/ice-9/expect.scm
@@ -0,0 +1,124 @@
+;;; installed-scm-file
+
+;;;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+
+
+;;; Expect: a macro for selecting actions based on what it reads from a port.
+;;; The idea is from Don Libes' expect based on Tcl.
+;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
+
+
+(define expect-port #f)
+(define expect-timeout #f)
+(define expect-timeout-proc #f)
+(define expect-eof-proc #f)
+(define expect-char-proc #f)
+
+;;; expect: each test is a procedure which is applied to the accumulating
+;;; string.
+(defmacro expect clauses
+ (let ((s (gentemp))
+ (c (gentemp))
+ (port (gentemp))
+ (timeout (gentemp)))
+ `(let ((,s "")
+ (,port (or expect-port (current-input-port)))
+ (,timeout (if expect-timeout
+ (+ (* expect-timeout internal-time-units-per-second)
+ (get-internal-real-time))
+ #f)))
+ (let next-char ()
+ (if (and expect-timeout
+ (or (>= (get-internal-real-time) ,timeout)
+ (and (not (char-ready? ,port))
+ (not (expect-select ,port ,timeout)))))
+ (if expect-timeout-proc
+ (expect-timeout-proc ,s)
+ #f)
+ (let ((,c (read-char ,port)))
+ (if expect-char-proc
+ (expect-char-proc ,c))
+ (cond ((eof-object? ,c)
+ (if expect-eof-proc
+ (expect-eof-proc ,s)
+ #f))
+ (else
+ (set! ,s (string-append ,s (string ,c)))
+ (cond
+ ,@(let next-expr ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (body ()))
+ (cond
+ ((null? tests)
+ (reverse body))
+ (else
+ (next-expr
+ (cdr tests)
+ (cdr exprs)
+ (cons
+ `((,(car tests) ,s)
+ ,@(cond ((null? (car exprs))
+ ())
+ ((eq? (caar exprs) '=>)
+ (if (not (= (length (car exprs))
+ 2))
+ (scm-error 'misc-error
+ "expect"
+ "bad recipient: %S"
+ (list (car exprs))
+ #f)
+ `((apply ,(cadar exprs)
+ (,(car tests) ,s)))))
+ (else
+ (car exprs))))
+ body)))))
+ (else (next-char)))))))))))
+
+;;; the regexec front-end to expect:
+;;; each test must evaluate to a regular expression.
+(defmacro expect-strings clauses
+ `(let ,@(let next-test ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (defs ())
+ (body ()))
+ (cond ((null? tests)
+ (list (reverse defs) `(expect ,@(reverse body))))
+ (else
+ (let ((rxname (gentemp)))
+ (next-test (cdr tests)
+ (cdr exprs)
+ (cons `(,rxname (regcomp ,(car tests)
+ REG_NEWLINE))
+ defs)
+ (cons `((lambda (s)
+ (regexec ,rxname s ""))
+ ,@(car exprs))
+ body))))))))
+
+;;; simplified select: returns #t if input is waiting or #f if timed out.
+;;; timeout is absolute in terms of get-internal-real-time.
+(define (expect-select port timeout)
+ (let* ((relative (/ (- timeout (get-internal-real-time))
+ internal-time-units-per-second))
+ (relative-s (inexact->exact (floor relative)))
+ (relative-ms (inexact->exact
+ (round (* (- relative relative-s) 1000)))))
+ (and (> relative 0)
+ (pair? (car (select (list port) () ()
+ relative-s
+ relative-ms))))))
diff --git a/ice-9/gtcl.scm b/ice-9/gtcl.scm
new file mode 100644
index 000000000..bacccb043
--- /dev/null
+++ b/ice-9/gtcl.scm
@@ -0,0 +1,379 @@
+;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+(define-module (ice-9 gtcl) :use-module (ice-9 debug))
+
+(read-set! keywords 'prefix)
+
+(define-public TCL_VERSION "7.4")
+(define-public TCL_MAJOR_VERSION 7)
+(define-public TCL_MINOR_VERSION 4)
+
+;;; When a TCL command returns, the string pointer interp->result points to
+;;; a string containing return information from the command. In addition,
+;;; the command procedure returns an integer value, which is one of the
+;;; following:
+;;;
+;;; TCL_OK Command completed normally; interp->result contains
+;;; the command's result.
+;;; TCL_ERROR The command couldn't be completed successfully;
+;;; interp->result describes what went wrong.
+;;; TCL_RETURN The command requests that the current procedure
+;;; return; interp->result contains the procedure's
+;;; return value.
+;;; TCL_BREAK The command requests that the innermost loop
+;;; be exited; interp->result is meaningless.
+;;; TCL_CONTINUE Go on to the next iteration of the current loop;
+;;; interp->result is meaningless.
+;;;
+
+(define-public TCL_OK 0)
+(define-public TCL_ERROR 1)
+(define-public TCL_RETURN 2)
+(define-public TCL_BREAK 3)
+(define-public TCL_CONTINUE 4)
+
+;;; Flag values passed to variable-related procedures.
+;;;
+
+(define-public TCL_GLOBAL_ONLY 1)
+(define-public TCL_APPEND_VALUE 2)
+(define-public TCL_LIST_ELEMENT 4)
+(define-public TCL_TRACE_READS #x10)
+(define-public TCL_TRACE_WRITES #x20)
+(define-public TCL_TRACE_UNSETS #x40)
+(define-public TCL_TRACE_DESTROYED #x80)
+(define-public TCL_INTERP_DESTROYED #x100)
+(define-public TCL_LEAVE_ERR_MSG #x200)
+
+;;; Flag values to pass to TCL_DoOneEvent to disable searches
+;;; for some kinds of events:
+;;;
+
+(define-public TCL_DONT_WAIT 2)
+(define-public TCL_X_EVENTS 4)
+(define-public TCL_FILE_EVENTS 8)
+(define-public TCL_TIMER_EVENTS #x10)
+(define-public TCL_IDLE_EVENTS #x20)
+(define-public TCL_ALL_EVENTS -3)
+
+;; A convenience function for combining flag bits. Like logior, but
+;; handles the cases of 0 and 1 arguments.
+;;
+(define (flags . args)
+ (cond
+ ((null? args) 0)
+ ((null? (cdr args)) (car args))
+ (else (apply logior args))))
+
+
+;; MDJ 961023 <djurfeldt@nada.kth.se>
+(define-public (tcl-eval . strings)
+; (pk 'cmd strings)
+ (let* ((cmd (tcl-merge the-interpreter (map ->tcl-arg-string strings)))
+ (status (tcl-global-eval the-interpreter cmd)))
+ (if (zero? (car status))
+ (cdr status)
+ (error (cdr status)))))
+
+(define uniq-command
+ (let ((cnt 0))
+ (lambda (prefix)
+ (set! cnt (+ cnt 1))
+ (string-append prefix (number->string cnt)))))
+
+(define (closure->tcl-name p)
+ ;(let ((tcl-name (procedure-property p 'tcl-name)))
+ ;(or #f tcl-name
+ (let ((name (uniq-command ;(or (procedure-property p 'name)
+ "*__guile#"))
+ ;(template (procedure-property p 'tcl-calling-convention)))
+ )
+ (tcl-create-command the-interpreter name p)
+ ;(set-procedure-property! p 'tcl-name name)
+ name))
+
+(define (->tcl-arg-string v)
+ (cond
+ ((symbol? v) v)
+ ((keyword? v) (keyword-dash-symbol v))
+ ((string? v) v)
+ ((number? v) (number->string v))
+ ((eq? #f v) "0")
+ ((eq? #t v) "1")
+ ((closure? v)
+ (let ((cc (procedure-property v 'tcl-calling-convention)))
+ (if cc
+ (string-append (closure->tcl-name v) " " cc)
+ (closure->tcl-name v))))
+ (else "")))
+
+(define (tcl-args args)
+ (cond ((null? args) '())
+ ((symbol? (car args))
+ (cons (car args) (tcl-args (cdr args))))
+ ((keyword? (car args))
+ (cons (keyword-dash-symbol (car args)) (tcl-args (cdr args))))
+ ((string? (car args))
+ (cons (car args) (tcl-args (cdr args))))
+ ((number? (car args))
+ (cons (number->string (car args)) (tcl-args (cdr args))))
+ ((eq? #f (car args))
+ (cons "0" (tcl-args (cdr args))))
+ ((eq? #t (car args))
+ (cons "1" (tcl-args (cdr args))))
+ ((closure? (car args))
+ (let ((cc (procedure-property (car args) 'tcl-calling-convention)))
+ (if cc
+ (cons (string-append (closure->tcl-name (car args)) " " cc)
+ (tcl-args (cdr args)))
+ (cons (closure->tcl-name (car args))
+ (tcl-args (cdr args))))))
+ (else "")))
+
+;; MDJ 961023 <djurfeldt@nada.kth.se>
+(define-public (tcl-command interp name)
+ (let ((proc
+ (lambda args
+ (let ((status (tcl-global-eval
+ the-interpreter
+ (tcl-merge interp (map ->tcl-arg-string
+ (cons name args))))))
+ (if (zero? (car status))
+ (cdr status)
+ (throw 'tcl-error (cdr status)))))))
+ (set-procedure-property! proc 'name name)
+ proc))
+
+;; Reifying a Tcl command as a Scheme procedure.
+;;
+;(define-public (reify-tcl-command interp name)
+; (let ((command-object (tcl-command interp name)))
+; (and command-object
+; (let ((reified
+; (lambda args
+; (let ((answer
+; (tcl-apply-command command-object
+; (map (lambda (a)
+; (or (procedure-property a 'tk-command)
+; a))
+; args))))
+; (if (eq? 0 (car answer))
+; (tcl-string-> (cdr answer))
+; (throw 'tcl-error (cdr answer)))))))
+; (set-procedure-property! reified 'tk-command name)
+; reified))))
+(define-public reify-tcl-command tcl-command)
+
+(define-public (tcl-command? p)
+ (and (procedure? p) (procedure-property 'tcl-command)))
+
+;; Evaluate some code in the scope of a TCL-ERROR handler.
+;; The handler returns a conventional Tcl error value (i.e. (cons 1 message))
+;; Some type conversion is automaticly done on the return value to put it
+;; in a form Tcl will like.
+;;
+(defmacro-public with-tcl-error-handling body
+ `(catch 'tcl-error
+ (lambda () (->tcl-string (begin ,@body)))
+ (lambda (tag . message)
+ (cons 1 (apply errcat message)))))
+
+(define (errcat . args)
+ (apply string-append
+ (map (lambda (x)
+ (call-with-output-string
+ (lambda (p)
+ ((if (string? x) display write) x p)
+ (display " " p))))
+ args)))
+
+;; If this is defined to be an unary function, it gets to extend the
+;; default type conversion rules for arguments (it is passed otherwise
+;; unhandled values).
+;;
+(define-public tcl-type-converter #f)
+
+;; Default conversions from Scheme to Tcl strings.
+;;
+(define-public (->tcl-string val)
+ (cond
+ ((string? val) val)
+ ((symbol? val) val)
+ ((number? val) (number->string val))
+ ((eq? #f val) "0")
+ ((eq? #t val) "1")
+ ((keyword? val) (keyword->symbol val))
+ (#t "")))
+
+(define (that x) x)
+
+;; Default conversions from Tcl strings to Scheme.
+;;
+(define-public (tcl-string-> val)
+ (cond
+ ((string->number val) => that)
+ ((equal? "" val) #f)
+ (#t val)))
+
+
+;;; {An Implicit Default Interpreter}
+;;;
+;;; For programs like "wish" in which there is one designated default
+;;; interpreter.
+;;;
+
+(define-public the-interpreter #f)
+
+
+;; Use defined-tcl-command to extend the global namespace
+;; with commands from the default Tcl interpreter.
+;;
+;(define-public (use-default-tcl-commands)
+; (set! *top-level-lookup-thunk* defined-tcl-command))
+
+;; If there is a defined variable called NAME, return it.
+;; If not, but there is a Tcl command in the default interpreter
+;; called NAME, create a variable an initialize it to point to the
+;; reified Tcl command.
+;;
+;; Finally, always return a variable, perhaps undefined, if DEFINING?
+;; is a true value.
+;;
+(define-public (make-tcl-binder interp)
+ (lambda (m s define?)
+ (if define?
+ (let ((b (make-undefined-variable s)))
+ (module-obarray-set! (module-obarray m) s b)
+ (if (tcl-defined? the-interpreter s)
+ (variable-set! b (tcl-command interp s)))
+ b)
+ (and (tcl-defined? interp s)
+ (let ((b (make-undefined-variable s)))
+ (module-obarray-set! (module-obarray m) s b)
+ (variable-set! b (tcl-command interp s))
+ b)))))
+
+;; Used to define Scheme procedures which are also Tcl commands.
+;; The declarations syntax is;
+;;
+;; (proc name (?<calling-convention>? ?.? <formals>) <body>)
+;;
+;; which is expanded in terms of tcl-lambda.
+;;
+(defmacro-public proc (name . spec)
+ `(begin
+ (define ,name (tcl-lambda ,@ spec))
+ (tcl-create-command the-interpreter ',name ,name)))
+
+
+;; Used to define an anonymous Scheme procedure which is suitable
+;; for use as a Tcl command.
+;;
+;; The declaration syntax is:
+;;
+;; (tcl-lambda (?<calling-convention>? ?.? <formals>) <body>)
+;;
+;; A <calling-convention> is a string that describes how the procedure
+;; should be called when it is used as a Tcl command.
+;; If the procedure hash the tcl-name PROC, and the calling convention
+;; "%x %y", then the procedure will be called as:
+;;
+;; PROC %x %y
+;;
+;; Such calling conventions are useful in cases such as binding a Scheme
+;; procedure to Tk event.
+;;
+;; Formals specifications are as usual except that non-rest parameters
+;; can have declarations. Declarations are arbitrary expressions in which
+;; the name of the formal is in the second position. The expressions are
+;; evaluated in the scope of the formals, and may modify the formals by
+;; side effect. Declarations should return a false value to cause an error
+;; to be thrown, a true value otherwise.
+;;
+(defmacro-public tcl-lambda (formals . body)
+ (let* ((calling-convention (if (and (pair? formals)
+ (string? (car formals)))
+ (let ((a (car formals)))
+ (set! formals (cdr formals))
+ a)
+ #f))
+ (args (tcl-formals-vars formals))
+ (full-body `(begin
+ ,@(tcl-type-checks formals 1)
+ ,@body)))
+ `(let ((proc (lambda ,args
+ (with-tcl-error-handling ,full-body))))
+ ,@(if calling-convention
+ `((set-procedure-property! proc
+ 'tcl-calling-convention
+ ,calling-convention)
+ proc)
+ `(proc)))))
+
+
+;; From a list of formals, perhaps with declarations, return the
+;; formals <<e.g. (a (tcl->int b) . c) => (a b . c) >>
+;;
+(define-public (tcl-formals-vars formals)
+ (if (not (pair? formals))
+ formals
+ (cons (if (pair? (car formals))
+ (cadar formals)
+ (car formals))
+ (tcl-formals-vars (cdr formals)))))
+
+(define-public (tcl-error . args)
+ (apply throw (cons 'tcl-error args)))
+
+
+(define-public (tcl-type-checks formals pos)
+ (cond
+ ((not (pair? formals)) '())
+ ((not (pair? (car formals)))
+ (tcl-type-checks (cdr formals) (+ 1 pos)))
+ (#t (cons (tcl-type-check (car formals))
+ (tcl-type-checks (cdr formals) (+ 1 pos))))))
+
+(define-public tcl-type-converters
+ `( (number . ,(lambda (x) (tcl->number x))) ))
+
+(define (tcl-type-check x)
+ (let ((a (assoc (car x) tcl-type-converters)))
+ (if (not a)
+ (error "Unsupported declaration" x)
+ (list 'set! (cadr x) (cons (cdr a) (cdr x))))))
+
+(define-public (tcl->number x)
+ (cond ((string? x) (string->number x))
+ ((integer? x) x)
+ (#t (tcl-error "Expected integer but got" x))))
+
+;;; To support stack handling:
+
+(define v (builtin-variable 'tk-stack-mark))
+
+(variable-set! v ->tcl-string)
diff --git a/ice-9/gwish.scm b/ice-9/gwish.scm
new file mode 100644
index 000000000..8efff185d
--- /dev/null
+++ b/ice-9/gwish.scm
@@ -0,0 +1,90 @@
+;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+(define-module (ice-9 gwish)
+ :use-module (guile)
+ :use-module (ice-9 threads)
+ :use-module (ice-9 nonblocking)
+ :use-module (ice-9 gtcl))
+
+
+;;; {The Interpreter}
+;;;
+
+(set! the-interpreter (tcl-create-interp))
+
+(define gtcl-module (local-ref '(app modules ice-9 gtcl)))
+(define tcl-binder (make-tcl-binder the-interpreter))
+
+(set-module-binder! (module-public-interface gtcl-module) tcl-binder)
+
+;;; {Namespace cleaning}
+;;;
+
+;; These are the names of procedures already defined
+;; in Scheme but which, in this context, ought to refer
+;; to Tcl/Tk commands.
+
+(define override-scheme-list '(bind raise))
+
+(for-each
+ (lambda (name)
+ (eval `(set! ,name (reify-tcl-command the-interpreter ',name))))
+ override-scheme-list)
+
+;;; {Non-blocking ports}
+
+(define stdin-avail #t)
+
+(proc set-stdin-flag args (set! stdin-avail #t) "")
+
+(define wait TCL_ALL_EVENTS)
+(define dont-wait (+ wait TCL_DONT_WAIT))
+
+(set! handle-input-events
+ (lambda ()
+ (cond ((single-active-thread?) (tcl-do-one-event wait))
+ ((zero? (tcl-do-one-event dont-wait))
+ (yield)
+ ))
+ (if stdin-avail
+ (begin
+ (set! stdin-avail #f)
+ (signal-condition-variable repl-input-port-condvar)))))
+
+(fileevent 'stdin 'readable 'set-stdin-flag)
+
+(activate-non-blocking-input)
+
+;;; {The application window}
+
+(let ((init-status (tk-init-main-window the-interpreter
+ (or (getenv "DISPLAY") ":0")
+ "gwish"
+ "Gwish")))
+ (if (not (eq? #t init-status))
+ (error init-status)))
diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm
index ffde88608..28e4a6515 100644
--- a/ice-9/lineio.scm
+++ b/ice-9/lineio.scm
@@ -95,15 +95,14 @@
(read-string (lambda ()
(cond
- (buffers (let ((answer (car buffers)))
- (set! buffers (cdr buffers))
- answer))
-
- ((ungetc-char-ready? self) (read-line self 'include-newline))
-
- (else (read-line underlying-port 'include-newline)))))
-
- )
+ ((not (null? buffers))
+ (let ((answer (car buffers)))
+ (set! buffers (cdr buffers))
+ answer))
+ ((ungetc-char-ready? self)
+ (read-line self 'include-newline))
+ (else
+ (read-line underlying-port 'include-newline))))))
(set-object-property! self 'unread-string unread-string)
(set-object-property! self 'read-string read-string)
diff --git a/ice-9/mapping.scm b/ice-9/mapping.scm
index 9d9bb7aa6..ceb3a1b38 100644
--- a/ice-9/mapping.scm
+++ b/ice-9/mapping.scm
@@ -112,7 +112,8 @@
(else (error 'hash-table-mapping
"Hash-procedure specified with no known delete function."
hash-proc)))))
- (table-constructor (or (kw-arg-ref options :table-constructor) make-vector)))
+ (table-constructor (or (kw-arg-ref options :table-constructor)
+ (lambda (len) (make-vector len '())))))
(make-hash-table-mapping (table-constructor size)
hash-proc
assoc-proc
diff --git a/ice-9/nonblocking.scm b/ice-9/nonblocking.scm
new file mode 100644
index 000000000..926a40c85
--- /dev/null
+++ b/ice-9/nonblocking.scm
@@ -0,0 +1,82 @@
+;;;; Copyright (C) 1996 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+;;; {Non-blocking ports}
+;;;
+
+(define-module (ice-9 nonblocking)
+ :use-module (ice-9 threads))
+
+(define mu (make-mutex))
+(define-public repl-input-port-condvar (make-condition-variable))
+
+(define non-blocking-input #f)
+
+(define-public (make-non-blocking-port wait-port read-port)
+ (letrec ((read-char-fn (lambda args
+ (if (char-ready? wait-port)
+ (read-char read-port)
+ (begin
+ (wait-condition-variable repl-input-port-condvar
+ mu)
+ (unlock-mutex mu)
+ (read-char-fn))))))
+ (make-soft-port
+ (vector #f #f #f
+ read-char-fn
+ (lambda () (close-port orig-port)))
+ "r")))
+
+(define-public repl-input-port (current-input-port))
+(define-public basic-repl-input-port repl-input-port)
+
+(define-public handle-input-events
+ (lambda ()
+ (if (single-active-thread?)
+ (select (list basic-repl-input-port) '() '()))
+ (if (char-ready? basic-repl-input-port)
+ (signal-condition-variable repl-input-port-condvar)
+ (yield))))
+
+(define (kick)
+ (call-with-new-thread
+ (lambda ()
+ (error-catching-loop
+ (lambda ()
+ (let loop ()
+ (handle-input-events)
+ (loop)))))
+ (lambda args args)))
+
+(define-public (activate-non-blocking-input)
+ (if (not non-blocking-input)
+ (begin
+ (set! repl-input-port (make-non-blocking-port basic-repl-input-port
+ (current-input-port)))
+ (set-current-input-port repl-input-port)
+ (kick)
+ (set! non-blocking-input #t))))
diff --git a/ice-9/oldprint.scm b/ice-9/oldprint.scm
new file mode 100644
index 000000000..bec6d0358
--- /dev/null
+++ b/ice-9/oldprint.scm
@@ -0,0 +1,122 @@
+;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+
+
+;;; {Print}
+;;;
+;;; This code was removed from boot-9.scm by MDJ 970301
+;;; <djurfeldt@nada.kth.se>. It is placed here for archival
+;;; purposes.
+
+(define (print obj . args)
+ (let ((default-args (list (current-output-port) 0 0 default-print-style #f)))
+ (apply-to-args (append args (list-cdr-ref default-args (length args)))
+ (lambda (port depth length style table)
+ (cond
+ ((and table (print-table-ref table obj))
+ ((print-style-tag-hook style 'eq-val)
+ obj port depth length style table))
+ (else
+ (and table (print-table-add! table obj))
+ (cond
+ ((print-style-max-depth? style depth)
+ ((print-style-excess-depth-hook style)))
+ ((print-style-max-length? style length)
+ ((print-style-excess-length-hook style)))
+ (else
+ ((print-style-hook style obj)
+ obj port depth length style table)))))))))
+
+(define (make-print-style) (make-vector 59 '()))
+
+(define (extend-print-style! style utag printer)
+ (hashq-set! style utag printer))
+
+(define (print-style-hook style obj)
+ (let ((type-tag (tag obj)))
+ (or (hashq-ref style type-tag)
+ (hashq-ref style (logand type-tag 255))
+ print-obj)))
+
+(define (print-style-tag-hook style type-tag)
+ (or (hashq-ref style type-tag)
+ print-obj))
+
+(define (print-style-max-depth? style d) #f)
+(define (print-style-max-length? style l) #f)
+(define (print-style-excess-length-hook style)
+ (hashq-ref style 'excess-length-hook))
+(define (print-style-excess-depth-hook style)
+ (hashq-ref style 'excess-depth-hook))
+
+(define (make-print-table) (make-vector 59 '()))
+(define (print-table-ref table obj) (hashq-ref table obj))
+(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref)))
+
+(define (print-obj obj port depth length style table) (write obj port))
+
+(define (print-pair pair port depth length style table)
+ (if (= 0 length)
+ (display #\( port))
+
+ (print (car pair) port (+ 1 depth) 0 style table)
+
+ (cond
+ ((and (pair? (cdr pair))
+ (or (not table)
+ (not (print-table-ref table (cdr pair)))))
+
+ (display #\space port)
+ (print (cdr pair) port depth (+ 1 length) style table))
+
+ ((null? (cdr pair)) (display #\) port))
+
+ (else (display " . " port)
+ (print (cdr pair) port (+ 1 depth) 0
+ style table)
+ (display #\) port))))
+
+(define (print-vector obj port depth length style table)
+ (if (= 0 length)
+ (cond
+ ((weak-key-hash-table? obj) (display "#wh(" port))
+ ((weak-value-hash-table? obj) (display "#whv(" port))
+ ((doubly-weak-hash-table? obj) (display "#whd(" port))
+ (else (display "#(" port))))
+
+ (if (< length (vector-length obj))
+ (print (vector-ref obj length) port (+ 1 depth) 0 style table))
+
+ (cond
+ ((>= (+ 1 length) (vector-length obj)) (display #\) port))
+ (else (display #\space port)
+ (print obj port depth
+ (+ 1 length)
+ style table))))
+
+(define default-print-style (make-print-style))
+
+(extend-print-style! default-print-style utag_vector print-vector)
+(extend-print-style! default-print-style utag_wvect print-vector)
+(extend-print-style! default-print-style utag_pair print-pair)
+(extend-print-style! default-print-style 'eq-val
+ (lambda (obj port depth length style table)
+ (if (symbol? obj)
+ (display obj)
+ (begin
+ (display "##" port)
+ (display (print-table-ref table obj))))))
diff --git a/ice-9/poe.scm b/ice-9/poe.scm
index b594ebe13..eb3a13fca 100644
--- a/ice-9/poe.scm
+++ b/ice-9/poe.scm
@@ -45,7 +45,7 @@
;;;
-(define funcq-memo (make-weak-hash-table 523)) ; !!! randomly selected values
+(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
(define funcq-buffer (make-gc-buffer 256))
(define (funcq-hash arg-list n)
diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm
new file mode 100644
index 000000000..c1ab627cb
--- /dev/null
+++ b/ice-9/r4rs.scm
@@ -0,0 +1,145 @@
+;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
+;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
+
+;;;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;;; apply and call-with-current-continuation
+
+;;; We want these to be tail-recursive, so instead of using primitive
+;;; procedures, we define them as closures in terms of the primitive
+;;; macros @apply and @call-with-current-continuation.
+(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
+(define (call-with-current-continuation proc)
+ (@call-with-current-continuation proc))
+
+
+;;;; Basic Port Code
+
+;;; Specifically, the parts of the low-level port code that are written in
+;;; Scheme rather than C.
+;;;
+;;; WARNING: the parts of this interface that refer to file ports
+;;; are going away. It would be gone already except that it is used
+;;; "internally" in a few places.
+
+
+;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
+;; mode to open files in. MSDOS does carraige return - newline
+;; translation if not opened in `b' mode.
+;;
+(define OPEN_READ (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "rb")
+ (else "r")))
+(define OPEN_WRITE (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "wb")
+ (else "w")))
+(define OPEN_BOTH (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "r+b")
+ (else "r+")))
+
+(define *null-device* "/dev/null")
+
+(define (open-input-file str)
+ (open-file str OPEN_READ))
+
+(define (open-output-file str)
+ (open-file str OPEN_WRITE))
+
+(define (open-io-file str) (open-file str OPEN_BOTH))
+(define close-input-port close-port)
+(define close-output-port close-port)
+(define close-io-port close-port)
+
+(define (call-with-input-file str proc)
+ (let* ((file (open-input-file str))
+ (ans (proc file)))
+ (close-input-port file)
+ ans))
+
+(define (call-with-output-file str proc)
+ (let* ((file (open-output-file str))
+ (ans (proc file)))
+ (close-output-port file)
+ ans))
+
+(define (with-input-from-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-output-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-error-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-input-from-file file thunk)
+ (let* ((nport (open-input-file file))
+ (ans (with-input-from-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-output-to-file file thunk)
+ (let* ((nport (open-output-file file))
+ (ans (with-output-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-error-to-file file thunk)
+ (let* ((nport (open-output-file file))
+ (ans (with-error-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-input-from-string string thunk)
+ (call-with-input-string string
+ (lambda (p) (with-input-from-port p thunk))))
+
+(define (with-output-to-string thunk)
+ (call-with-output-string
+ (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-string thunk)
+ (call-with-output-string
+ (lambda (p) (with-error-to-port p thunk))))
+
+(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
+
+
+;;;; Loading
+
+(if (not (defined? '%load-verbosely))
+ (define %load-verbosely #f))
+(define (assert-load-verbosity v) (set! %load-verbosely v))
+
+(define (%load-announce file)
+ (if %load-verbosely
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (display ";;; ")
+ (display "loading ")
+ (display file)
+ (newline)
+ (force-output)))))
+
+(set! %load-hook %load-announce)
+
+(define (load name)
+ (start-stack 'load-stack
+ (primitive-load name)))
diff --git a/ice-9/slib.scm b/ice-9/slib.scm
index 3178598fd..1ef5c5a87 100644
--- a/ice-9/slib.scm
+++ b/ice-9/slib.scm
@@ -10,7 +10,7 @@
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <filename>)
- (do ((o (read port #t read-sharp) (read port #t read-sharp)))
+ (do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
@@ -35,6 +35,11 @@
(define slib:tab #\tab)
(define slib:form-feed #\page)
+(define slib-module (current-module))
+
+(define (defined? symbol)
+ (module-defined? slib-module symbol))
+
(define slib:features
(append '(source
eval
@@ -56,27 +61,27 @@
string-port
with-file)
- (if (defined? getenv)
+ (if (defined? 'getenv)
'(getenv)
'())
- (if (defined? current-time)
+ (if (defined? 'current-time)
'(current-time)
'())
- (if (defined? system)
+ (if (defined? 'system)
'(system)
'())
- (if (defined? array?)
+ (if (defined? 'array?)
'(array)
'())
- (if (defined? char-ready?)
+ (if (defined? 'char-ready?)
'(char-ready?)
'())
- (if (defined? array-for-each)
+ (if (defined? 'array-for-each)
'(array-for-each)
'())
@@ -102,25 +107,43 @@
'()))))
-(define slib-module (current-module))
-
(define (slib:load name)
(save-module-excursion
(lambda ()
(set-current-module slib-module)
- (load name))))
+ (let* ((errinfo (catch 'system-error
+ (lambda ()
+ (basic-load name)
+ #f)
+ (lambda args args)))
+ (errinfo (and errinfo
+ (catch 'system-error
+ (lambda ()
+ (basic-load (string-append name ".scm"))
+ #f)
+ (lambda args args)))))
+ (if errinfo
+ (apply throw errinfo))))))
(define slib:load-source slib:load)
(define defmacro:load slib:load)
-(define (library-vicinity) (string-append (implementation-vicinity) "slib/"))
+(define slib-parent-dir
+ (let* ((path (%search-load-path "slib/require.scm")))
+ (if path
+ (make-shared-substring path 0 (- (string-length path) 17))
+ (error "Could not find slib/require.scm in " %load-path))))
+
+(define-public (implementation-vicinity)
+ (string-append slib-parent-dir "/"))
+(define (library-vicinity)
+ (string-append (implementation-vicinity) "slib/"))
(define (scheme-implementation-type) 'guile)
(define (scheme-implementation-version) "")
(define (output-port-width . arg) 80)
(define (output-port-height . arg) 24)
-
;;; {Time}
;;;
@@ -139,6 +162,30 @@
(define (software-type) 'UNIX)
-(slib:load "require.scm")
+(slib:load (in-vicinity (library-vicinity) "require.scm"))
(define-public require require:require)
+
+;; {Extensions to the require system so that the user can add new
+;; require modules easily.}
+
+(define *vicinity-table*
+ (list
+ (cons 'implementation (implementation-vicinity))
+ (cons 'library (library-vicinity))))
+
+(define (install-require-vicinity name vicinity)
+ (let ((entry (assq name *vicinity-table*)))
+ (if entry
+ (set-cdr! entry vicinity)
+ (set! *vicinity-table*
+ (acons name vicinity *vicinity-table*)))))
+
+(define (install-require-module name vicinity-name file-name)
+ (let ((entry (assq name *catalog*))
+ (vicinity (cdr (assq vicinity-name *vicinity-table*))))
+ (let ((path-name (in-vicinity vicinity file-name)))
+ (if entry
+ (set-cdr! entry path-name)
+ (set! *catalog*
+ (acons name path-name *catalog*))))))
diff --git a/ice-9/source.scm b/ice-9/source.scm
new file mode 100644
index 000000000..3d3a960a4
--- /dev/null
+++ b/ice-9/source.scm
@@ -0,0 +1,161 @@
+;;;; source.scm --- finding lines of source code for the debugger to display
+;;;; Jim Blandy <jimb@cyclic.com> --- February 1997
+;;;;
+;;;; Copyright (C) 1997 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; This module retrieves selected lines from files of source code.
+;;; It's meant for use by source-level debuggers, to display regions
+;;; of code to the user.
+;;;
+
+;;; We don't keep the text in memory. However, we do cache the
+;;; starting positions of each line in the file, so once the file has
+;;; been scanned, we can extract any line we want pretty quickly. We
+;;; also only scan as far as we need, i.e., up to the latest line
+;;; we've been asked for. This is fast enough for interactive use,
+;;; but doesn't take up much memory.
+
+;(define-module '(ice-9 source))
+
+
+;;;; public interface
+
+;;; (get-source-line FILE LINE)
+;;; Return the text of the LINE'th line from the file FILE, as a
+;;; string.
+(define-public (get-source-line file line)
+ ...)
+
+;;; (check-source-cache FILE)
+;;; The source access routines in this module cache some information
+;;; about the contents of the files they examine. If we have cached
+;;; any information about FILE, check its modification time, and forget
+;;; our cached information if it is out of date.
+;;;
+;;; Try to call this function periodically before retrieving lines
+;;; from FILE; however, it does perform a file system access, so don't
+;;; call it too often.
+
+
+;;;; trivia
+
+(define (throw-out-of-range op index)
+ (throw 'out-of-range op "Argument out of range: %S" (list index) #f))
+
+
+;;;; stretchy vectors
+
+;;; A stretchy vector is one that you can append new entries onto
+;;; efficiently.
+
+;;; (make-svect) => a new, zero-length stretchy vector
+(define (make-svect)
+ (cons 0 (make-vector 20 '-)))
+
+;;; (svect-ref SVECT K) => the K'th element of SVECT
+(define (svect-ref svect k)
+ (vector-ref (cdr svect) k))
+
+;;; (svect-add! SVECT ELT) => append ELT to the end of SVECT
+(define (svect-add! svect elt)
+
+ ;; If we don't have room in the current vector, create a new, larger one.
+ (if (>= (car svect) (vector-length (cdr svect)))
+ (let* ((old-vect (cdr svect))
+ (new-vect (make-vector (* 2 (vector-length old-vect)) '-)))
+ (vector-move-left! old-vect 0 (vector-length old-vect)
+ new-vect 0)
+ (set-cdr! svect new-vect)))
+
+ (vector-set! (cdr svect) (car svect) elt)
+ (set-car! svect (+ 1 (car svect))))
+
+;;; (svect-length SVECT) => the length of SVECT
+(define svect-length car)
+
+
+;;;; source files
+
+;;; We keep a limited number of source files open at any given time.
+;;; A source file structure looks like:
+;;;
+;;; (PORT LINESTARTS)
+;;;
+;;; PORT is a seekable input port looking at a text file.
+;;; LINESTARTS is a stretchy vector, whose Ith element is the seek
+;;; position of the start of line I (assuming lines are numbered
+;;; starting with zero). The file may have more lines than this
+;;; array records; this occurs when we haven't completely scanned
+;;; the file.
+(define (make-source file)
+ (let ((port (open-input-file file)))
+ (let ((linestarts (make-svect)))
+ (svect-add! linestarts 0) ; We know where the first line starts.
+ (list port linestarts))))
+
+;;; Return the text of the LINE'th line of SOURCE. Return the EOF
+;;; object if SOURCE doesn't have that many lines.
+(define (get-line source line)
+ (let* ((port (car source))
+ (linestarts (cadr source))
+ (known (svect-length linestarts)))
+
+ ;; Starting at the last line whose position is known, scan SOURCE for
+ ;; new line positions, until we've found the start of the LINE'th
+ ;; line. Assume that LINE is not one whose position we already know.
+ ;; Record all line positions in SOURCE. Return the text of
+ ;; the LINE'th line (without a newline), or the EOF object if the
+ ;; file doesn't have that many lines.
+ (define (scan line)
+ (fseek port (svect-ref linestarts (- known 1)) SEEK_SET)
+ (let loop ((known known))
+ (let ((text (read-line port)))
+ (if (eof-object? text) text
+ (begin
+ (svect-add! linestarts (ftell port))
+ (if (>= line known) (loop (+ known 1))
+ text))))))
+
+ ;; Return the text of the line that starts at POS.
+ (define (get pos)
+ (fseek port pos SEEK_SET)
+ (read-line port))
+
+ (if (< line known)
+ (get (svect-ref linestarts line))
+ (scan line))))
+
+
+;;;; cache of files
+
+;;; The cache is an alist mapping filenames onto source objects. We
+;;; put a fixed limit on the number of files it contains; new files replace
+;;; the least recently used file.
+
+(define (cache-add! cache max file source)
+ (let* ((cache (cons (cons file source) cache))
+ (
+ (set-cdr!
+
+(define (cache-ref file)
+
+
+
+
+(define the-file-cache '())
+(define file-cache-max 10)
+
diff --git a/ice-9/test.scm b/ice-9/test.scm
new file mode 100644
index 000000000..aeb28ee59
--- /dev/null
+++ b/ice-9/test.scm
@@ -0,0 +1,1032 @@
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "test.scm" Test correctness of scheme implementations.
+;;; Author: Aubrey Jaffer
+;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
+;;; won't pass. Made the the tests (test-cont), (test-sc4), and
+;;; (test-delay) start to run automatically.
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named
+;;; "test.scm", so you'll have to run it from the ice-9 source
+;;; directory, or copy this file elsewhere
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests. You may need to delete them in order to run
+;;; "test.scm" more than once.
+
+;;; 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 or
+;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
+
+(define cur-section '())(define errs '())
+(define SECTION (lambda args
+ (display "SECTION") (write args) (newline)
+ (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(define test
+ (lambda (expect fun . args)
+ (write (cons fun args))
+ (display " ==> ")
+ ((lambda (res)
+ (write res)
+ (newline)
+ (cond ((not (equal? expect res))
+ (record-error (list res expect (cons fun args)))
+ (display " BUT EXPECTED ")
+ (write expect)
+ (newline)
+ #f)
+ (else #t)))
+ (if (procedure? fun) (apply fun args) (car args)))))
+(define (report-errs)
+ (newline)
+ (if (null? errs) (display "Passed all tests")
+ (begin
+ (display "errors were:")
+ (newline)
+ (display "(SECTION (got expected (call)))")
+ (newline)
+ (for-each (lambda (l) (write l) (newline))
+ errs)))
+ (newline))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+ (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+ (list
+ #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\ ))
+ (set! i (+ 3 i))
+ (write x)
+ (newline))
+ disjoint-type-functions)
+(define type-matrix
+ (map (lambda (x)
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ (write t)
+ (write x)
+ (newline)
+ t))
+ type-examples))
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+(test 'composite 'case (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+ (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+ (odd?
+ (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+ (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x 5) (+ x 1)))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((negative? (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg)))))
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+ 'quasiquote
+ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it.
+(define (sqt x)
+ (do ((i 0 (+ i 1)))
+ ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+ (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(SECTION 5 2 2)
+(test 45 'define
+ (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+;;; Not for Guile
+;(test #f not '())
+;(test #f not (list))
+(test #f not 'nil)
+
+(test #t boolean? #f)
+(test #f boolean? 0)
+;;; Not for Guile
+;(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+ (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+(test #t pair? '(a . b))
+(test #t pair? '(a . 1))
+(test #t pair? '(a b c))
+(test #f pair? '())
+(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+(test #f symbol? "bar")
+(test #t symbol? 'nil)
+(test #f symbol? '())
+(test #f symbol? #f)
+;;; But first, what case are symbols in? Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+ (set! char-standard-case char-downcase))
+;;; Not for Guile
+;(test #t 'standard-case
+; (string=? (symbol->string 'a) (symbol->string 'A)))
+;(test #t 'standard-case
+; (or (string=? (symbol->string 'a) "A")
+; (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+ (let ((v (make-string (string-length s))))
+ (do ((i (- (string-length v) 1) (- i 1)))
+ ((< i 0) v)
+ (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+ (set! s (str-copy s))
+ (do ((i 0 (+ 1 i))
+ (sl (string-length s)))
+ ((>= i sl) s)
+ (string-set! s i (char-standard-case (string-ref s i)))))
+;;; Not for Guile
+;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+;(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+;;; Not for Guile
+;(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+;;; Not for Guile
+;(test #t eq? 'mISSISSIppi 'mississippi)
+;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3 5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(define (divtest n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+ (define f3.9 (string->number "3.9"))
+ (define f4.0 (string->number "4.0"))
+ (define f-3.25 (string->number "-3.25"))
+ (define f.25 (string->number ".25"))
+ (define f4.5 (string->number "4.5"))
+ (define f3.5 (string->number "3.5"))
+ (define f0.0 (string->number "0.0"))
+ (define f0.8 (string->number "0.8"))
+ (define f1.0 (string->number "1.0"))
+ (define wto write-test-obj)
+ (define dto display-test-obj)
+ (define lto load-test-obj)
+ (newline)
+ (display ";testing inexact numbers; ")
+ (newline)
+ (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 (- f4.0) round (- f4.5))
+ (test (- f4.0) round (- f3.5))
+ (test (- f4.0) round (- f3.9))
+ (test f0.0 round f0.0)
+ (test f0.0 round f.25)
+ (test f1.0 round f0.8)
+ (test f4.0 round f3.5)
+ (test f4.0 round f4.5)
+ (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+ (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+ (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+ (test #t call-with-output-file
+ "tmp3"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+ (check-test-file "tmp3")
+ (set! write-test-obj wto)
+ (set! display-test-obj dto)
+ (set! load-test-obj lto)
+ (let ((x (string->number "4195835.0"))
+ (y (string->number "3145727.0")))
+ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+ (report-errs))
+
+(define (test-bignum)
+ (define tb
+ (lambda (n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2)))))
+ (newline)
+ (display ";testing bignums; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test 0 modulo -2177452800 86400)
+ (test 0 modulo 2177452800 -86400)
+ (test 0 modulo 2177452800 86400)
+ (test 0 modulo -2177452800 -86400)
+ (test #t 'remainder (tb 281474976710655 65535))
+ (test #t 'remainder (tb 281474976710654 65535))
+ (SECTION 6 5 6)
+ (test 281474976710655 string->number "281474976710655")
+ (test "281474976710655" number->string 281474976710655)
+ (report-errs))
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+
+(SECTION 6 6)
+(test #t eqv? '#\ #\Space)
+(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\ )
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(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))
+(test -3 call-with-current-continuation
+ (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
+ (lambda (return)
+ (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+ ((pair? obj) (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation. It
+;;; is a separate test because some schemes do not support call/cc
+;;; 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.
+(define (next-leaf-generator obj eot)
+ (letrec ((return #f)
+ (cont (lambda (x)
+ (recur obj)
+ (set! cont (lambda (x) (return eot)))
+ (cont #f)))
+ (recur (lambda (obj)
+ (if (pair? obj)
+ (for-each recur obj)
+ (call-with-current-continuation
+ (lambda (c)
+ (set! cont c)
+ (return obj)))))))
+ (lambda () (call-with-current-continuation
+ (lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+ (let* ((eot (list 'eot))
+ (xf (next-leaf-generator x eot))
+ (yf (next-leaf-generator y eot)))
+ (letrec ((loop (lambda (x y)
+ (cond ((not (eq? x y)) #f)
+ ((eq? eot x) #t)
+ (else (loop (xf) (yf)))))))
+ (loop (xf) (yf)))))
+(define (test-cont)
+ (newline)
+ (display ";testing continuations; ")
+ (newline)
+ (SECTION 6 9)
+ (test #t leaf-eq? '(a (b (c))) '((a) b c))
+ (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+ (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+ (newline)
+ (display ";testing DELAY and FORCE; ")
+ (newline)
+ (SECTION 6 9)
+ (test 3 'delay (force (delay (+ 1 2))))
+ (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+ (test 2 'delay (letrec ((a-stream
+ (letrec ((next (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+ (head car)
+ (tail (lambda (stream) (force (cdr stream)))))
+ (head (tail (tail a-stream)))))
+ (letrec ((count 0)
+ (p (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (x 5))
+ (test 6 force p)
+ (set! x 10)
+ (test 6 force p))
+ (test 3 'force
+ (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+ (c #f))
+ (force p)))
+ (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file "test.scm" input-port?)
+(define this-file (open-input-file "test.scm"))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+ (define test-file (open-input-file name))
+ (test #t 'input-port?
+ (call-with-input-file
+ name
+ (lambda (test-file)
+ (test load-test-obj read test-file)
+ (test #t eof-object? (peek-char test-file))
+ (test #t eof-object? (read-char test-file))
+ (input-port? test-file))))
+ (test #\; read-char test-file)
+ (test display-test-obj read test-file)
+ (test load-test-obj read test-file)
+ (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+ '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+ '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+ (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+ "tmp1"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+(check-test-file "tmp1")
+
+(define test-file (open-output-file "tmp2"))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+(define (test-sc4)
+ (newline)
+ (display ";testing scheme 4 functions; ")
+ (newline)
+ (SECTION 6 7)
+ (test '(#\P #\space #\l) string->list "P l")
+ (test '() string->list "")
+ (test "1\\\"" list->string '(#\1 #\\ #\"))
+ (test "" list->string '())
+ (SECTION 6 8)
+ (test '(dah dah didah) vector->list '#(dah dah didah))
+ (test '() vector->list '#())
+ (test '#(dididit dah) list->vector '(dididit dah))
+ (test '#() list->vector '())
+ (SECTION 6 10 4)
+ (load "tmp1")
+ (test write-test-obj 'load foo)
+ (report-errs))
+
+(report-errs)
+(if (and (string->number "0.0") (inexact? (string->number "0.0")))
+ (test-inexact))
+
+(let ((n (string->number "281474976710655")))
+ (if (and n (exact? n))
+ (test-bignum)))
+(newline)
+(test-cont)
+(newline)
+(test-sc4)
+(newline)
+(test-delay)
+(newline)
+"last item in file"
diff --git a/ice-9/threads.scm b/ice-9/threads.scm
new file mode 100644
index 000000000..bec189009
--- /dev/null
+++ b/ice-9/threads.scm
@@ -0,0 +1,53 @@
+;;;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; ----------------------------------------------------------------
+;;;; threads.scm -- User-level interface to Guile's thread system
+;;;; 4 March 1996, Anthony Green <green@cygnus.com>
+;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
+;;;; ----------------------------------------------------------------
+;;;;
+
+
+(define-module #/ice-9/threads)
+
+
+
+; --- MACROS -------------------------------------------------------
+
+(defmacro-public make-thread (fn . args)
+ `(call-with-new-thread
+ (lambda ()
+ (,fn ,@args))
+ (lambda args args)))
+
+(defmacro-public begin-thread (first . thunk)
+ `(call-with-new-thread
+ (lambda ()
+ (begin
+ ,first ,@thunk))
+ (lambda args args)))
+
+(defmacro-public with-mutex (m . thunk)
+ `(dynamic-wind
+ (lambda () (lock-mutex ,m))
+ (lambda () (begin ,@thunk))
+ (lambda () (unlock-mutex ,m))))
+
+(defmacro-public monitor (first . thunk)
+ `(with-mutex ,(make-mutex)
+ (begin
+ ,first ,@thunk)))
diff --git a/libguile/.cvsignore b/libguile/.cvsignore
new file mode 100644
index 000000000..209746383
--- /dev/null
+++ b/libguile/.cvsignore
@@ -0,0 +1,20 @@
+*.la
+*.lo
+*.x
+.deps
+.libs
+Makefile
+config.cache
+config.log
+config.status
+cpp_err_symbols.c
+cpp_sig_symbols.c
+errnos.list
+fd.h
+gh_test_c
+gh_test_repl
+guile-snarf
+libpath.h
+libtool
+scmconfig.h
+stamp-h
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 1726e3cb5..5735bf4d5 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,3177 @@
+Mon Apr 14 20:20:14 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Merge threads directory into libguile.
+ * coop-defs.h, coop-threads.c, coop-threads.h, coop.c, threads.c,
+ threads.h: New source files.
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Add threads.c.
+ (noinst_HEADERS): Add coop-threads.c, coop-threads.h, coop.c
+ here; see comment.
+ (modinclude_HEADERS): Add threads.h, coop-defs.h.
+ (EXTRA_DIST): Add fsu-pthreads.h, mit-pthreads.c, mit-pthreads.h,
+ coop-threads.c.cygnus, coop-threads.h.cygnus.
+ * configure.in: If we're using threads, include threads.o in
+ LIBOBJS.
+ * _scm.h, libguile.h: threads.h lives in this directory now.
+ * fsu-pthreads.h, mit-pthreads.c, mit-pthreads.h,
+ coop-threads.c.cygnus, coop-threads.h.cygnus: New files, not
+ currently used, but brought along for information's sake.
+ * ChangeLog-threads: log from old 'threads' directory.
+ * Makefile.in, configure: Rebuilt.
+
+Mon Apr 14 20:15:29 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * stime.c (scm_mktime): #ifndef HAVE_TM_ZONE, Use lt.tm_zone, not
+ lt->tm_zone.
+
+Mon Apr 14 01:32:57 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * gh_init.c (gh_standard_handler): Return SCM_BOOL_F, not garbage.
+
+ Merge GH interface library into libguile.
+ * gh.h, gh_data.c, gh_eval.c, gh_funcs.c, gh_init.c, gh_io.c,
+ gh_list.c, gh_predicates.c, gh_test_c.c, gh_test_repl.c: New files.
+ * Makefile.am (libguile_la_SOURCES): Add gh_data.c, gh_eval.c,
+ gh_funcs.c, gh_init.c, gh_io.c, gh_list.c, gh_predicates.c. Move
+ _scm.h to ...
+ (EXTRA_libguile_la_SOURCES): ... here.
+ (pkginclude_HEADERS): Add variable, to get gh.h installed.
+ (THREAD_LIBS, check_ldadd, check_PROGRAMS, gh_test_c_SOURCES,
+ gh_test_c_LDADD, gh_test_repl_SOURCES, gh_test_repl_LDADD):
+ New variables, describing how to build the gh test programs.
+ * configure.in: Check for -lm, -lsocket, -lnsl; we need this to
+ build the test programs, and we probably should have been linking
+ libguile.la against them all along, to support AIX shared libs.
+ Add cflags for threads to CFLAGS; add libs for threads to new
+ variable THREAD_LIBS, used in Makefile.am.
+ * ChangeLog-gh: log from old `gh' subdirectory.
+ * Makefile.in, configure, scmconfig.h.in: Rebuilt.
+
+Sun Apr 13 23:03:55 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * acconfig.h: Undo change of Apr 9; including the definition of
+ PACKAGE in the guile headers conflicts with applications' own
+ definitions.
+ * scmconfig.h.in: Regenerated.
+
+Fri Apr 11 14:12:13 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+* * filesys.c (scm_fcntl): New function from Roland McGrath.
+ (scm_init_filesys): New symbols for use with fcntl.
+ * filesys.h: Added prototype.
+
+ * eval.c (SCM_APPLY): Set debug apply frame argument list correctly
+ when PROC is receiving no arguments.
+
+Fri Apr 11 19:39:32 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * filesys.c (S_ISSOCK): Define this if it's missing, but we do
+ have S_IFSOCK. This is the case under Ultrix.
+
+ * posix.c (scm_status_exit_val, scm_status_exit_val,
+ scm_status_term_sig, scm_status_stop_sig): Modified to work with
+ Ultrix versions of WIFSTOPPED, etc., which assume that their
+ arguments are lvalues (hmm).
+
+Thu Apr 10 15:10:07 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c: Doc fixes.
+
+ * throw.c: Doc fixes; rearranged.
+
+ * putenv.c: #include "libguile/scmconfig.h", not <config.h>.
+
+Wed Apr 9 18:01:20 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * acconfig.h: Added entry for PACKAGE.
+ * scmconfig.h.in: Regenerated.
+
+ Changes to work with automake-1.1n, which has better libtool support.
+ * Makefile.am: Use lib_LTLIBRARIES instead of lib_PROGRAMS.
+ Use libguile_la_LIBADD instead of libguile_la_LDADD. (What's the
+ difference here?)
+ (libguile_la_SOURCES, modinclude_HEADERS, EXTRA_DIST): Format for
+ readability.
+ * Makefile.in: Rebuild.
+
+Wed Apr 9 09:08:54 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (scm_mktime): take an optional zone argument.
+ (scm_localtime): check putenv return value.
+ (scm_strftime, scm_strptime): moved from posix.c. move #include
+ sequences.h too.
+ stime.h, posix.h: update prototypes.
+ (bdtime2c, setzone, restorezone): new static procedures.
+ (scm_mktime, scm_strftime): use them.
+ (scm_strftime): don't call mktime before strftime. Use
+ filltime for return value.
+ (filltime): convert NULL zname to #f.
+* (scm_strptime): return a count of characters consumed, not
+ the remaining string.
+
+Sun Apr 6 05:44:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (scm_localtime): check HAVE_TM_ZONE and HAVE_TZNAME.
+ (scm_mktime): likewise.
+ Declare *tzname[].
+ Uncomment localtime and mktime.
+
+ * configure.in: add AC_STRUCT_TIMEZONE.
+
+Sat Apr 5 23:56:40 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (scm_init_stime): don't define ticks/sec.
+ (scm_gettimeofday): renamed from scm_time_plus_ticks (avoids multiple
+ return value problem and is still portable.)
+
+Sat Apr 5 17:59:24 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * cpp_err_symbols.in: Renamed from cpp_err_symbols, to avoid
+ make's implicit cpp_err_symbols: cpp_err_symbols.c rule.
+ * cpp_sig_symbols.in: Renamed from cpp_sig_symbols.
+ * Makefile.am (check_errnos, check_signals, cpp_sig_symbols.c,
+ cpp_err_symbols.c): Corresponding changes.
+ * Makefile.in: Regenerated.
+
+Sat Apr 5 02:39:02 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c (scm_putenv): don't check HAVE_PUTENV.
+ * Makefile.am (EXTRA_libguile_la_SOURCES): add putenv.c.
+ * configure.in: move putenv from AC_CHECK_FUNCS to AC_REPLACE_FUNCS.
+ * putenv.c: new file, from sh-utils 1.12.
+
+ * posix.c (scm_environ): use malloc in place of scm_must_malloc
+ since allocation isn't for Scheme objects.
+ (scm_putenv): copy strings before placing in the environment.
+
+ * stime.c (scm_current_time): throw an error if time returns -1,
+ instead of returning #f.
+ (scm_get_internal_real_time, scm_get_internal_real_time): use
+ scm_long2num for return value instead of SCM_MAKINUM.
+
+ * stime.h: prototypes updated.
+
+ * stime.c (scm_time_in_msec): apparently unused, deleted.
+
+Fri Apr 4 08:53:41 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure.in: check for gettimeofday.
+
+ * stime.c (scm_time_plus_ticks): new procedure, an scsh interface
+ which may be more usefully portable than a gettimeofday interface.
+
+Wed Apr 2 17:11:39 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.am (EXTRA_DIST): It's cpp_err_symbols, not
+ cpp_err_signals.
+ * Makefile.in: Regenerated.
+
+Mon Mar 31 03:22:37 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (filltime): recovered static procedure.
+ (scm_localtime, scm_gmtime, scm_mktime, scm_tzset): recovered from
+ an earlier Guile.
+
+ * posix.h: add prototype for scm_close_pipe, remove prototypes for
+ scm_open_input_pipe, scm_open_output_pipe, change scm_mknod prototype.
+
+* * posix.c (scm_mknod): split the mode argument into type and perms
+ arguments, like the extra fields returned by stat.
+
+ * fports.c (scm_pipob): set the close, free and print procedures.
+ (scm_close_pipe): new procedure.
+
+ * posix.c (scm_open_input_pipe, scm_open_output_pipe): deleted,
+ define them in boot-9.scm
+
+Wed Mar 26 04:10:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_setfileno): throw a runtime error if SET_FILE_FD_FIELD
+ wan't defined. Don't include fd.h.
+
+ * Previously fd.h was regenerated whenever configure was run,
+ forcing a couple of files to be recompiled.
+
+ * fd.h.in: deleted, SET_FILE_FD_FIELD moved to ioext.c.
+ * configure.in: AC_DEFINE FD_SETTER instead of HAVE_FD_SETTER.
+ Check for _fileno as well as _file.
+ Don't output fd.h.
+ * ioext.c: don't fd.h.
+ * acconfig.h: remove duplicate HAVE_FD_SETTER and change the
+ other to FD_SETTER.
+
+ * Change the stratigy for getting information about errno
+ (and now signal number) values, e.g., ENOSYS, SIGKILL. Instead of
+ generating lists of symbols during the build process, which will
+ not always work, include comprehensive lists in the distribution.
+ To help keep the lists up to date, the "check_signals" and
+ "check_errnos" make targets can be used.
+
+ * configure.in: don't check for a command to extract errno codes.
+ * Makefile.am: update file lists, remove errnos.list and errnos.c
+ targets, add cpp_err_symbols.c, cpp_sig_symbols.c, check_signals,
+ check_errnos targets.
+ (CLEANFILES): remove errnos.c and errnos.list, add
+ cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new
+ cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new
+ * errnos.default: deleted.
+ * cpp_signal.c: new file.
+ * cpp_errno.c: renamed from errnos_get.c.
+ * cpp_err_symbols, cpp_sig_symbols: new files.
+ * cpp_cnvt.awk: renamed from errnos_cnvt_awk.
+ * error.c (scm_init_error): #include cpp_err_symbols instead of
+ errnos.c.
+ * posix.c (scm_init_posix): don't intern signal symbols. #include
+ cpp_sig_symbols.c.
+
+Tue Mar 25 04:51:10 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * strop.c (scm_i_index): allow the lower bound to be equal to the
+ length of the string, so a null string doesn't always give an error.
+
+ * posix.h: new prototypes.
+ * posix.c (scm_status_exit_val, scm_status_term_sig,
+ scm_status_stop_sig): new functions, as in scsh. They break down
+ process status values as returned by waitpid.
+
+Sat Mar 22 18:16:29 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * net_db.c (scm_gethost): don't check HAVE_GETHOSTENT, since
+ configure doesn't know about it.
+
+Fri Mar 21 23:49:28 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * snarf.h, backtrace.c: Name change SCM_GLOBAL --> SCM_VCELL.
+
+ * snarf.h: Added new macros SCM_GLOBAL_SYMBOL and SCM_GLOBAL_VCELL
+ which defines C variables with global linkage.
+
+Mon Mar 17 05:57:11 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * snarf.h (SCM_PROC1): Bugfix: Use (void) rather than (...) for
+ zero arg subrs.
+
+Sun Mar 16 11:43:49 1997 Mikael Djurfeldt <mdj@floss.cyclic.com>
+
+ * eval.c (safe_setjmp): Temporarily use old setjmp until someone
+ has time to check why this doesn't work well with continuations.
+
+Sun Mar 16 05:09:55 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Fix shell syntax error; some shells won't tolerate
+ multiple "fi" statements on a single line. (Thanks to Fred Fish.)
+
+Sat Mar 15 01:11:40 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c (scm_uname): throw an error if uname fails instead
+ of returning errno.
+
+ * error.h (scm_errno, scm_perror): obsolete prototypes removed.
+
+ * error.c (err_head, scm_errno, scm_perror): obsolete procedures
+ removed.
+
+ * async.c (scm_ints_disabled): definition moved from error.c.
+
+Sat Mar 15 00:06:08 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * acconfig.h: Removed PACKAGE.
+
+ * scmconfig.h.in: Regenerated.
+
+ * snarf.h: g++ says it's non-portable not to specify the first
+ argument in a varargs declaration. I introduced the first
+ argument by using preprocessor conditionals.
+
+Thu Mar 13 21:28:25 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_read_delimited_x): use RO string macros for delims.
+ (scm_freopen): use RO string macros for filename and modes.
+ (scm_duplicate_port, scm_fdopen): use RO string macros for modes.
+
+ * posix.c (scm_getgrgid): simplify conversion of name to C string.
+ (scm_mknod): use RO string macros for path.
+
+ * socket.c (scm_fill_sockaddr, scm_send, scm_sendto):
+ use SCM_ROSTRINGP, SCM_ROCHARS, SCM_ROLENGTH.
+
+ * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_getserv):
+ use SCM_ROSTRINGP and SCM_ROCHARS.
+
+Thu Mar 13 18:31:33 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * unif.c (scm_array_set_x): Cast ICHR (obj) to char if storing in
+ a scm_tc7_byvect.
+
+ * ramap.c (scm_ra_matchp, scm_ra_matchp, scm_array_fill_int, racp,
+ scm_array_index_map_x, raeql_1, scm_array_equal_p): Completed
+ support for byte vectors.
+
+ * print.c (scm_iprin1): Limit number of vector elements printed
+ according to pstate->length.
+
+Thu Mar 13 00:12:35 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * backtrace.c (scm_display_error_message): don't segv if message
+ is an immediate.
+
+ * error.h: prototype for scm_error_scm.
+
+ * error.c (scm_error_scm): new procedure, reimplements scm-error
+ in C and uses scm_error.
+
+Tue Mar 11 03:51:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.c (scm_read_hash_extend): make scm_read_hash_procedures a
+ pointer to the Scheme variable read-hash-procedures and intern it
+ in scm_init_read. Modify scm_read_hash_extend and
+ scm_get_hash_procedure to use the pointer.
+
+Mon Mar 10 06:28:54 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.h (SCM_N_READ_OPTIONS): increase SCM_N_READ_OPTIONS to 4.
+ (SCM_KEYWORD_STYLE): defined.
+
+ * read.c (scm_read_opts): add a keywords option. This isn't a
+ boolean option, in case someone wants to add support for DSSSL
+ keywords too.
+ Setup scm_keyword_prefix symbol.
+ (scm_lreadr): Only process keywords if SCM_KEYWORD_STYLE is
+ set to 'prefix.
+* I've left keyword support disabled by default, since it doesn't
+ seem to break the module system and it gives R4RS standard behaviour.
+ It can be reactivated with (read-set! keywords 'prefix).
+
+Sun Mar 9 14:14:39 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * arbiters.c (scm_make_arbiter): Bugfix: Must SCM_DEFER_INTS
+ before constructing arbiter.
+
+ * eval.c (scm_m_define): Bugfix: Check that the object is a
+ closure before setting the procedure property!
+
+ * ports.h: Removed prototype for scm_ungetc_char_ready_p.
+
+ * ports.c: Removed `ungetc-char-ready?'.
+
+Sat Mar 8 00:27:05 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.c (scm_init_read): intitialise scm_read_hash_procedures
+ (idea from Mikael: make it a pair so scm_permanent object only
+ called once.)
+ (scm_read_hash_extend): don't call scm_permanent_object.
+ (ideas from Mikael): if chr is already in the list, replace its
+ procedure instead of appending it again. If proc is #f, remove
+ it from the list.
+ (scm_get_hash_procedure): take CDR of scm_read_hash_procedures.
+
+ * strports.c (scm_read_0str, scm_eval_0str): update scm_read usage.
+
+ * gdbint.c (gdb_read): update scm_lreadr usage.
+
+ * load.h: update prototypes.
+
+ * load.c (scm_primitive_load, scm_read_and_eval_x,
+ scm_primitive_load_path): remove case_insensitive_p, sharp arguments.
+
+ * read.h: add prototype for scm_read_hash_extend. Change args for
+ other prototypes.
+
+ * read.c (scm_read_hash_procedures): new variable.
+ (scm_read_hash_extend): new procedure.
+ (scm_get_hash_procedure): new procedure.
+* (scm_lreadr): use scm_get_hash_procedure instead of an argument
+ for extended # processing.
+ (scm_read, scm_lreadr, scm_lreadrecparen, scm_lreadparen,
+ scm_read_token): remove case_i, sharp arguments. Change callers.
+
+Fri Mar 7 08:58:21 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.h (SCM_N_READ_OPTIONS): increase to 3.
+ (SCM_CASE_INSENSITIVE_P): define.
+
+ * read.c: add case-insensitive option to scm_read_opts.
+* (scm_read_token): use SCM_CASE_INSENSITIVE_P instead of an argument
+ to determine whether to convert symbol case.
+ (default_case_i): definition removed.
+ * read.c (scm_read_token): if case_i, downcase ic before doing
+ anything with it.
+
+Sat Mar 8 03:49:03 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added configuration option `guile-debug'.
+ Configure with --enable-guile-debug if you want a bunch of extra
+ functions used for debugging when developing Guile.
+
+ * acconfig.h: Added new preprocessor symbol GUILE_DEBUG.
+
+ * procs.c (make-cclo): New undocumented debugging procedure: Make
+ compiled closure with internal procedure PROC and length LENGTH.
+ Only compiled if GUILE_DEBUG is defined.
+
+ * debug.c: Only include `debug-hang' if GUILE_DEBUG is defined.
+
+ * print.c: Put #ifdef GUILE_DEBUG around `current-pstate'.
+
+ * ports.c: Changed preprocessor symbol DEBUG --> GUILE_DEBUG.
+
+ * eval.c (SCM_CEVAL): Added code sections for handling of rpsubrs
+ with 3 or more args internally to the evaluator.
+
+Fri Mar 7 19:38:18 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Added code sections for handling of asubrs
+ with 3 or more args internally to the evaluator. This is mainly
+ because we don't want to pass entry and exit points of the
+ debug support twice, but it also seems to increase the speed of
+ the evaluator for such calls (e. g. (+ 1 2 3)).
+
+* * backtrace.c (scm_display_application): New procedure:
+ display-application; Set fancy printing parameters individually
+ for different types of display (backtrace, error, application).
+ (These should of course be customizable!)
+
+ * debug.h (SCM_RESET_DEBUG_MODE): Bugfix: The old code didn't
+ clear the CHECK-flags.
+
+Thu Mar 6 00:53:02 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h, eval.c (iqq): Fixes to comments about SCM_ECONSP.
+
+Wed Mar 5 23:31:21 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h (SCM_ECONSP, SCM_NECONSP): Bugfix: Discriminate structs
+ from pairs with a GLOC in the car.
+
+ * symbols.c (msymbolize): Bugfix: Also initialize SCM_SYMBOL_HASH,
+ otherwise `symbol-hash' will behave badly.
+ (scm_symbol_hash): Bugfix: Must msymbolize if tc7_ssymbol, othwise
+ we get segmentation fault!
+
+* * symbols.c: Added #include "weaks.h". New functions:
+ `builtin-bindings' and `builtin-weak-bindings'. (These will be
+ moved to an extraneous library when we split libguile.)
+
+Tue Mar 4 19:50:07 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * filesys.c (scm_stat): stat now takes fport arguments too as
+ documented in the manual.
+
+Mon Mar 3 07:11:33 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.c (scm_single_step): Bugfix: Call continuation with
+ scm_call_continuation instead of throwing to it.
+
+Mon Mar 3 09:07:56 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.c (scm_char_ready_p): bug fix: in SCM_PROC char-ready's
+ argument wasn't declared to be optional.
+
+Sun Mar 2 16:34:40 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stime.c (scm_init_stime): Add feature "current-time".
+
+Sun Mar 2 06:37:31 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * throw.h: prototype for scm_exit_status.
+ * throw.c (scm_handle_by_message): if a 'quit is caught, use its
+ args to derive an exit status. Allows (quit) to work from a
+ script.
+ (scm_exit_status): new function.
+ #include "eq.h".
+
+Sat Mar 1 00:09:15 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (scm_deval): Removed some old code.
+ (ENTER_APPLY): Bugfix: Reset apply-frame trap on trap as is done
+ with the others.
+ (ENTER_APPLY, scm_deval): Reset trace flag on apply-frame and
+ exit-frame traps.
+
+ * symbols.c (msymbolize): Bugfix: Must initialize property list to
+ SCM_EOL.
+
+ * procs.c: Introduce the existent C function scm_thunk_p at the
+ Scheme level as well.
+
+Wed Feb 26 12:53:58 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * symbols.c, symbols.h (scm_symbol_value0): New function. Can be
+ used from C to easily lookup the value of a symbol in the current
+ module.
+
+Tue Feb 25 00:14:10 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * unif.c (scm_init_unif): Added #include "unif.x". (There are two
+ scm_init_unif in this file. This will also fix a previous problem
+ with guile-snarf.)
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Fri Feb 21 23:07:26 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gdb_interface.h (GDB_INTERFACE): Added some (void *) casts to
+ avoid warnings.
+
+Fri Feb 21 18:00:38 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): New variable to hold
+ source files that are not always included in libguile but should
+ have their dependencies calculated by automake. This variable is
+ recognized by automake, no further magic is needed.
+ (libguile_la_DEPENDENCIES): Changed to @LIBLOBJS@. Libtool wants
+ to deal exclusively with *.lo files, as it seems. The *.o files
+ are built automatically when the corresponding *.lo file gets
+ built.
+
+Wed Feb 19 14:04:23 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * list.h (scm_list_cdr_ref): Delete prototype; function no longer
+ exists.
+
+Thu Feb 13 21:44:07 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * unif.c (scm_array_set_x): minor change to argument error checking.
+
+Tue Feb 11 18:19:47 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.am (libguile_la_SOURCES): Remove backtrace.c, debug.c,
+ inet_aton.c, srcprop.c, stacks.c, and strerror.c from this list.
+ They should only be included in the library at configure.in's
+ discretion.
+ (libguile_la_LDADD): Include the appropriate .lo files here.
+ (libguile_la_DEPENDENCIES): List the corresponding .o files here,
+ so we know when to build them (and their .lo bretheren).
+ * configure.in (LIBLOBJS): New substituted variable. We let
+ configure decide which .o files to include in LIBOBJS, and then
+ put the corresponding list of .lo files in LIBLOBJS. The latter
+ is what we pass to libtool.
+ * Makefile.in, configure: regenerated.
+
+Mon Feb 10 00:08:08 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * symbols.c (scm_sysintern0): New function. Contains the core of
+ old scm_sysintern but doesn't take a second value argument.
+ (scm_sysintern): Now uses scm_sysintern0.
+ (scm_sysintern_no_module_lookup): Renamed to
+ scm_sysintern0_no_module_lookup and doesn't take a second value
+ argument any longer.
+
+ * symbols.h (scm_sysintern0: Added declaration.
+
+ * options.c (scm_init_opts): Use scm_sysintern0 instead of
+ scm_sysintern when interning option keys. Otherwise we risk
+ destroying the values of already interned variables.
+
+ * symbols.c (scm_sym2vcell): Bugfix: Treat definedp as
+ scheme-level boolean (use SCM_NFALSEP).
+
+ * backtrace.c (scm_init_backtrace): Make Scheme-level variable
+ `the-last-stack'.
+ (scm_backtrace): New function. (C version of old function from
+ boot-9.scm) Motivation: Make it possible to display backtraces
+ without depending on boot-9.scm. (I'm uncertain if this
+ motivation is good enough...)
+
+ * root.h (scm_root_state): Add member the_last_stack_var.
+ (scm_the_stack_var): Defined to scm_root->the_last_stack_var.
+
+ * root.c (mark_root): Mark scm_the_last_stack_var.
+
+ * init.c (scm_start_stack): Initialize scm_the_last_stack_var to
+ SCM_BOOL_F.
+
+Sun Feb 9 18:04:41 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * throw.c (mark_lazy_catch, free_lazy_catch): Removed.
+ 1. mark_lazy_catch didn't mark the smob.
+ 2. Both functions above have standard variants:
+ (lazy_catch_funs): Changed mark_lazy_catch --> scm_mark0,
+ free_lazy_catch --> scm_free0.
+
+Fri Feb 7 17:30:26 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * throw.c (scm_internal_lazy_catch): New function.
+ (scm_lazy_catch): Rewritten to use it.
+ (scm_ithrow): Handle the new lazy catch representation.
+ Use SCM_LAZY_CATCH_P, instead of assuming that any wind list entry
+ that doesn't have a jmpbuf is a lazy catch clause.
+ (tc16_lazy_catch, struct lazy_catch, mark_lazy_catch,
+ free_lazy_catch, print_lazy_catch, lazy_catch_funs,
+ make_lazy_catch, SCM_LAZY_CATCH_P): Support funs, including a new
+ smob.
+ (scm_init_throw): Register the new lazy-catch smob type.
+ * throw.h (scm_internal_lazy_catch): decl for new function.
+
+ * throw.c (scm_internal_catch): Doc fixes.
+
+ * alloca.c: New file, needed to support the AC_FUNC_ALLOCA call in
+ configure.in. Including this might cause problems if applications
+ that link against libguile include their own copies of alloca, but
+ if they're using autoconf, they should be adding libguile to LIBS
+ before calling AC_FUNC_ALLOCA anyway, in which case they'll find
+ the copy in libguile, and things will be okay. (I think.)
+
+Thu Feb 6 03:10:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * strop.c (scm_string_upcase_x, scm_string_downcase_x): moved from
+ unif.c.
+ strop.h: move prototypes too.
+
+Wed Feb 5 08:33:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c (scm_init_posix): don't intern EINTR since it's now done
+ elsewhere.
+
+ * ioext.c (scm_init_ioext): don't intern stat macros, S_IRUSR
+ etc. I deleted them from filesys.c long ago, but didn't
+ notice they were here too (although ineffective since
+ sys/stat.h wasn't included).
+
+Tue Feb 4 18:17:50 1997 Tom Tromey <tromey@cygnus.com>
+
+ * eval.c: Don't define alloca in GCC case. gcc will automatically
+ use __builtin_alloca if appropriate.
+
+Tue Feb 4 16:57:40 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (safe_setjmp): New function: trivial wrapper for setjmp.
+ (SCM_CEVAL, SCM_APPLY): Call it, instead of setjmp, to make sure
+ that values of automatic variables are preserved. See comments
+ for safe_setjmp for details.
+
+ Change from Thomas Morgan:
+ * variable.c: Include eq.h.
+ (var_equal): New function.
+ (variable_smob): Use var_equal as the discriminator for variables.
+
+ * throw.c (s_throw): Remove extraneous declaration.
+
+ * configure.in: Call AC_FUNC_ALLOCA, to see if we have alloca.
+ * eval.c: Add necessary CPP cruft to support that.
+ * configure, Makefile.in, scmconfig.h.in: regenerated.
+
+ Change from Thomas Morgan:
+ * procprop.c (scm_procedure_properties): Convert the Scheme
+ boolean returned by scm_procedure_p into a C boolean before using
+ it as a condition for SCM_ASSERT.
+ (scm_procedure_property): Likewise.
+
+ * simpos.c (SYSTNAME): Accept both 'unix' and '__unix' as
+ indications of Unixness.
+ * stime.c: Same.
+
+Tue Feb 4 05:07:35 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+* * net_db.c (scm_lnaof): change scheme name from lnaof to inet-lnaof.
+
+Mon Feb 3 06:12:37 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.c (scm_lreadr): use scm_misc_error to improve one of the
+ "unknown # object" error messages.
+
+ * strop.c (scm_i_index, scm_i_rindex): combine into one procedure
+ (scm_i_index) and declare it static. Add a 'direction' argument
+ to indicate what way the search should go.
+ (scm_i_index): throw out-of-range error instead of wrong-type-arg
+ if indices are bad.
+ (scm_string_index, scm_string_rindex): adjust usage of scm_i_index.
+ strop.h: remove scm_i_index, scm_i_rindex prototypes.
+
+Fri Jan 31 04:33:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c, ioext.h: remove obsolete _sys_ from 9 procedure names.
+
+* * posix.c (scm_fork): Scheme name changed from fork to primitive-fork,
+ to avoid clash with various scsh forks.
+
+Thu Jan 30 20:14:09 1997 Mikael Djurfeldt <mdj@syk-0606.pdc.kth.se>
+
+ The following two changes (ramap.c, throw.c) are motivated by the
+ apparent unportability of forward declarations of static arrays of
+ the form `static foo bar[];'.
+
+ * ramap.c (scm_array_fill_x): Moved above scm_array_fill_int.
+ (ra_rpsubrs, ra_asubrs): Moved to the top of array code.
+
+ * throw.c (scm_throw): Moved above scm_ithrow.
+
+ * options.h: Removed the extern declarations of scm_yes_sym and
+ scm_no_sym since these are static.
+
+Fri Jan 24 06:16:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.c: add SCM_PROC declarations for pt-size and pt-member.
+
+ * Makefile.am: remove AWK=@AWK@.
+ Add a rule for generating errnos.list.
+ (CLEANFILES): put errnos.list here instead of in DISTCLEANFILES.
+
+ * configure.in: add AC_SUBST(AWK) and AC_SUBST(ERRNO_EXTRACT).
+ don't extract errnos, just set a variable (avoids the
+ need to recompile error.c just because configure is run.)
+
+ * unif.h: update prototypes.
+ * unif.c (scm_uniform_array_read,write): change the offset and
+ length arguments to start and end, for consistency.
+
+ * __scm.h: uncomment SCM_ARG6 and SCM_ARG7, I needed SCM_ARG6.
+
+ * ioext.h: update prototypes.
+* * ioext.c (scm_read_delimited_x): replaces scm_read_line and
+ scm_read_line_x, it's a more general procedure using an
+ interface from scsh. read-line and read-line! are now defined
+ in boot-9.scm.
+* Note that the new read-line trims the terminator
+ by default, previously it was appended to the returned string. An
+ optional argument specifies how to process the terminator (scsh
+ compatible). For the old behaviour: (read-line port 'concat).
+ scm_read_line, scm_read_line_x: deleted. (read-line port 'split)
+ returns a pair, but is converted to multiple values if the scsh
+ module is loaded.
+
+ socket.h: update prototypes.
+ * socket.c (scm_recvfrom): for consistency with other procedures,
+ take start and end as separate optional arguments.
+* (scm_recv, scm_recvfrom): don't allow the second argument
+ to be a size, only a buffer. Change the scheme names to
+ recv! and recvfrom!. Don't return the buffer.
+
+ * ioext.h, posix.h: move prototypes too.
+ * ioext.c, posix.c (scm_read_line, scm_read_line_x, scm_write_line:
+ moved back from posix.c to ioext.c. Also move #includes of "genio.h"
+ "read.h" and "unif.h".
+ * ioext.c: include "chars.h"
+
+Mon Jan 20 19:54:49 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c: The dynamic linking and module registration functions
+ are now defined even when dynamic linking is not available for the
+ host system. Some of their functionality can be done without
+ dynamic linking; when it's really needed, they throw errors.
+
+Thu Jan 16 16:39:29 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Only define DYNAMIC_LINKING when one of the system
+ dependent functions is detected.
+ * dynl.c (scm_dynamic_func): New function to get the address of a
+ function in a dynamic object.
+ (scm_dynamic_call, scm_dynamic_args_call): Accept the values
+ produced by scm_dynamic_func as the thing to call.
+
+Sun Jan 12 21:09:42 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c, dynl-dl.c, dynl-dld.c, dynl-shl.c: Restructured.
+ (scm_register_module_xxx, scm_registered_modules,
+ scm_clear_registered_modules): New functions.
+
+Sat Jan 11 21:37:15 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * symbols.c (scm_sysintern): Renamed to
+ scm_sysintern_no_module_lookup.
+ (scm_sysintern): New function to take the place of the old
+ scm_sysintern. It uses the current toplevel lookup closure to give
+ the symbol its value. This is a temporary hack to put packages
+ like gtcltk into their own module.
+ (scm_can_use_top_level_lookup_closure_var): New variable to tell
+ us whether `scm_top_level_lookup_closure_var' has been initialized
+ and is usable.
+ * eval.c (scm_init_eval): Set it.
+
+Sat Jan 18 00:03:31 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * fports.c (scm_open_file): pass errno to scm_syserror_msg.
+ * filesys.h: update prototypes. Remove macros: SCM_FD_P, SCM_FD_FLAGS,
+ SCM_FD.
+ * filesys.c (scm_sys_stat, scm_sys_lstat): pass errno to
+ scm_syserror_msg.
+* (scm_sys_read_fd, scm_sys_write_fd, scm_sys_close, scm_sys_lseek,
+ scm_sys_dup): deleted: FD capability will be added to other
+ procedures.
+* Remove support for the FD object type: scm_tc16_fd, scm_fd_print,
+ scm_fd_free, fd_smob, scm_intern_fd.
+* (scm_open): renamed from scm_sys_open. Return a port instead of
+ an FD object. Make the mode argument optional.
+* (scm_sys_create): deleted, it's just a special case of open.
+ (scm_init_filesys): move interning of constants O_CREAT etc.,
+ here (were previously using SCM_CONST_LONG macro).
+ Add missing constants: O_RDONLY, O_WRONLY, O_RDWR, O_CREAT.
+ don't newsmob fd.
+ (numerous _sys_ procedures): remove gratuitous _sys_ from names.
+ include "fports.h" and <stdio.h>
+ (scm_stat, scm_select): don't support FD objects.
+
+ * error.h: adjust scm_syserror_msg prototype.
+ * error.c (scm_syserror_msg): take an extra argument for errno.
+ Using the global value didn't always work, since it could be
+ reset by procedure calls in the message or args arguments.
+
+ * fports.c (scm_setbuf0): call setbuf even if FIONREAD is not defined.
+ I don't understand why the check was there (and what about the
+ ultrix check?)
+
+ * strop.c (scm_string_copy): allow shared substrings to be copied.
+
+ * unif.h: corresponding change to prototypes.
+ * unif.c (scm_uniform_array_read_x, scm_uniform_array_write_x):
+ recognize two new optional arguments: offset and length. Allow
+ the port argument to be an integer (file descriptor, for scsh).
+ Include <unistd.h> for "read" prototype.
+
+Tue Jan 14 02:42:02 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c: don't include filesys.h.
+
+Mon Jan 13 03:47:04 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Makefile.am: add AWK=@AWK@ (?)
+
+ * Makefile.am (EXTRA_DIST): add errnos_cnvt.awk, errnos.default,
+ errnos_get.c.
+ Add a rule to generate errnos.c from errnos.
+ * error.c (scm_init_error): include errnos.c.
+ * errnos_cnvt.awk: new file, converts the list of errno codes to
+ C expressions.
+ * errnos_get.c: new file.
+ * errnos.default: new file, contains errnos to try if they can't
+ be extracted from errno.h.
+ * configure.in: if using GCC, try and extract errno codes from
+ errno.h.
+ Added AC_PROG_AWK.
+
+Sat Jan 11 14:47:00 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Replaced AC_PROG_RANLIB with AM_PROG_LIBTOOL.
+ * Makefile.am: Made libguile into a libtool library.
+ * PLUGIN/guile.config: Removed "-L ../libguile" from xtra_cflags.
+ Set libtool_libs to indicate that libguile is a libtool library.
+ See guile/ChangeLog for details.
+ * .cvsignore: ignore "*.lo", the libtool library objects.
+
+Wed Jan 8 06:54:54 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * net_db.c (scm_getserv): add missing SCM_ALLOW_INTS.
+ use htons in getservbyport argument.
+
+Tue Jan 7 18:11:24 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * ports.h (SCM_PTOBNUM): Removed extraneous semicolon.
+ * smob.h: (SCM_PTOBNUM): Removed entirely; this definition is a
+ duplicate.
+
+ * objprop.c (scm_object_property): No need to take the CDR of the
+ value returned by scm_object_properties, since Aug 20 change.
+
+ * configure.in: When checking for struct linger, #include
+ <sys/types.h> as well as <sys/socket.h>. I've never known
+ <sys/types.h> to cause any portability problems, and Solaris's
+ <sys/socket.h> needs it.
+ * configure: Rebuilt.
+
+ I think the Sun compiler has chosen a perverse way to interpret
+ ANSI declarations combined with K&R definitions. We'll
+ appease it a little bit. But when it invades France, we fight.
+ * print.c (scm_iprlist): Change 'tlr' argument to an int.
+ * print.h (scm_iprlist): Here too.
+ * numbers.c (scm_divbigdig): Change definition to match
+ declaration in numbers.h.
+ * unif.c (scm_makflo): Change definition to match declaration in
+ unif.h.
+
+ * init.c (scm_boot_guile): Don't return the value of
+ scm_boot_guile_1. This function doesn't return a value;
+ scm_boot_guile_1 doesn't return a value (or return at all).
+
+ * eval.c (unmemocopy): Add a semicolon to appease the Sun
+ compiler.
+
+ * simpos.c (SYSTNAME): Add case for AIX; otherwise it won't
+ compile. I have a feeling this function is a bad idea anyway ---
+ one should always test for features, not systems.
+
+ * smob.h (SCM_SMOBNUM, SCM_PTOBNUM): Remove extraneous
+ semicolons. Only pure luck kept this from being noticed earlier.
+
+Tue Jan 7 15:04:06 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * socket.c (scm_recvfrom): Added missing semicolon.
+
+Mon Jan 6 20:39:08 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c (scm_recvfrom): allow buff_or_size to be a list containing
+ the buffer and start and end positions for scsh networking
+ implementation.
+
+Sun Jan 5 13:53:53 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Revert previous change to this file; the problem
+ is due to transient automake weirdness.
+ * configure: Rebuilt.
+
+ * Makefile.am (EXTRA_DIST): Distribute PLUGIN/guile.libs.in, not
+ PLUGIN/guile.libs. configure generates the latter from the former.
+ * Makefile.in: Rebuilt.
+
+ * configure.in: Call AM_PROG_INSTALL; the automake manual says we
+ need this if we install scripts, like guile-snarf.
+ * configure: Rebuilt.
+
+Thu Jan 2 01:56:38 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST): Added DYNAMIC-LINKING
+
+Sat Dec 28 19:14:01 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c (scm_addr_vector): fix faulty scm_listify.
+
+Sat Dec 28 13:55:58 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * read.c (scm_lreadr): Encountering EOF after skipping a SCSH
+ style block comment is no longer considered an error.
+
+Fri Dec 27 13:44:23 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * PLUGIN/guile.libs.in: New file.
+ * PLUGIN/guile.libs: Removed from repository.
+ * configure.in: Create PLUGIN/guile.libs from
+ PLUGIN/guile.libs.in. This is for including additonal libraries
+ needed for dynamic linking.
+ * Makefile.am (EXTRA_DIST): Distribute PLUGIN/guile.libs.in
+ instead of PLUGIN/guile.libs.
+
+ * Makefile.am: Added explicit dependency "dynl.o: dynl.x".
+
+Sun Dec 22 23:06:14 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * list.c (scm_delq_x, scm_delv_x, scm_delete_x): Delete all
+ occurrences of the given element from the list, not just the
+ first. This is how the Emacs Lisp functions behave, how the
+ analogous Common Lisp functions behave, and (I believe) how the
+ older Maclisp functions worked. I realize that this change may
+ break code, but it seemed better to break it before the Guile
+ release than after.
+
+ * gc.c (scm_protect_object, scm_unprotect_object): New functions.
+ Their prototypes were already present in gc.h, but they weren't
+ implemented.
+ (scm_init_storage): Initialize scm_protects.
+ * root.c (scm_protects): New element of scm_sys_protects.
+
+ * net_db.h (scm_init_net_db): Fix spelling from scm_init_netdb.
+
+Sat Dec 21 15:38:32 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * libguile.h: Added #include "libguile/net_db.h".
+
+ * libguile.h: Don't #include "libguile/libpath.h", contrary to Oct
+ 30 change. That file is only meant for communication between the
+ configuration process and load.c. If code linked against libguile
+ wants to get at the paths mentioned in libpath.h, it can call
+ functions declared in load.h.
+
+Sat Dec 21 14:50:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libguile.h: Removed #include "libguile/fdsocket.h"
+
+ * net_db.c: Added #include <sys/socket.h>.
+
+Sat Dec 21 00:33:03 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_input_waiting_p): use select in preference to
+ FIONREAD, since the latter doesn't detect EOF.
+ Throw error if neither select nor FIONREAD available.
+
+ * socket.c (scm_connect): take a port, not a fd object.
+ (scm_fill_sockaddr): throw an error if fam is not recognised.
+ (scm_bind): use scm_fill_sockaddr.
+ (scm_listen): take a port, not a fd object.
+ (scm_accept): take and return a port. return #f in the car if
+ address can't be got
+ (scm_sock_fd_to_port): new procedure.
+ (scm_socket): use scm_sock_fd_to_port.
+ (scm_addr_vector): throw error if unrecognised address type.
+ take an extra argument with the calling procedure name.
+ (scm_getsockname): take a port. return #f if address can't be got.
+ (scm_getpeername): take a port. return #f if address can't be got.
+ (scm_recvfrom): take a port. return #f for address component if can't
+ be got.
+ (scm_sendto, scm_socketpair, scm_getsockopt scm_shutdown,
+ scm_setsockopt, scm_recv, scm_send): take a port not a fd object.
+
+Fri Dec 20 23:06:53 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * throw.c (scm_internal_catch): Make body funcs and handler funcs
+ use separate data pointers, to allow them to be designed
+ independently and reused.
+ (scm_body_thunk, scm_handle_by_proc, scm_handle_by_message):
+ Renamed from catch_body, catch_handler, and uncaught_throw; made
+ generically useful.
+ (struct scm_catch_body_data): Renamed from catch_body_data; moved
+ to throw.h.
+ (scm_catch): Use the above.
+ (scm_throw): Don't bother printing a message for an uncaught
+ throw; we establish a default handler in init.
+ * throw.h (scm_internal_catch): Prototype updated.
+ (scm_body_thunk, scm_handle_by_proc, scm_handle_by_message): New
+ decls.
+ (struct scm_body_thunk_data): New structure, used as data
+ argument to scm_body_thunk.
+ * init.c (struct main_func_closure): New structure, packaging up
+ the data to pass to the user's main function.
+ (scm_boot_guile): Create one. Pass it to scm_boot_guile_1.
+ (scm_boot_guile_1): Pass it through to invoke_main_func. Use
+ scm_internal_catch to establish a catch-all handler, using
+ scm_handle_by_message. This replaces the special-case code in
+ scm_throw.
+ (invoke_main_func): Body function for scm_internal_catch; invoke
+ the user's main function, using the main_func_closure pointer to
+ decide what to pass it.
+ * root.c (struct cwdr_body_data): Remove handler_proc member.
+ (cwdr): Use scm_handle_by_proc instead of cwdr_handler.
+ (cwdr_handler): Removed.
+
+Thu Dec 19 00:00:26 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.h (SCM_P): update bind prototype.
+ * socket.c (scm_init_socket): intern PF_UNSPEC, PF_UNIX, PF_INET.
+ include "feature.h".
+ (scm_socket): return a port, not a file descriptor object.
+ include "fports.h" and <unistd.h>
+ (scm_bind): take a port, not a file descriptor object.
+ take an extra argument for address args.
+
+ * net_db.c (scm_init_net_db): intern INADDR_ANY, INADDR_BROADCAST,
+ INADDR_NONE, INADDR_LOOPBACK.
+
+Tue Dec 17 22:58:26 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * init.c: include net_db.h and not fdsocket.h.
+ (scm_boot_guile_1): call scm_init_net_db and not scm_init_fdsocket.
+
+ * Makefile.am: corresponding changes.
+ * socket.h: renamed from fdsocket.h, fix names.
+ * net_db.h: renamed from socket.h, fix names.
+ * socket.c: renamed from fdsocket.c.
+ remove _sys from procedure names.
+ (scm_init_socket): rename from scm_init_fdsocket. include socket.x.
+ add "socket" to features list.
+ * net_db.c: renamed from socket.c.
+ remove _sys from procedure names.
+ (scm_init_net_db): rename from scm_init_socket. include net_db.x.
+ add "net-db" to features list.
+ include "net_db.h". don't include <sys/socket.h> or
+ <sys/un.h>.
+
+Thu Dec 19 14:03:24 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h (scm_tags): Removed comma at end of last enumerator.
+
+Thu Dec 19 02:54:59 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Don't use GCC extensions to allocate space for debugging frames.
+ (Here he goes again! Why do we put up with this?!)
+ * debug.h (scm_debug_frame): Make the 'vect' member a pointer to
+ an scm_debug_info structure, not an in-line array of them. Add
+ 'info' member, to say how many vect elements we've used, for eval
+ frames.
+ * eval.c (SCM_CEVAL): Use alloca to allocate space for vect. Use
+ a new variable debug_info_end to mark the end of vect, instead of
+ the address of the 'info' pointer itself.
+ [DEVAL] (ENTER_APPLY, SCM_CEVAL, SCM_APPLY): Remove casts of
+ &debug to scm_debug_frame *; debug is a real scm_debug_frame now.
+ (SCM_APPLY): Explicitly allocate space for debug.vect.
+ * debug.c (scm_m_start_stack): Same, for vframe.vect.
+ * stacks.c: Adjusted for new debug frame structure.
+ (RELOC_INFO, RELOC_FRAME): New macros.
+ (stack_depth, read_frames): Use them, and new scm_debug_frame
+ element 'info', instead of magically knowing that eval frames have
+ an info pointer sitting after vect.
+ (scm_make_stack, scm_stack_id, scm_last_stack_frame): Use
+ RELOC_FRAME.
+ (scm_init_stacks): Formatting tweaks.
+
+Wed Dec 18 14:57:57 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Give GCC more control flow information, so it can be sure that
+ variables aren't used uninitialized.
+ * error.h (scm_error, scm_syserror, scm_syserror_msg,
+ scm_sysmissing, scm_num_overflow, scm_out_of_range,
+ scm_wrong_num_args, scm_wrong_type_arg, scm_memory_error,
+ scm_misc_error): Tell GCC that these functions never return.
+ * struct.c (scm_struct_ref, scm_struct_set_x): If we can't figure
+ out the field type, call abort if SCM_ASSERT returns, to placate
+ the optimizer.
+ * stacks.c (scm_make_stack, scm_last_stack_frame): abort if
+ scm_wta ever returns. We can't handle this case anyway, and this
+ gives the optimizer more information.
+ * unif.c (scm_uniform_vector_ref, scm_array_set_x): Abort if
+ scm_wta ever returns.
+
+ In some cases, the code is fine, but GCC isn't smart enough to
+ figure that out; this usually happens when one variable is only
+ initialized and used when a particular condition holds true, and
+ we know that condition will never change within a given invocation
+ of the function. In this case, we simply initialize the variables
+ to placate the compiler, hopefully to a value which will cause a
+ crash if it is ever actually used.
+ * print.c (scm_iprin1): Initialize mw_pos.
+ * read.c (scm_lreadrecparen): Initialize tl2, ans2.
+ * throw.c (scm_ithrow): Initialize dynpair.
+ * unif.c (scm_uniform_vector_ref): Initialize cra.
+ * struct.c (init_struct): Initialize prot.
+ * mbstrings.c (scm_print_mb_symbol): Initialize mw_pos and inc.
+
+ * strports.c (scm_eval_0str): Don't return uninitialized garbage
+ if EXPR contains no expressions.
+
+Wed Dec 18 11:43:22 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * eval.c, debug.h: Revert changes of Dec 16 and Nov 21. They
+ cause an infinite loop (???). So much for the algebraic
+ equivalency of variable-sized arrays and alloca...
+
+Tue Dec 17 20:29:03 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * backtrace.c (scm_display_error): Bugfix: scm_procedure_p returns
+ a SCM boolean, not a C boolean.
+
+Sat Dec 14 23:21:45 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gc.c (SCM_MTRIGGER_HYSTERESIS): New memory management parameter.
+ (scm_must_malloc, scm_must_realloc): Added a hysteresis to the
+ rules for raising scm_mtrigger. Previously, unfortunate but not
+ unlikely circumstances could result in almost constant invokation
+ of the gc. Now, this situations should be less likely, but they
+ are not prevented completely.
+
+Tue Dec 17 16:19:07 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_fuck): Procedure removed; looks like old test
+ code.
+ * numbers.h: Prototype removed.
+
+Mon Dec 16 18:20:32 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * debug.h (scm_debug_frame): Change `vect' member from an in-line
+ array to a pointer, to match my Nov 21 change in eval.c.
+
+Fri Dec 13 16:12:14 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libguile.h: Added #include "libguile/backtrace.h", #include
+ "libguile/stacks.h".
+
+ * strings.c (scm_string scm_make_string scm_string_ref
+ scm_string_set_x scm_string_equal_p scm_string_append):
+ Bugfix according to scm patch from Aubrey Jaffer:
+ Corrected long-standing
+ (not (eqv? (integer->char 128)
+ (string-ref (make-string 1 (integer->char 128)) 0)))
+ bug found by John Kozak <jk@noontide.demon.co.uk>.
+
+ * strports.c, strports.h: Make scm_eval_0str return the value of
+ the last expression evaluated (previously, it returned void).
+
+ * strports.c, strports.h: New function: scm_read_0str. Does what
+ it sounds like.
+
+Tue Dec 10 23:38:43 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * simpos.c (scm_getenv): return #f if string can't be found in the
+ environment instead of throwing an exception, for compatibility
+ with numerous other systems.
+
+Mon Dec 9 23:23:35 1996 Tom Tromey <tromey@cygnus.com>
+
+ * Makefile.am (.c.x): Use guile-snarf.
+ * configure.in (AC_OUTPUT): Generate guile-snarf; make it
+ executable.
+ * guile-snarf.in: New file, resurrected from old guile-snarf.sh.
+
+Mon Dec 9 18:36:50 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu>
+
+ * backtrace.c (scm_display_error_message): Made non-static, and
+ renamed from display_error_message.
+ * backtrace.h (scm_display_error_message): Added extern decl.
+ * throw.c (uncaught_throw): Use it to display the error message.
+
+Mon Dec 9 10:10:38 1996 Tom Tromey <tromey@cygnus.com>
+
+ * inet_aton.c: Use #if 0, not #ifdef 0.
+
+Mon Dec 9 06:36:48 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_sys_ftell): use scm_long2num instead of SCM_MAKINUM
+ to convert the returned value.
+ (scm_sys_fseek): use scm_num2long instead of SCM_INUM to convert
+ the offset argument.
+
+Sun Dec 8 21:06:38 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu>
+
+ Add new interface to catch/throw, usable from C as well as
+ Scheme.
+ * throw.h (scm_catch_body_t, scm_catch_handler_t): New types.
+ (scm_internal_catch): New function, replaces...
+ (scm_catch_apply): Deleted.
+ * throw.c (scm_catch_apply): Deleted; replaced with a more general
+ mechanism which is a bit more code, but can be used nicely from C
+ and implement the Scheme semantics as well.
+ (scm_internal_catch): This is the replacement; it's named after
+ the analogous function in Emacs.
+ (scm_catch): Reimplemented in terms of the above.
+ (struct catch_body_data, catch_body, catch_handler): New
+ functions, used by scm_catch.
+ * root.c (cwdr): Reimplemented in terms of scm_internal_catch.
+ (struct cwdr_body_data, cwdr_body, cwdr_handler): New functions;
+ support for new cwdr.
+
+ * Makefile.am (libpath.h): Re-incorporate Mikael's changes of Wed
+ Oct 30.
+
+Sun Dec 8 17:55:34 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * acconfig.h: Added DYNAMIC_LINKING symbol.
+ * configure.in: Add option and checks for dynamic linking.
+ * dynl.c, dynl-dl.c, dynl-dld.c, dynl-shl.c, dynl-vms.c,
+ dynl.h: New files for dynamic linking support.
+ * Makefile.am (libguile_a_SOURCES):
+ Added "dynl.c".
+ (modinclude_HEADERS): Added "dynl.h".
+ (EXTRA_DIST): Added "dynl-dl.c", "dynl-dld.c", "dynl-shl.c" and
+ "dynl-vms.c".
+ * init.c (scm_boot_guile_1): Call
+ scm_init_dynamic_linking to initialize dynamic linking support.
+
+Thu Dec 5 22:47:53 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * init.c (scm_boot_guile_1): Moved `live' variable to the toplevel
+ (as we Schemers say). It needs to be global, so that I can tweak
+ it for the proper operation of unexec.
+ (scm_boot_guile_1_live): New variable, see above.
+
+Sun Dec 1 00:00:49 1996 Tom Tromey <tromey@cygnus.com>
+
+ * guile-snarf.sh: Removed.
+ * PLUGIN/guile.libs: Added dependency for -lm.
+ * acinclude.m4: Renamed from aclocal.m4.
+ * PLUGIN/greet: Removed.
+ * Makefile.am, aclocal.m4: New files.
+ * configure.in: Updated for Automake.
+
+Thu Nov 28 00:23:55 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_definedp): Use top_level_lookup_closure_var
+ and not top_level_lookup_thunk_var.
+
+Wed Nov 27 22:04:19 1996 Jim Blandy <jimb@baalperazim.frob.com>
+
+ * Makefile.in (ancillary): List ChangeLog-scm, not ChangeLog.scm.
+
+Wed Nov 27 14:14:56 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_definedp): Incompatibly changed to be a builtin
+ Scheme function, instead of syntax. Single argument is now a
+ symbol.
+
+Thu Nov 21 20:26:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * ramap.c (scm_ra_sum, scm_ra_difference, scm_ra_product,
+ scm_ra_divide): Properly terminate statements passed as arguments
+ to IVDEP macros. (Thanks to Bernard Urban.)
+
+ * eval.c (SCM_CEVAL): Use alloca, not GCC's extensions for arrays
+ with non-constant sizes. (Thanks to Bernard Urban.)
+
+Thu Nov 21 11:17:42 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ It's an "eval closure", not an "eval thunk." A thunk is a
+ function of no arguments.
+ * root.h (struct scm_root_state): Renamed
+ top_level_lookup_closure_var from top_level_lookup_thunk_var.
+ (scm_top_level_lookup_closure_var): Renamed from
+ scm_top_level_lookup_thunk_var.
+ * root.c (mark_root): Uses changed.
+ * gdbint.c (gdb_eval, gdb_binding): Uses changed.
+ * init.c (scm_start_stack): Uses changed.
+ * eval.c (scm_eval, scm_eval_x, scm_init_eval): Rename uses.
+ Change scheme-visible name to *top-level-lookup-closure* from
+ *top-level-lookup-thunk*.
+
+Tue Nov 19 22:43:31 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * gc.c (scm_igc, scm_gc_mark): Round up the size of the stack we
+ pass to scm_mark_locations. (Thanks to Aubrey Jaffer.)
+
+Sun Nov 10 13:35:05 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * gc.c (struct scm_heap_seg_data): Doc fixes.
+
+ * gc.c (scm_gc_sweep): Empty all segments' freelists before
+ sweeping. Then, prepend each segment's free cells to its
+ freelist, rather than wiping out the old value. (Thanks to Marius
+ Vollmer.)
+
+ * gc.c (which_seg, scm_map_free_list, scm_newcell_count,
+ scm_check_freelist, scm_debug_newcell): New functions and
+ variables, for debugging freelist problems.
+ * pairs.h (SCM_NEWCELL): New debugging version added.
+ * gc.h (scm_debug_newcell): Added extern declaration, used by
+ debugging version of SCM_NEWCELL.
+
+Sat Nov 9 19:02:46 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ On some systems <libc.h> conflicts with <unistd.h>, and should not
+ be #included at all.
+ * aclocal.m4 (GUILE_HEADER_LIBC_WITH_UNISTD): New autoconf macro.
+ * acconfig.h (LIBC_H_WITH_UNISTD_H): New CPP symbol.
+ * configure.in: Call it.
+ * posix.c, filesys.c: Use its results to decide whether or not to
+ #include <libc.h>.
+ * configure, scmconfig.h.in: Rebuilt with autoconf and
+ autoheader.
+
+Wed Nov 6 16:19:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * fports.c (scm_stdio_to_port, scm_open_file): Set the port's
+ pointer to the stdio stream before calling scm_setbuf0, so the
+ latter will be able to retrieve it. I'm surprised this didn't
+ segfault earlier. (Thanks to Christopher Lee.)
+
+Wed Nov 6 16:01:20 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * throw.c (scm_lazy_catch, scm_ithrow): Completed implementation
+ of `lazy-catch'.
+
+Sat Nov 2 21:01:48 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stacks.c, stacks.h (scm_make_stack): Now takes arbitrary
+ number of stack narrowing specifier pairs. The first specifier in
+ a pair controls inner border, the second the outer border. A
+ number means cut that number of frames, a procedure object means
+ cut until that object is found in operator position in a frame.
+
+ * root.c (cwdr): Bugfix.
+
+ * read.c: Recording of positions disabled by default.
+
+ * procs.c (scm_closure_p): New function.
+
+ * posix.c (scm_tmpnam): New function.
+
+ * load.c: Added #include "throw.h".
+ (scm_sys_search_load_path): Bugfix: Don't add an extra '/' if path
+ ends with '/'.
+
+ * load.c, load.h (scm_read_and_eval_x): New function.
+
+ * eval.c: Renamed debug option "deval" to "debug".
+
+ (scm_eval_x): `eval!' is no longer accessible from the scheme
+ level. Motivation: We can't allow operations which introduce
+ glocs into the scheme level. Guile's type system can't handle
+ these as data. Use `eval' or `read-and-eval!' as replacement.
+
+ * debug.c (scm_m_start_stack): Bugfix: Use SCM_ECONSP instead of
+ SCM_CONSP since this is a macro!; Set vframe.prev to
+ scm_last_debug_frame instead of 0. In this way we can look
+ "above" the virtual start stack frame if we wish.
+ (scm_debug_hang): New function: Useful for debugging Guile in
+ certain tricky situations. Will probably be removed later...
+
+ * debug.h: Changed semantics of debug option "backtrace". This
+ option now only indicates whether we want automatic backtrace at
+ an error.
+
+Wed Oct 30 00:31:55 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ports.c: #include "filesys.h"
+ (scm_char_ready_p): input_waiting renamed and moved to filesys.c.
+
+ * filesys.c, filesys.h (scm_input_waiting_p): Moved from ports.c.
+ Motivation: This is system specific code which is related to file
+ I/O. It also may use select. Added code by Gary Houston to
+ detect presence of character in stdio buffers.
+
+ * libguile.h: #include "libguile/libpath.h"
+
+ * Makefile.in (libpath.h): Renamed definition of: LIBRARY_PATH -->
+ SCM_LIBRARY_DIR; Added definitions of: SCM_PKGDATA_DIR,
+ SCM_SITE_DIR; Install libpath.h among the other include files.
+
+ * load.c, load.h (scm_sys_package_data_dir): New function.
+
+Mon Oct 28 11:43:41 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stacks.h: Bugfix: Don't use tail-array length field as stack
+ length field! This screwed GC.
+
+Tue Oct 22 01:01:00 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * _scm.h: Added #ifndef around definition of macros min and max.
+
+ * __scm.h: Added hooks for threads to plugin to in ints protection
+ macros: SCM_THREAD_DEFER, SCM_THREAD_ALLOW, SCM_THREAD_REDEFER,
+ SCM_THREAD_ALLOW_1, SCM_THREAD_ALLOW_2. Motivation: We don't want
+ the main code in these macros duplicated and spread over multiple
+ files. Renamed SCM_THREADS_SWITCHING_CODE ->
+ SCM_THREAD_SWITCHING_CODE.
+
+Tue Oct 29 14:55:40 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * snarf.h: New file.
+ * guile-snarf.sh: New file.
+ * Makefile.in (inner_h_files): Added snarf.h
+ (ancillary, install, uninstall, distclean): Added actions for
+ guile-snarf.
+ (.c.x): Use guile-snarf.
+ (guile-snarf): New rule, to produce guile-snarf from guile-snarf.sh.
+ (gen_c_files): Note that these depend on guile-snarf.
+ * _scm.h: Removed the snarfing macros (SCM_PROC, etc). They are
+ now in "snarf.h". Added #include "snarf.h" to get them.
+ * libguile.h: Added #include "snarf.h".
+ (Patches applied and tweaked by Jim Blandy.)
+
+Tue Oct 29 13:21:13 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Use K&R style declaration for 'close'; the GNU coding
+ standards suggest against providing prototypes for system
+ functions. Thanks to Greg Troxel.
+
+Mon Oct 28 16:48:32 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * strports.c (scm_eval_0str): New function.
+ #include "read.h", to get prototype for scm_read.
+ * Makefile.in (strports.o): Update dependencies.
+ * strports.h: New prototype.
+
+ * numbers.c (scm_integer_p): Renamed from scm_int_p; change its
+ scheme name from "int?" to "integer?". It seems to do the job.
+ * numbers.h: Rename prototype too.
+ * scmhob.h (intp): Change definition to refer to scm_integer_p. I
+ hope this is right.
+
+ * numbers.c (scm_less_p, scm_gr_p, scm_leq_p, scm_geq_p,
+ scm_num_eq_p): Rename these according to R4RS conventions: call
+ them <, <=, =, >, and >=, not <?, <=?, =?, >?, and >=?. En route
+ to making libguile R4RS compliant without ice-9...
+
+ * load.c (scm_sys_search_load_path): Search for files under all
+ extensions listed in the %load-extensions variable. If FILENAME
+ is absolute, return it unchanged, without searching the load path.
+ (scm_loc_load_extensions): New variable, pointing to
+ %load-extensions' value cell.
+ (scm_init_load): Initialize it, and the value it points to.
+ (scm_primitive_load_path): Improve error reporting.
+
+ * load.c (scm_loc_load_hook): New variable, pointing to value cell
+ of new Scheme variable %load-hook.
+ (scm_primitive_load): Apply %load-hook to filename.
+
+Mon Oct 28 06:28:28 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure.in: add tests for figuring out whether buffered data
+ is available in a FILE structure, which is needed by char-ready.
+
+ * acconfig.h: define FILE_CNT_FIELD, FILE_CNT_GPTR and
+ FILE_CNT_READPTR.
+
+ * simpos.c (scm_getenv): renamed from scm_sys_getenv. Throw
+ exceptions using misc_error instead of syserror. It seems a bit
+ odd to throw an exception if a string can't be found in the
+ environment, but it's consistent with open-file, stat etc.
+ (simpos.h): remove sys_ from getenv.
+
+ * posix.c (scm_putenv): renamed from scm_sys_putenv. If an error
+ occurs, throw an error instead of returning errno. Return value
+ is now unspecified.
+ (numerous in posix.c and posix.h): removed superfluous sys_ from names.
+
+Sun Oct 27 01:22:04 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_stat2scm): derive file type and permissions from
+ the stat mode and append them to the returned vector.
+ There isn't much overhead in doing this and it avoids the need to
+ work with S_IRUSR et al. in Scheme.
+ Define symbols scm_sym_regular etc.
+ (scm_init_filesys): don't intern S_IRUSR etc.
+
+ * load.c: change s_try_load and s_try_load_path to s_primitive_load
+ and s_primitive_load_path.
+
+ * eval.c, load.c, error.c (scm_wta): use scm_misc_error.
+
+ * error.h: don't declare error symbols. prototype for scm_misc_error.
+
+ * stackchk.c (scm_stack_overflow_key): defined here instead of in
+ error.c.
+
+ * error.c: use SCM_SYMBOL to set up error keys.
+ scm_misc_error: new procedure.
+
+Fri Oct 25 01:56:30 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * read.c (scm_lreadr): Recognize SCSH-style block comments; text
+ between `#!' and `!#' is ignored.
+ (skip_scsh_block_comment): New function.
+
+ * feature.c (scm_set_program_arguments): New argument, FIRST.
+ * feature.h: Update prototype.
+ * init.c (scm_boot_guile_1): Pass new argument to
+ scm_set_program_arguments.
+
+Tue Oct 22 20:54:42 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * init.c (scm_start_stack): Don't initialize scm_progargs here.
+ (scm_boot_guile): Call scm_set_program_arguments here, later than
+ the old initialization.
+
+ * init.c: (scm_boot_guile, scm_boot_guile_1): New, simplified
+ initialization procedure.
+ - Delete in, out, err arguments; there are other perfectly good
+ ways to override these when desired.
+ - Delete result argument; this function shouldn't ever return.
+ - Rename init_func argument to main_func, for less confusion.
+ - Delete boot_cmd argument; main_func is more general.
+ -Add 'closure' argument, to help people pass data to main_func
+ without resorting to global variables.
+ - Abort if reentered; don't bother returning an error code.
+ - Call scm_init_standard_ports to set up the default/current
+ standard ports; no need to pass them to scm_start_stack.
+ - Remove code to evaluate the boot_cmd, and start the repl; let
+ the user do something like that in main_func if they want.
+ - Remove code to package up a return value; main_func can do any
+ of that as needed.
+ - Call exit (0), instead of returning.
+ (scm_start_stack): Don't initialize the I/O ports here; that's
+ weird. Delete in, out, err arguments. Move guts to
+ scm_init_standard_ports, scm_stdio_to_port.
+ (scm_init_standard_ports): New function, to set up current and
+ default standard ports.
+ (scm_start_stack, scm_restart_stack): Make these static.
+ * init.h (scm_boot_guile): Adjust declaration.
+ (scm_start_stack, scm_restart_stack): Remove externally
+ visible declarations for these.
+ (enum scm_boot_status): Removed; now scm_boot_guile never returns.
+
+ * fports.c (scm_stdio_to_port): New function. Its guts used to be
+ written out several times in scm_start_stack.
+ * fports.h: New declaration for the above.
+
+ * feature.c (scm_set_program_arguments): New function.
+ * feature.h: New declaration for the above.
+
+ * ports.c: Formatting tweak.
+
+Sun Oct 20 03:29:32 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * pairs.h, eval.c, eval.h, feature.c, gc.c, list.c, load.c,
+ ramap.c, symbols.c: Added new selectors SCM_CARLOC and SCM_CDRLOC
+ for obtaining the address of a car or cdr field. Motivation:
+ &SCM_CXR make assumptions about the internal structure of the
+ SCM_CXR selectors.
+
+ * eval.h, eval.c: Added new selector SCM_GLOC_VAL_LOC.
+ Motivation: see SCM_CXRLOC.
+
+ * pairs.h, eval.c, gc.c, init.c, ioext.c, ports.c, ports.h,
+ srcprop.h, tags.h, throw.c, unif.c: Added new selectors
+ SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR and SCM_SETOR_CDR.
+ Motivation: Safer use. Some other macros are defined in terms of
+ these operations. If these are defined using the SCM_SETCXR
+ (<e1>, SCM_CXR (<e1>) <op> <e2>) pattern a complex <e1> will lead
+ to inefficiency and an <e1> with side-effects could potentially
+ break. Also, these particular operations are heavily utilized in
+ the garbage collector. In unoptimized code there will be a
+ measurable speedup.
+
+ * alist.c, arbiters.c, continuations.c, debug.c, debug.h, eval.c,
+ eval.h, feature.c, filesys.c, fports.c, gc.c, gsubr.c, init.c,
+ ioext.c, kw.c, list.c, load.c, mallocs.c, numbers.c, numbers.h,
+ pairs.c, pairs.h, ports.c, ports.h, posix.c, procprop.c, procs.c,
+ procs.h, ramap.c, read.c, root.c, srcprop.c, srcprop.h,
+ strports.c, symbols.c, tags.h, throw.c, unif.c, variable.c,
+ vports.c: Cleaned up use of pairs: Don't make any special
+ assumptions about the internal structure of selectors and
+ mutators: SCM_CXR (<e1>) = <e2> --> SCM_SETCXR (<e1>, <e2>),
+ SCM_CXR (<e1>) &= <e2> --> SCM_SETAND_CXR (<e1>, <e2>) etc.
+ (Among other things, this change makes it easier to build Guile
+ with certain compilers which have problems with casted lvalues.)
+
+Fri Oct 18 01:11:56 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stacks.c: Improve selection of relevant stack frames when making
+ a stack object. Introduce one level of indirection in the stack
+ object to make it possible to "narrow" to a certain region of the
+ stack. This facilitates making use of more clever algorithms (not
+ implemented) for selecting relevant frames and gives a cleaner
+ design since selection of frames can be done independently of
+ extraction of frames from the real stack.
+ (scm_stack_id): Also take #t as argument which means look at
+ current stack.
+
+ * stacks.h: In struct scm_stack: Turn field frames into a pointer.
+ Turn n_tail into an integer directly representing current number
+ of frames in stack. Add field tail.
+
+ * ports.c (scm_port_line_x, scm_port_column_x): New mutators.
+
+ * debug.c (scm_make_memoized): Made it available at scheme level.
+ (scm_unmemoize, scm_memoized_environment): Bugfix: Check for
+ SCM_NIMP before applying heavier predicates in argument checking.
+ (scm_local_eval): Also take memoized object as argument.
+
+ * backtrace.c (scm_display_error): Just a safety measure: Stacks
+ aren't created with zero length, but should such a strange
+ creature suddenly turn up...
+
+Wed Oct 16 11:08:41 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * hashtab.h (scm_hashx_remove_x): Renamed `delete' parameter to
+ `del', for the sake of C++ compilers. (Patch applied by JimB.)
+
+Tue Oct 15 17:06:13 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * variable.c (scm_make_variable): Make the name hint optional, as
+ documented.
+ (anonymous_variable_sym): Renamed from variable_sym. All uses
+ changed.
+
+ * load.c (scm_primitive_load, scm_primitive_load_path): Renamed
+ from scm_sys_try_load and scm_sys_try_load_path. The Scheme name
+ of scm_primitive_load_path was also changed to
+ "primitive-load-path", from "%try-load-path". Callers changed.
+ We'd like to respect the convention that a function named
+ "try-mumble" should behave just like the function called "mumble",
+ but return #f instead of signalling some error.
+ * load.h: Rename prototypes.
+
+Tue Oct 15 05:34:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * print.c (make_print_state, grow_print_state), print.h: Modified
+ the print state representation: Don't use a tail array for
+ recording of circular references. Resizing of the print state
+ structure invalidates the print state pointer. To avoid passing
+ around an indirect print state reference to all printing
+ functions, we instead let the print state reference a resizable
+ vector.
+
+Mon Oct 14 19:25:00 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * alist.c (scm_sloppy_assq, scm_sloppy_assv, scm_sloppy_assoc):
+ Don't crash when passed an improper list terminated by a
+ non-immediate value.
+
+Mon Oct 14 19:08:33 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Allocate data for structures on an eight-byte boundary, as
+ required by the tagging system.
+ * struct.c (alloc_struct): New function.
+ (scm_make_struct, scm_make_vtable_vtable): Call it.
+ * struct.h (scm_struct_n_extra_words): Bump to 3.
+ (scm_struct_i_ptr): New "field".
+ * gc.c (scm_gc_sweep): When we need to free the data, use the
+ information stored by alloc_struct to find the beginning of the
+ block allocated to the structure, so we can free it.
+
+Mon Oct 14 17:07:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * init.c (scm_boot_guile_1): Moved scm_init_struct in front of
+ scm_init_stacks.
+
+ * debug.h (SCM_VOIDFRAME, SCM_VOIDFRAMEP): New macros.
+ (scm_debug_info): New member: id.
+
+ * stacks.c: Stacks are now represented as structs; Stacks have an
+ id given to them by `start-stack'.
+ (scm_last_stack_frame): Added predicates `stack?' and `frame?'.
+
+ * stacks.h: Added declarations of scm_stack_p and scm_frame_p;
+ Changed stack representation.
+
+ * debug.c (scm_procedure_name): Try procedure property `name' for
+ compiled closures aswell.
+
+ * gc.c (scm_init_storage): Initialize scm_stand_in_procs to SCM_EOL.
+
+ * eval.c: scm_i_name moved to gsubr.c
+ (scm_m_define): Record names of all kinds of procedure
+ objects. (Earlier, only closures were recorded.)
+
+ * procprop.h: Added declaration of scm_i_name.
+
+ * gsubr.c: Added global scm_i_name. Added #include "procprop.h".
+ (scm_make_gsubr): Record names of compiled closures.
+
+Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c, debug.h: Removed obsolete code.
+
+ * continuations.c, continuations.h, debug.c, gc.c, init.c, root.c,
+ stacks.c: Renamed regs --> scm_contregs.
+
+ * print.c (scm_free_print_state): Cleanup print state before
+ returning it to pool. It is better to do it here than in
+ scm_prin1 since scm_prin1 is called often.
+
+ * srcprop.c (scm_source_properties, scm_set_source_properties_x,
+ s_set_source_property_x): Check that first argument is a pair or a
+ memoized object.
+
+ * srcprop.c, srcprop.h: Made scm_i_filename, scm_i_copy,
+ scm_i_line, scm_i_column and scm_i_breakpoint global.
+
+ * init.c: Added #include "backtrace.h" and #include "stacks.h".
+ (scm_boot_guile_1): Added calls to scm_init_backtrace and
+ scm_init_stacks.
+
+ * debug.h: Added debug object smob declaration and macro
+ definitions.
+
+ * configure.in: Build with backtrace.o and stacks.o if debug
+ support enabled.
+
+ * Makefile.in: Added entries for new files: backtrace.c,
+ backtrace.h, stacks.c and stacks.h.
+
+ * symbols.c (scm_sym2ovcell): Fixed documentation.
+
+ * _scm.h (min, max): Added.
+
+ * async.c: Moved `min' macro to _scm.h.
+
+ * debug.h: New debug options SCM_BACKTRACE_MAXDEPTH and
+ SCM_BACKTRACE_INDENT.
+
+ * eval.c: Added new debug options `maxdepth' and `indent'.
+
+ * print.c (make_print_state): Bugfix: Initialize pstate->ceiling.
+
+ * print.h: Added selector SCM_PRINT_STATE.
+
+ * print.c: New functions: scm_make_print_state,
+ scm_free_print_state.
+
+ * print.h: Added declarations for scm_make_print_state,
+ scm_free_print_state.
+
+ * debug.c (scm_m_start_stack): New acro.
+
+ * debug.h: Small cleanup.
+
+ * init.c (scm_boot_guile_1): Moved scm_init_debug below
+ scm_init_eval.
+
+Sun Oct 13 20:14:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * __scm.h, alist.c, alist.h, append.c, append.h, appinit.c,
+ arbiters.c, arbiters.h, async.c, async.h, boolean.c, boolean.h,
+ chars.c, chars.h, continuations.c, continuations.h, debug.c,
+ debug.h, dynwind.c, dynwind.h, eq.c, eq.h, error.c, eval.c,
+ eval.h, extchrs.c, extchrs.h, fdsocket.c, fdsocket.h, filesys.c,
+ filesys.h, fports.c, fports.h, gc.c, gdb_interface.h, gdbint.c,
+ gdbint.h, genio.c, genio.h, gscm.c, gscm.h, gsubr.c, gsubr.h,
+ hash.c, hash.h, hashtab.c, hashtab.h, init.c, ioext.c, ioext.h,
+ kw.c, kw.h, libguile.h, mallocs.c, mallocs.h, markers.c,
+ markers.h, mbstrings.c, mbstrings.h, numbers.c, numbers.h,
+ objprop.c, objprop.h, options.c, options.h, pairs.c, pairs.h,
+ ports.c, ports.h, posix.c, posix.h, print.c, print.h, procprop.c,
+ procprop.h, procs.c, procs.h, ramap.c, ramap.h, read.c, read.h,
+ root.c, scmsigs.c, scmsigs.h, sequences.c, sequences.h, simpos.c,
+ simpos.h, smob.c, socket.c, socket.h, srcprop.c, srcprop.h,
+ stackchk.c, stackchk.h, stime.c, stime.h, strings.c, strings.h,
+ strop.c, strop.h, strorder.c, strorder.h, strports.c, strports.h,
+ struct.c, struct.h, symbols.c, symbols.h, tag.c, tag.h, unif.c,
+ unif.h, variable.c, variable.h, vectors.c, vectors.h, version.c,
+ version.h, vports.c, vports.h, weaks.c, weaks.h: Use SCM_P to
+ declare functions with prototypes. (Patch thanks to Marius
+ Vollmer.)
+
+ More prototype-related changes from Marius Vollmer:
+ * gdb_interface.h: Wrapped header file in #ifdef/#endif
+ * gscm.h (gscm_run_scm): Added prototype for `initfn' paramter.
+ * ports.h (ptobfuns): Added prototypes. This means some casting in
+ fports.c.
+ * fports.c: Added casts for initializations, since the functions
+ are defined to take FILE * as their stream argument, not SCM.
+ * fdsocket.c, fdsocket.h: Made `init_addr_buffer' static.
+ * genio.c (scm_gen_puts): Changed `unsigned char *str_data' parameter
+ to `char *str_data' to conform to prototype.
+
+Sat Oct 12 21:49:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c, eval.c, load.c, stackchk.c: use scm_error not lgh_error.
+
+ * __scm.h (lgh_error): removed, lgh shouldn't be in libguile.
+
+ * stime.c, stime.h: use SCM_P method.
+
+Sat Oct 12 16:16:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (scm_nconc2last): Don't accept an empty list; apply must
+ be given at least two arguments. Insist that lst's last element
+ be a list, but don't make any requirements of its predecessors.
+
+Fri Oct 11 03:58:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (scm_nconc2last): Revert last change; there seems to be
+ other stuff going on here.
+
+Fri Oct 11 02:43:59 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * eval.c (scm_nconc2last): Make sure that each element of lst
+ (which is a list of argument lists, except for the tail) is a
+ proper list, i.e., finite and terminated by '().
+
+Thu Oct 10 21:09:13 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * unif.c (scm_ra_set_contp): Localize `inc' declaration.
+ Clarifies flow.
+
+ * struct.c (scm_make_struct, scm_make_vtable_vtable): Use the
+ symbolic name for the tag, scm_tc3_cons_gloc, instead of just
+ saying "1".
+
+ * vectors.c (scm_make_vector): Fill vectors with the undefined
+ value, to help make Guile Scheme code more portable to other
+ Schemes.
+
+ * symbols.c (scm_intern_obarray_soft, scm_sysintern): Doc fixes.
+ * symbols.h, tags.h: Doc fixes.
+
+Wed Oct 9 19:39:29 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * async.c (scm_take_signal): Doc fixes.
+
+Mon Oct 7 22:30:34 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_divbigint): When the remainder is zero, we don't
+ want to subtract it from the modulus; we just want to leave it
+ alone.
+
+Mon Oct 7 00:14:17 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * init.c (scm_boot_guile_1): Bugfix: i --> base in argument to
+ `scm_init_threads'.
+
+ * throw.h (scm_catch_apply): Removed the `lazyp' argument.
+
+ * throw.c (scm_catch_apply): Finished implementation of
+ `lazy-catch'.
+
+Sun Oct 6 05:26:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_sys_select): move SCM_ALLOW_INTS past the sreturn
+ check.
+ (scm_init_filesys): set "i/o-extensions" feature.
+ include feature.h.
+
+Sat Oct 5 12:22:00 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (root.o): Correct dependencies.
+
+Sat Oct 5 18:40:42 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * Makefile.in: Added dependency entry for root.o.
+
+ * continuations.c, debug.[ch], eval.c, gscm.c init.c, root.c,
+ throw.c: Renamed last_debug_info_frame -> scm_last_debug_frame.
+
+ * init.c (scm_start_stack): Set initial root continuation number
+ to 0.
+
+ * procs.c: New function: scm_thunk_p.
+
+ * procs.h: Added declarations of scm_thunk_p.
+
+ * root.c: Renamed `call-with-new-root' -->
+ `call-with-dynamic-root'.
+ (cwdr): Removed allocation of new root state. This should be done
+ separately by use of scm_make_root.
+ (scm_apply_with_dynamic_root): New function: Does what it
+ sounds like. Needed when spawning threads.
+
+ * root.h: Added member last_debug_frame to root state.
+ Added #include "libguile/debug.h"
+
+ * throw.c: Renamed scm_catch --> scm_catch_apply and added more
+ arguments. The motivation is that code in root.c needs catch
+ functionality, and we want to avoid code duplication.
+ New functions: scm_catch, scm_lazy_catch. These are wrappers for
+ scm_catch_apply. scm_lazy_catch is intended to introduce catch
+ handlers that run without popping the stack into the dynwind
+ chain.
+
+ * throw.h: Added prototypes for scm_catch_apply and
+ scm_lazy_catch.
+
+Thu Oct 3 11:12:33 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * root.h (scm_root, scm_set_root): Decouple thread support details
+ by introducing the selector SCM_THREAD_LOCAL_DATA and the mutator
+ SCM_SET_THREAD_LOCAL_DATA.
+
+ * print.c (scm_iprlist): Bugfix: Added SCM_ECONSP tests in hare
+ and tortoise scanning loop.
+
+Thu Oct 3 00:04:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in: Rebuild dependencies.
+
+ * libguile.h: #include "libguile/print.h" before "smob.h", since
+ the latter uses the print_state structure.
+
+ * throw.c (scm_ithrow): Use the correct variable when checking to
+ see if a given element of scm_dynwinds is a valid catch.
+
+ * throw.c (scm_ithrow): If scm_dynwinds has invalid list
+ structure, abort; don't just silently ignore the garbage.
+
+ * _scm.h: #include "print.h" here, since it seems to be used just
+ about everywhere.
+ * eval.c, gdbint.c, genio.h, numbers.h, smob.h, srcprop.c,
+ strports.c, unif.h: Don't #include "print.h".
+
+Tue Oct 1 05:15:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * feature.h (scm_loc_features): Removed external declaration.
+ (Bug fix suggested by Petr Adamek <adamek@mit.edu>.)
+
+Tue Oct 1 00:00:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * feature.c (scm_init_feature): Added threads feature (needs to be
+ initialized here, since features doesn't exist when
+ scm_init_threads is called).
+
+ * libguile.h: Added #include "libguile/../threads/threads.h".
+ (This is a kludge to get thread support working. This should be
+ fixed.)
+
+ * configure.in, acconfig.h: Added flags for thread support.
+
+ * scmsigs.c: Define `signal' to be `pthread_signal' if using
+ mit-pthreads.
+
+ * gc.c (scm_igc): Added SCM_THREAD_CRITICAL_SECTION_START and
+ SCM_THREAD_CRITICAL_SECTION_END. Moved marking of root data to
+ root.c:mark_root.
+
+ * _scm.h: Added conditional #include "threads.h"
+
+ * __scm.h (SCM_ASYNC_TICK): Added call to macro
+ SCM_THREADS_SWITCHING_CODE.
+
+ * init.c (scm_start_stack): Call `scm_make_root' to dynamically
+ allocate the basic dynamic root object.
+ (scm_boot_guile): Added call to scm_init_root.
+
+ * root.c, root.h: Added root smob.
+ (cwdr, scm_call_with_new_root, scm_dynamic_root, scm_app_wdr): New
+ functions: Implements dynamic roots mostly according to spec in
+ SCM manual. Main difference is that the second argument is a
+ throw handler rather than an error "thunk".
+
+ * root.h: Added declaration of scm_init_root.
+
+ * root.c: Added #include "genio.h", #include "smob.h", #include
+ "pairs.h", #include "throw.h", #include "dynwind.h", #include
+ "eval.h"
+ (scm_init_root): Added #include "root.x".
+
+ * throw.c: Added #include "stackchk.h"
+ (scm_catch): Changed SCM_DEFER_INTS --> SCM_REDEFER_INTS and
+ SCM_ALLOW_INTS --> SCM_REALLOW_INTS. This is so that scm_catch
+ can be used in scm_call_with_new_root; Added reenabling of stack
+ checking when catching a throw.
+
+Mon Sep 30 21:48:11 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * list.c, list.h: Use SCM_P instead of CPP hair. Doc fixes.
+
+ * list.c (scm_member, scm_memv, scm_memq): Return #f if a matching
+ element is not found, as per R4RS.
+
+Sat Sep 28 18:13:01 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * list.c: Doc fixes throughout.
+
+Sat Sep 28 02:07:43 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * strings.c, strings.h: (scm_makfrom0str, scm_makefrom0str_opt:
+ declare the char * to be const. Avoids a warning in rgx.c.
+
+ * ports.h: spelling fix.
+
+ * filesys.c (scm_sys_stat, scm_sys,lstat): include file name in
+ error messages.
+
+ * load.c (scm_sys_try_load_path): throw an error if file not found
+ (like it says it in NEWS).
+
+Fri Sep 27 18:27:01 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * symbols.c (scm_intern_obarray_soft): Initialize the new symbol's
+ PROPS slot to '(), not #f; it's an empty alist.
+
+ * throw.h, throw.c: Use SCM_P instead of #if hair.
+
+ Remove special support for uncaught throws; see throw.c for
+ rationale.
+ * throw.c (uncaught_throw): New function.
+ (scm_ithrow): Call uncaught_throw if we don't find a throw
+ target; don't mess with scm_bad_throw_vcell.
+ (scm_bad_throw_vcell): Variable deleted.
+ (scm_init_throw): Don't initialize it.
+
+ * throw.c (scm_ithrow): Don't let outer key matches shadow inner
+ #t catches.
+
+Wed Sep 25 04:35:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_istr2int): If the number is short (as most
+ numbers are), just call scm_small_istr2int to deal with it.
+ (scm_small_istr2int): New function, created by un-#ifdefing the
+ non-bignum version of scm_istr2int and renaming it.
+
+Tue Sep 24 06:48:38 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * load.c (scm_sys_try_load): don't check whether value returned
+ by scm_open_file is #f, it won't be. Always return SCM_UNSPECIFIED.
+ Change the Scheme name from %try-load to primitive-load.
+
+ * error.c (scm_error): convert a NULL message to SCM_BOOL_F.
+ Can avoid passing a message, allowing it to be derived in the
+ error handler (e.g., if we want to throw to the key both from
+ Scheme and C).
+
+Mon Sep 23 00:42:15 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * print.c (scm_iprin1, scm_prin1, scm_iprlist): Circular
+ references now have a new appearance which is more compact and
+ also gives a clue about what the target of the reference is.
+ By setting parameters in the print state, more fancy printing can
+ be achieved. This is used by the (not yet commited) backtrace
+ code.
+
+Sun Sep 22 17:10:06 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * eval.c, numbers.h, unif.h, smob.h, srcprop.c: Added #include
+ "print.h"
+
+ * print.c: Added #include "struct.h". Removed function
+ scm_prlist.
+
+ * print.h: Modified prototypes for scm_iprlist, scm_prin1 and
+ scm_iprin1. Removed prototype for scm_prlist.
+
+ * arbiters.c (prinarb),
+ async.c (print_async),
+ debug.c (prindebugobj, prinmemoized),
+ eval.c (prinprom, prinmacro),
+ filesys.c (scm_fd_print, scm_dir_print),
+ kw.c (print_kw),
+ mallocs.c (prinmalloc),
+ numbers.c, numbers.h (scm_floprint, scm_bigprint),
+ smob.h (scm_smobfuns),
+ srcprop.c (prinsrcprops),
+ throw.c (prinjb),
+ unif.c, unif.h (scm_raprin1, rapr1),
+ variable.c (prin_var): Changed argument `int writing' to
+ `scm_print_state *pstate'.
+
+ * init.c (scm_boot_guile): Moved scm_init_struct upwards so
+ that it will be called before scm_init_print.
+
+ * print.c (scm_prin1): Print states are now allocated when calling
+ scm_prin1 and then passed around to all printing functions as an
+ argument. A cache `print_state_pool' enables reuse of print
+ states.
+ (scm_make_print_state): New function.
+ (scm_iprin1): Adaption to print states.
+ (scm_iprlist): An initial "hare and tortoise" scan brings down
+ time complexity to O (depth * N). (Better time complexity will be
+ achieved when the printing code is completely rewritten.)
+
+Fri Sep 20 22:01:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * aclocal.m4 (GUILE_STRUCT_UTIMBUF): Use AC_CACHE_CHECK instead of
+ AC_CACHE_VAL; #define UTIMBUF_NEEDS_POSIX outside AC_CACHE_VAL, so
+ it gets done whether or not the cache variable has a value.
+
+Thu Sep 19 17:06:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Distinguish #f and ().
+ * __scm.h: #undef SICP.
+ * pairs.h (SCM_EOL): Delete this definition, equating it with
+ SCM_BOOL_F.
+ * tags.h (SCM_EOL): Give it a new definition here; I think I found
+ the value it used to have. Doc fixes, too.
+
+Thu Sep 19 15:33:51 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * struct.c (scm_make_struct_layout, init_struct, scm_struct_ref,
+ scm_struct_set_x), struct.h, gc.c (scm_gc_mark): Completed Tom
+ Lord's implementation of structs, allowing for tail arrays as
+ described in the manual. Also fixed some bugs. (Both the interface
+ and the implementation should be improved.)
+
+ * read.c (scm_init_read): Removed #ifdef READER_EXTENSIONS
+
+ * print.c, print.h: Closures now print like #<procedure foo (x)>.
+ People who whish to see the source can do `(print-enable 'source)'.
+ Removed #ifdef DEBUG_EXTENSIONS.
+
+Thu Sep 19 00:00:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scsm_sys_stat): don't SIGSEGV if argument is an
+ integer (assuming for now accepting an integer is a good thing).
+
+ * error.c, fports.c: replace use of %S in lgh_error args with %s.
+ %S will be used instead for write'ing arguments.
+
+ * unif.c (scm_transpose_array): change arguments in the SCM_WNA
+ asserts. fix a few other asserts.
+ (scm_aind, scm_enclose_array, scm_array_in_bounds_p,
+ scm_uniform_vector_ref, scm_array_set_x,
+ scm_dimensions_to_unform_array): change args in
+ SCM_WNA SCM_ASSERTS and change scm_wta's to scm_wrong_num_args.
+ strop.c (scm_substring_move_left_x, scm_substring_move_right_x,
+ scm_substring_fill_x): likewise.
+ gsubr.c (scm_gsubr_apply): likewise.
+ eval.c (SCM_APPLY): likewise.
+
+ * eval.c (4 places): replace scm_everr with lgh_error or
+ scm_wrong_num_args.
+
+ * error.c, error.h (scm_wrong_num_args, scm_wrong_type_arg,
+ scm_memory_error): new procedures.
+ scm_everr: deleted. can use scm_wta, dropping first two args.
+ scm_error: convert NULL subr to SCM_BOOL_F.
+
+ * __scm.h: don't define SCM_STACK_OVFLOW, SCM_EXIT, SCM_ARG6, SCM_ARG7,
+ SCM_ARGERR.
+
+ * stackchk.c (scm_report_stack_overflow): use lgh_error instead
+ of scm_wta.
+
+ * error.c, error.h: new error keys: scm_arg_type_key,
+ scm_args_number_key, scm_memory_alloc_key, scm_stack_overflow_key,
+ scm_misc_error_key.
+ scm_wta: reimplement using lgh_error instead of scm_everr.
+
+Wed Sep 18 17:13:35 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * gdbint.c: scm_lread now has one more argument.
+
+ * ports.c, ports.h: Name change: scm_\(line\|column\)_number -->
+ scm_port_\1; Added mutator scm_set_port_filename_x (used when
+ loading source from non-file ports, which, e. g., happens when
+ using the Emacs interface).
+
+ * fports.c (scm_open_file): Don't call scm_makfrom0str on a scheme
+ object.
+
+ * read.c: Added code for recording of positions of source code
+ expressions; New functions: recsexpr, scm_lreadrecparen;
+ _scm_make_srcprops --> scm_make_srcprops
+ (scm_flush_ws): Removed updating of positions counters. This work
+ is already done by scm_gen_getc
+
+ * read.h: Added prototype for scm_lreadrecparen
+
+ * print.c: Added #include "alist.h"
+
+ * eval.c: Added #include "hash.h"
+
+ * eq.c: Added #include "ramap.h"
+
+ * options.c: Documentation fixes.
+
+ * srcprop.c (scm_finish_srcprop): Bugfix: update ptr.
+ (scm_init_srcprop): Adjusted size of initial source-whash. Name
+ changes: tc16_srcprops --> scm_tc16_srcprops, _scm_make_srcprops
+ --> scm_make_srcprops
+
+ * srcprop.h: Name changes: tc16_srcprops --> scm_tc16_srcprops,
+ _scm_make_srcprops --> scm_make_srcprops; Remove one layer of
+ function calls in the definition of the whash access macros.
+
+Tue Sep 17 11:33:16 1996 Lee Iverson <leei@Canada.AI.SRI.COM>
+
+ * init.c (scm_boot_guile): Add level of indirection to
+ scm_boot_guile_1() to ensure that stack base pointer is properly
+ initialized. There was no guarantee that variable i was the
+ highest/lowest variable on stack (i.e. the call frame of
+ scm_boot_guile was not completely protected from gc).
+
+Tue Sep 17 01:40:56 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.h (scm_port_table): put back file_name, it will be used to
+ support debugging. Undo related changes in fports.c, ioext.c,
+ ports.c, gc.c.
+
+Sun Sep 15 03:58:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.h (scm_port_table): remove file_name member for now, it seems
+ undesirable.
+ * fports.c (scm_open_file): don't set file_name in PTAB.
+ (prinfport): don't use file_name in PTAB.
+ * ioext.c (scm_sys_duplicate_port): don't set file_name in PTAB.
+ * ports.c (scm_add_to_port_table): don't intialize file_name.
+ (scm_port_file_name): remove for now.
+ * gc.c (scm_gc_mark): don't mark PTAB file_name.
+
+ * fports.h (scm_mkfile): prototype deleted.
+ * fports.c (scm_mkfile): merged into scm_open_file to simplify.
+
+ * debug.c, unif.c: use scm_out_of_range instead of
+ wta for range errors (ASSERT still needs work).
+
+ * error.c, error.h (scm_out_of_range): new procedure.
+
+ * error.c, error.h (scm_out_of_range_key): new key.
+
+ * posix.c (scm_sync): #else was missing.
+
+ * error.c, error.h: append _key to names scm_num_overflow and
+ scm_system_error.
+
+ * __scm.h (SCM_SYSMISSING, SCM_NUM_OVERFLOW): use SCM_BOOL_F instead
+ of consing an empty list.
+ (SCM_SYSERROR etc.): move into error.c, make them procedures instead
+ of macros, saves code and string space.
+ error.c, fports.c, numbers.c, posix.c, ioext.c, filesys.c, socket.c,
+ fdsocket.c, simpos.c: change names of SCM_SYSERROR etc., to
+ lower case. Rename scm_syserror_m to scm_syserror_msg.
+ error.h: prototypes for new procedures.
+
+Sat Sep 14 03:35:41 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * numbers.c: use SCM_NUM_OVERFLOW instead of scm_wta or ASSERT.
+
+ * error.c, error.h: setup scm_num_overflow key.
+
+ * __scm.h: SCM_NUM_OVERFLOW: macro for reporting numerical overflow.
+ Remove definition of SCM_OVSCM_FLOW.
+
+ * fports.c (scm_open_file): use SCM_SYSERROR_M.
+
+ * __scm.h: SCM_SYSERROR_M: new macro for system errors with an
+ explicit message and args.
+
+ * error.c, error.h, __scm.h: change system_error_sym to
+ scm_system_error.
+
+ * error.c (system_error_sym): remove leading %% from the Scheme name
+ "%%system-error".
+
+ * __scm.h (SCM_SYSMISSING): Redefine using lgh_error.
+
+Fri Sep 13 12:58:08 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * __scm.h, chars.c, debug.c, eval.c, eval.h, extchrs.c, extchrs.h,
+ fdsocket.c, feature.c, mbstrings.c, mbstrings.h, numbers.c,
+ numbers.h, print.c, scmhob.h, simpos.h, symbols.c, symbols.h,
+ tags.h, throw.c, variable.h: Name cleanup. Lots of xxxSCM_yyy
+ renamed. (These were introduced by unsupervised name
+ substitution.)
+
+Fri Sep 13 01:19:08 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * print.c: Added code for detection of circular references during
+ printing. (init_ref_stack, grow_ref_stack): New functions. Added
+ a hook for printing of closures (accessible via print options).
+ This leads to a split of calls to scm_iprin1 into two classes:
+ elementary print operations (e. g. the code which prints a smob)
+ still use scm_iprin1 while top level calls (like scm_display) use
+ scm_prin1. scm_prin1 begins by clearing the data structure used
+ to record reference information.
+
+ * print.h: Added declarations of scm_prin1 and scm_prlist.
+
+ * strports.c (scm_strprint_obj): scm_iprin1 --> scm_prin1
+
+ * gscm.c (gscm_portprint_obj): scm_iprin1 --> scm_prin1
+
+ * gscm.h (gscm_print_obj): scm_iprin1 --> scm_prin1
+
+ * error.c (err_head): scm_iprin1 --> scm_prin1
+
+ * debug.c: Adjusted header comment.
+
+ * tags.h: Typo.
+
+Wed Sep 11 17:55:59 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * strerror.c: Doc fix.
+
+Thu Sep 12 00:00:32 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * gdbint.c (gdb_read): Now possible to run during GC.
+ (unmark_port, remark_port): New functions.
+
+ * symbols.h (SCM_SETLENGTH): Use SCM_SETCAR.
+
+ * read.c (scm_grow_tok_buf): Use scm_vector_set_length_x instead
+ of allocating a new string object. Also, increase size by
+ the factor 2 instead of 1.5.
+
+Wed Sep 11 15:10:38 1996 Petr Adamek <jimb@floss.cyclic.com>
+
+ * __scm.h (SCM_P): Corrected to run under traditional C.
+
+ * _scm.h (SCM_PROC): Extraneous semicolon (outside functions)
+ removed.
+
+ * async.c: Calls to scm_sysintern corrected.
+
+ * async.h (scm_async_clock): Redundant declaration removed.
+
+ * continuations.c (scm_dynthrow): Redundant declaration removed.
+
+ * debug.c (scm_single_step, scm_memoized, scm_lookup_soft):
+ Definition typos corrected.
+
+ * debug.h: Missing declarations of functions in debug.c added
+ (lots).
+
+ * eval.h (scm_eval_args, scm_deval_args, scm_m_undefine):
+ Missing declarations to functions in eval.c added.
+
+ * filesys.c: Possibly uninitialized variable rv.
+
+ * gc.h (scm_object_addr, scm_unhash_name): Missing
+ declarations of functions defined in gc.c added.
+
+ * genio.c: Possible typos str_data -> wstr_data. ???
+
+ * genio.c: Possibly unintended shadowing of local variable
+ `int c' (gotos out of scope of inner `c'). ???
+
+ * init.c: Uninitialized `SCM last' may be used.
+
+ * ioext.h: (scm_sys_isatty_p): Typo.
+
+ * list.h (scm_list_head): Missing prototype for function in
+ list.c added.
+
+ * numbers.c (scm_two_doubles): Changed from extern to static
+ (is used only within numbers.c).
+
+ * numbers.h: Repeated declarations removed.
+
+ * ports.h (scm_close_all_ports_except): Declaration for the
+ function defined in ports.c added.
+
+ * posix.h: Missing declarations added.
+
+ * procs.h (scm_make_subr_opt): Missing declaration added.
+
+ * socket.h (scm_sys_gethost): Missing declaration added.
+
+ * socket.h: Redundant declarations removed (they are in fdsocket.h).
+
+ * srcprop.h (scm_set_source_property_x, scm_finish_srcprop):
+ Missing declarations added.
+
+ * stime.h (scm_get_internal_real_time): Repeated declarations removed.
+
+ * struct.c: Uninitialized variable `SCM answer' may be used.
+
+ * unif.c (l2ra): Declaration prototype.
+
+ * unif.c (scm_array_equal_p): Dummy definition removed (it is
+ defined in ramap.c).
+
+ * unif.h (scm_raprin1, scm_istr2bve, scm_array_equal_p):
+ Redundant declarations removed (they are in ramap.h).
+
+ * variable.h (scm_make_udvariable,
+ scm_make_undefined_variable): Declaration corrected to
+ correspond variable.c.
+
+ * vectors.h (scm_vector_move_left_x, scm_vector_move_right_x):
+ Missing declarations added.
+
+Wed Sep 11 14:38:50 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (distclean): Don't forget to delete fd.h.
+
+Tue Sep 10 14:01:46 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * fd.h.in, tags.h: Trivial cleanups.
+
+ * marksweep.c, marksweep.h: Deleted; marksweep.c was empty, and
+ marksweep.h just declared functions from gc.c.
+ * gc.h, libguile.h: Don't #include "marksweep.h".
+ * Makefile.in (libobjs, inner_h_files, c_files, gen_c_files): Omit
+ marksweep.o, marksweep.h, marksweep.c, and marksweep.x. Other
+ dependencies updated.
+
+ * libguile.h: Don't #include "files.h"; it's been deleted.
+
+ * files.c (scm_sys_delete_file): Moved to filesys.c.
+ File is now empty; deleted.
+ * files.h: Deleted.
+ * filesys.c: scm_sys_delete_file is now here. Remove
+ #if's; they seem to rely on remnants of an old portability
+ regimen. If the problems come up again, solve them properly,
+ using autoconf. Specifically: Don't test M_SYSV, and #define
+ remove to be unlink if it's #defined; don't use remove just
+ because HAVE_STDC_HEADERS is #defined.
+ * filesys.h: Add declarations for scm_sys_delete_file.
+ * Makefile.in (libobjs, inner_h_files, c_files, gen_c_files): Omit
+ files.o, files.h, files.c, and files.x.
+ * init.c: Don't #include "files.h", and don't call scm_init_files.
+
+ Use SCM_P instead of PROTO; the latter intrudes on the user's
+ namespace.
+ * params.h: Deleted; definition of SCM_P moved to...
+ * __scm.h: ... here, where it replaces PROTO macro.
+ * libguile.h, smob.h: Don't #include "params.h".
+ * continuations.c, error.h, feature.h, gc.c, gc.h, init.h, load.h,
+ smob.h: Fix prototypes accordingly.
+ * Makefile.in: Update dependencies.
+ (inner_h_files): Remove params.h.
+
+ * gc.c: #include "gc.h"; every module should include its header,
+ to let the compiler cross-check the declarations against the
+ definitions.
+
+ * eq.h, files.h, hashtab.h, load.h, mallocs.h, scmsigs.h,
+ simpos.h: #include "libguile/__scm.h".
+
+Mon Sep 9 20:00:15 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * init.c: Don't forget to #include smob.h and init.h.
+ * Makefile.in: Dependencies updated.
+
+ * smob.h: Use PROTO instead of #if __STDC__.
+
+ * continuations.c (scm_dynthrow): Use PROTO, not SCM_P.
+
+ * __scm.h: Doc fixes.
+
+ * __scm.h, libguile.h: Use "quotes" in the #includes, not
+ <angles>; this allows `make depends' to work properly.
+
+ * libguile.h: #include smob.h and pairs.h before the others; they
+ define typedefs used by other headers.
+
+ C files should #include only the header files they need, not
+ libguile.h (which #includes all the header files); the pointless
+ recompilation was wasting my time.
+ * Makefile.in (all .o dependency lists): Regenerated.
+ * libguile.h: Don't try to get a definition for size_t here...
+ * __scm.h: Do it here.
+ * _scm.h: Since this is the internal libguile header, put things
+ here that all (or a majority) of the libguile files will want.
+ Don't #include <libguile.h> here; that generates dependencies on
+ way too much. Instead, get "__scm.h", "error.h", "pairs.h",
+ "list.h", "gc.h", "gsubr.h", "procs.h", "numbers.h", "symbols.h",
+ "boolean.h", "strings.h", "vectors.h", "root.h", "ports.h", and
+ "async.h".
+ * alist.c: Get "eq.h", "list.h", "alist.h".
+ * append.c: Get "append.h", "list.h".
+ * arbiters.c: Get "arbiters.h", "smob.h".
+ * async.c: Get "async.h", "smob.h", "throw.h", "eval.h".
+ * boolean.c: Get "boolean.h".
+ * chars.c: Get "chars.h".
+ * continuations.c: Get "continuations.h", "dynwind.h", "debug.h",
+ "stackchk.h".
+ * debug.c: Get "debug.h", "feature.h", "read.h", "strports.h",
+ "continuations.h", "alist.h", "srcprop.h", "procprop.h", "smob.h",
+ "genio.h", "throw.h", "eval.h".
+ * dynwind.c: Get "dynwind.h", "alist.h", "eval.h".
+ * eq.c: Get "eq.h", "unif.h", "smob.h", "strorder.h",
+ "stackchk.h".
+ * error.c: Get "error.h", "throw.h", "genio.h", "pairs.h".
+ * eval.c: Get "eval.h", "stackchk.h", "srcprop.h", "debug.h",
+ "hashtab.h", "procprop.h", "markers.h", "smob.h", "throw.h",
+ "continuations.h", "eq.h", "sequences.h", "alist.h", "append.h",
+ "debug.h".
+ * fdsocket.c: Get "fdsocket.h", "unif.h", "filesys.h".
+ * feature.c: Get "feature.h".
+ * files.c: Get "files.h".
+ * filesys.c: Get "filesys.h", "smob.h", "genio.h".
+ * fports.c: Get "fports.h", "markers.h".
+ * gc.c: Get "async.h", "unif.h", "smob.h", "weaks.h",
+ "genio.h", "struct.h", "stackchk.h", "stime.h".
+ * gdbint.c: Get "gdbint.h", "chars.h", "eval.h", "print.h",
+ "read.h", "strports.h", "tag.h".
+ * genio.c: Get "genio.h", "chars.h".
+ * gsubr.c: Get "gsubr.h", "genio.h".
+ * hash.c: Get "hash.h", "chars.h".
+ * hashtab.c: Get "hashtab.h", "eval.h", "hash.h", "alist.h".
+ * init.c: Get everyone who has an scm_init_mumble function:
+ "weaks.h", "vports.h", "version.h", "vectors.h", "variable.h",
+ "unif.h", "throw.h", "tag.h", "symbols.h", "struct.h",
+ "strports.h", "strorder.h", "strop.h", "strings.h", "stime.h",
+ "stackchk.h", "srcprop.h", "socket.h", "simpos.h", "sequences.h",
+ "scmsigs.h", "read.h", "ramap.h", "procs.h", "procprop.h",
+ "print.h", "posix.h", "ports.h", "pairs.h", "options.h",
+ "objprop.h", "numbers.h", "mbstrings.h", "mallocs.h", "load.h",
+ "list.h", "kw.h", "ioext.h", "hashtab.h", "hash.h", "gsubr.h",
+ "gdbint.h", "gc.h", "fports.h", "filesys.h", "files.h",
+ "feature.h", "fdsocket.h", "eval.h", "error.h", "eq.h",
+ "dynwind.h", "debug.h", "continuations.h", "chars.h", "boolean.h",
+ "async.h", "arbiters.h", "append.h", "alist.h".
+ * ioext.c: Get "ioext.h", "fports.h".
+ * kw.c: Get "kw.h", "smob.h", "mbstrings.h", "genio.h".
+ * list.c: Get "list.h", "eq.h".
+ * load.c: Get "load.h", "eval.h", "read.h", "fports.h".
+ * mallocs.c: Get "smob.h", "genio.h".
+ * markers.c: Get "markers.h".
+ * mbstrings.c: Get "mbstrings.h", "read.h", "genio.h", "unif.h",
+ "chars.h".
+ * numbers.c: Get "unif.h", "genio.h".
+ * objprop.c: Get "objprop.h", "weaks.h", "alist.h", "hashtab.h".
+ * options.c: Get "options.h".
+ * ports.c: Get "ports.h", "vports.h", "strports.h", "fports.h",
+ "markers.h", "chars.h", "genio.h".
+ * posix.c: Get "posix.h", "sequences.h", "feature.h", "unif.h",
+ "read.h", "scmsigs.h", "genio.h", "fports.h".
+ * print.c: Get "print.h", "unif.h", "weaks.h", "read.h",
+ "procprop.h", "eval.h", "smob.h", "mbstrings.h", "genio.h",
+ "chars.h".
+ * procprop.c: Get "procprop.h", "eval.h", "alist.h".
+ * procs.c: Get "procs.h".
+ * ramap.c: Get "ramap.h", "feature.h", "eval.h", "eq.h",
+ "chars.h", "smob.h", "unif.h".
+ * read.c: Get "alist.h", "kw.h", "mbstrings.h", "unif.h",
+ "eval.h", "genio.h", "chars.h".
+ * root.c: Get "root.h", "stackchk.h".
+ * scmsigs.c: Get "scmsigs.h".
+ * sequences.c: Get "sequences.h".
+ * simpos.c: Get "simpos.h", "scmsigs.h".
+ * smob.c: Get "smob.h".
+ * socket.c: Get "socket.h", "feature.h".
+ * srcprop.c: Get "srcprop.h", "weaks.h", "hashtab.h", "debug.h",
+ "alist.h", "smob.h".
+ * stackchk.c: Get "stackchk.h", "genio.h".
+ * stime.c: Get "stime.h"."libguile/continuations.h".
+ * strings.c: Get "strings.h", "chars.h".
+ * strop.c: Get "strop.h", "chars.h".
+ * strorder.c: Get "strorder.h", "chars.h".
+ * strports.c: Get "strports.h", "print.h", "eval.h", "unif.h".
+ * struct.c: Get "struct.h", "chars.h".
+ * symbols.c: Get "symbols.h", "mbstrings.h", "alist.h",
+ "variable.h", "eval.h", "chars.h".
+ * tag.c: Get "tag.h", "struct.h", "chars.h".
+ * throw.c: Get "throw.h", "continuations.h", "debug.h",
+ "dynwind.h", "eval.h", "alist.h", "smob.h", "genio.h".
+ * unif.c: Get "unif.h", "feature.h", "strop.h", "sequences.h",
+ "smob.h", "genio.h", "eval.h", "chars.h".
+ * variable.c: Get "variable.h", "smob.h", "genio.h".
+ * vectors.c: Get "vectors.h", "eq.h".
+ * version.c: Get "version.h".
+ * vports.c: Get "vports.h", "fports.h", "chars.h", "eval.h".
+ * weaks.c: Get "weaks.h".
+
+ * stackchk.h: #include "libguile/debug.h",
+
+ * print.h, read.h: #include "options.h", since everyone who uses
+ either of these files will need that.
+
+ * smob.h: #include "ports.h", "genio.h", and "print.h", since
+ anyone who uses this file will need them to define the smob
+ printing functions. Also, get markers.h, since people will need
+ to #define the mark functions.
+
+ * smob.h (scm_ptobfuns, SCM_PTOBNUM): Definitions moved...
+ * ports.h: ... to here.
+
+ * ports.h (scm_port_table_size): Explicitly give type as 'int';
+ don't rely on archaic C default type rules.
+
+ * fports.h: #include "libguile/ports.h", since you need that in
+ order to parse this.
+
+ * genio.h: #include "libguile/print.h", because you need that to
+ parse this; don't bother #including "ports.h", since print.h gets
+ that.
+
+ * error.h: Don't #include "pairs.h"; _scm.h will do that now.
+
+ * eval.h (scm_top_level_lookup_thunk_var): Remove declaration for
+ this; it's now a reference to an element of *scm_root.
+
+ * debug.h: Don't #include "options.h"; the compiler won't be able
+ to find that once the headers are installed; instead, #include
+ "libguile/options.h".
+ * gc.h: Same, with marksweep.h.
+ * mbstrings.h: Same, with symbols.h.
+ * scmhob.h: Same, with _scm.h.
+ * smob.h: Same, with params.h.
+
+ * Makefile.in (depends): Don't nuke scmconfig.h and the generated
+ C files; there's no need for this, and it forces recompilations
+ unnecessarily.
+
+Sat Sep 7 06:57:23 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c (scm_error): declare scm_error_callback.
+
+ * error.h: prototype for scm_error_callback.
+
+ * __scm.h: define lgh_error.
+ (SCM_SYSERROR): redefine using lgh_error.
+
+Thu Sep 5 22:40:06 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c (scm_error): new procedure.
+
+ * error.h: prototype for scm_error.
+
+ * Makefile.in (install): install scmconfig.h from the current
+ directory, not $(srcdir).
+
+Thu Sep 5 11:38:07 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * alist.h, append.h, arbiters.h, async.h, boolean.h, chars.h,
+ continuations.h, debug.h, dynwind.h, error.h, eval.h, fdsocket.h,
+ feature.h, filesys.h, fports.h, gc.h, gdbint.h, genio.h, gsubr.h,
+ hash.h, init.h, ioext.h, kw.h, list.h, markers.h, marksweep.h,
+ mbstrings.h, numbers.h, objprop.h, options.h, pairs.h, ports.h,
+ posix.h, print.h, procprop.h, procs.h, ramap.h, read.h, root.h,
+ sequences.h, smob.h, socket.h, srcprop.h, stackchk.h, stime.h,
+ strings.h, strop.h, strorder.h, strports.h, struct.h, symbols.h,
+ tag.h, throw.h, unif.h, variable.h, vectors.h, version.h,
+ vports.h, weaks.h: #include "libguile/__scm.h", not
+ <libguile/__scm.h>. This allows 'gcc -MM' to determine which
+ dependencies are within libguile properly.
+
+Thu Sep 5 11:38:07 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (.c.x): Simplify; there's no need to run this rule
+ when scmconfig.h doesn't exist.
+
+ * load.c (scm_sys_try_load): Correct spelling.
+
+ * feature.c (scm_loc_features): Make this static.
+
+ * Makefile.in (libpath.h): Omit trailing slash from path. We
+ shouldn't require it of users, so why put it here?
+
+ Move code to initialize and search %load-path from ice-9 to C
+ code, so we can use the load-path to find the ice-9 boot code;
+ this makes it easier to run Guile without installing it. See
+ corresponding changes in guile/Makefile.in.
+ * feature.c: Move stuff concerned with the load path to load.c.
+ (scm_compiled_library_path): Deleted.
+ Don't #include libpath.h here.
+ * feature.h: Don't mention scm_compiled_library_path.
+ * load.c: #include "libpath.h" here, as well as <sys/types.h>,
+ <sys/stat.h>, and <unistd.h> (if present).
+ (R_OK): #define if the system hasn't deigned to.
+ (scm_loc_load_path): New variable.
+ (scm_init_load_path, scm_sys_search_load_path,
+ scm_sys_try_load_path): New functions.
+ (scm_init_load): Initialize scm_loc_load_path to point to the
+ value cell of the Scheme %load-path variable.
+ * load.h: Add declarations for scm_sys_search_load_path,
+ scm_sys_try_load_path.
+ * init.c: Call scm_init_load_path.
+ * Makefile.in (feature.o, load.o): Dependencies updated.
+
+ * load.c, load.h: Rewrite using PROTO macro.
+
+Thu Sep 5 01:54:33 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * gc.c (scm_cellp): New function: C predicate to determine if an
+ SCM value can be regarded as a pointer to a cell on the heap.
+
+ * gc.h: Added declaration of scm_cellp.
+
+ * gdb_interface.h: New file: The GDB interface header from the GDB
+ distribution.
+
+ * gdbint.c: New file: GDB interface.
+
+ * gdbint.h: New file: GDB interface.
+
+ * libguile.h: Added #include <libguile/gdbint.h>.
+
+ * init.c (scm_boot_guile): Added scm_init_gdbint.
+
+ * Makefile.in: Added gdb_interface.h, gdbint.[hc].
+ Added -I.. to INCLUDE_CFLAGS (otherwise the include files won't be
+ found if object files and source are kept separate).
+
+Wed Sep 4 14:35:02 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * feature.h, feature.c: Use PROTO macro, instead of #if __STDC__.
+
+Wed Sep 4 01:30:47 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * configure.in: Don't substitute the values of TCL_SRC_DIR and
+ TK_SRC_DIR; they're not relevant any more.
+
+ * Makefile.in (CC): Don't list -Wall here; it's a GCC-specific flag.
+ * configure.in: Instead, put it in CFLAGS here, iff we're using GCC.
+
+Wed Sep 4 00:55:49 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * PLUGIN/guile.config (xtra_cflags): Include .. in the header
+ search path, so we can find the <libguile/MUMBLE.h> headers.
+
+ * Makefile.in (ancillary): List aclocal.m4, for 'make dist'.
+
+ * Makefile.in (ALL_CFLAGS): Don't mention CFLAGS here; it's
+ implicit in the .c.o rule.
+ (.c.x): Don't mention ALL_CFLAGS here; its value is included in
+ $(CC) already.
+
+ Put the library path in a header file, instead of passing it on
+ the command line in every compilation.
+ * Makefile.in (libpath.h): New target.
+ (feature.o): Depend on libpath.h.
+ (clean): Delete libpath.h.
+ (ALL_CFLAGS): Don't use -DLIBRARY_PATH here. Instead ...
+ * feature.c: ... #include "libpath.h" here.
+ * .cvsignore: Ignore libpath.h.
+
+ Don't install the unwashed masses of Guile header files in the
+ main #include path; put most of them in a subdirectory called
+ 'libguile'. This avoids naming conflicts between Guile header
+ files and system header files (of which there were a few).
+ * Makefile.in (pkgincludedir): Deleted.
+ (innerincludedir): New variable; this and $(includedir) are enough.
+ (INCLUDE_CFLAGS): Search for headers in "-I$(srcdir)/..".
+ (installed_h_files): Divide this up. Now this variable lists
+ those header files which should go into $(includedir) (i.e. appear
+ directly in the #include path), and ...
+ (inner_h_files): ... this new variable says which files appear in
+ a subdirectory, and are referred to as <libguile/mumble.h>.
+ (h_files): List them both.
+ (install): Create innerincludedir, not pkgincludedir. Put
+ the installed_h_files and inner_h_files in their proper places.
+ (uninstall): Corresponding changes.
+ * alist.h, append.h, arbiters.h, async.h, boolean.h, chars.h,
+ continuations.h, debug.h, dynwind.h, error.h, eval.h, fdsocket.h,
+ feature.h, fports.h, gc.h, genio.h, gsubr.h, hash.h, init.h,
+ ioext.h, kw.h, libguile.h, list.h, markers.h, marksweep.h,
+ mbstrings.h, numbers.h, options.h, pairs.h, ports.h, posix.h,
+ print.h, procprop.h, procs.h, ramap.h, read.h, root.h,
+ sequences.h, smob.h, socket.h, srcprop.h, stackchk.h, stime.h,
+ strings.h, strop.h, strorder.h, strports.h, struct.h, symbols.h,
+ tag.h, throw.h, unif.h, variable.h, vectors.h, version.h,
+ vports.h, weaks.h: Find __scm.h in its new location.
+ * __scm.h: Find scmconfig.h and tags.h in their new locations
+ (they're both "inner" files).
+
+Tue Sep 3 20:27:35 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (.c.x): Remove duplicate use of $(ALL_CFLAGS).
+
+Tue Sep 3 19:53:00 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * posix.c: Doc fixes.
+
+Mon Sep 2 15:22:40 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Don't include a prototype for inet_aton; just use a
+ K&R style declaration, to avoid warnings but minimize the chance
+ of conflicts with the system.
+
+ On NextStep, <utime.h> doesn't define struct utime, unless we
+ #define _POSIX_SOURCE before #including it.
+ * aclocal.m4 (GUILE_STRUCT_UTIMBUF): New test.
+ * acconfig.h: New comment text for above CPP symbol.
+ * configure.in: Call it.
+ * posix.c: #define _POSIX_SOURCE if it seems necessary.
+
+ * configure.in (AC_CHECK_HEADERS): Include sys/utime.h and utime.h
+ in the list.
+ * posix.c: Check HAVE_SYS_UTIME_H and HAVE_UTIME_H, instead of
+ testing for __EMX__.
+
+ * posix.c: #include <libc.h>, if it exists.
+
+ * posix.c: Cast the return result to GETGROUPS_T, not gid_t; we
+ don't even know if the latter exists.
+
+ * posix.c (s_sys_setpgid, s_sys_setsid, s_sys_ctermid,
+ s_sys_tcgetpgrp, s_sys_tcsetpgrp): Renamed from s_setpgid,
+ s_setsid, s_ctermid, s_tcgetpgrp, s_tcsetpgrp, for consistency.
+
+ * posix.c (R_OK, W_OK, X_OK, F_OK): #define these if the system's
+ header files don't.
+ (scm_init_posix): Use them when initializing the Scheme constants
+ of the same name.
+
+Fri Aug 30 16:01:30 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (libdir, includedir, bindir): Use the
+ autoconf-supplied values, instead of deriving them ourselves.
+ (pkgincludedir, datadir, pkgdatadir): New variables.
+ (install, uninstall): Put the header files in a special
+ subdirectory, not in the main search path.
+
+ * Makefile.in (ALL_CFLAGS): Provide the proper value for
+ LIBRARY_PATH --- use $(pkgdatadir) instead of $(libdir).
+
+ * Makefile.in (IMPLPATH): Deleted; never used.
+
+ * Makefile.in (TCL_SRC_DIR, TK_SRC_DIR): Deleted; we don't depend
+ on the Tcl/Tk source any more.
+ (INCLUDE_CFLAGS): Remove references to the above.
+
+ * Makefile.in (version.o): Corrected dependencies.
+
+Thu Aug 29 23:06:19 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu>
+
+ * libguile.h: #include "version.h"
+
+ * init.c (scm_boot_guile): Call scm_init_version.
+ * gscm.c (gscm_run_scm): Call scm_init_version.
+
+ * configure.in (GUILE_MAJOR_VERSION, GUILE_MINOR_VERSION,
+ GUILE_VERSION): AC_DEFINE these.
+ (acconfig.h): #undef the above symbols.
+
+ * Makefile.in (libobjs): Add version.o.
+ (installed_h_files): Add version.h.
+ (c_files): Add version.c.
+ (gen_c_files): Add version.x.
+ (version.o): New rule.
+ (alist.o, append.o, appinit.o, arbiters.o, async.o, boolean.o,
+ chars.o, continuations.o, dynwind.o, eq.o, error.o, eval.o,
+ fdsocket.o, feature.o, files.o, filesys.o, fports.o, gc.o,
+ genio.o, gsubr.o, hash.o, hashtab.o, init.o, kw.o, list.o, load.o,
+ mallocs.o, markers.o, marksweep.o, mbstrings.o, numbers.o,
+ objprop.o, pairs.o, ports.o, posix.o, print.o, procprop.o,
+ procs.o, ramap.o, read.o, root.o, scmsigs.o, sequences.o,
+ simpos.o, smob.o, socket.o, stackchk.o, stime.o, strings.o,
+ strop.o, strorder.o, strports.o, struct.o, symbols.o, tag.o,
+ throw.o, unif.o, variable.o, vectors.o, version.o, vports.o,
+ weaks.o): Add version.h to dependency lists.
+ (markers.o): Remove duplicate rule.
+
+ * version.h: New file.
+
+ * version.c: New file.
+
+Thu Aug 29 15:21:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * symbols.c (scm_strhash): scm_downcase is now a function, not an
+ array; use it appropriately. Since GCC is quite happy to
+ subscript functions, it never warned us about this; we should use
+ -Wpointer-arith in the future. I guess we never tested
+ case-insensitivity.
+
+Wed Aug 28 18:52:22 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Doc and copyright fixes.
+
+Sat Aug 24 05:29:19 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c: Fixed and improved gdb support.
+
+Fri Aug 23 18:00:16 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * socket.c: Added declaration of inet_aton to avoid compiler
+ warning. (Hope this solution is correct.)
+
+ * stime.c: Added declaration of ftime. (This is missing in
+ Solaris 2 headers.)
+
+Fri Aug 23 02:03:32 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure, scmconfig.h.in: Updated, using autoconf and autoheader.
+
+ * Makefile.in (c_files): add strerror.c.
+
+ * strerror.c: new file from Emacs' sysdep.c.
+ maybe configure should also check for sys_errlist.
+
+ * configure.in (AC_REPLACE_FUNCS): add strerror.
+
+Fri Aug 23 03:02:46 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c (scm_init_debug): Added initialization for
+ scm_evaluator_traps.
+
+ * debug.h, debug.c: Various name changes.
+ (Mostly prefixing with SCM_.) Renamed "debug-options" -->
+ "debug-options-interface". See commentary in options.c.
+
+ * options.h, options.c: Options now have documentation strings.
+ Also added a long explanatory commentary.
+
+ * eval.c, print.h, print.c, read.h, read.c: Modifications to
+ run-time options.
+
+ * gscm.c, init.c, root.c, throw.c: Bug fixes:
+ last_debug_info_frame is now updated in all cases.
+
+ * __scm.h, stackchk.h, stackchk.c: Guile now performs stack
+ checking.
+
+Thu Aug 22 17:34:17 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * __scm.h: SCM_STACK_LIMIT removed (now a run-time option).
+ Added option STACK_CHECKING.
+
+Tue Aug 20 18:48:40 1996 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.in: Added {debug,options,srcprop}.{h,c}
+
+ * __scm.h: Removed symbols for debugging support.
+
+ * acconfig.h: Added symbols for debugging support.
+
+ * configure.in: Added user option for debugging support.
+ --enable-debug will include the debugging code into libguile.a.
+
+ * continuations.c (scm_make_cont): Enlarged the #if 0 around
+ scm_relocate_chunk_to_heap.
+
+ * debug.c: New file: low-level debugging support. It also
+ includes support for debugging with gdb. (The extensions to gdb
+ are written by Per Bothner at Cygnus.)
+
+ * debug.h: New file: low-level debugging support.
+
+ * eval.c: scm_m_set and SCM_IM_SET no longer supports multiple
+ argument pairs. Extensive modifications to the debugging
+ evaluator. Added "SECTION:" commentaries to clarify what happens
+ when, during double compilation. Renamed EVALIMP --> EVALIM.
+ Renamed EVAL --> XEVAL. Removed function evalcar. Defined
+ evalcar to scm_eval_car. Added explanation of "EVAL" symbols to
+ the beginning of the file. New procedure: scm_unmemocopy.
+ Added some global state variables needed by the debugging
+ evaluator: scm_ceval_ptr, last_debug_info_frame, debug_mode,
+ check_entry, check_apply, check_exit, debug_options and
+ evaluator_traps. New acro: undefine.
+
+ * eval.h: Renamed EVAL --> XEVAL.
+
+ * gc.c (scm_init_storage): Renamed scm_make_weak_hash_table
+ --> scm_make_weak_key_hash_table.
+
+ * init.c (scm_restart_stack, scm_boot_guile): Added initialization
+ of SCM_DFRAME. Added calls to scm_init_{debug,options,srcprop}.
+
+ * libguile.h: Conditionally include debug.h
+
+ * objprop.c (scm_object_properties, scm_set_object_properties_x):
+ scm_object_properties shouldn't return handle. `handle' now gets
+ initialized in scm_set_object_properties_x. scm_object_properties
+ doesn't any longer create an entry in scm_object_whash.
+
+ * options.c: New file: handling of run time options.
+
+ * options.h: New file: handling of run time options.
+
+ * posix.c (scm_getpgrp): Cast pointer to getpgrp.
+
+ * print.c: New procedure: scm_print_options
+
+ * print.h: Defines for print options.
+
+ * read.c: New procedure: scm_read_options
+
+ * read.h: Defines for reader options.
+
+ * root.h: Added scm_source_whash among scm_sys_protects.
+
+ * srcprop.c: New file: source properties.
+
+ * srcprop.h: New file: source properties.
+
+ * throw.c (jbsmob): Jump buffers are now correctly allocated.
+ (Bug found by A. Green.)
+
+ * weak.c: Renamed scm_weak_hash_table --> scm_weak_key_hash_table.
+
+ * weak.h: Renamed scm_weak_hash_table --> scm_weak_key_hash_table.
+
+Thu Aug 15 02:05:14 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * libguile.h: #include "objprop.h"; I guess this was forgotten.
+
+ * init.c (scm_boot_guile): Don't call scm_init_rgx; it's a plugin,
+ and should be called by the final client.
+
+Wed Aug 14 21:41:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * gc.h: Use the PROTO macro when declaring functions.
+ * gc.c: Use the PROTO macro when declaring static functions.
+ Remove the CPP hair around function definitions.
+
+ * gc.c (scm_init_storage): Initialize scm_asyncs.
+
+ * libguile.h: #include "__scm.h" before testing the STDC_HEADERS
+ preprocessor symbol; "__scm.h" is where it might get #defined.
+ * __scm.h: Similar: #include <scmconfig.h> before testing
+ HAVE_LIMITS_H.
+
+ * __scm.h: It's HAVE_LIMITS_H, not HAVE_LIMITSH.
+
+Fri Aug 9 11:09:28 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * init.c (scm_boot_guile): Add init_func argument; call
+ (*init_func) instead of calling scm_appinit; it's ucky to
+ hard-code names for the user's procedures.
+ * init.h (scm_boot_guile): Adjust declaration.
+
+ * __scm.h (PROTO): New macro, for declaring functions with
+ prototypes.
+
+ * init.h (scm_start_stack, scm_restart_stack): Use PROTO;
+ eliminate all the __STDC__ conditionals.
+ (scm_boot_guile): Add declaration.
+ * init.c (scm_start_stack, scm_restart_stack, scm_boot_guile):
+ Remove __STDC__ conditionals around function definitions; the
+ declarations in init.h will provide the same information, more
+ usefully.
+
+ * __scm.h (SCM_SYSMISSING): When we don't have ENOSYS, don't
+ complain about it in the error message; the error message is
+ adequate without that note, and there's nothing the user can do
+ about it.
+
+Wed Aug 7 14:14:46 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in (ancillary): Drop def.sed.
+
+ * posix.c (scm_init_posix): Use numeric values, rather than
+ CPP symbols, when defining the scheme values R_OK, W_OK, X_OK, and
+ F_OK. The symbols aren't available on some systems, and I'm
+ pretty sure their values are fixed by common widespread practice.
+ * ioext.c (scm_init_ioext): Code here defined them too; remove it.
+
+ More functions unavailable on some systems.
+ * configure.in (AC_CHECK_FUNCS): Add ctermid, setpgid, setsid,
+ tcgetpgrp, tcsetpgrp, and waitpid to the list of functions to
+ check for.
+ * configure, scmconfig.h.in: Updated, using autoconf and autoheader.
+ * posix.c (scm_sys_ctermid, scm_sys_setpgid, scm_sys_setsid,
+ scm_sys_tcgetpgrp, scm_sys_tcsetpgrp, scm_sys_waitpid): Put the
+ bodies of these functions in "#ifdef HAVE_MUMBLE" clauses, with a
+ stub that signals an error as the #else.
+
+ * Makefile.in (ancillary): Drop acconfig-1.5.h; add acconfig.h.
+
+Wed Aug 7 06:28:42 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Fixes motivated by Petr Adamek <adamek@mit.edu>:
+
+ * unif.c: include ramap.h.
+
+ * read.c (endif): case_insensative_p renamed case_insensitive_p.
+
+ * ramap.h: rename scm_array_copy prototypes to scm_array_copy_x.
+
+ * ports.c: include sys/ioctl.h.
+
+ * scmconfig.h.in: add HAVE_SYS_IOCTL_H.
+
+ * configure.in: check for sys/ioctl.h.
+
+ * ports.c: include <malloc.h> not "malloc.h".
+
+ * mallocs.c: include <malloc.h> not "malloc.h", likewise for unistd.h.
+
+ * fports.c: remove ttyname and tmpnam declarations.
+
+ * posix.c: fewer ttyname declarations.
+
+ * fports.c: include <string.h> not "string.h".
+
+ * init.c, ioext.c: include string.h and unistd.h.
+
+ * gc.c: include <malloc.h> not "malloc.h", likewise for unistd.h.
+
+ * async.c, strings.h, strports.c, struct.c, symbols.c, feature.c,
+ genio.c, simpos.c, vports.c: include string.h.
+
+ * socket.c, fdsocket.c: include string.h only if HAVE_STRING_H.
+
+ * fdsocket.c (getsockopt, setsockopt): change type of optlen from
+ scm_sizet to int.
+ (scm_addr_buffer_size): change type from scm_sizet to int.
+ (accept, getsockname, getpeername, recvfrom): change type of tmp_size
+ from scm_sizet to int.
+
+ * error.c: include unistd.h.
+
+ * __scm.h: (SCM_SYSMISSING): another version in case ENOSYS isn't
+ defined.
+
+ * Makefile.in: remove references to .hd, .cd suffix and __scm.hd.
+
+ * __scm.hd, def.sed: deleted.
+
+Tue Aug 6 14:49:08 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Changes for NeXT, suggested by Robert Brown.
+ * configure.in: Call AC_TYPE_MODE_T.
+ (AC_CHECK_HEADERS): Add libc.h, to get more prototypes on the
+ NeXT. Put header file list in alphabetical order.
+ * configure, scmconfig.h.in: Regenerated.
+ * filesys.c [HAVE_LIBC_H]: #include <libc.h>.
+
+ * filesys.c [HAVE_STRING_H]: #include <string.h>, to get prototype
+ for strerror.
+
+ * acconfig.h: New file, providing documentation for the CPP
+ symbols defined in configure.in
+ * acconfig-1.5.h: Removed; superceded by the above.
+
+Sat Aug 3 01:27:14 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_sys_fdopen): fix the port-table assignment.
+
+ * fports.c (scm_open_file): don't return #f, throw error.
+
+ * ioext.c (fileno): renamed from %fileno.
+ (soft-fileno): deleted.
+
+ * ports.c (scm_port_revealed): don't need to check for -1 from
+ scm_revealed_count.
+ (scm_set_port_revealed_x): return unspecified, not #f.
+
+ * ioext.c (primitive-move->fdes): return #t or #f, not 1 or 0.
+
+ * fdsocket.c: getsockopt, setsockopt: use HAVE_STRUCT_LINGER.
+
+ * scmconfig.h.in: add HAVE_STRUCT_LINGER.
+
+ * configure.in: check for struct linger, set HAVE_STRUCT_LINGER.
+
+Thu Aug 1 02:58:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * filesys.c, posix.c: #include <sys/types.h> before <sys/stat.h>.
+ This is necessary on Ultrix, and doesn't hurt portability.
+
+ * Makefile.in (dist-dir): New target, implementing a new dist system.
+ (installed_h_files): Put in alphabetical order.
+ Remove duplicate entries for markers.h and unif.h.
+ (c_files): Remove duplicate entries for markers.c.
+ (ancillary): Renamed from anillery; all uses changed. Remove
+ PLUGIN; it's a directory, and needs special treatment in dist-dir.
+ Remove all the ../doc/* files; doc/Makefile.in handles that.
+
+ * Makefile.in (libobjs): Remove duplicate entry for markers.o.
+
+ * Makefile.in (.c.x): Compensate for Ultrix's broken Bourne shell:
+ every if must have an else, or else the whole command has a
+ non-zero exit code whenever the if's condition is false.
+
+Thu Aug 1 08:22:24 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c: include string.h.
+
+Wed Jul 31 23:43:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * numbers.c: rename %expt -> $expt, %atan2 -> $atan2, as it must
+ have been once.
+
+ * posix.c, ioext.c, socket.c, fdsocket.c, files.c, filesys.c, simpos.c:
+ Remove leading % from scheme names.
+ Do not return error values, call SCM_SYSERROR or similar.
+
+ * __scm.h (SCM_SYSERROR, SCM_SYSMISSING): new macros.
+
Wed Jun 12 00:28:31 1996 Tom Lord <lord@beehive>
* struct.c (scm_init_struct): new file.
@@ -458,9 +3632,9 @@ Sat Jan 20 23:21:37 1996 Tom Lord <lord@beehive>
Wed Dec 6 02:40:49 1995 Tom Lord <lord@beehive>
- * ports.h fports.c vports.c marksweep.c gc.c strports.c: moved the STREAM
- of ports into the port table and replaced it with a port-table
- index.
+ * ports.h fports.c vports.c marksweep.c gc.c strports.c: moved the
+ STREAM of ports into the port table and replaced it with a
+ port-table index.
* repl.c (iprin1): added tc7_mb_string -- same as tc7_string.
@@ -471,14 +3645,12 @@ Wed Dec 6 02:40:49 1995 Tom Lord <lord@beehive>
* tags.h (scm_typ7_string, scm_typ7_mb_string): added a tag
for multi-byte strings. Moved the string tag.
- * chars.h chars.c repl.c (many functions): made scm_upcase and scm_downcase
- functions that are safe for extended character sets.
+ * chars.h chars.c repl.c (many functions): made scm_upcase and
+ scm_downcase functions that are safe for extended character sets.
Changed the range of integer->char.
- Changed the tyep of SCM_ICHR.
-
-
+ Changed the type of SCM_ICHR.
Tue May 16 17:49:58 1995 Mikael Djurfeldt <mdj@sanscalc.nada.kth.se>
diff --git a/libguile/ChangeLog-gh b/libguile/ChangeLog-gh
new file mode 100644
index 000000000..52dbc58e4
--- /dev/null
+++ b/libguile/ChangeLog-gh
@@ -0,0 +1,256 @@
+The gh implementation (gh_data.c, gh.h, etc.) used to live in a
+separate directory called gh. In April 1997, that dir was merged with
+libguile; this is the ChangeLog from the old directory.
+
+Please put new entries in the ordinary ChangeLog.
+
+Thu Apr 10 16:14:43 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Let the test programs build even when we're not using threads.
+ * configure.in: Use CY_AC_WITH_THREADS to decide whether to build
+ with threads.
+ * Makefile.am (check_PROGRAMS_LDADD): Remove -lthreads -lqt. The
+ configure script will stick them in LIBS if they're needed.
+ * Makefile.in, aclocal.m4, configure: Rebuilt.
+
+ * gh_funcs.c (gh_apply, gh_call0, gh_call1, gh_call2, gh_call3):
+ New functions.
+ * gh.h: Prototypes for above.
+ * gh_test_c.c (main_prog): Added test cases for above.
+
+ * gh.h (gh_display, gh_newline): Added prototypes.
+
+ * gh_test_c.c (main_prog): Remove bizarre single quote from test
+ of gh_symbol2scm, and from "test" of (display "hello world").
+
+ * gh.c: Removed; its guts have been redistributed to the other
+ gh-mumble.c files.
+
+ * gh.c, gh_data.c, gh_eval.c, gh_funcs.c, gh_init.c, gh_io.c,
+ gh_list.c, gh_predicates.c, gh_test_c.c, gh_test_repl.c:
+ Re-indented, according to the GNU coding standards. (Put function
+ names at beginning of lines, basically.)
+
+Wed Apr 9 17:56:34 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Changes to work with automake-1.1n, which has better libtool support.
+ * Makefile.am: Use lib_LTLIBRARIES, not lib_PROGRAMS.
+ * Makefile.in: Regenerated.
+
+Sat Mar 8 06:37:23 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * gh_eval.c (gh_eval_file): remove case_i, sharp arguments from
+ scm_primitive_load call.
+
+Mon Feb 24 21:45:32 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Wed Feb 12 16:34:42 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_data.c (gh_symbol2newstr): added this conversion from SCM
+ symbol to C string.
+ (gh_set_substr): more data conversion: from part of a (possibly
+ large) C string to an existing SCM string.
+ (gh_get_substr): more data conversion: from part of a (possibly
+ large) SCM string to an existing C char array.
+
+Mon Feb 10 14:03:09 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_funcs.c (gh_define): added this function.
+
+ * gh_init.c (gh_catch): fixed stupid bug, gh_catch() was not
+ returning anything.
+
+ * gh_data.c (gh_scm2newstr): Renamed gh_scm2str0() to
+ gh_scm2newstr(), and did away with the str0 convention (it doesn't
+ seem to belong in gh_).
+ (gh_scm2str): this function now copies Scheme data to a
+ pre-allocated C string.
+
+Fri Feb 7 15:12:30 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_data.c (gh_scm2str0): On Sascha Ziemann and Jim Blandy's
+ suggestion I changed gh_scm2str0() so that it returns a malloc-ed
+ string, rather than taking a pre-allocated string with a maximum
+ length...
+
+Fri Jan 24 08:18:28 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_eval.c (gh_eval_str): gh_eval_str() now returns an SCM object
+ with the result of the evaluation. It has also been simplified to
+ just call scm_eval_0str(). gh_eval_file() has been similarly
+ altered.
+
+Sat Jan 11 14:40:17 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * ltconfig, ltmain.sh: New files for libtool support. libguile,
+ rx, gh and gtcltk-lib can now be build as shared libraries.
+ * Makefile.am (EXTRA_DIST): Added ltconfig and ltmain.sh
+
+Sun Jan 5 16:57:10 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Guile 1.0 released. This is the first release by the Free
+ Software Foundation; Cygnus has also released earlier versions of
+ Guile.
+
+ * GUILE-VERSION: Updated version number.
+ * NEWS: Added comments for all the user-visible changes marked in
+ the ChangeLogs.
+ * README: Updated for release.
+
+Thu Dec 12 00:14:32 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scsh: new directory.
+
+Mon Dec 2 17:33:04 1996 Tom Tromey <tromey@cygnus.com>
+
+ * configure.in: Generate doc/guile-programmer/Makefile and
+ doc/guile-user/Makefile.
+
+Sat Nov 30 23:45:54 1996 Tom Tromey <tromey@cygnus.com>
+
+ * aclocal.m4: Now automatically generated by aclocal.
+ * threads.m4: New file.
+ * guile.m4: New file.
+ * Makefile.am, doc/Makefile.am: New files.
+ * configure.in: Updated for Automake. Avoid excessively verbose
+ "greet" messages.
+
+Wed Oct 16 07:32:14 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * lgh: directory renamed to gh, along with all prefixes of the
+ high level library procedures.
+
+Thu Oct 10 14:37:43 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS tags): Find the source files in $srcdir.
+
+Wed Oct 9 19:37:14 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (DISTFILES): Add AUTHORS and aclocal.m4.
+
+Tue Oct 1 00:13:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * configure.in: Added some configuration magic from the Cygnus
+ distribution.
+
+ * aclocal.m4: New file. For now used for thread support
+ configuration.
+
+Fri Sep 13 14:39:30 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * Makefile.in (DISTFILES): added mkinstalldirs to the DISTFILES
+
+ * PLUGIN: changed the PLUGIN/REQ files in the ice-9 and lgh
+ directories, to arrange for lgh to the last thing
+ configured/built.
+
+Wed Sep 11 21:11:33 1996 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * lgh/: added the directory in which I implement the high level
+ libguile library (lgh_) for this release of Guile. See the
+ ChangeLog in there for further details.
+
+Wed Sep 11 16:12:53 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * doc/ (guile-user and guile-programmer): added the guile-user and
+ guile-programmer directories which contain the user and programmer
+ manuals. See the ChangeLog entries there for detail.
+
+Wed Sep 11 14:33:49 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (distclean): Don't forget to delete doc/Makefile.
+
+ * Makefile.in (distclean): Don't forget to delete
+ config.build-subdirs.
+
+Thu Sep 5 17:36:15 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (tags): New name for `TAGS' target, which will
+ always run the commands.
+
+Thu Sep 5 09:56:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Doc fixes.
+
+Fri Aug 30 16:56:27 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS): Produce a single tags file for all of Guile.
+
+Thu Aug 15 19:03:03 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Check for -ldl, so the check for Tcl won't fail
+ spuriously.
+
+Thu Aug 15 01:29:29 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Change the way we decide whether to build gtcltk-lib, so that it's
+ omitted from the build process when appropriate, but never from
+ the dist process.
+ * configure.in: Don't edit all_subdirs depending on the
+ availability of Tk; let that be the list of all PLUGIN
+ subdirectories present, as it used to be. Instead, edit a new
+ variable, build_subdirs; write its final value, the list of
+ subdirs we do want to compile in, to config.build-subdirs.
+ Substitute that into the top-level Makefile too.
+ * Makefile.in (subdirs): Set this to @build_subdirs@, so we only
+ recurse on the subdirectories we should build.
+ (distdirs): Set this to @existingdirs@, so it includes the subdirs
+ we decided not to build.
+
+ * doc/gtcltk.texi: File resurrected from old Guile releases.
+ * doc/Makefile.in (info): Build the gtcltk documentation.
+ (DIST_FILES): Include it in the distribution.
+
+ * configure.in: If we can find the library for tcl7.5, build
+ gtcltk-lib. Call AC_PROG_CC, to help run that test with the right
+ compiler (not sure this is necessary).
+
+Mon Aug 12 15:09:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * NEWS: Fix bug reporting address.
+
+Fri Aug 9 15:58:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * AUTHORS: New file, in accordance with the GNU maintainers'
+ standards.
+
+Tue Aug 6 14:40:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Renamed from ANNOUNCE; include bug report address,
+ description, and short tour.
+ * INSTALL: Renamed from BUILDING.
+ * NEWS: New file.
+ * Makefile.in (DISTFILES): Update appropriately.
+
+Thu Aug 1 02:31:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * doc/Makefile.in: Added pattern targets for creating DVI and
+ PostScript files.
+ (%.ps, %.dvi, %.txt): New targets.
+ (DVIPS, TEXI2DVI): New variables.
+
+ * GUILE-VERSION: Updated to 1.0b3.
+
+ Rehashed distribution system, in preparation for nightly
+ snapshots. Other changes in subdirectories.
+ * Makefile.in (dist): Rewritten --- the old target was out of
+ date, dependent on files that we don't have, and relied on GNU
+ tar. The new target is simpler.
+ (VERSION, srcdir, dist_dirs): New variables.
+ (DISTFILES): Renamed from localfiles. Added GUILE-VERSION and
+ TODO.
+ (localtreats): Variable removed. We don't have this file.
+ (info): cd to doc and make info there; don't make info in every
+ ${subdir}; those Makefiles don't know what to do.
+ (distname, distdir, treats, announcefile): Variables removed.
+ (manifest-file): Target removed.
+ (dist-dir): New target, responsible for distributable files in
+ this directory.
+ (GZIP, GZIP_EXT, TAR_VERBOSE, DIST_NAME): New variables,
+ controlling the 'dist' target.
+ * configure.in: Substitute GUILE-VERSION into the top-level
+ Makefile. Build doc/Makefile from doc/Makefile.in.
+
+ * doc/Makefile.in: New file.
diff --git a/libguile/ChangeLog-scm b/libguile/ChangeLog-scm
new file mode 100644
index 000000000..0ba497ed7
--- /dev/null
+++ b/libguile/ChangeLog-scm
@@ -0,0 +1,2610 @@
+Wed Apr 5 14:32:51 1995 Gary Houston <ghouston@actrix.gen.nz>
+
+ * unix.c, ioext.c, posix.c, sys.c: Scheme name changes,
+ semantic cleanups, the port table, missing system calls
+ and coding cleanups from ghouston@actrix.gen.nz
+
+Thu Mar 16 14:37:38 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * guile.c: fixed the gcc-specific definition of the macro "AT(x)".
+
+ * guile.c (gscm_init_from_fn): Parameterize what init functions
+ get called (see guile_ks, below).
+
+ * guile-mini.c (guile_mini): a minimalist alternative to guile_ks.
+
+ * guile-ks.c (guile_ks): factor out the call to optional inits to
+ a separate file so you can link against libguile without getting
+ the kitchen sink.
+
+ * Ginit.scm (try-load of "ScmInit.scm"): Be robust in the absense
+ of a binding for the environment varialbe HOME. Try
+ (getpw (geteuid)) or just use "/".
+
+
+Thu Mar 9 15:35:20 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * gmain.c (main): Print additional error message if init file
+ can't be opened.
+
+ * guile.c (initialize_gscm): Report an error if the
+ init file can't be opened.
+
+Thu Mar 23 23:22:59 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (I/O-Extensions): Finished.
+
+ * Init.scm (scm:load): `loading' messages now indented.
+
+Sat Mar 4 20:58:51 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi: documentation finished for "posix.c" and "unix.c".
+
+ * posix.c (scm_getgroups): added.
+
+ * posix.c (makfrom0str): According to glibc.info, some field in
+ structures like pwent may have NULL pointers. Changed makfrom0str
+ to return BOOL_F in this case.
+
+Thu Mar 2 12:52:25 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c: CLKTCK set from CLOCKS_PER_SEC, if available. Metaware
+ HighC ported.
+
+ * scm.h: USE_ANSI_PROTOTYPES now controls prototypes (was
+ __STDC__). This allows an overly fussy compiler to still have
+ __STDC__.
+
+ From: dorai@ses.com (Dorai Sitaram)
+ * ioext.c (l_utime): include files fixed for __EMX__
+
+Sun Feb 26 23:46:18 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * repl.c (scm_app_wdr): Like scm_apply, but takes an error function.
+ The caller's continuation is never captured or escaped.
+ The error function is invoked as with scm_cwdr.
+
+Sun Feb 26 21:03:04 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (gc_mark gc_sweep): tc7_ssymbol now gets GCed because it
+ gets used for non-GCed strings in scm_evalstr scm_loadstr.
+ (mkstrport cwos cwis): changed so caller's name is passed into
+ mkstrport().
+
+ * repl.c
+ (scm_eval_string scm_evalstr scm_load_string scm_loadstr): added
+ for easier C to scheme callbacks.
+ (loadport): variable added so lreadr() and flush_ws()
+ increment linum only when reading from the correct port.
+ (def_err_response): now handles ARGn for argument numbers > 5 and
+ unknown position arguments.
+
+ * dynl.c: Dynamic Linking now sets and restores *load-pathname*
+ around the init_ call.
+
+Sat Feb 25 11:03:56 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (lsystem getenv softtype ed vms_debug): moved from scl.c.
+ (add_feature): moved from repl.c.
+ (features): init table removed (caused multiple symbols).
+
+Fri Feb 24 23:48:03 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (scm_init_extensions COMPILED_INITS): Added so that
+ statically linked, compiled code can be initialized *after* most
+ of Init.scm has loaded.
+
+Wed Feb 22 15:54:01 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (append): Added check for bad arguments and fixed errobj.
+
+Sun Feb 19 01:31:59 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (exec execp): changed so that 2nd arguments is argv[0]
+ (like posix) and renamed to execl and execlp.
+ (execv execvp): added.
+
+Sat Feb 11 17:30:14 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (lexec): moved from repl.c and scm.c.
+ (lexecp i_exec l_putenv): added.
+
+ * posix.c (open_pipe l_open_input_pipe l_open_output_pipe
+ prinpipe): moved from ioext.c.
+ (l_fork): added.
+
+Fri Feb 10 10:50:03 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c (num2long long2num): moved here from subr.c.
+ (num2ulong): fixed (< to >=) bug.
+
+ * unif.c (aset array2list array_ref cvref): uniform integers and
+ unsigned integer arrays now handle full size integers (and
+ inexacts) using num2long, num2ulong, long2num, and ulong2num when
+ INUMS_ONLY is not defined.
+
+ * scmfig.h (INUMS_ONLY): defined when INUMs are the only numbers.
+
+Wed Feb 8 17:57:26 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * Ginit.scm (stand-alone-repl): Use new function (rooted-repl)
+ (rooted-repl): new function
+
+Tue Jan 31 16:46:26 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * repl.c (lreadr): compare string constant names
+ in a case insensative way.
+
+ (scm_lread): Take an optional parameter CASEP.
+ If specified and not #f, then symbols are read
+ in a case sensative way.
+
+ If not specified, the state variable default_case_i is checked
+ (a C int, either 0 or 1). The state variable hasn't been
+ exposed and so is constant and depends on compile-time flags --
+ but in the future it might be made more explicit if there is a
+ need.
+
+Sun Jan 29 23:22:40 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Overview): scm.1 converted to texinfo format and
+ incorporated.
+
+Sat Jan 28 23:11:40 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * repl.c (compiled-library-path): return the value of the
+ compile-time cpp macro "LIBRARY_PATH" or #f.
+
+ * Ginit.scm: use the above path to find slib on unix.
+ This solution should be generalized.
+
+Fri Jan 27 19:58:27 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * sys.c (gc_sweep): Fixed a gc bug that caused circular free-lists
+ resulting in Cells that thought they were free long after they
+ were allocated for some nefarious purpose or other.
+
+ * Makefile.in (manifest): ship all pieces of the info manual.
+ Typos fixes from ghouston.
+
+Thu Jan 26 01:52:00 1995 Tom Lord <lord@x1.cygnus.com>
+
+ From: cessu@cs.hut.fi (Kenneth Oksanen)
+
+ * configure.in:
+ AC_CHECK_LIB(nsl, gethostent)
+ AC_CHECK_LIB(ucb, bzero)
+ AC_CHECK_LIB(socket, socket)
+ AC_CHECK_LIB(bsd, bzero)
+
+
+ From: brent@jade.ssd.csd.harris.com (Brent Benson)
+
+ * gmain.c: line 31: In ANSI C, string literals cannot span multiple
+ source lines.
+
+ * guile.c: line 592: The two cases in the ifdef are reversed, AT(X)
+ should expand to nothing if you are *not* using GNUC.
+
+ * ioext.c: line 29: On my system it is necessary to
+ include <unistd.h> *before* <sys/stat.h> in order to
+ have the correct types defined.
+
+ * ioext.c: line 194: Declaration of popen conflicts with my system's
+ popen() defined in <unistd.h>. Let the header file provide the
+ prototype!!
+
+Sun Jan 22 11:13:58 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Internals): code.doc converted to texinfo format.
+ Much added and reorganized. code.doc removed.
+
+Thu Jan 19 00:40:11 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (logbitp logtest): added.
+
+Mon Jan 16 01:42:20 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * repl.c (scm_repl): takes two arguments now (prompt and top-level).
+ Callable from Scheme.
+
+ * sys.c (scm_init_storage): only use stdin if scm_take_stdin is true.
+ Otherwise, use an empty string port. If using stdin, make it
+ unbuffered.
+
+Sun Jan 15 21:51:37 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * sys.c (scm_mkarray, scm_free_array, mark_arrays): support for
+ C programs. malloc/free style interface to allcoating
+ protected storage of type SCM*.
+
+Sun Jan 15 17:49:43 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * guile.c: new file. Friendly C interface for Guile.
+ (see file GUILE)
+
+ * repl.c (scm_cwdr): added call-with-dynamic-root (see scm.texi).
+
+Sat Jan 14 23:35:21 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * repl.c, subr.c: re-arrangement, commenting
+ of source in preparation for pulling repls apart
+ for libguile.
+
+Wed Jan 11 14:45:17 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c (num2ulong): checks for bignum sign and magnitude added.
+
+ * subr.c (logand logior logxor lognot): lognot restriction to
+ INUMs removed. Logand, logior, and logxor now will work for up to
+ 32 bit signed numbers.
+
+Tue Jan 10 13:19:52 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (def_err_response): Circuitous call to quit() replaced
+ with exit(EXIT_FAILURE);
+ (everr): Now calls def_err_response() in interrupt frame if
+ errjmp_bad or there are dynwinds to do. This prevents silent
+ failure in batch mode.
+
+
+Mon Jan 9 00:12:14 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (handle_it): Now discards possibly used top freelist cell
+ for GC safety. Also now just punts if errjmp_bad.
+
+ * scm.texi: converted from MANUAL. GUILE documentation merged in.
+
+Sat Jan 7 13:51:04 1995 Miles Bader (miles@eskimo.com)
+
+ * mrequire.scm: New file: Wrapper for slib require/provide that
+ makes it modular (that is, each slib package is loaded into its
+ own module, and sees only other modules that it requires).
+
+ * defmod.scm: Allow use-interface in the default module.
+
+ * libguile.scm: Put symbols common to both guile and scm
+ interfaces into the internal interface `EXTRA' (which is included
+ by both). Other random shuffling, mostly to make slib happy.
+
+ * modops.scm (extend-interface, export-interface, export): Add
+ another operation type, #f, which turns off automatic exporting of
+ the current source interface when finishing up with it. This is
+ used by export-interface to prevent trying to export all symbols.
+
+ * modops.scm (import): No longer signal an error when trying to
+ export a whole module, as we want to do this sometimes.
+
+ * Ginit.scm: No longer try to load require.scm, or depend on it;
+ In the case of getopt, we just load it manually. Also make
+ defmacro module-safe.
+
+Sat Jan 7 01:54:11 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * sys.c (scm_intern_obarray_soft): Reserve room for symbol slots.
+
+ * sys.c (scm_makstr, scm_makfromstr): added an extra parameter SLOTS.
+ The parameter means:
+ 0: same as the old behavior
+ 1: not useful
+ > 1: allocate SLOTS - 1 extra slots in the string storage.
+
+ The base address of SLOTS, an array of SCM, is at SLOTS(obj).
+ This is for symbol slots, and later for procedure slots.
+ If you use this in the constructor for your new type (usually
+ done by creating a string and then invoking SETLENGTH to change
+ its type), you are responsible for making sure slot contents
+ are properly gc'ed.
+
+ Callers of these were fixed as well.
+
+Tue Jan 3 14:30:34 1995 Miles Bader (miles@eskimo.com)
+
+ * modops.scm, extlibs.scm, libguile.scm, defmod.scm: New files:
+ These implement the user-level module system.
+
+ * sys.c (scm_sym2vcell): Add another argument: definedp, which is
+ passed as additional argument to the lookup-thunk (if any).
+ If this argument is BOOL_T, this lookup is for a define (which
+ has somewhat different semantics for modules); otherwise it
+ should be satisfied with an existing variable. If the thunk
+ returns BOOL_F (meaning there was no such variable), sym2vcell
+ returns BOOL_F as well.
+ * eval.c (scm_lookupcar, scm_m_define): Use the new sym2vcell param.
+ * variable.c (scm_builtin_var): Use the new sym2vcell param.
+
+ * eval.c (scm_top_level_env): New function: return an environment
+ using the given top-level-lookup thunk.
+ * eval.c (scm_eval2): Use scm_top_level_env.
+ * eval.c (scm_eval): Use an env with a top-level lookup thunk from
+ scm_top_level_lookup_thunk_var (aka *top-level-lookup-thunk*).
+ * eval.c (scm_neval): New function: just like scm_eval, but may
+ destroy its argument. Known in scheme as eval!.
+
+ * repl.c (scm_repl, scm_tryload, lreadr): Use scm_neval, not eval_3.
+
+ * Ginit.scm (make-module): Use the new definition of top-level thunks.
+ * Ginit.scm (set-current-module): Set *top-level-lookup-thunk* too.
+ * Ginit.scm: Trash all the repl stuff; we just use the C repl now.
+ Load the user module system.
+
+ * Makefile.in: Install the user-module implementation files.
+
+Mon Jan 2 16:27:25 1995 Miles Bader (miles@eskimo.com)
+
+ * Ginit.scm (repl:repl): Have the guile repl redefine try-load
+ instead of load, as this is the SCM primitive.
+ (module-for-each): Write module-for-each.
+ (module-search): Make this recurse into each module use-list
+ entry, as per the low-level module spec.
+ (define-macro): Make this function usable by modules that don't
+ have access to the internals of the guile module.
+
+Sun Jan 1 22:30:25 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * repl.c (scm_iprin1), subr.c (scm_lock_vector, scm_unlock_vector,
+ scm_lvector_ref, scm_lvector_set):
+
+ Added locked vectors. See N
+
+Sat Dec 31 15:45:22 1994 Miles Bader <miles@eskimo.com>
+
+ * Ginit.scm:
+ Add define-macro, delq!.
+
+ Add a module print-function, and some new name fields
+ to the module that the modops code uses to make modules
+ print nicely (e.g., #<interface guile/module 7a89c>)
+
+
+ * eval.c(ceval): Here's a patch that makes closures & subrs
+ self-evaluating.
+
+
+Wed Dec 28 00:31:22 1994 Tom Lord <lord@cygnus.com>
+
+ * scm.c (raise): use kill not raise, since it is more portable.
+
+Wed Dec 21 05:18:47 1994 Tom Lord <lord@x1.cygnus.com>
+
+ * eval.c (scm_eval2): Two argument eval. The
+ second argument is #f or a proc returning a variable.
+
+Fri Dec 9 00:40:26 1994 Tom Lord <lord@x1.cygnus.com>
+
+ * eval.c (scm_fasl_eval): eval without copying the source form.
+ This is just a temporary hack.
+
+Sun Dec 4 21:50:37 1994 Tom Lord <lord@x1.cygnus.com>
+
+ * eval.c (scm_ceval): Added special forms LITERAL-VARIABLE-SET!
+ and LITERAL-VARIABLE-REF. The first argument of each is a
+ variable object (see variable.c). The second argument
+ of set! is an expression. They do what you'd expect.
+ -SET! returns UNSPECIFIED.
+
+ Note that one can not read a form which uses literal-variable*
+ correctly because there is no way to read a variable object.
+ These forms exist for the sake of the module system.
+
+Fri Dec 2 19:52:40 1994 Tom Lord (lord@x1.cygnus.com)
+
+ * subr.c (string->obarray-symbol, intern-symbol, unintern-symbol,
+ symbol-set!, symbol-binding)
+ Multiple obarrays.
+
+ * variable.c (scm_make_variable, scm_variable_{ref,set}
+ Implemented variables. Variables are anonymous
+ objects holding one settable value.
+
+Wed Nov 30 04:31:18 1994 Tom Lord (lord@x1.cygnus.com)
+
+ * *.[ch]: renamed all global identifiers to have the prefix scm_.
+
+ * sys.c (gc_sweep, scm_mark_locations, scm_init_heap):
+
+ Modified gc to allow objects of any multiple of sizeof(CELLPTR).
+ In addition, each heap segment gets to specify a freelist (which
+ may be shared).
+
+ new function: scm_alloc_obj
+ new vars: scm_heap_table (replaces hplims)
+ scm_n_heap_segs (replaces (hpims_ind / 2))
+
+Thu Oct 27 12:57:02 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Jerry D. Hedden <hedden@esdsdf.dnet.ge.com>
+ * ioext.c: conditional code for vms and version (3.6) of Aztec C.
+ * pi.scm ((e digits)): Modified 'bigpi' for slight speed
+ improvement. Added function to calculate digits of 'e'.
+
+Wed Oct 26 11:22:05 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Gary Houston <ghouston@actrix.gen.nz>
+ * scl.c (round): Now rounds as described in R4RS.
+
+ * test.scm (test-inexact): test cases for round.
+
+Tue Oct 25 00:02:27 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (grow_throw lthrow dynthrow): now pass arrays, check
+ for adequate growth, and clear out register windows (on sparc).
+
+Mon Oct 24 01:05:34 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (ttyname fileno): added.
+
+Sat Oct 22 12:12:57 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unix.c (symlink readlink lstat): added.
+
+ * scmfig.h repl.c sys.c (IO_EXTENSIONS): flag removed.
+
+ * ioext.c (read-line read-line! file-position, file-set-position
+ reopen-file open-pipe opendir readdir rewinddir closedir chdir
+ umask rename-file isatty? access chmod mkdir rmdir stat utime
+ raise): moved from "repl.c" and "sys.c".
+
+Fri Oct 21 21:19:13 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Radey Shouman <shouman@ccwf.cc.utexas.edu>
+ * unif.c (ra2contig): now has a second parameter to indicate
+ whether copying is necessary or not. Eliminates gratuitous copy
+ by UNIFORM-ARRAY-READ! when called with a noncontiguous array.
+
+ (array_map): more liberal check on when ARRAY-MAP! can use
+ array-ified asubrs.
+
+Thu Oct 20 18:00:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (opendir readdir rewinddir closedir reopen-file): added
+ under IO_EXTENSIONS.
+
+Wed Oct 19 14:18:26 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (badargsp): added under ifndef RECKLESS to check @apply
+ and apply() arg counts.
+
+Tue Oct 18 00:02:10 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unix.c (mknod acct nice sync): added.
+
+ * socket.c (socket bind! gethost connect! listen! accept): added.
+
+ * time.c (utime): added under IO_EXTENSIONS.
+
+Mon Oct 17 23:49:06 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (getcwd umask access chmod mkdir rmdir): added
+ under IO_EXTENSIONS.
+
+ * scm.c (l_pause): added if SIGALRM defined.
+ (l_sleep): added if SIGALRM not defined.
+
+ * scl.c (num2ulong): added. Used in "time.c"
+
+Sun Oct 16 22:41:04 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (access chmod): Posix access added under IO_EXTENSIONS.
+
+Fri Oct 14 09:45:32 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * posix.c (chown link pipe waitpid, kill, getpw, getgr, get*id,
+ set*id): added.
+
+ * time.c (l_raise l_getpid): added
+ * subr.c (ulong2big):
+ * scl.c (ulong2num): useful routines for system call data
+ conversion moved from "time.c".
+
+Thu Sep 22 14:48:16 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (big2inum): (more accruately) renamed from big2long.
+
+Tue Sep 6 22:22:16 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@hpcf.cc.utexas.edu (Radey Shouman)
+ Date: Mon, 29 Aug 1994 11:36:46 +0600
+ * unif.c: This is a large patch, but also a bit larger than it
+ appears -- I moved a few function definitions around to eliminate
+ gratuitous forward references.
+
+ * unif.c repl.c (raprin1): Combined print routine for arrays with
+ that for uves.
+
+ * unif.c (UNIFORM-VECTOR-READ! and -WRITE): work with general
+ arrays, by copying when necessary, renamed them to
+ UNIFORM-ARRAY-READ! and -WRITE.
+
+ * unif.c (ARRAY-CONTENTS): Generalized so that it returns a 1-d
+ array even when the stride in the last dimension is greater than
+ one, gave it an optional second argument STRICT, which makes it
+ behave as it did before, returning an array/vector only if the
+ contents are contiguous in memory.
+
+ * unif.c (ARRAY-CONTIGUOUS?) Eliminated. Instead, use
+ (lambda (ra) (array? (array-contents ra #t)))
+
+ * unif.c code.doc (ramapc): unrolls arrays mapping into one loop
+ if possible, to make this quick, changed the format of the array
+ CAR, now uses one bit to indicate that an array is contiguous --
+ this still allows a ridiculous number of dimensions.
+
+ * scm.h (DSUBRF): dsubrs are mapped directly, to allow this I
+ moved the typedef for dsubr and #define for DSUBRF to scm.h
+
+ * unif.c (ARRAY-MAP!) taught something about subrs, now most subrs
+ may be mapped without going through apply(), saving time and
+ reducing consing. +, -, *, /, =, <, <=, >, and >= are mapped
+ directly as special cases -- for uniform arrays this is nearly as
+ fast as the equivalent C, and doesnt' cons. I've made sure that
+ +, -, *, and / vectorize on the CRAY, this may be wasted effort
+ but the effort is not great.
+
+ * unif.c (ARRAY-COPY!) now copies many arrays of differing types
+ to each other without going through the aref/aset, e.g. float ->
+ double, double -> complex, integer -> float ... This should make
+ array type coercions for arithmetic faster.
+
+ * unif.c (TRANSPOSE-ARRAY) Added, which returns a shared array
+ that is the transpose of its first argument. I think this does
+ what an APL:TRANSPOSE would.
+
+ * unif.c (ENCLOSE-ARRAY) Added, this returns an array that looks
+ like an array of shared arrays, the difference being that the
+ shared arrays are not actually allocated until referenced.
+ Internally, the contents of an enclosed array is another array.
+ The main reason for this is to allow a reasonably efficient
+ implementation of APL:COMPRESS, EXPAND, and INDEXING. In order to
+ actually make an array of shared arrays, just use ARRAY-COPY!.
+
+ * unif.c (cvref): Created internal version of aref(), cvref() that
+ doesn't do error checking; Thus speeding things up. Profiling of
+ SCM running array code revealed that aref() was taking a
+ surprising fraction of the CPU time
+
+ TO DO:
+
+ The mechanism for looking up the vectorized functions is a little
+ kludgy, I was tempted to steal some of the CAR of the subr type to
+ encode an offset into a table of vectorized functions, but this
+ would make it more likely that dynamically loaded subrs lose thier
+ names.
+
+ It is almost possible to write APL:+ and friends now, it is just
+ necessary to figure out the appropriate type of the returned array
+ and allocate it, and to promote scalar arguments to arrays (with
+ increments 0).
+
+ This doesn't include vectorized REAL-PART, IMAG-PART,
+ MAKE-RECTANGULAR ...
+
+ I think some C support for APL:REDUCE and maybe INNER-PRODUCT will
+ be needed for a reasonably fast APL.scm
+
+ unif.c is getting quite big, time to split it up?
+
+
+Mon Sep 5 22:44:50 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm repl.c (quit): code was not using return values
+ correctly.
+
+Sun Aug 21 01:02:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * record.c (init_record): remaining record functions moved into C
+ code.
+ * eval.c sys.c: compiled closures now conditional under CCLO.
+
+Sat Aug 20 23:03:36 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * eval.c (ceval apply):
+ * sys.c (makcclo): tc7_cclo, compiled closures, now supported.
+ * record.c (init_record): C implementation of slib "Record"s using
+ CCLO.
+ * scm.h subr.c (QUOTIENT MODULO REMAINDER): fixes a bug for
+ bignums with DIGSTOOBIG defined. Also, changed the return type of
+ longdigs() to void, since that value is no longer used anywhere.
+
+Mon Aug 1 11:16:56 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c (curtime): replaces get-universal-time. Other time
+ functions removed (SLIB support more complete).
+
+ * subr.c (divbigbig): fixed (modulo -2177452800 86400) => 86400
+ bug. Also added to test.scm.
+
+Sun Jul 24 16:09:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * dynl.c (init_dynl): *feature* dld:dyncm added for dynamically
+ (ldso) linked libc.sa and libm.sa (under Linux).
+
+Fri Jul 15 12:53:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unif.c (array-fill!): bug with increment in default clause fixed.
+ Fast string support added.
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c (array-fill! array-for-each): bug fixes.
+
+Sun Jul 10 01:51:00 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (run_scm init_scm): "-a" heap allocation argument supported.
+
+ * Makefile (proto.h): removed.
+
+ From: Drew Whitehouse, Drew.Whitehouse@anu.edu.au
+ * scm.h (P): Conditionalized ANSI'fied version of the scm.h.
+
+Sun Jun 26 12:41:59 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm (usr:lib lib): Now checks for shared libraries
+ (lib*.sa) first.
+
+Thu Jun 23 19:45:53 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c scm.c: Support for compilation under Turbo C++ for Windows
+ (system and exec disabled) added under C flag "_Windows".
+
+Sat Jun 18 11:47:17 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * test.scm ((test-delay)): added.
+ ((test-bignum)): added and called automatically if bignums
+ suported. test-inexact called automatically if inexacts
+ supported.
+
+Mon Jun 6 09:26:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm (trace untrace): moved to SLIB/trace.scm.
+
+Thu May 12 00:01:20 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm: Autoload for hobbit now does (provide 'hobbit). This
+ allows hobbit to know if it is self compiling (although reloads of
+ hobbit will not be quite right).
+ ((compile file . args)): removed.
+
+ * makefile.unix (proto.h): removed.
+
+ * Transcen.scm: compile-allnumbers HOBBIT declaration added.
+ Init.scm will now load compiled Transcen.o.
+
+ * scm.h: HOBBIT section removed.
+
+ * README (SLIB): Now strongly recommends getting SLIB and lists
+ ftp sites.
+
+ * eval.c (m_delay): fixed bug with multiple sets of (delay x).
+
+Thu Apr 28 22:41:41 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unif.c (makflo): shortcut for single precision float arrays
+ added.
+
+Fri Apr 15 00:54:14 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: no longer uses pointer comparisons in loops. Should
+ fix problems on 8086 processors.
+ * unif.c (make_sh_array): Fixes MAKE-SHARED-ARRAY so that shared
+ arrays with only 1 element in some direction may still be
+ ARRAY-CONTIGUOUS?
+ (uve_write uve_read): Fixes bug in UNIFORM-ARRAY-WRITE,
+ UNIFORM-ARRAY_READ!. Now they do the right thing for shared
+ bit-arrays not starting at the beginning of their contents vector.
+ (array_contents ARRAY-SIMPLE?): ARRAY-CONTENTS may now return a
+ shared, contiguous, 1-d array, instead of a vector, if the array
+ cannot access all of the contents vector. ARRAY-SIMPLE? removed.
+ (array-fill!): a replacement and generalization of
+ UNIFORM-VECTOR-FILL!.
+ (raequal): Combines with uve_equal(), providing also ARRAY-EQUAL?
+ ARRAY-EQUAL? is equivalent to EQUAL? if all its arguments are
+ uniform vectors or if all are arrays. It differs from EQUAL? in
+ that a shared, 1-d array may be ARRAY-EQUAL? to a uniform vector.
+ for example
+ (define sh (make-shared-array '#(0 1 2 3) list '(0 1))) ==> #1(0 1)
+ (equal? '#(0 1) sh) ==> #F
+ (array-equal? '#(0 1) sh) ==> #T
+ (list2ura): Combines list2uve() and list2ura().
+
+Thu Apr 14 23:26:54 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c (LACK_FTIME LACK_TIMES): defined for vms.
+
+Mon Apr 4 10:39:47 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (copytree): now copies vectors as well.
+
+ * repl.c (quit): now accepts #t and #f values.
+
+Sun Apr 3 23:30:14 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (repl): call to my_time() moved to not include READ time.
+
+ * time.c (mytime): now prefers to use times() over clock().
+ Compilation constant CLOCKS_PER_SEC doesn't scale when a binary is
+ moved between machines.
+
+Thu Mar 31 16:22:53 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm (*SCM-VERSION*): added.
+
+ * Makefile (intro): Added message for those who just make.
+ Cleaned up and reorganized Makefile.
+
+ * patchlvl.h (PATCHLEVEL): removed. Whole version now just in
+ SCMVERSION.
+
+Wed Mar 23 00:09:51 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * repl.c (iprin1): Characters higher than 127 print as
+ #\<octal-number>.
+
+ * Init.scm ((read:array digit port)): added. Most # syntax
+ handled in read:sharp.
+
+ * unif.c (clist2uve clist2array): removed.
+
+Fri Mar 11 15:10:53 1994 Radey Shouman (rshouman@chpc.utexas.edu)
+
+ * sys.c (sfgetc): can now return EOF.
+
+Mon Mar 7 17:07:26 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * patchlvl.h (SCMVERSION): 4e0
+
+ * scmfig.h: was config.h (too generic).
+
+ * scm.c (main run_scm) repl.c (repl_driver init_init): now take
+ initpath argument. IMPLINIT now used in scm.c
+
+Sun Feb 27 00:27:45 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (ceval m_cont IM_CONT): @call-with-current-continuation
+ special form for tail recursive call-with-current-continuation
+ added. call_cc() routine removed.
+
+Fri Feb 25 01:55:06 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (ceval m_apply IM_APPLY apply:nconc-to-last): @apply
+ special form for tail-recursive apply added. ISYMs reactivated.
+
+Mon Feb 21 14:42:12 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * crs.c (nodelay): added. In NODELAY mode WGETCH returns
+ eof-object when no input is ready.
+
+ * Init.scm ((read:sharp c port)): defined to handle #', #+, and
+ #-.
+
+ * repl.c (lreadr): Now calls out to Scheme function read:sharp
+ when encountering unknown #<char>.
+
+Tue Feb 15 01:08:10 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Shiro KAWAI <kawai@sail.t.u-tokyo.ac.jp>
+ * eval.c (ceval apply): under flag CAUTIOUS, checks for applying
+ to non-lists added.
+
+Sat Feb 12 21:23:01 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (sym2vcell intern sysintern): now use internal strhash().
+
+ * scl.c sys.c (hash hashv hashq strhash()): added.
+
+Sat Feb 5 01:24:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.h (ARRAY_NDIM): #define ARRAY_NDIM NUMDIGS changed to
+ #define ARRAY_NDIM(x) NUMDIGS(x) to correct problem on Next.
+
+Fri Feb 4 23:15:21 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: 0d arrays added. Serial array mapping functions and
+ ARRAY-SIMPLE? added.
+
+Thu Feb 3 12:42:18 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.h (LENGTH): now does unsigned shift.
+
+Wed Feb 2 23:40:25 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm (*catalog*): catalog entries for db (wb),
+ turtle-graphics, curses, regex, rev2-procedures, and
+ rev3-procedures added.
+
+Sun Jan 30 19:25:24 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * sys.c eval.c setjump.h setjump.s (longjump setjump): full
+ continuations now work on Cray YMP.
+
+Thu Jan 27 01:09:13 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * dynl.c MANUAL Init.scm (init_dynl): dynamic linking modified for
+ modern linux.
+
+Sat Jan 22 17:58:55 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: ucs3028@aberdeen.ac.uk (Al Slater)
+ * makefile.acorn repl.c (set_erase): Port to acorn archimedes.
+ This uses Huw Rogers free unix function call library for the
+ archimedes - this is very very widely available and should pose no
+ problem to anyone trying to find it - its on every archimedes ftp
+ site.
+
+ From: hugh@cosc.canterbury.ac.nz (Hugh Emberson)
+ * dynl.c Link.scm: Dynamic Linking with SunOS.
+
+Thu Jan 6 22:12:51 1994 (jaffer at jacal)
+
+ * sys.c (gc_mark mark_locations): now externally callable.
+
+Sun Jan 2 19:32:59 1994 (jaffer at jacal)
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * unif.c (ra_matchp ramapc): patch to unif.c avoids two problems
+ (K&R C does not allow initialization of "automatic" arrays or
+ structures). This was not use in 4d2 or previously, and the
+ following patch ensures that such initialization only occurs for
+ ANSI C compilers (Note that K&R C compilers need to explicitly
+ assign the values).
+
+Sat Dec 18 23:55:30 1993 (jaffer at jacal)
+
+ * scm.1 scm.doc (FEATURES): improved and updated manual page.
+
+ * repl.c (BRACKETS_AS_PARENS): controls whether [ and ] are read
+ as ( and ) in forms.
+
+Wed Dec 8 23:13:09 1993 (jaffer at jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: More array fixes and functions.
+
+Tue Dec 7 00:44:23 1993 (jaffer at jacal)
+
+ * dynl.c (dld_stub): removed since dld is working better on Linux.
+
+Wed Dec 1 15:27:44 1993 (jaffer at jacal)
+
+ * scm.h (SNAME): explicit cast added to get rid of compiler
+ warnings.
+
+ From: bh@anarres.CS.Berkeley.EDU (Brian Harvey)
+ * repl.c (repl) output newlines when more than one form on a line
+ for Borland C.
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: More array fixes and documentation.
+
+Mon Nov 29 01:06:21 1993 Aubrey Jaffer (jaffer at montreux)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: More array functions (need documentation).
+
+Sun Nov 28 01:34:22 1993 (jaffer at jacal)
+
+ * scm.h (SNAME): returns a pointer to nullstr if offset is 0.
+
+ * subr.c eval.c (make_synt make_subr): now check that offset from
+ heap_org hack works for each subr. If not, 0 is used.
+
+ * Link.scm (compile-file): compiles SCM file to object suitable
+ for LOAD.
+
+ * Link.scm: initialization file created with Scheme code for
+ compilation and linking. LOAD now automatically loads SCM object
+ files.
+
+ * dynl.c Init.scm: dynamic linking now works under DLD on Linux.
+ Wb, crs, and sc2 can by dynamically loaded.
+
+Thu Nov 25 22:58:36 1993 (jaffer at jacal)
+
+ * sys.c (ltmpnam): return value of mktemp call tested in accord
+ with HP-UX documentation (returns "" on error).
+
+ * config.h (SYSCALLDEF): removed. Macro I/O calls (getc, putc)
+ replaced with function versions. Control-C interrupts should work
+ while pending input on all systems again.
+
+Tue Nov 23 01:18:35 1993 (jaffer at jacal)
+
+ From: dorai@cs.rice.edu (Dorai Sitaram)
+ * repl.c sys.c time.c config.h: MWC (Mark Williams C) support.
+
+Sun Nov 7 10:58:53 1993 (jaffer at jacal)
+
+ From: "Greg Wilson" <Greg.Wilson@cs.anu.edu.au>
+ * scm.c config.h (TICKS ticks tick-interrupt): if TICKS is
+ #defined, ticks and tick-interrupt work like alarm and
+ alarm-interrupt, but with units of evaluation rather than units of
+ time.
+
+Mon Nov 1 18:47:04 1993 (jaffer at jacal)
+
+ * unif.c (uniform-vector-ref => array-ref): integrated arrays
+ with uniform-vectors. Strings, vectors, and uniform-vectors
+ now just special case of arrays (to the user).
+
+Fri Oct 29 01:26:53 1993 (jaffer at jacal)
+
+ * unif.c (rasmob tc16_array): arrays are now a smob.
+
+Thu Oct 28 01:21:43 1993 (jaffer at jacal)
+
+ * sys.c repl.c (igc gc_start): GC message gives reason for GC.
+
+Wed Oct 27 10:03:00 1993 (jaffer at jacal)
+
+ * config.h (SICP): flag makes (eq? '() '#f) and changes other
+ things in order to make SCM more compatible with Abelson and
+ Sussman's book.
+
+ * sys.c (gc_mark gc_sweep mark_locations): GC bug fixed. GC from
+ must_malloc would collect the tc_free_cell already allocated.
+
+ * sys.c setjump.h (must_malloc must_realloc INIT_MALLOC_LIMIT):
+ modified to call igc when malloc usage exceeds mtrigger (idea from
+ hugh@ear.MIT.EDU, Hugh Secker-Walker).
+
+ From: Jerry D. Hedden
+ * pi.scm (bigpi): bignum version of pi calculator.
+
+Tue Oct 26 18:41:33 1993 (jaffer at jacal)
+
+ * repl.c (room): added procedure for printing storage statistics.
+
+Sun Oct 24 22:40:15 1993 (jaffer at jacal)
+
+ * config.h eval.c scl.c (STACK_LIMIT CHECK_STACK): added.
+ * sys.c (stack_check): added.
+
+Sat Oct 23 00:08:30 1993 (jaffer at jacal)
+
+ * sys.c (mallocated): added to keep track of non-heap usage.
+
+ * sys.c (igc): fixed interrupt vulnerabilities around gc.
+
+Sun Oct 17 13:06:11 1993 (jaffer at jacal)
+
+ * repl.c (exit_report): added. Prints cumulative times if
+ (verbose > 2). Called from free_storage().
+
+ * repl.c (repl): fixed CRDYP(stdin) BUG! Transcripts should work
+ again. Other annoying CR behaviour fixed.
+
+ * time.c (init_time your_base my_base): now not reset when
+ restarting so timing numbers for restarting are correct.
+
+ * scm.h (sys_protects): rearranged.
+ * sys.c (tmp_errp): now a statically allocated global variable,
+ used by init_storage and free_storage.
+ * scm.h sys.c (tc16_fport, tc16_pupe, tc16_strport, tc16_sfport):
+ now #defines (which must correspond to order of newptob calls).
+
+Sun Oct 3 20:38:09 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * README.unix configure configure.in scmconfig.h.in
+ mkinstalldirs Makefile.in acconfig-1.5.h: SCM can now be built
+ using GNU autoconf. Put in scmconfig4c5.tar.gz
+
+Sun Oct 3 00:33:57 1993 (jaffer at jacal)
+
+ * MANUAL (bit-count bit-position bit-set*! bit-count*
+ bit-invert!): (from unif.c) are now documented.
+
+ * sys.c (fixconfig): added 3rd argument to distinguish between
+ setjump.h and config.h.
+ * setjump.h config.h: moved IN_SYS stuff from config.h to
+ setjump.h.
+ * config.h (HAVE_CONFIG_H): User config preferences now taken
+ from "scmconfig.h" if HAVE_CONFIG_H is defined.
+ * config.h (EXIT_SUCCESS EXIT_FAILURE): fixed for VMS.
+
+Sat Oct 2 00:34:38 1993 (jaffer at jacal)
+
+ From: rshouman@hermes.chpc.utexas.edu (Radey Shouman)
+ * unif.c repl.c: added read and write syntax for uniform vectors.
+ * unif.c (uniform-vector->list list->uniform-vector): created.
+ * time.c (time_in_msec): conditionalized for wide range of CLKTCK
+ values.
+ * config.h (BITSPERDIG POINTERS_MUNGED)
+ * scm.h (PTR2SCM SCM2PTR)
+ * scl.c (DIGSTOOBIG)
+ Ported SCM to Unicos, the Cray operating system.
+
+ From: schwab@ls5.informatik.uni-dortmund.de (Andreas Schwab)
+ * scl.c (dblprec): set from DBL_DIG, if available.
+
+Fri Oct 1 21:43:58 1993 (jaffer at jacal)
+
+ * unif.c (bit-position): now returns #f when item is not found.
+ Now returns #f when 3rd argument is length of 2nd argument
+ (instead of error).
+
+Fri Sep 24 14:30:47 1993 (jaffer at jacal)
+
+ * sys.c (free_storage): fixed bug where growth_mon was being
+ called after the port cell had been freed. gc_end now also
+ called at end.
+
+Tue Sep 21 23:46:05 1993 (jaffer at jacal)
+
+ * Init.scm scm.c: Restored old command line behaviour (loading all
+ command line arguments) for case when first command line argument
+ does not have leading `-'.
+
+ * sys.c (mode_bits): abstracted from open_file and mksfpt.
+
+ * scm.h (*FPORTP): series of predicates added for operations which
+ only work on some fports.
+
+ * sys.c crs.c: ungetc removed from ptobfuns structure and
+ soft-ports.
+
+Mon Sep 20 23:53:25 1993 (jaffer at jacal)
+
+ * sys.c (make-soft-port): Soft-ports added, allowing Scheme
+ i/o extensions.
+
+Sun Sep 19 22:55:28 1993 (jaffer at jacal)
+
+ * 4c4: released.
+ * Init.scm scm.c scm.1: command line proccessing totally
+ rewritten. Thanks to Scott Schwartz
+ <schwartz@groucho.cs.psu.edu> for help with this.
+
+Mon Sep 13 21:45:52 1993 (jaffer at jacal)
+
+ From: pegelow@moorea.uni-muenster.de (Ulrich Pegelow)
+ * scl.c (add1): finally a way to fool optimizing gcc to not use
+ extra precision registers.
+
+Sun Sep 12 18:46:02 1993 (jaffer at jacal)
+
+ * sys.c (pwrite): added to stubbify fwrite to fix bug on VMS.
+ * config.h: moved flags to top per suggestions from Bryan
+ O'Sullivan (bos@scrg.cs.tcd.ie).
+
+Fri Sep 10 11:42:27 1993 (jaffer at jacal)
+
+ * repl.c config.h (EXIT_SUCCESS EXIT_ERROR): added. Values
+ returned by SCM program.
+
+Thu Sep 9 13:09:28 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: Vincent Manis <manis@cs.ubc.ca>
+ * sys.c (stwrite init_types add_final): fixed declarations.
+
+Mon Sep 6 16:10:50 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * README: changed the build and installation instructions to bring
+ them up to date with reality.
+
+Sun Sep 5 23:08:54 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * Wrote autoconf script to support GNU Autoconf configuration
+ to make scm easier to build.
+
+ * Created Makefile.in; a radical overhaul of Makefile to remove
+ some of the brokenness and allow cross-compilation and use of
+ autoconf.
+
+Sat Sep 4 23:00:49 1993 (jaffer at jacal)
+
+ * 4c3: released.
+ * sys.c (grow_throw): removed use of memset for SPARC machines.
+
+Sat Sep 4 18:09:59 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * time.c: added SVR4 to the list of LACK_FTIME systems, because
+ most all SVR4 BSD-compatibility stuff is a total mess.
+
+ * config.h: changed definition of STDC_HEADERS so it does the
+ Right Thing on systems which run GCC but don't have header files
+ with prototypes.
+
+ * makefile.unix: added a note for SVR4 users.
+
+Tue Aug 31 18:30:53 1993 (jaffer at jacal)
+
+ * eval.c (m_define): if verbose >= 5 warnings are issued for all
+ top-level redefinitions.
+
+Mon Aug 30 16:24:26 1993 (jaffer at jacal)
+
+ * scm.c sys.c (finals num_finals add_final): Finalization calls
+ now dynamically, incrementally, defined.
+
+Thu Aug 26 12:38:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * 4c2: fixed declaration problems in PTOB with K&R C.
+
+Sun Aug 22 23:02:51 1993 (jaffer at jacal)
+
+ * split.scm: code which directs input, output, and diagnostic
+ output to separate windows (using curses functions defined in
+ crs.c).
+
+Sat Aug 21 16:46:33 1993 (jaffer at jacal)
+
+ * Init.scm (output-port-height): added if not already defined.
+ output-port-width also made conditional.
+
+ * sys.c (tc16_strport): string ports created.
+
+Thu Aug 19 11:37:07 1993 (jaffer at jacal)
+
+ * sys.c (init_types): freecell, floats, and bignums now have SMOB
+ entries. gc_sweep and gc_mark still inline codes for bignums and
+ floats.
+
+ * sys.c repl.c code.doc: Ports now an extensible type.
+ Indirection suggested by Shen <sls@aero.org>.
+
+Mon Aug 16 01:20:26 1993 (jaffer at jacal)
+
+ * crs.c: curses support created.
+
+Sun Aug 15 16:56:36 1993 (jaffer at jacal)
+
+ * rgx.c sys.c (mark0 equal0): mark0 moved to sys.c. equal0
+ created.
+
+Fri Jun 25 01:16:31 1993 (jaffer at jacal)
+
+ * QUICKREF: added.
+
+Tue Jun 22 00:40:58 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (ungetted): replaced with CRDYP(stdin) to fix recently
+ introduced transcript bug.
+
+Sun Jun 20 22:29:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * config.h (NOSETBUF): setbuf() now conditionalized on NOSETBUF.
+
+ * Init.scm (defmacro): now copies the results of macro expansion
+ in order to avoid capture of memoized code by macros like:
+ (defmacro f (x) `(list '= ',x ,x)).
+
+Wed Jun 2 23:32:05 1993 Aubrey Jaffer (jaffer at caddr)
+
+ * eval.c (map for-each): now check that arguments are lists.
+
+Mon May 31 23:05:19 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (trace untrace): now defmacros which handle (trace) and
+ (untrace) as in Common Lisp.
+
+Wed May 5 01:17:37 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: Roland Orre <orre@sans.kth.se>
+ * all: internal output functions now take SCM ports instead of
+ FILE* in preparation for string-ports.
+
+Tue May 4 17:49:49 1993 Aubrey Jaffer (jaffer at wbtree)
+
+ * makefile.unix (escm.a): created scm "ar" file and used for
+ dbscm.
+
+Sun Apr 25 21:35:46 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (free_storage): i++ moved out of CELL_* in response to:
+From: john kozak <jkozak@cix.compulink.co.uk>
+Minor bug report: around line 10 of routine "free_storage" you do calls
+to CELL_UP and CELL_DOWN with arguments having side-effects: with the
+PROT386switch defined in config.h these args are evaluated twice...
+
+Sun Apr 11 22:56:19 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (IM_DEFINE): added. Internal defines are no longer
+ turned into LETRECS.
+
+Wed Apr 7 13:32:53 1993 Aubrey Jaffer (jaffer at camelot)
+
+ Jerry D. Hedden <HEDDEN@ESDSDF.dnet.ge.com>
+ * scl.c (idbl2str): fix for bug introduced by removing +'s.
+
+Tue Mar 23 15:37:12 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * scl.c (idbl2str): now prints positivie infinity as +#.# again
+ (instead of #.#).
+
+Mon Mar 22 01:38:02 1993 Aubrey Jaffer (jaffer at montreux)
+
+ * subr.c (quotient): renamed to lquotient to avoid conflict with
+ HP-UX 9.01.
+
+Fri Mar 19 01:21:08 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c repl.c: #ifndef THINK_C #include <sys/ioctl.h>
+ * time.c (lstat): #ifndef THINK_C. ThinkC 5.0.1 lacked.
+
+Mon Mar 15 23:35:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: jhowland@ariel.cs.trinity.edu (Dr. John E. Howland)
+ * scl.c (idbl2str iflo2str big2str): leading + eliminated on
+ output and number->string.
+
+Wed Mar 10 00:58:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c scm.h (CRDYP CLRDY CGETUN CUNGET): cleaned up ungetc hack.
+
+ * scm.c repl.c (exec): added.
+
+Sun Mar 7 22:44:23 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (def_err_response): now will print errobjs if they are
+ immediates, symbols, ports, procedures, or numbers.
+
+Fri Mar 5 23:15:54 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (repl): now gives repl_report() for initialization.
+
+ * Init.scm (defvar): added.
+
+ From: Roland Orre <orre@sans.kth.se>
+ * repl.c (lungetc): no longer calls ungetc. Fixed problem that
+ many systems had with ungetc on unbuffered ports (setbuf(0)).
+
+Thu Mar 4 13:51:12 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: Stephen Schissler
+ * makefile.wcc: Watcom support added.
+
+Wed Mar 3 23:11:08 1993 Aubrey Jaffer (jaffer at montreux)
+
+ * sys.c scm.h (dynwinds): made a sys_protect.
+
+Mon Feb 15 11:30:50 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (defmacro macroexpand macroexpand1 macro? gensym):
+ added.
+
+ * repl.c (stdin): setbuf not done for __TURBOC__==1.
+
+ * makefile.bor: now has method to build turtegr.exe.
+
+ * eval.c (ceval): Memoizing macros now can return any legal Scheme
+ expression.
+
+Sat Feb 13 18:01:13 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (mkbig adjbig): now check for bignum size.
+
+ * Init.scm: reorganized so site-specific information is at the
+ head.
+
+ * repl.c (errno): changed from set-errno now returns value.
+
+ * subr.c (intexpt): now handles bignum exponents.
+
+ From: "David J. Fiander" <davidf@golem.waterloo.on.ca>
+ * time.c makefile.unix subr.c: SCO Unix and XENIX patches.
+
+Fri Feb 12 22:18:57 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (WITH-INPUT-FROM-PORT WITH-OUTPUT-TO-PORT
+ WITH-ERROR-TO-PORT): added.
+
+ * subr.c (ash): fixed for case (ash 2 40) where INUM arguments
+ make a bignum result.
+
+ * repl.c (lreadr): \ followed by a newline in a string is ignored.
+
+ From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
+ * repl.c (lreadr): Can now read \0\f\n\r\t\a\v in strings.
+
+Thu Feb 11 01:25:50 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (with-input-from-file with-output-to-file
+ with-error-to-file): now use dynamic-wind.
+
+Sun Feb 7 22:51:08 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (ceval): fixed bug with non-memoizing macro returning an
+ IMP.
+
+Sat Feb 6 01:22:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * (current-error-port with-error-to-file): add.
+
+Fri Feb 5 00:51:23 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * time.c (stat): added.
+
+ From: rnelson@wsuaix.csc.wsu.edu (roger nelson)
+ * dmakefile: support for DICE C on Amiga.
+
+Thu Feb 4 01:55:30 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (open-file) makes unbuffered if isatty.
+
+ * repl.c (char-ready?) added.
+
+Mon Feb 1 15:24:18 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (logor): changed to LOGIOR to be compatible with common
+ Lisp.
+
+ * eval.c (bodycheck): now checks for empty bodies.
+
+Sun Jan 31 01:01:11 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * time.c (get-universal-time decode-universal-time): now use
+ bignums.
+
+Tue Jan 26 00:17:06 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (mark_locations): now length argument in terms of
+ STACKITEM. Does both alignments in one pass.
+
+Mon Jan 25 12:13:40 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: soravi@Athena.MIT.EDU
+ * makefile.emx: for OS/2
+
+Sun Jan 24 18:46:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender)
+ * scl.c (big2str): now faster because it divides by as many 10s as
+ fit in a BIGDIG.
+
+Sat Jan 23 00:23:53 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender):
+ * config.h (INUM MAKINUM): shift optimization for TURBOC.
+
+Fri Jan 22 00:46:58 1993 Aubrey Jaffer (jaffer at montreux)
+
+ From: hanche@ams.sunysb.edu (Harald Hanche-Olsen)
+ * unif.c (uniform-vector?): added.
+
+Tue Jan 19 00:27:04 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender)
+ * subr.c scl.c config.h: bignum bug fixes for MSDOS.
+
+Mon Jan 18 01:15:24 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (ash lognot intlength logcount bitextract): now handle
+ bignums.
+
+Sun Jan 17 10:42:44 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (close_port): can now close pipes as well.
+
+ * subr.c (adjbig normbig divide quotient): fixed more divide bugs.
+
+ * subr.c (even? odd?): fixed problem with bignums.
+
+Sat Jan 16 00:02:05 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (divbigbig): Fixed last divide bug?
+
+Fri Jan 15 00:07:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * rgx.c (regmatch?): added. Debugged for both HP-UX and GNU
+ regex-0.11. Documentation added to MANUAL.
+
+Thu Jan 14 11:54:52 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * patchlvl.h (SCMVERSION): moved from config.h.
+
+ * scl.c (product): fixed missing {} bug.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c (lmin lmax) bignum versions.
+
+Wed Jan 13 01:40:51 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * released scm4b0.
+
+ * subr.c: fixed bignum bugs found by jacal.
+
+ * code cleanup.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * subr.c (lgcd quotent modulo lremainder): Bignum versions.
+ * subr.c (divbigbig): new version.
+
+Sun Jan 3 00:29:35 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender)
+ * Re-port to BorlandC v2.0
+
+ * sys.c (must_realloc): added
+
+ * config.h subr.c (BIGRAD pseudolong): now insensitive to ratio of
+ sizeof(long)/sizeof(BIGDIG).
+
+Mon Dec 21 23:20:47 1992 Aubrey Jaffer (jaffer at camelot)
+
+ From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
+ * rgx.c: created SCM interface to regex and regexp routines.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * subr.c scl.c: Now just one mulbigbig and addbigbig routine.
+
+ from: soravi@Athena.MIT.EDU
+ * README: directions for compiling SCM under OS/2 2.0.
+
+Wed Dec 9 15:34:30 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (tc7_subr_2x): eliminated. All comparison subrs now
+ rpsubrs.
+
+ * scm.h: Changed SUBR numbers. This improves HP-UX interpretation
+ speed (why?).
+
+ * eval.c (PURE_FUNCTIONAL): removed. Can now be done in
+ initialization code.
+
+ * eval.c (tc7_rpsubr): added type for transitive comparison
+ operators. Suprisingly, this slows down (pi 100 5).
+
+Mon Dec 7 16:15:47 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (logand logor logxor lognot ash logcount integer-length
+ bit-extract): added.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c: lots more numeric improvements and code reductions.
+
+Mon Nov 30 12:25:54 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.h (IDINC ICDR IDIST): enlarged depth count in ILOCs.
+
+Sun Nov 29 01:10:18 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c scl.c: most arithmetic operations will now return
+ bignums.
+
+ * config.h (FIXABLE POSFIXABLE NEGFIXABLE): added.
+
+ * sys.c (object-hash object-unhash): now use bignums.
+
+ * scl.c (big2str istr2int): bignum i/o implemented.
+
+ * unif.c: subr2s were incorrectly initialized as lsubr2s.
+
+Tue Nov 24 14:02:52 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (ceval): added unmemocar calls to error handling when
+ possible.
+
+ * scl.c (idbl2str): added back NAN and infinity support.
+
+ * eval.c (syntax_mem): replaced with individual macros.
+ * eval.c (procedure->syntax procedure->macro
+ procedure->memoizing-macro): All syntactic keywords are now
+ tc7_symbol. User definable macros added.
+ * sys.c: ISYMs no longer in symhash. ISYMs cannot be read.
+ init_isyms merged into init_eval.
+
+Sat Nov 21 00:39:31 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * makefile.unix (check): now exits with error code.
+
+ * sys.c (init_isyms): eliminated. ISYMS now inited in init_eval.
+
+Fri Nov 20 16:14:06 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * released scm4a13
+
+ * repl.c: longjmps now dowinds() first.
+
+ * setjump.h: now has all setjmp related definitions.
+
+ * Init.scm (trace untrace): use new macro system.
+
+ * eval.c (defined? procedure->macro procedure->memoizing-macro
+ make_synt): macro system added. defined? uses it.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c: fixes for several transcendental functions.
+
+Thu Nov 19 01:14:38 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c sys.c: errjmp replaced with JMPBUF(rootcont).
+
+Sun Nov 15 01:49:00 1992 Aubrey Jaffer (jaffer at camelot)
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c (istr2int istr2flo istring2number string2number): new
+ versions.
+
+Thu Nov 12 23:00:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.scm (load): now prints out actual filename found in mesasge
+ ;done loading ...
+
+Wed Nov 11 01:01:59 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (def_err_response): ARG1 error with errobj==UNDEFINED
+ becomes WNA error.
+
+ From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
+ * scl.c (difference divide): Now are asubrs.
+
+ * Init.scm (*features*): fixed to correspond to SLIB conventions.
+
+Mon Nov 9 12:03:58 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scl.h test.scm: (string->number "i") and "3I" and "3.3I" fixed
+ to return #f. Tests added to test.scm.
+
+Fri Nov 6 16:39:38 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.h (rootcont): sysprotect added.
+
+ From: Vincent Manis <manis@cs.ubc.ca>
+ * scm.h: __cplusplus prototype support.
+
+Thu Nov 5 00:39:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (lookupcar): now checks for UNDEFINED in local bindings
+ becuase LETREC inits to UNDEFINED.
+
+ * sys.c (dynamic-wind): added.
+
+ * config.h eval.c (ceval): CAUTIOUS mode added.
+
+ From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
+ * eval.c (ceval): internal defines now transformed to letrecs.
+
+Sun Oct 25 12:27:23 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (read-line read-line!): created.
+
+Sat Oct 24 18:36:23 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (lreadparen): now tail-recursive.
+
+ * eval.c (copy-tree eval): added. dummy_cell replaced with a
+ cons(obj,UNDEFINED).
+
+Thu Oct 22 21:26:53 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (set-errno!): changed to set-errno.
+
+Thu Oct 15 00:49:20 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (must_free): must_free created. Pointers are set to 0.
+ It detects objects being freed twice.
+
+Wed Oct 14 23:57:43 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.c (run_scm): Now has INITS and FINALS.
+
+ * scm.c (init_signals ignore_signals unignore_signals
+ restore_signals): siginterrupt() for ultix.
+
+Fri Oct 9 14:25:06 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * all: put in explicit casts to (unsigned char *) and (long) to
+ satisfy lint.
+
+ * sys.c (gc): all to gc_end was during deferred interrupts,
+ causing problems with verbose=3 and interrupts during GC.
+
+ * config.h(SYSCALLDEF): fixed so that test on errno occurs before
+ ALLOW_INTS (and possible call to user code).
+
+Sun Oct 4 01:45:25 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (syntax_mem): removed gratuitous cons.
+
+ * eval.c repl.c scm.h: Reduced static string use. Added peephole
+ optimizations for AND and OR.
+
+ From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
+ * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized
+ so that syntax checks are done only once. Interpreter is now
+ smaller and faster and uses less stack space. Modifications to
+ code are now made under DEFER_INTS as they always should have
+ been.
+
+Wed Sep 30 22:06:24 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c subr.c scm.h config.h: Started adding bignum code.
+
+Sun Sep 27 22:59:59 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (restart): added.
+
+ * sys.c (freeall): finished.
+
+ * scm.h (tc7_symbol): split into tc7_ssymbol and tc7_msymbol to
+ distinguish between non-GCable and GCable symbols.
+
+Wed Sep 23 00:36:23 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (peek_char lungetc): added workaround for TURBOC 1.0
+ problem with ungetc inside SYSCALLDEF macro.
+
+ * repl.c (iprin1): uses ttyname for #<stream ..> if available.
+
+ * Init.scm: now sets verbose to 0 if stdin or stdout is not a tty.
+
+ * repl.c (isatty?): added.
+
+ * repl.c (verbose): levels bumped up by 1. verbose == 0 means no
+ prompt.
+
+ * makefile.djg config.h (GNUDOS -> GO32): flags changed for djgpp108.
+
+Wed Aug 26 21:46:26 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * test.scm: put in (test #f < 1 3 2) and (test #f >= 1 3 2).
+
+ * scl.c (leqp greqp): put back in. (not (< 1 3 2)) does not imply
+ (>= 1 3 2).
+
+ * makefile.unix: tar and shar files now created in subdirectory.
+
+ * config.h time.c: Linux support added.
+
+ * repl.c: Greatly improved VMS interrupt support.
+
+ * eval.c (ceval): I_LET now changes to I_LETSTAR for single clause
+ unnamed lets.y
+
+ * (tc7_lsubr_2n): removed.
+
+Fri Jul 31 00:24:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * unif.c (bit-position): fixed; I am sure I had done these
+ changes before. Also corrected some error messages.
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * scm.h subr.c sys.c (equalp): smobfuns now include equalp.
+
+Mon Jul 20 16:44:30 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
+ * eval.c scm.h subr.c (BOOL_NOT) macro added to fix ^ bug in
+ BorlandC. This was fixed previously as well.
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * unif.c (vector-set-length!): was always typing to tc7_vector.
+
+Sat Jul 18 01:07:33 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c sys.c (make_vector init_storage resizuve): mallocs and
+ reallocs are now always > 0.
+
+ * time.c (get_univ_time): bypassed mktime() for (__TURBOC__ == 1).
+
+Mon Jul 13 22:27:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (lreadr): now ignores first line of port if begins with "#!"
+
+ * scl.c (lesseqp greqp): removed; changed to use tc7_lsubr_2n.
+
+ * scm.h eval.c (tc7_lsubr_2n): type added. Other subr types
+ rearranged.
+
+Sat Jul 11 23:47:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c repl.c eval.c code.doc (newsmob smobs smobfuns): now
+ support dynamically added smob types. Promises moved to eval.c.
+ Promises and arbiters are now newsmobs.
+
+ * makefile.unix repl.c scl.c (floprint): moved from repl.c to
+ scl.c. The only files which care about -DFLOATS are now scl.c,
+ eval.c, scm.c, and unif.c.
+
+ * sys.c scm.h (init_storage): now uses variable num_protects
+ instead of #define NUM_PROTECTS.
+
+Tue Jul 7 00:00:57 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: Ulf_Moeller@hh2.maus.de (Ulf Moeller)
+ * Init.scm config.h makefile.prj: support for the ATARI-ST with
+ Turbo C added.
+
+Tue Jun 30 23:45:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * unif.c (make-uniform-vector uniform-vector-set!
+ uniform-vector-ref): added.
+
+Tue Jun 23 11:49:13 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c code.doc: rearranged tc7 codes and added bvect,
+ ivect, uvect, fvect, dvect, cvect, and cclo.
+
+ * scm.h sys.c eval.c repl.c code.doc: Changed symbols to be
+ tc7_symbol.
+
+Sat Jun 6 22:27:40 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * scl.c (divide): divide by 0 and Exact-only divides of non
+ multiples now cause exception in RECKLESS mode.
+
+Wed May 27 16:02:58 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h scl.c (NUMBUFLEN): split into INTBUFLEN and FLOBUFLEN
+ and made proportional to size of numeric types.
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * makefile.ast scm.c Init.scm: minor chages for ATARI ST support.
+
+ * test.scm (test-inexact): created.
+
+Thu May 21 11:43:41 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ From: hugh@ear.mit.edu (Hugh Secker-Walker)
+ * config.h: better wording for heap allocation strategy
+ explanation.
+
+Wed May 20 00:31:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From S.R.Adams@ecs.southampton.ac.uk
+ * subr.c (stci_leqp st_leqp): reversed order of ^ clauses to avoid
+ Borland 3.0 bug.
+
+ * sys.c (gc_sweep): missing i-=2; added when splicing out segment.
+
+ * MANUAL time.c (get-universal-time decode-universal-time): half
+ hearted attempt to add these. Needs bignums.
+
+Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc_mark): improved tail recursivness for CONSes.
+
+ * repl.c (growth_mon): now prints out the hplims table if
+ verbose>3.
+
+ * sys.c (init_heap_seg): Serious bug in growing hplims fixed.
+ num_heap_segs eliminated; hplims are realloced whenever grown.
+
+Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train)
+
+ * config.h sys.c (alloc_some_heap expmem): expmem captures
+ whether the INIT_HEAP_SIZE allocation was successful. If so,
+ alloc_some_heap uses exponential heap allocation instead of
+ HEAP_SEG_SIZE.
+
+Mon May 11 15:29:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc_sweep init_heap_seg heap_org): Empty heap segments
+ are now freed.
+
+ * sc2.c (STR_EXTENSIONS): renamed REV2_PROCEDURES and R2RS and
+ R3RS functions put into sc2.c.
+
+Sun May 10 01:34:11 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (ignore_interrupts unignore_interrupts): added for
+ system, edt$edit, and popen to use.
+
+ * repl.c (lwrite display newline write_char): Close pipe if EPIPE.
+
+ * repl.c (file_set_position): now errs on ESPIPE.
+
+ * scm.c (SIGPIPE): now ignored (errs come back as EPIPE).
+
+Sat May 9 17:52:36 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
+ * config.h (PROT386): PROT386 added. PTR_LT and CELL_UP modified.
+
+Fri May 8 17:57:22 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: hugh@ear.mit.edu (Hugh Secker-Walker)
+ * Init.scm (last-pair append!): last-pair is faster version.
+ Append! corrected for null first arg. (getenv "HOME") now gets
+ a "/" added if not present.
+
+ * config.scm (MIN_GC_YIELD): now proportional to HEAP_SEG_SIZE.
+
+ * README: setting environment variables corrected.
+
+ * subr.c (length): error message now has arg if not a list.
+
+ * sys.c (open-pipe): now turns off interrupts before forking.
+
+ * scl.c (lsystem): now turns off interrupts before forking.
+
+ * scm.c (ignore_signals): created.
+
+Sat May 2 01:02:16 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.c (WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE): defined in
+ terms of current-input-port and current-output-port. Bug in
+ open-input-pipe and open-output-pipe fixed.
+
+ * sys.c repl.c (current-input-port current-output-port): moved
+ from sys.c to repl.c. set-current-input-port and
+ set-current-output-port added to repl.c.
+
+Mon Apr 13 22:51:32 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h: (PATCHLEVEL): released scm4a1.
+
+ * makefile.* VMSBUILD.COM VMSGCC.COM: compile time.h.
+
+ * scm.c (alrm_signal int_signal): now save and restore errno so
+ SYSCALL will work correctly across interrupts.
+
+Sun Apr 12 01:44:10 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h: (PATCHLEVEL): released scm4a0.
+
+ * repl.c (lread): tok_buf now local to each invocation of read.
+ This makes READ interruptable and reentrant.
+
+ * sys.c MANUAL (STRING-SET-LENGTH! STRING-VECTOR-LENGTH!): created.
+
+ * sys.c repl.c (grow_tok_buf tok_buf tok_buf_len): moved to repl.c
+
+ * repl.c (lfwrite): now emulated for VMS.
+
+ * repl.c scl.c (num_buf): now local to all routines that use it.
+
+ * time.h: created by moving time functions from repl.c. Read and
+ write functions were moved from sys.c to repl.c.
+
+ * sys.c repl.c (DEFER_INTS ALLOW_INTS CHECK_INTS): totally
+ rewritten. SIGALRM and SIGINT now execute at interrupt level.
+ Interrupts deferred only for protected code sections, not for
+ reads and writes.
+
+ * sys.c repl.c (SYSCALL): created to reexecute system calls
+ interrupted (EINTR) by SIGALRM and SIGINT.
+
+ * sys.c scl.c (flo0): 0.0 is now always flo0.
+
+ * repl.c sys.c (TRANSCRIPT-ON TRANSCRIPT-OFF): added. This
+ required shadowing putc, fputs, fwrite, and getc with lputc,
+ lputs, lfwrite, and lgetc.
+
+Sun Apr 5 00:27:33 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
+ * scl.c (eqp lessp greaterp lesseqp greatereqp):
+ Comparisons with inexact numbers was not being performed
+ correctly. For example, (< 1.0 2.0 1.5) would yield #t. What was
+ missing was a line x=y; in the inexact comparison sections of
+ lessp(), greaterp(), lesseqp() and greatereqp(). In addition, I
+ modified these routines and eqp() to allow for mixed arithmetic
+ types.
+
+Sat Apr 4 00:17:29 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h code.doc: tc7_bignum => tc7_spare. Added tc16_bigpos and
+ tc16_bigneg. SMOBS reordered. tc16_record added.
+
+ * scm.h repl.c sys.c (make-arbiter try-arbiter release-arbiter):
+ added. tc16_arbiter added.
+
+Fri Apr 3 01:25:35 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h (TEMPTEMPLATE): created in config.h.
+
+ * scm.h: removed long aliases for C versions of Scheme functions.
+
+ * sys.c eval.c scm.h: (delay force makprom): added. Also added
+ tc16_promise data type.
+
+ * Init.scm (trace untrace): added autoloads and read macros.
+
+ From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
+ * sys.c (template): correct template for VMS.
+
+Tue Mar 31 01:50:12 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h Init.scm (open-file open-pipe): created and
+ expressed other open functions in terms of. Bracketed all i/o
+ system calls with DEFER and ALLOW _SIGINTS.
+
+Sat Mar 28 00:24:01 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c MANUAL (#.): read macro syntax added. Balanced comments
+ also documented.
+
+Fri Mar 27 22:53:26 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (iprin1): changed printed representation for unreadable
+ objects from #[...] to #<...>.
+
+ From: brh@aquila.ahse.cdc.com (brian r hanson x6009):
+ * scm.h config.h (NCELLP PTR_LT): fixes for 64 bit pointers on
+ nosve.
+
+Fri Mar 20 01:36:08 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Released scm3c13
+
+ * code.doc: corrected some minor inconsistencies and added a
+ section "To add a package of new procedures to scm".
+
+Sun Mar 15 19:44:45 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.scm: now loads <program-name>_INIT_PATH when <program-name>
+ is not "SCM".
+
+ * config.h (PTR_LT): (x < y) => ((x) < (y))
+
+Wed Mar 4 01:53:15 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Released scm3c12.
+
+ * scm.h code.doc eval.c sys.c (IXSYM): Eliminated Immediate IXSYM
+ type.
+
+Tue Mar 3 00:58:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c config.c (ceval DEFINED? SYNTAX_EXTENSIONS): added
+ DEFINED? to ceval conditional on SYNTAX_EXTENSIONS.
+
+ From: Andrew Wilcox <andrew@astro.psu.edu>
+ * makefile.unix scm.c (main init_scm display_banner init_signals
+ restore_signals run_scm): RTL support.
+
+Mon Mar 2 19:05:29 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c (make-string): now checks for ARG1 >= 0.
+
+Fri Feb 28 00:13:00 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 12
+
+ * Init.scm: loads JCAL if scm is invoked with name JCAL, JACAL,
+ jcal or jacal.
+
+ * Init.scm (ABS): set to MAGNITUDE if FLOATS are supported.
+
+ * gc_mark gc: no longer assume sizeof(short) == 2.
+
+ * config.h (CELL_UP CELL_DN): no longer assume sizeof(CELL) == 8.
+
+ From: Brian Hanson, Control Data Corporation. brh@ahse.cdc.com
+ * scl.c config.h repl.c: partial port to Control Data NOS/VE.
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * repl.c Init.scm makefile.ast: Port to Atari-ST
+
+ * sys.c scm.h eval.c (throw): renamed to lthrow to avoid conflict
+ with Gnu CC.
+
+Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (delete-file rename-file): added.
+
+ * sys.c (chdir): now returns #f instead of error.
+
+ * Init.scm: Calls to PROVIDED? inlined so no longer dependent on
+ SLIB being loaded. (set! ABS MAGNITUDE) if inexacts supported.
+ Support for slib1b3 added.
+
+ * sys.c (alloc_some_heap): fixed bugs. One fix from
+ bowles@is.s.u-tokyo.ac.jp.
+
+ * eval.c (ceval): fixed bug with internal (define foo bar) where
+ bar is a global. Put badfun2: back in for better error reporting.
+
+ * patchlvl.h (PATCHLEVEL): 11
+
+Mon Jan 20 16:19:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.c (INITS): comments added.
+
+ From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
+ * VMSGCC.COM VMSMAKE.COM: now take arguments.
+
+ From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
+ * makefile.aztec repl.c: Aztec C (makefile) port.
+
+Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc init_storage stack_size): stack_size now of type
+ sizet. init_storage no longer uses it. gc() now uses it instead
+ of pointer to local. This fixes bug with gcc -O.
+
+ * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above
+ fix.
+
+Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (real-part): added.
+
+Wed Jan 15 13:06:39 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
+ * scl.c repl.c scm.c config.c: Port for AMIGA
+
+ * scm.h (REALP): fixed for SINGLES not defined.
+
+Sat Jan 11 20:20:40 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 8 released.
+
+ * README: added hints for EDITING SCHEME CODE.
+
+ * repl.c (SIGRETTYPE): now int for __TURBOC__.
+
+ * makefile.tur makefile.djg: created.
+
+ * config.h: DJGPP (__GO32__) support added.
+
+ * scm.h (memv): definition added.
+
+Sun Jan 5 00:33:44 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c makefile.* (main): INITS added.
+
+ * scl.c: fixed ASSERT statements with mismatched ARGn and
+ arguments.
+
+Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train)
+
+ * sys.c (cons cons2 cons2r): added fix for gcc -O bug.
+
+ * repl.c (LACK_FTIME LACK_TIMES): more messing with these.
+
+ * sys.c config.o (HAVE_PIPE): created.
+
+ * config.h (FLT_RADIX): now #ifdef FLT_RADIX rather than __STDC__.
+ Needed for DJGCC.
+
+ * sys.c (DBLMANT_DIG DBL_FLOAT_DIG): now tested for directly
+ rather than STDC_INCLUDES.
+
+ * makefile.unix (subr.o): explicit compilation line added.
+
+ * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries.
+
+Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (apply): added check for number of args to closures.
+
+Sat Dec 7 01:30:46 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 7
+
+ * sys.c (chdir): THINK_C doesn't support;
+
+ * repl.c: SVR2 needs <time.h> instead of <sys/time.h>
+
+ * repl.c: SVR2 needs LACK_FTIME
+
+ * repl.c: #include <sys/timeb.h> now automatic ifndef LACK_FTIME.
+
+Mon Dec 2 15:42:11 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ * sys.c (intern sysintern): made strings and hash unsigned. Fixed
+ bug with characters > 128 in symbols.
+
+ * scl.c (eqv? memv assv): created if FLOATS is #defined. From
+ boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza).
+
+Mon Dec 2 11:37:11 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 4
+
+ * sys.c (gc_sweep): usaage of pclose() now conditional on unix.
+
+ * MANUAL (chdir): documented.
+
+ from T. Kurt Bond, Adminisoft, Inc. <tkb@MTNET2.WVNET.EDU>:
+
+ * repl.c sys.c (errno): VMS GNU C uses a special hack in <errno.h>
+ to get the link-time attributes for the errno variable to match
+ those the VMS C run-time library expects (it makes errno a
+ preprocessor define so that the variable that the compiler sees
+ has a special form that the assember then interprets), so if it is
+ VMS and __GNUC__ is defined <errno.h> needs included.
+
+ * setjump.h (SETJUMP LONGJUMP): SETJUMP and LONGJUMP changed to
+ setjump and longjump. The VMS linker is case-indifferent. VMS GNU
+ C mangles variable names that have upper case letters in them to
+ preserve their uniqueness.
+
+ * sys.c (iprint iprin1): Now inline putc loops instead of calls to
+ fwrite for VMS. The VMS `fwrite' has been enhanced to work with
+ VMS's Record Management Sevice, RMS. Part of this enhancement is
+ to treat each call to `fwrite' as producing a separate record.
+ This works fine if you are writing to a stream_LF file or an
+ actual terminal screen, but if you are writing to a file that has
+ implied carriage control (such as a batch log file, or a mailbox
+ used for subprocess communication), which is a more common file
+ organization for RMS, each call to `fwrite' has a newline appended
+ to it. This causes much of the output to be incorrectly split
+ across lines.
+
+ * vmsgcc.com: created.
+
+Sun Dec 1 00:33:42 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 3 released.
+
+ * Init.scm (rev2-procedures): all now supported.
+
+ * Init.scm sys.c MANUAL (flush): flush changed to force-output to
+ be compatible with Common Lisp.
+
+ * sys.c (chdir): added.
+
+Wed Nov 27 09:37:20 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 2
+
+ * repl.c (set-errno! perror): added.
+
+ * sys.c (gc): FLUSH_REGISTER_WINDOWS call added.
+
+ * sys.c (open-input-pipe open-output-pipe close-pipe): added.
+
+Mon Nov 25 13:02:13 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 1
+
+ * sys.c (flush): added.
+
+ * repl.c (mytime): macro was missing (). CLKTCK now defaults to 60.
+
+ * README Init.scm subr.c scm.c repl.c scl.c: From Yasuaki Honda,
+ honda@csl.SONY.co.jp, support for Macintosh running Think C.
+
+Sun Nov 24 15:30:51 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (str2flo): fixed parsing of -1-i.
+
+ * repl.c (repl_driver): from jjc@jclark.com, now checks that
+ s_response is non-NULL before INTERNing.
+
+ * subr.c (equal): Now correct for inexacts. Need to do eqv.
+
+ * scm.h (REALPART): fixed pixel C compiler bug with doubles inside
+ `?' conditionals.
+
+ * scl.c (zerop): now checks imaginary half of complex number.
+
+Tue Nov 19 00:10:59 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * version scm3c0
+
+ * documentation: changed revised^3.99 to revised^4.
+
+ * example.scm: created from Scheme^4 spec.
+
+ * makefile.msc: -Ox changed to -Oxp to fix over-enthusiastic float
+ optimizations.
+
+ * Init.scm (ed): defined.
+
+ * repl.c (def_err_response): UNDEFINED objects don't print out.
+
+Sun Nov 17 23:11:03 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (vms-debug): now returns UNSPECIFIED.
+
+ * repl.c MANUAL (restart_repl): RESTART-REPL changed to ABORT.
+
+ * repl.c (err_ctrl_c):now clears sig_pending.
+
+Wed Nov 13 23:51:36 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h: removed #ifdef sparc #define STDC_HEADERS
+
+ * makefile.bor: added extra '\' to filepath.
+
+ * repl.c (everr): fixed bug with ARGx.
+
+ * repl.c (errmsgs def_err_response): cleaned up error messages.
+
+Sun Nov 10 23:10:24 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * released scm3b7
+
+Mon Nov 4 18:36:49 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 6
+
+ * sys.c (idbl2str): tests for Not-a-Number and Infinity added.
+
+ * repl.c scm.h: response system rewritten and integrated with
+ error system.
+
+ * scl.c (/): now returns inexacts if integer arguments do not
+ divide evenly.
+
+Mon Oct 28 23:44:16 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * makefile.unix: can now make float (scm) and integer-only (escm)
+ versions in same directory.
+
+ * repl.c (*sigint-response* *arithmetic-response* restart-repl):
+ responses for signals added.
+
+ * scl.c (lmin lmax sum difference product divide expt exp log):
+ now take mixed types. expt available in non-FLOATS compilation.
+
+ * repl.c (get-decoded-time): added. Includes and time functions
+ reorganized.
+
+ * sys.c (object-hash object-unhash): added.
+
+Tue Oct 15 00:45:35 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c Init.scm (*features*): moved constant features into
+ Init.scm. Moved tests for numeric features to slib/require.scm.
+
+ * release scm3b1.
+
+ * config.h (ANSI_INCLUDES): redid include files.
+
+ * subr.c scl.c: moved all FLOAT conditionals from subr.c to scl.c.
+
+Wed Oct 9 00:28:54 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * release scm3a13.
+
+ * patchlvl.h (PATCHLEVEL): 13
+
+ * Init.scm: "vicinity.scm" changed to "require.scm"
+
+Mon Oct 7 00:34:07 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * test.scm: test of redefining built-in symbol and extra ')'
+ removed.
+
+ * scm.doc makefile.unix: scm.doc created from scm.1 in
+ makefile.unix.
+
+ * VMSBUILD.COM setjump.asm setjump.h (setjmp longjmp jmp_buf): put
+ in from comp.sources.reviewed in order to let VMS have full
+ continuations. VMSBUILD.COM is a compile script.
+
+Fri Oct 4 00:05:54 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c(sleep): removed; not supported by MSC (although could be
+ written).
+
+ * scm.h config.h (size_t): moved to config.h.
+
+ * sys.c (f_getc): -> lgetc for vax, getc otherwise.
+
+ * patchlvl.h (PATCHLEVEL): 12
+
+Mon Sep 30 01:14:48 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c(sleep): created.
+
+ * repl.c(internal-time-units-per-second get=internal-run-time):
+ created
+
+ * repl.c: created from scm.c (shuffled around lots of functions).
+
+Sat Sep 28 00:22:30 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c config.h (char-code-limit most-positive-fixnum
+ most-negative-fixnum): created.
+
+Tue Sep 24 01:21:43 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (software-type); created.
+
+ * scm.c config.h (terms, list-file, library-vicinity,
+ program-vicinity, user-vicinity, make-vicinity, sub-vicinity):
+ moved to Init.scm and library.
+
+ * scm.c config.h Makefile (PROGPATH): changed to IMPLPATH.
+
+ * Init.scm: created
+
+Fri Sep 20 13:22:08 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ * all: changed declarations to size_t where appropriate. scm.h
+ test preprocessor flag _SIZE_T to determine if already declared.
+ size_t should greatly enhance portability to Macintosh and other
+ machines.
+
+Tue Sep 17 01:15:31 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (tmpnam): support for mktemp added.
+
+Mon Sep 16 14:06:26 1991 Aubrey Jaffer (jaffer at train)
+
+ * scm.c (implementation-vicinity): added. (program-vicinity) now
+ returns undefined if called not within a load.
+
+ * sys.c (call-with-io-file): removed.
+
+ * scm.c (tmpnam): added.
+
+ * scm.c config.h (tmporary-vicinity): removed.
+
+Sun Sep 15 22:21:30 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c scm.h (remainder): renamed to lremainder to avoid
+ conflict with math.h on SunOS4.1 (from bevan@cs.man.ac.uk).
+
+Sat Sep 7 22:27:49 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (program-arguments load): program-arguments created.
+
+ * scm.c (getenv): added getenv and used for program-vicinity and
+ library-vicinity.
+
+ * scm.c (program-vicinity): fixed if load_name is NULL.
+
+ * scl.c config.h (substring-move-left! substring-move-right!):
+ added under STR_EXTENSIONS flag.
+
+Wed Aug 28 22:59:20 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * Sending scm3a to comp.sources.reviewed
+
+ * scm.c (main): prints out feature list at startup.
+
+ * subr.c (eqp lessp greaterp lesseqp greatereqp): now work for
+ floats.
+
+ * scl.c (sum difference divide product): moved to scl.c and
+ now work for floats.
+
+ * all: all masks with low bits explicity cast to (int).
+
+Sat Aug 17 00:39:06 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c subr.c scl.c (iint2str istr2int istring2number istr2flo
+ iflo2str idbl2str): number I/O and conversion to strings rewritten.
+
+ * sys.c (gc_mark): continuations now marked SHORT_ALIGNed. (from
+ Craig Lawson).
+
+ * added QuickC support from Craig Lawson.
+
+Tue Jul 30 01:08:52 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h: #ifdef pyr added.
+
+ * scm.c MANUAL: vicinity functions added.
+
+Tue Jul 16 00:51:23 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c sys.c: float functions added.
+
+ * Documentation reorganized according to comp.sources.reviewed
+ guidelines.
+
+ * sys.c config.h (open_input_file open_output_file open_rw_file):
+ file mode string moved to defines in config.h
+
+Thu Jul 11 23:30:03 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h (EBCDIC ASCII) moved to config.h
+
+ * subr.c config.h (BADIVSGNS) moved to config.h
+
+ * scm.h config.h (SRS) moved to config.h
+
+Sun Jul 7 23:49:26 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * all: started adding comp.sources.reviewed corrections and
+ suggestions.
+
+ * scm.c patchlvl.h (main): PATCHLEVEL now printed in banner.
+
+ * subr.c sys.c: read_integer removed. istring2number created.
+ lread and string2number now both use istring2number.
+
+Fri Jun 7 13:43:40 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * VERSION scm2e sent to comp.sources.reviewed
+
+ * public.lic: renamed COPYING.
+
+ * scm.c (gc_status): gc_status renamed prolixity. Now returns old
+ value of verbose. Can take 0 arguments.
+
+ * sys.c (lreadr): added #| common lisp style |# balanced comments.
+
+ * scm.h scm.c sys.c (I/O functions): combined **PORTP and OPENP to
+ become OP**PORTP.
+
+ * scm.h sys.c (gc_sweep): moved OPENP to bit in upper half word of
+ port cells.
+
+Sat May 25 00:04:45 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (stack_start_ptr, repl_driver, main, err functions):
+ exits removed from all err functions. all escapes through
+ repl_driver.
+
+ * scm.c README (verbose): Now has graded verbosity.
+
+ * scm.c README (quit): Now takes optional argument which is return
+ value.
+
+Wed May 22 01:40:17 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * code.doc scm.h eval.c (ceval): Rearanged immediate type codes to
+ create IXSYMs (immediate extension syms) to allow more than 15
+ special forms. ILOCs now work with up to 32767 in one environment
+ frame. Dispatch is slightly faster for ILOCs in function position.
+ ICHRs can be up to 24 bits.
+
+Fri May 10 00:16:32 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c (gc_mark, gc_sweep): GCMARK moved to bit 8 of CAR
+ for some datatypes.
+
+Wed May 1 14:11:05 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patch1 MESSAGE SENT.
+
+ * sys.c (lreadr) from jclark@bugs.specialix.co.uk.jjc: removed
+ order evaluation bug when growing tok_buf.
+
+Fri Apr 26 10:39:41 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm2d RELEASED
+
+ * sys.c (closure) no longer calls ilength (ECONS problem). Added
+ ASSERT before call to closure in eval.
+
+Thu Apr 25 09:53:40 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (error): created.
+
+Wed Apr 24 16:58:06 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * utils.scm: created.
+
+ * makefile (name8s): code from dmason works in makefile.
+
+ * eval.c (evalcar): fixed errobj on (else 3 4) error.
+ Inlined function application in (cond ((foo => fun))).
+
+ * sys.c (lprin1): change looped putcs to fwrite.
+
+Wed Apr 24 01:54:09 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (lreadr): fixed assert for "eof in string".
+
+ * subr.c (lgcd): changed to work with borland C.
+
+ * eval.c (eval): added checks to LAMBDA and LET.
+
+ * eval.c (apply): now checks for null arg1 in lsubr.
+
+Fri Apr 12 00:09:03 1991 Aubrey Jaffer (jaffer at kleph)
+
+ * config.h scm.h (SCMPTR): created to correct address arithmetic
+ on stack bounds under Borland C++. Borland C++ now runs scm2c.
+
+Wed Apr 10 21:38:09 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (open_io_file, cw_io_file, file_position, file_set_pos,
+ read_to_str) created (IO_EXTENSIONS)
+
+ * config.h (IO_EXTENSIONS): defined
+
+ * sys.c scm.c: lprin1f changed to iprin1
+
+Wed Apr 10 12:58:59 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (intern): line 850: for(i = alen;0 <= --i;)changed to
+ for(i = alen;0 < --i;).
+ This fixed b_pos and v_pos mapping to the same symbol.
+
+Wed Apr 4 00:00:00 1991 Aubrey Jaffer (jaffer at kleph.ai.mit.edu)
+
+ * released scm2b
+
+Wed Apr 3 22:51:39 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * all files: eliminated types tc7_subr_2n and tc7_subr_2xn.
+ Replaced with tc7_subr_2o and tc7_subr_1o so that all subr calls
+ can be checked for number of arguments.
+
+Tue Apr 2 23:11:15 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * code.doc: cleaned up.
+
+Mon Apr 1 14:27:22 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (ceval): fixed nasty tail recursion bug at carloop:.
+
+ * scm.c (everr): still fixing error reporting.
+
+ * eval.c subr.c: added flag PURE_FUNCTIONAL which removes side
+ effect special forms and functions.
+
+ * subr.c (substring): now allows first index to be equal to length
+ of string
+
+ * sys.c (lprin1f): dispatches on TYP16 of smobs.
+
+ * scm.h: fixed typo in unused function defs.
+
+Mon Mar 28 00:00:00 1991 Aubrey Jaffer (jaffer at zohar.ai.mit.edu)
+
+ * scm2a released: too many changes to record. See code.doc.
+
+Mon Feb 18 21:48:24 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm.h: types reformatted (TYP6 -> TYP7).
+
+ * eval.c (ceval): Now dispatch directly on ISYMs in ceval.
+
+Fri Feb 15 23:39:48 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * sys.c: #include <malloc.h> not done for VMS
+
+Wed Feb 13 17:49:33 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm.c scl.c: added unsigned declarations to some char *
+ definitions in order to fix characters having negative codes.
+
+ * scm.h (MAKISYM, MAKFLAG, ICHR, MAKICHR, MAKINUM): Now cast to
+ long so that their calls don't have to. Changing MAKICHR fixed
+ problem in scl.c (string2list) on IBMPC.
+
+ * subr.c (quotient): support for `/' reintroduced; required by
+ r3.99rs but not IEEE.
+
+ * subr.c (char functions): added isascii tests for
+ char-alphabetic, char-numeric?, char-whitespace?,
+ char-upper-case?, and char-lower-case?. Added test against
+ char_code_limit to int2char.
+
+ * subr.c (s_char_alphap): is subr_1 not lsubr.
+
+ * test.scm: added tests for char-alphabetic, char-numeric?,
+ char-whitespace?, char-upper-case?, and char-lower-case?.
+
+ * sys.c: most `return;'s eliminated to reduce warning messages.
+ Substituted breaks and reordered switch and if clauses.
+
+Sun Feb 3 23:12:34 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm1-2: released.
+
+ * sys.c (read-char peek-char) added code for EOF.
+
+ * test.scm (leaf-eq?) added and file "cont.scm" removed. I/O
+ tests added.
+
+ * sys.c (I/O functions) now check for input and output ports
+ rather than just ports.
+
+ * sys.c (lprin1f): occurences of stdout changed to f. Newlines
+ after printing port removed.
+
+Thu Jan 31 22:52:39 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * subr.c (quotient): support for `/' removed; not required.
+
+ * scm.c (wta): message for OUTOFRANGE fixed.
+
+Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * eval.c (apply): added checks for number of arguments.
+
+ * scm.h (CHECK_SIGINT): checks for blocked SIGINT.
+
+ * sys.c (lprin1): added blocking and testing for SIGINT so that
+ output won't hang on VMS.
+
+ * scm.c (repl): added fflush call.
+
+ * scm.c (err_head, wta): added fflush calls to error routines so
+ that error message come out in proper order.
+
diff --git a/libguile/ChangeLog-threads b/libguile/ChangeLog-threads
new file mode 100644
index 000000000..1acd8360c
--- /dev/null
+++ b/libguile/ChangeLog-threads
@@ -0,0 +1,251 @@
+Some of the thread support code (threads.c, coop.c, etc.) used to live
+in a separate directory called threads. In April 1997, that dir was
+merged with libguile; this is the ChangeLog from the old directory.
+
+Please put new entries in the ordinary ChangeLog.
+
+Mon Feb 24 21:48:12 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Fri Feb 21 23:52:16 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am (modincludedir, modinclude_HEADERS): Added until
+ libthreads is integrated into libguile, otherwise people who try
+ to use Guile from an independent application will have trouble
+ finding libguile/../threads/threads.h.
+
+Sat Jan 11 18:35:39 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (noinst_HEADERS): Added coop-defs.h so that it gets
+ distributed.
+
+Tue Jan 7 14:05:35 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * coop-defs.h: Added includes which define `time_t'.
+
+Sun Jan 5 15:07:07 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.am (EXTRA_DIST): Add .cvsignore.
+
+ * Makefile.am (libthreads_a_SOURCES): Add threads.h. I think this
+ is right...
+ (noinst_HEADERS): Remove it from here.
+ * Makefile.in: Rebuilt.
+
+Thu Jan 2 15:15:16 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ These changes separates threads declarations which everybody wants
+ to see (coop-defs.h) from declarations internal to the threads
+ module (coop-threads.h), thereby solving the "-I ../qt" problem.
+ (This is not the final solution. All files in the threads
+ directory should be moved into libguile since 1. it is too tightly
+ interconnected with libguile internals to be a separate module and
+ 2. it is actually quite small. When doing this, things can be
+ organized in a more natural way.)
+
+ * coop-defs.h: New file.
+
+ * coop-threads.c: Added #include "coop-threads.h"
+
+ * coop-threads.h: Moved coop_t struct and threads macros to
+ coop-defs.h. Added #include "coop-defs.h".
+
+ * threads.h: Changed #include "coop-threads.h" --> #include
+ "coop-defs.h".
+
+Mon Dec 9 17:20:39 1996 Tom Tromey <tromey@cygnus.com>
+
+ * Makefile.am (.c.x): Use guile-snarf.
+ (INCLUDES): Search for headers in libguile source and build
+ directories.
+
+Mon Dec 2 20:37:07 1996 Tom Tromey <tromey@cygnus.com>
+
+ * PLUGIN/greet: Removed.
+ * Makefile.am, aclocal.m4: New files.
+ * configure.in: Updated for Automake.
+
+Sun Nov 10 18:21:00 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in (uninstall_threads): rmdir -f isn't portable;
+ use rm -rf instead.
+
+Sun Nov 10 17:41:21 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in, configure.in: When threads are disabled,
+ short-circuit the `install' and `uninstall' Makefile targets too.
+
+Sat Nov 2 21:29:33 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * threads.c: Added #include "dynwind.h".
+ Added scheme level procedure `single-active-thread?'.
+
+ * mit-pthreads.c, mit-pthreads.h: Port completed but untested.
+
+ * coop-threads.h: Increased SCM_THREAD_SWITCH_COUNT from 10 to 50
+ to decrease overhead at the cost of granularity.
+
+ * coop.c, coop-threads.h: Made coop_global_runq and
+ coop_global_sleepq visible globally.
+
+ * coop-threads.c (scm_single_thread_p): New function.
+
+Thu Oct 24 22:37:03 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * threads.c: #include "dynwind.h"
+
+ * coop-threads.c (scm_threads_mark_stacks): Removed unused
+ variable.
+
+ * coop.c (coop_qput, coop_all_qput, coop_all_qremove): Removed
+ unused variable.
+
+Wed Oct 9 19:46:00 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in: Doc fixes.
+
+ * Makefile.in (ancillary): Corrected spelling from `ancillery'.
+
+ * Makefile.in (source, h_files, ancillary): Updated to describe
+ the actual contents of the tree.
+ (PLUGIN_distfiles): New variable.
+ (dist-dir): New target, to create a sub-tree of a distribution.
+
+ * Makefile.in (all): Depend on @target_all@ instead of
+ libthreads.a, so the configure script can make this makefile do
+ nothing when threads aren't in use.
+ * configure.in: If we using cooperative threads, then let
+ @target_all@ expand to libthreads.a; otherwise, let it expand to
+ the empty string.
+
+Sat Oct 5 18:40:09 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * threads.c, threads.h (scm_init_threads, scm_threads_init): Added
+ stack base pointer argument so that main thread can be initialized
+ properly.
+
+ * configure.in: Added lines to set default -g flag in CFLAGS and
+ LDFLAGS.
+
+ * coop-threads.c: Added argument checking to scheme level
+ procedures. Change the way threads are launched.
+
+ * threads.h: Added #include "procs.h"
+ Added macros SCM_THREADP, SCM_MUTEXP and SCM_CONDVARP.
+
+Wed Oct 2 14:36:44 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * coop-threads.c (scm_threads_free_thread, scm_threads_free_mutex,
+ scm_threads_free_condvar): free --> scm_must_free
+
+ * coop-threads.h: Added macros SCM_THREAD_LOCAL_DATA and
+ SCM_SET_THREAD_LOCAL_DATA.
+
+Tue Oct 1 00:05:54 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * coop-threads.c (scm_threads_mark_stacks): scm_save_regs_gc_mark
+ is already in root state (should it really?). Don't allocate it
+ locally; Remove extra argument to scm_mark_locations.
+
+ * coop-threads.h: Changed #include <qt.h> --> #include "../qt/qt.h"
+ (SCM_THREAD_INITIALIZE_STORAGE, SCM_DEFER_INTS, SCM_ALLOW_INTS,
+ SCM_REDEFER_INTS, SCM_REALLOW_INTS, scm_coop_create_info_type):
+ Removed; Declaration of scm_coop_create_info removed. Added
+ definition of SCM_THREADS_SWITCHING_CODE.
+
+ * coop-threads.c: Removed gscm_type objects. Renamed all
+ gscm_threads_<type>_die --> scm_threads_free_<type> and let them
+ return freed size as smob freeing code normally does. Removed
+ thread creation mutex and thread creation info structure.
+ (gscm_threads_thread_equal, gscm_pthread_delete_info,
+ scm_threads_init): Removed.
+ (scm_threads_init_coop_threads): Removed allocation of thread
+ local data. Removed initialization of thread creation mutex.
+ Renamed scm_threads_init_coop_threads --> scm_threads_init.
+ (scm_threads_mark_stacks): Mark root object instead of local
+ protects.
+ (launch_thread): thunk and handler is passed as a scheme list.
+ Call scm_with_new_root instead of scm_with_dynamic_root. Let
+ scm_with_new_root care about thread local variables. Removed
+ unlocking of creation mutex.
+ (scm_call_with_new_thread): Remove initialization of create info
+ structure and locking of creation mutex. Do smob allocation.
+ (scm_join_thread): Extract thread data in a new way.
+ (scm_make_mutex): Do smob allocation.
+ (scm_lock_mutex, scm_unlock_mutex): Extract thread data in a new
+ way.
+ (scm_make_condition_variable): Do smob allocation.
+ (scm_wait_condition_variable, scm_signal_condition_variable):
+ Extract thread data in a new way.
+
+ * threads.c: Don't use files "no-threads.[hc]". Removed old code
+ for creation of thread, mutex and condition-variable objects.
+ Added smobs instead. Use scm_threads_free_<type> for freeing.
+ (scm_init_threads): Moved scm_add_feature ("threads") to
+ feature.c.
+
+ * threads.h: Added declaration of scm_init_threads. Added macro
+ selectors SCM_THREAD_DATA, SCM_MUTEX_DATA and SCM_CONDVAR_DATA.
+
+ * coop-threads.c, coop-threads.h, coop.c, fsu-pthreads.h,
+ mit-pthreads.c, mit-pthreads.h, threads.c, threads.h: Replaced
+ "gscm" --> "scm" everywhere. Lots of name changes to concord with
+ new Guile.
+
+Thu Apr 4 10:19:56 1996 Tom Tromey <tromey@creche.cygnus.com>
+
+ Fixed CFLAGS usage:
+ * Makefile.in (XCFLAGS): New macro.
+ (.c.x): Use it.
+ (.c.o): Ditto.
+ * configure.in: Use DEFS, not X_CFLAGS.
+
+Fri Mar 29 17:08:14 1996 Anthony Green <green@snuffle.cygnus.com>
+
+ * no-threads.c (gscm_threads_init_all): This function is now
+ found in libguile.
+
+Fri Mar 29 16:52:27 1996 Tom Tromey <tromey@creche.cygnus.com>
+
+ * configure.in (CFLAGS): Use "test !=", not "! test".
+
+Fri Mar 29 11:51:18 1996 Anthony Green <green@snuffle.cygnus.com>
+
+ * Makefile.in (install): make install now works properly.
+
+Thu Mar 28 07:52:11 1996 Anthony Green <green@csk3.cygnus.com>
+
+ * mit-pthreads.c: dynwinds set to BOOL_T for new threads.
+ Added dummy yield function.
+
+Tue Mar 26 15:17:42 1996 Anthony Green (green@gerbil.cygnus.com)
+
+ * coop.c: Added new sleep() function. Behaves properly
+ among multiple cooperative threads. Replaces system call.
+
+Mon Mar 25 11:05:41 1996 Anthony Green (green@gerbil.cygnus.com)
+
+ * coop.c (COOP_STKSIZE): Boosted default stack size.
+
+ * coop-threads.c: Moved declaration of scm_coop_create_info
+ to avoid multiple definitions at link time.
+
+Sun Mar 24 23:04:29 1996 Anthony Green (green@gerbil.cygnus.com)
+
+ * configure: Rebuilt
+ * configure.in: Upgraded thread library/include support.
+
+Tue Mar 19 12:44:26 1996 Anthony Green (green@gerbil.cygnus.com)
+
+ * coop.c, coop-threads.h coop-threads.c: Major cleanup of
+ cooperative threading code.
+
+Tue Feb 13 15:45:39 1996 Anthony Green <green@hoser.cygnus.com>
+
+ * mit-pthreads.h: Defined pthread aware SCM_DEFER_INTS and friends.
+
+Mon Feb 12 19:59:55 1996 Anthony Green <green@hoser.cygnus.com>
+
+ * threads.c, no-threads.c, mit-pthreads.c, threads.scm: Creation.
+
diff --git a/libguile/DYNAMIC-LINKING b/libguile/DYNAMIC-LINKING
new file mode 100644
index 000000000..78fb4e586
--- /dev/null
+++ b/libguile/DYNAMIC-LINKING
@@ -0,0 +1,188 @@
+Random notes about dynamic linking for Guile. I will update this file
+as I go along. Comments are very welcome. I can be reached at
+mvo@zagadka.ping.de (Marius Vollmer).
+
+The dynamic linking support is mostly untested. I can't test it
+because I don't have all the different platforms, of course. Please
+try it out.
+
+To enable support for dynamic linking in libguile, give the
+
+ --enable-dynamic-linking
+
+option to configure. It is disabled by default because it will
+probably cause lots of problems in its present state. Currently there
+is support for -ldld, -ldl, HP-UX (and VMS, but not really).
+
+Files affected:
+
+ dynl* new
+ configure.in add --enable-dynamic-linking option and checking for
+ system dependencies
+ Makefile.am include dynl* in build and dist.
+ init.c initialize dynamic linking support
+
+Here is my plan with indications of progress.
+
+- port "dynl.c" and maybe some parts of "Link.scm" from SCM to
+ Guile. This should not be difficult, maybe I can even squeeze the
+ VMS code into the "dynl:link", "dyn:call" interface.
+
+* Mostly done, except VMS, and almost completely untested. The -dl
+ support should work, but the rest has not even been compiled.
+
+ The code is in the "dynl*" files. "dynl.c" is the system independent
+ portion and includes the appropriate system dependent file, either
+ "dynl-dld.c", "dynl-dl.c" or "dynl-shl.c".
+
+ I have renamed the SCM names of the functions, because they didnn't
+ fit very well into Guile, the semantics are mostly the same:
+
+ SCM name Guile name
+
+ dynl:link dynamic-link FILENAME
+ dynl:call dynamic-call SYMBOL DYNOBJ
+ dynl:main-call dynamic-args-call SYMBOL DYNOBJ STRING-LIST
+ dynl:unlink dynamic-unlink DYNOBJ
+
+ I plan to generalise dynamic-call and dynamic-args-call to work with
+ arbitrary arguments, so these names are likely to change.
+
+* There's now one new function
+
+ dynamic-func SYMB DYNOBJ
+
+ It determines the address of a function in a dynamic object. The
+ result of this function can be used with `dynamic-call' and
+ `dynamic-args-call' as the SYMBOL.
+
+ PROBLEMS:
+
+ Can tsort cope with blank lines? This situation arises when
+ configure substitutes nothing for @xtra_PLUGIN_guile_libs@.
+
+ You may need to link your application in a special way to make
+ dynamic linking work. For example, on Linux and a statically linked
+ libguile.a, you need -rdynamic to make the libguile symbols
+ available for dynamic linking. The solution is probably to build
+ libguile as a shared library on the systems that support it. Libtool
+ seems to be the right solution.
+
+* Libguile is now build using libtool and it works fine for me.
+
+
+- see how to couple dynamic linking with the module system. Dynamic
+ objects should have a way to specify the module they want to add
+ their bindings to. Extend this to statically linked parts of
+ guile. (i.e. posix could be put into a module and initialized on
+ demand)
+
+* Maybe it will suffice to have scm_make_gsubr, etc to honor the
+ current scm_top_level_lookup_closure and do all the module switching
+ from Scheme.
+
+* I now have modified scm_sysintern to use the lookup procedure when
+ there is one. This is a temporal hack while waiting for the module
+ system to be accessible from C.
+
+
+- use gtcltk as a test case for the above, so that TCL/Tk capabilities
+ can be added to guile at runtime.
+
+* Works.
+
+ When you link libgtcltk into your application and initialize it with
+
+ scm_init_gtcl ();
+ scm_init_gtk ();
+
+ you get the old behaviour. If you initialize it with
+
+ scm_init_ice_9_gtcltk_module ();
+
+ the TCL/Tk functions are made available in a module called
+ #/ice-9/gtcltk.
+
+ When you don't link libgtcltk into your application but put it
+ somewhere in your %load-path, it will be linked dynamically upon the
+ first `:use-module #/ice-9/gtcltk'. Using the %load-path for this
+ is probably not very smart.
+
+ From boot-9:
+
+;;; Dynamic linking of modules
+
+;; Initializing a module that is written in C is a two step process.
+;; First the module's `module init' function is called. This function
+;; is expected to call `scm_register_module_xxx' to register the `real
+;; init' function. Later, when the module is referenced for the first
+;; time, this real init function is called in the right context. See
+;; gtcltk-lib/gtcltk-module.c for an example.
+;;
+;; The code for the module can be in a regular shared library (so that
+;; the `module init' function will be called when libguile is
+;; initialized). Or it can be dynamically linked.
+;;
+;; You can safely call `scm_register_module_xxx' before libguile
+;; itself is initialized. You could call it from an C++ constructor
+;; of a static object, for example.
+;;
+;; To make your Guile extension into a dynamic linkable module, follow
+;; these easy steps:
+;;
+;; - Find a name for your module, like #/ice-9/gtcltk
+;; - Write a function with a name like
+;;
+;; scm_init_ice_9_gtcltk_module
+;;
+;; This is your `module init' function. It should call
+;;
+;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk);
+;;
+;; "ice-9 gtcltk" is the C version of the module name. Slashes are
+;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is
+;; the real init function that executes the usual initilizations
+;; like making new smobs, etc.
+;;
+;; - Make a shared library with your code and a name like
+;;
+;; ice-9/libgtcltk.so
+;;
+;; and put it somewhere in %load-path.
+;;
+;; - Then you can simply write `:use-module #/ice-9/gtcltk' and it
+;; will be linked automatically.
+;;
+;; This is all very experimental.
+
+
+- see how G-Wrap and libffi can work together and extend dyn:call to
+ functions taking arbitrary arguments. Something along the lines
+
+ (define XOpenDisplay (make-foreign-function X11-lib 'XOpenDisplay
+ .. whatever args ..))
+
+* I have received Guile libffi glue code from Anthony Green but I have
+ yet to try it out.
+
+I have no ideas how to support the development of packages for Guile
+that can be dynamically linked into a running application. Maybe
+automake can be used to automate most of the issues.
+
+One nice thing is, however, that developers and users of Guile
+packages have already installed Guile. So we might able to use Scheme
+to describe and handle the build process. I would like that much more
+than the arcane shell based implementations of autoconf, automake,
+etc.
+
+One more random thought about packages: I think it would be an
+advantage if the configuration informations are not contained in a
+bunch of files (like the PLUGIN stuff, or like tclConfig.sh) that have
+to be found and analyzed, but rather can be accessed via a small
+program that can be assumed to be in the PATH. That program (probably
+a shell script, but not necessarily) can be queried about several
+interesting things like prefix and exec_prefix of libguile or told to
+do some tasks like installing a new module (and constructing a new
+guile executable if that is necessary). It might even be used for such
+generic things as uninstalling Guile (or downloading, configuring,
+building and installing the latest version of Guile...)
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
new file mode 100644
index 000000000..802c5d6ea
--- /dev/null
+++ b/libguile/Makefile.am
@@ -0,0 +1,134 @@
+## Process this file with Automake to create Makefile.in
+
+AUTOMAKE_OPTIONS = foreign
+
+## Check for headers in $(srcdir)/.., so that #include
+## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
+## building.
+INCLUDES = -I.. -I$(srcdir)/..
+
+lib_LTLIBRARIES = libguile.la
+
+libguile_la_SOURCES = \
+ alist.c append.c appinit.c arbiters.c async.c boolean.c chars.c \
+ continuations.c dynl.c dynwind.c eq.c error.c eval.c extchrs.c \
+ feature.c filesys.c fports.c gc.c gdbint.c genio.c gh_data.c gh_eval.c \
+ gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c gsubr.c hash.c \
+ hashtab.c init.c ioext.c kw.c list.c load.c mallocs.c markers.c \
+ mbstrings.c net_db.c numbers.c objprop.c options.c pairs.c ports.c \
+ posix.c print.c procprop.c procs.c ramap.c read.c root.c scmsigs.c \
+ sequences.c simpos.c smob.c socket.c stackchk.c stime.c strings.c \
+ strop.c strorder.c strports.c struct.c symbols.c tag.c throw.c unif.c \
+ variable.c vectors.c version.c vports.c weaks.c
+EXTRA_libguile_la_SOURCES = _scm.h \
+ backtrace.c stacks.c debug.c srcprop.c \
+ strerror.c inet_aton.c putenv.c \
+ threads.c
+
+## This is kind of nasty... there are ".c" files that we don't want to
+## compile, since they are #included in threads.c. So instead we list
+## them here. Perhaps we can deal with them normally once the merge
+## seems to be working.
+noinst_HEADERS = coop-threads.c coop-threads.h coop.c
+
+libguile_la_DEPENDENCIES = @LIBLOBJS@
+libguile_la_LIBADD = @LIBLOBJS@
+libguile_la_LDFLAGS = -version-info 0:0 -rpath $(libdir)
+
+include_HEADERS = libguile.h
+
+# These are headers visible as <guile/mumble.h>
+pkginclude_HEADERS = gh.h
+
+# These are headers visible as <libguile/mumble.h>.
+modincludedir = $(includedir)/@module@
+modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \
+ backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h \
+ eq.h error.h eval.h extchrs.h feature.h filesys.h fports.h gc.h \
+ gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h \
+ ioext.h kw.h list.h load.h mallocs.h markers.h mbstrings.h net_db.h \
+ numbers.h objprop.h options.h pairs.h ports.h posix.h print.h \
+ procprop.h procs.h ramap.h read.h root.h scmhob.h scmsigs.h \
+ sequences.h simpos.h smob.h socket.h srcprop.h stackchk.h stacks.h \
+ stime.h strings.h strop.h strorder.h strports.h struct.h symbols.h \
+ tag.h tags.h throw.h unif.h variable.h vectors.h version.h vports.h \
+ weaks.h snarf.h threads.h coop-defs.h
+
+## This file is generated at configure time. That is why it is DATA
+## and not a header -- headers are included in the distribution.
+modinclude_DATA = scmconfig.h
+
+bin_SCRIPTS = guile-snarf
+
+THREAD_LIBS = @THREAD_LIBS@
+check_ldadd = libguile.la ${THREAD_LIBS}
+check_PROGRAMS = gh_test_c gh_test_repl
+gh_test_c_SOURCES = gh_test_c.c
+gh_test_c_LDADD = ${check_ldadd}
+gh_test_repl_SOURCES = gh_test_repl.c
+gh_test_repl_LDADD = ${check_ldadd}
+
+EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \
+ dynl-vms.c DYNAMIC-LINKING PLUGIN/REQ PLUGIN/guile.config \
+ PLUGIN/guile.libs.in cpp_signal.c cpp_errno.c cpp_err_symbols.in \
+ cpp_sig_symbols.in cpp_cnvt.awk \
+ coop-threads.h.cygnus coop-threads.c.cygnus mit-pthreads.h mit-pthreads.c \
+ fsu-pthreads.h
+
+## FIXME: shouldn't directly generate file; instead generate temp file
+## and "mv". Consider using timestamp file as well, to avoid
+## unnecessary rebuilds.
+libpath.h: Makefile
+ echo '/* generated by Makefile */' > libpath.h
+ echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h
+ echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h
+ echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h
+
+SUFFIXES = .x
+.c.x:
+ ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@
+
+## Add -MG to make the .x magic work with auto-dep code.
+MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+
+cpp_err_symbols.c: cpp_err_symbols.in
+ $(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_err_symbols.in > \
+ cpp_err_symbols.c
+
+cpp_sig_symbols.c: cpp_sig_symbols.in
+ $(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_sig_symbols.in > \
+ cpp_sig_symbols.c
+
+## Create a new version of the cpp_sig_symbols.in file, including all SIGXXX
+## macros defined on this platform.
+check_signals:
+ gcc -undef -dM -E $(srcdir)/cpp_signal.c | egrep ' SIG[A-Z]+' \
+ | cut -f2 -d' ' | sort > cpp_sig_symbols_here
+ diff -u $(srcdir)/cpp_sig_symbols.in cpp_sig_symbols_here \
+ | egrep '^\+S' \
+ | cut -c2- > cpp_sig_symbols_diff
+ if test -s cpp_sig_symbols_diff ; then \
+ cat $(srcdir)/cpp_sig_symbols.in cpp_sig_symbols_diff \
+ | sort > cpp_sig_symbols_new ;\
+ echo "cpp_sig_symbols_new has the following additions:" ;\
+ cat cpp_sig_symbols_diff ;\
+ else echo "No new symbols found."; \
+ fi
+
+## Likewise for cpp_err_symbols.in.
+check_errnos:
+ gcc -undef -dM -E $(srcdir)/cpp_errno.c | egrep ' E.+' \
+ | cut -f2 -d' ' | sort > cpp_err_symbols_here
+ diff -u $(srcdir)/cpp_err_symbols.in cpp_err_symbols_here \
+ | egrep '^\+E' \
+ | cut -c2- > cpp_err_symbols_diff
+ if test -s cpp_err_symbols_diff ; then \
+ cat $(srcdir)/cpp_err_symbols.in cpp_err_symbols_diff \
+ | sort > cpp_err_symbols_new ;\
+ echo "cpp_err_symbols_new has the following additions:" ;\
+ cat cpp_err_symbols_diff ;\
+ else echo "No new symbols found."; \
+ fi
+
+CLEANFILES=cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \
+ cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new
diff --git a/libguile/Makefile.in b/libguile/Makefile.in
index d1ed25c4f..cde3c58fe 100644
--- a/libguile/Makefile.in
+++ b/libguile/Makefile.in
@@ -1,984 +1,621 @@
-# @configure_input@
-
-# Copyright (C) 1995 Free Software Foundation, Inc.
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-#
-
-
-#
-# Makefile for libguile
-#
+# Makefile.in generated automatically by automake 1.1n from Makefile.am
-VPATH = @srcdir@
-srcdir = @srcdir@
-SHELL = /bin/sh
+# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
-VERSION=@GUILE_VERSION@
-# Common prefix for machine-independent installed files.
-prefix = @prefix@
+SHELL = /bin/sh
-# Common prefix for machine-dependent installed files.
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+prefix = @prefix@
exec_prefix = @exec_prefix@
-# Directory in which to install init files &c
-libdir = $(exec_prefix)/lib
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = .
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = true
+PRE_INSTALL = true
+POST_INSTALL = true
+NORMAL_UNINSTALL = true
+PRE_UNINSTALL = true
+POST_UNINSTALL = true
+host_alias = @host_alias@
+host_triplet = @host@
+AWK = @AWK@
+CC = @CC@
+LIBLOBJS = @LIBLOBJS@
+LIBTOOL = @LIBTOOL@
+MAINT = @MAINT@
+PACKAGE = @PACKAGE@
+RANLIB = @RANLIB@
+VERSION = @VERSION@
+module = @module@
+xtra_PLUGIN_guile_libs = @xtra_PLUGIN_guile_libs@
+
+AUTOMAKE_OPTIONS = foreign
+
+INCLUDES = -I.. -I$(srcdir)/..
+
+lib_LTLIBRARIES = libguile.la
+
+libguile_la_SOURCES = \
+ alist.c append.c appinit.c arbiters.c async.c boolean.c chars.c \
+ continuations.c dynl.c dynwind.c eq.c error.c eval.c extchrs.c \
+ feature.c filesys.c fports.c gc.c gdbint.c genio.c gh_data.c gh_eval.c \
+ gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c gsubr.c hash.c \
+ hashtab.c init.c ioext.c kw.c list.c load.c mallocs.c markers.c \
+ mbstrings.c net_db.c numbers.c objprop.c options.c pairs.c ports.c \
+ posix.c print.c procprop.c procs.c ramap.c read.c root.c scmsigs.c \
+ sequences.c simpos.c smob.c socket.c stackchk.c stime.c strings.c \
+ strop.c strorder.c strports.c struct.c symbols.c tag.c throw.c unif.c \
+ variable.c vectors.c version.c vports.c weaks.c
+EXTRA_libguile_la_SOURCES = _scm.h \
+ backtrace.c stacks.c debug.c srcprop.c \
+ strerror.c inet_aton.c putenv.c \
+ threads.c
+
+noinst_HEADERS = coop-threads.c coop-threads.h coop.c
+
+libguile_la_DEPENDENCIES = @LIBLOBJS@
+libguile_la_LIBADD = @LIBLOBJS@
+libguile_la_LDFLAGS = -version-info 0:0 -rpath $(libdir)
+
+include_HEADERS = libguile.h
+
+# These are headers visible as <guile/mumble.h>
+pkginclude_HEADERS = gh.h
+
+# These are headers visible as <libguile/mumble.h>.
+modincludedir = $(includedir)/@module@
+modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \
+ backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h \
+ eq.h error.h eval.h extchrs.h feature.h filesys.h fports.h gc.h \
+ gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h \
+ ioext.h kw.h list.h load.h mallocs.h markers.h mbstrings.h net_db.h \
+ numbers.h objprop.h options.h pairs.h ports.h posix.h print.h \
+ procprop.h procs.h ramap.h read.h root.h scmhob.h scmsigs.h \
+ sequences.h simpos.h smob.h socket.h srcprop.h stackchk.h stacks.h \
+ stime.h strings.h strop.h strorder.h strports.h struct.h symbols.h \
+ tag.h tags.h throw.h unif.h variable.h vectors.h version.h vports.h \
+ weaks.h snarf.h threads.h coop-defs.h
+
+modinclude_DATA = scmconfig.h
+
+bin_SCRIPTS = guile-snarf
+
+THREAD_LIBS = @THREAD_LIBS@
+check_ldadd = libguile.la ${THREAD_LIBS}
+check_PROGRAMS = gh_test_c gh_test_repl
+gh_test_c_SOURCES = gh_test_c.c
+gh_test_c_LDADD = ${check_ldadd}
+gh_test_repl_SOURCES = gh_test_repl.c
+gh_test_repl_LDADD = ${check_ldadd}
+
+EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \
+ dynl-vms.c DYNAMIC-LINKING PLUGIN/REQ PLUGIN/guile.config \
+ PLUGIN/guile.libs.in cpp_signal.c cpp_errno.c cpp_err_symbols.in \
+ cpp_sig_symbols.in cpp_cnvt.awk \
+ coop-threads.h.cygnus coop-threads.c.cygnus mit-pthreads.h mit-pthreads.c \
+ fsu-pthreads.h
+
+SUFFIXES = .x
+
+MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+
+CLEANFILES=cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \
+ cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+CONFIG_HEADER_IN = scmconfig.h.in
+CONFIG_HEADER_FULL = scmconfig.h
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_HEADER = scmconfig.h
+CONFIG_CLEAN_FILES = guile-snarf
+LTLIBRARIES = $(lib_LTLIBRARIES)
+
+
+DEFS = @DEFS@ -I. -I$(srcdir) -I.
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+libguile_la_OBJECTS = alist.lo append.lo appinit.lo arbiters.lo \
+async.lo boolean.lo chars.lo continuations.lo dynl.lo dynwind.lo eq.lo \
+error.lo eval.lo extchrs.lo feature.lo filesys.lo fports.lo gc.lo \
+gdbint.lo genio.lo gh_data.lo gh_eval.lo gh_funcs.lo gh_init.lo \
+gh_io.lo gh_list.lo gh_predicates.lo gsubr.lo hash.lo hashtab.lo \
+init.lo ioext.lo kw.lo list.lo load.lo mallocs.lo markers.lo \
+mbstrings.lo net_db.lo numbers.lo objprop.lo options.lo pairs.lo \
+ports.lo posix.lo print.lo procprop.lo procs.lo ramap.lo read.lo \
+root.lo scmsigs.lo sequences.lo simpos.lo smob.lo socket.lo stackchk.lo \
+stime.lo strings.lo strop.lo strorder.lo strports.lo struct.lo \
+symbols.lo tag.lo throw.lo unif.lo variable.lo vectors.lo version.lo \
+vports.lo weaks.lo
+gh_test_c_OBJECTS = gh_test_c.o
+gh_test_c_DEPENDENCIES = libguile.la
+gh_test_c_LDFLAGS =
+gh_test_repl_OBJECTS = gh_test_repl.o
+gh_test_repl_DEPENDENCIES = libguile.la
+gh_test_repl_LDFLAGS =
+SCRIPTS = $(bin_SCRIPTS)
+
+CFLAGS = @CFLAGS@
+COMPILE = $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+LTCOMPILE = $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+LINK = $(LIBTOOL) --mode=link $(CC) $(LDFLAGS) -o $@
+DATA = $(modinclude_DATA)
+
+HEADERS = $(include_HEADERS) $(modinclude_HEADERS) $(noinst_HEADERS) \
+$(pkginclude_HEADERS)
+
+DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in acconfig.h \
+acinclude.m4 aclocal.m4 configure configure.in guile-snarf.in \
+scmconfig.h.in stamp-h.in
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = tar
+GZIP = --best
+DEP_FILES = .deps/alist.P .deps/append.P .deps/appinit.P \
+.deps/arbiters.P .deps/async.P .deps/backtrace.P .deps/boolean.P \
+.deps/chars.P .deps/continuations.P .deps/debug.P .deps/dynl.P \
+.deps/dynwind.P .deps/eq.P .deps/error.P .deps/eval.P .deps/extchrs.P \
+.deps/feature.P .deps/filesys.P .deps/fports.P .deps/gc.P \
+.deps/gdbint.P .deps/genio.P .deps/gh_data.P .deps/gh_eval.P \
+.deps/gh_funcs.P .deps/gh_init.P .deps/gh_io.P .deps/gh_list.P \
+.deps/gh_predicates.P .deps/gh_test_c.P .deps/gh_test_repl.P \
+.deps/gsubr.P .deps/hash.P .deps/hashtab.P .deps/inet_aton.P \
+.deps/init.P .deps/ioext.P .deps/kw.P .deps/list.P .deps/load.P \
+.deps/mallocs.P .deps/markers.P .deps/mbstrings.P .deps/net_db.P \
+.deps/numbers.P .deps/objprop.P .deps/options.P .deps/pairs.P \
+.deps/ports.P .deps/posix.P .deps/print.P .deps/procprop.P \
+.deps/procs.P .deps/putenv.P .deps/ramap.P .deps/read.P .deps/root.P \
+.deps/scmsigs.P .deps/sequences.P .deps/simpos.P .deps/smob.P \
+.deps/socket.P .deps/srcprop.P .deps/stackchk.P .deps/stacks.P \
+.deps/stime.P .deps/strerror.P .deps/strings.P .deps/strop.P \
+.deps/strorder.P .deps/strports.P .deps/struct.P .deps/symbols.P \
+.deps/tag.P .deps/threads.P .deps/throw.P .deps/unif.P .deps/variable.P \
+.deps/vectors.P .deps/version.P .deps/vports.P .deps/weaks.P
+SOURCES = $(libguile_la_SOURCES) $(EXTRA_libguile_la_SOURCES) $(gh_test_c_SOURCES) $(gh_test_repl_SOURCES)
+OBJECTS = $(libguile_la_OBJECTS) $(gh_test_c_OBJECTS) $(gh_test_repl_OBJECTS)
+
+default: all
-# Directory to search by default for included makefiles.
-includedir = $(prefix)/include
+.SUFFIXES:
+.SUFFIXES: .c .o .lo .x
+$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
+ cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile
-# Directory to install `guile' in.
-bindir = $(exec_prefix)/bin
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
+ cd $(top_builddir) \
+ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
+$(srcdir)/aclocal.m4: @MAINT@ configure.in acinclude.m4
+ cd $(srcdir) && $(ACLOCAL)
-INSTALL = $(srcdir)/../install-sh -c
-INSTALL_DATA = $(INSTALL) -m 644
+config.status: configure
+ $(SHELL) ./config.status --recheck
+$(srcdir)/configure: @MAINT@configure.in $(ACLOCAL_M4) $(CONFIGURE_DEPENDENCIES)
+ cd $(srcdir) && $(AUTOCONF)
-# Programs to make tags files.
-ETAGS = etags
-CTAGS = ctags -tw
+$(CONFIG_HEADER): stamp-h
+stamp-h: $(CONFIG_HEADER_IN) $(top_builddir)/config.status
+ cd $(top_builddir) \
+ && CONFIG_FILES= CONFIG_HEADERS=$(CONFIG_HEADER_FULL) \
+ $(SHELL) ./config.status
+ @echo timestamp > stamp-h
+$(srcdir)/$(CONFIG_HEADER_IN): @MAINT@stamp-h.in
+$(srcdir)/stamp-h.in: $(top_srcdir)/configure.in $(ACLOCAL_M4) acconfig.h
+ cd $(top_srcdir) && $(AUTOHEADER)
+ echo timestamp > $(srcdir)/stamp-h.in
-# where the init files are found
-IMPLPATH=$(libdir)/gls/guile
+mostlyclean-hdr:
-# where the Tcl and Tk sources are found
-TCL_SRC_DIR = @TCL_SRC_DIR@
-TK_SRC_DIR = @TK_SRC_DIR@
+clean-hdr:
-# CC
-X11_INCLUDES = @XINCLUDES@
-XFLAGS = @X_CFLAGS@
-CFLAGS = @CFLAGS@
-INCLUDE_CFLAGS = -I. -I$(srcdir) -I$(TCL_SRC_DIR)/generic -I$(TK_SRC_DIR)/generic
-ALL_CFLAGS = $(CFLAGS) $(X_CFLAGS) $(INCLUDE_CFLAGS) $(X11_INCLUDES) -DLIBRARY_PATH=\"$(libdir)/\" @DEFS@
-CC = @CC@ $(ALL_CFLAGS) -Wall
+distclean-hdr:
+ rm -f $(CONFIG_HEADER)
-# CC used as a front end for ld
-LDFLAGS = @LDFLAGS@
-CCLD= $(CC) $(LDFLAGS)
+maintainer-clean-hdr:
+guile-snarf: $(top_builddir)/config.status guile-snarf.in
+ cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status
-# AR
-AR = ar
-AR_FLAGS = rc
-RANLIB = @RANLIB@
+mostlyclean-libLTLIBRARIES:
-# Any extra object files your system needs.
-extras = @LIBOBJS@
-
-libobjs= alist.o \
- append.o \
- appinit.o \
- arbiters.o \
- async.o \
- boolean.o \
- chars.o \
- continuations.o \
- dynwind.o \
- eq.o \
- error.o \
- eval.o \
- extchrs.o \
- fdsocket.o \
- feature.o \
- files.o \
- filesys.o \
- fports.o \
- gc.o \
- genio.o \
- gsubr.o \
- hash.o \
- hashtab.o \
- init.o \
- ioext.o \
- kw.o \
- list.o \
- load.o \
- mallocs.o \
- markers.o \
- markers.o \
- marksweep.o \
- mbstrings.o \
- numbers.o \
- objprop.o \
- pairs.o \
- ports.o \
- posix.o \
- print.o \
- procprop.o \
- procs.o \
- ramap.o \
- read.o \
- root.o \
- scmsigs.o \
- sequences.o \
- simpos.o \
- smob.o \
- socket.o \
- stackchk.o \
- stime.o \
- strings.o \
- strop.o \
- strorder.o \
- strports.o \
- struct.o \
- symbols.o \
- tag.o \
- throw.o \
- unif.o \
- variable.o \
- vectors.o \
- vports.o \
- weaks.o \
- $(extras)
-
-
-uninstalled_h_files= _scm.h __scm.hd
-
-installed_h_files= __scm.h \
- alist.h \
- append.h \
- arbiters.h \
- async.h \
- boolean.h \
- chars.h \
- continuations.h \
- dynwind.h \
- eq.h \
- error.h \
- eval.h \
- extchrs.h \
- fdsocket.h \
- feature.h \
- fports.h \
- files.h \
- filesys.h \
- gc.h \
- genio.h \
- gsubr.h \
- hash.h \
- hashtab.h \
- init.h \
- ioext.h \
- kw.h \
- list.h \
- load.h \
- libguile.h \
- mallocs.h \
- markers.h \
- marksweep.h \
- markers.h \
- mbstrings.h \
- numbers.h \
- objprop.h \
- pairs.h \
- ports.h \
- posix.h \
- params.h \
- print.h \
- procs.h \
- procprop.h \
- ramap.h \
- read.h \
- root.h \
- scmsigs.h \
- sequences.h \
- simpos.h \
- smob.h \
- socket.h \
- stackchk.h \
- strports.h \
- struct.h \
- symbols.h \
- tag.h \
- stime.h \
- tags.h \
- variable.h \
- vectors.h \
- vports.h \
- weaks.h \
- unif.h \
- scmhob.h \
- strings.h \
- strop.h \
- strorder.h \
- throw.h \
- unif.h
-
-h_files=$(uninstalled_h_files) $(installed_h_files)
-
-c_files= alist.c \
- append.c \
- appinit.c \
- arbiters.c \
- async.c \
- boolean.c \
- chars.c \
- continuations.c \
- dynwind.c \
- eq.c \
- error.c \
- eval.c \
- extchrs.c \
- fdsocket.c \
- feature.c \
- files.c \
- filesys.c \
- fports.c \
- gc.c \
- genio.c \
- gsubr.c \
- hash.c \
- hashtab.c \
- inet_aton.c \
- init.c \
- ioext.c \
- kw.c \
- list.c \
- load.c \
- mallocs.c \
- markers.c \
- markers.c \
- marksweep.c \
- mbstrings.c \
- numbers.c \
- objprop.c \
- pairs.c \
- ports.c \
- posix.c \
- print.c \
- procprop.c \
- procs.c \
- ramap.c \
- read.c \
- root.c \
- scmsigs.c \
- sequences.c \
- simpos.c \
- smob.c \
- socket.c \
- stackchk.c \
- stime.c \
- strings.c \
- strop.c \
- strorder.c \
- strports.c \
- struct.c \
- symbols.c \
- tag.c \
- throw.c \
- unif.c \
- variable.c \
- vectors.c \
- vports.c \
- weaks.c
-
-gen_c_files= alist.x \
- append.x \
- arbiters.x \
- async.x \
- boolean.x \
- chars.x \
- continuations.x \
- dynwind.x \
- eq.x \
- error.x \
- eval.x \
- extchrs.x \
- fdsocket.x \
- feature.x \
- files.x \
- filesys.x \
- fports.x \
- gc.x \
- genio.x \
- gsubr.x \
- hash.x \
- hashtab.x \
- init.x \
- ioext.x \
- kw.x \
- list.x \
- load.x \
- mallocs.x \
- markers.x \
- marksweep.x \
- mbstrings.x \
- numbers.x \
- objprop.x \
- pairs.x \
- ports.x \
- posix.x \
- print.x \
- procprop.x \
- procs.x \
- ramap.x \
- read.x \
- root.x \
- scmsigs.x \
- sequences.x \
- simpos.x \
- smob.x \
- socket.x \
- stackchk.x \
- stime.x \
- strings.x \
- strop.x \
- strorder.x \
- strports.x \
- struct.x \
- symbols.x \
- tag.x \
- throw.x \
- unif.x \
- variable.x \
- vectors.x \
- vports.x \
- weaks.x
-
-
-
-ancillery = gscm.c \
- gscm.h \
- COPYING \
- ChangeLog \
- ChangeLog.scm \
- Makefile.in \
- PLUGIN \
- acconfig-1.5.h \
- configure \
- configure.in \
- def.sed \
- scmconfig.h.in \
- fd.h.in \
- ../doc/guile.texi \
- ../doc/guile.ps \
- ../doc/guile.info \
- ../doc/guile.info-1 \
- ../doc/guile.info-2 \
- ../doc/guile.info-3 \
- ../doc/guile.info-4 \
- ../doc/guile.info-5 \
- ../doc/in.texi \
- ../doc/in.info \
- ../doc/in.ps \
- ../doc/agenda \
- ../doc/texinfo.tex
-
-
-c_sources = $(c_files) $(h_files)
-manifest = $(ancillery) $(c_sources)
+clean-libLTLIBRARIES:
+ test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES)
+distclean-libLTLIBRARIES:
-.SUFFIXES:
-.SUFFIXES: .o .c .h .ps .dvi .info .texinfo .scm .cd .x .hd
-
-.cd.c:
- ( echo "/* DO NOT EDIT --- AUTO-GENERATED --- DO NOT EDIT */" > $@ \
- && echo -n "#line 1" \" \
- && echo $<\" | sed -e "s,^.*/,," >> $@ \
- && sed -f $(srcdir)/def.sed $< >> $@) \
- || rm -f $@
-
-.hd.h:
- ( echo "/* DO NOT EDIT --- AUTO-GENERATED --- DO NOT EDIT */" > $@ \
- && echo -n "#line 1" \" >> $@ \
- && echo $<\" | sed -e "s,^.*/,," >> $@ \
- && sed -f $(srcdir)/def.sed $< >> $@) \
- || rm -f $@
+maintainer-clean-libLTLIBRARIES:
-.c.x:
- if test ! -escmconfig.h ; then \
- touch scmconfig.h; \
- fake_scmconfig=1; \
- else \
- fake_scmconfig=0; \
- fi; \
- $(CC) $(ALL_CFLAGS) -I. -DSCM_MAGIC_SNARFER -E $< | grep "^%%%" | sed -e "s/^%%%//" > $@ ; \
- if test $$fake_scmconfig -eq 1 ; then \
- rm scmconfig.h; \
- fi
+install-libLTLIBRARIES: $(lib_LTLIBRARIES)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(libdir)
+ @list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ if test -f $$p; then \
+ echo "$(LIBTOOL) --mode=install $(INSTALL_PROGRAM) $$p $(libdir)/$$p"; \
+ $(LIBTOOL) --mode=install $(INSTALL_PROGRAM) $$p $(libdir)/$$p; \
+ else :; fi; \
+ done
+
+uninstall-libLTLIBRARIES:
+ $(NORMAL_UNINSTALL)
+ list='$(lib_LTLIBRARIES)'; for p in $$list; do \
+ $(LIBTOOL) --mode=uninstall rm -f $(libdir)/$$p; \
+ done
+
+.c.o:
+ $(COMPILE) -c $<
+
+mostlyclean-compile:
+ rm -f *.o core
+
+clean-compile:
+
+distclean-compile:
+ rm -f *.tab.c
+
+maintainer-clean-compile:
+
+.c.lo:
+ $(LIBTOOL) --mode=compile $(COMPILE) -c $<
+
+mostlyclean-libtool:
+ rm -f *.lo
+
+clean-libtool:
+ rm -rf .libs
+
+distclean-libtool:
+
+maintainer-clean-libtool:
-.PHONY: all
-all: libguile.a
+libguile.la: $(libguile_la_OBJECTS) $(libguile_la_DEPENDENCIES)
+ $(LINK) -rpath $(libdir) $(libguile_la_LDFLAGS) $(libguile_la_OBJECTS) $(libguile_la_LIBADD) $(LIBS)
-SUBDIR=.
-manifest:
- for file in $(manifest) ; \
- do echo $(SUBDIR)/$$file ; \
+mostlyclean-checkPROGRAMS:
+
+clean-checkPROGRAMS:
+ test -z "$(check_PROGRAMS)" || rm -f $(check_PROGRAMS)
+
+distclean-checkPROGRAMS:
+
+maintainer-clean-checkPROGRAMS:
+
+gh_test_c: $(gh_test_c_OBJECTS) $(gh_test_c_DEPENDENCIES)
+ @rm -f gh_test_c
+ $(LINK) $(gh_test_c_LDFLAGS) $(gh_test_c_OBJECTS) $(gh_test_c_LDADD) $(LIBS)
+
+gh_test_repl: $(gh_test_repl_OBJECTS) $(gh_test_repl_DEPENDENCIES)
+ @rm -f gh_test_repl
+ $(LINK) $(gh_test_repl_LDFLAGS) $(gh_test_repl_OBJECTS) $(gh_test_repl_LDADD) $(LIBS)
+
+install-binSCRIPTS: $(bin_SCRIPTS)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(bindir)
+ @list='$(bin_SCRIPTS)'; for p in $$list; do \
+ if test -f $$p; then \
+ echo " $(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`"; \
+ $(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`; \
+ else if test -f $(srcdir)/$$p; then \
+ echo " $(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`"; \
+ $(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`; \
+ else :; fi; fi; \
+ done
+
+uninstall-binSCRIPTS:
+ $(NORMAL_UNINSTALL)
+ list='$(bin_SCRIPTS)'; for p in $$list; do \
+ rm -f $(bindir)/`echo $$p|sed '$(transform)'`; \
+ done
+
+install-modincludeDATA: $(modinclude_DATA)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(modincludedir)
+ @list='$(modinclude_DATA)'; for p in $$list; do \
+ if test -f $(srcdir)/$$p; then \
+ echo " $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \
+ $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \
+ else if test -f $$p; then \
+ echo " $(INSTALL_DATA) $$p $(modincludedir)/$$p"; \
+ $(INSTALL_DATA) $$p $(modincludedir)/$$p; \
+ fi; fi; \
+ done
+
+uninstall-modincludeDATA:
+ $(NORMAL_UNINSTALL)
+ list='$(modinclude_DATA)'; for p in $$list; do \
+ rm -f $(modincludedir)/$$p; \
+ done
+
+install-includeHEADERS: $(include_HEADERS)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(includedir)
+ @list='$(include_HEADERS)'; for p in $$list; do \
+ echo " $(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p"; \
+ $(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p; \
done
-libguile.a: $(libobjs)
- rm -f libguile.a
- $(AR) $(AR_FLAGS) libguile.a $(libobjs)
- $(RANLIB) libguile.a
-
-install: all
- test -d $(prefix) || mkdir $(prefix)
- test -d $(libdir) || mkdir $(libdir)
- test -d $(includedir) || mkdir $(includedir)
- test -d $(includedir)/guile$(VERSION) || mkdir $(includedir)/guile$(VERSION)
- $(INSTALL_DATA) libguile.a $(libdir)/libguile$(VERSION).a
- $(RANLIB) $(libdir)/libguile$(VERSION).a
- $(INSTALL_DATA) scmconfig.h $(includedir)/guile$(VERSION)
- for h in $(h_files); do \
- $(INSTALL_DATA) $(srcdir)/$$h $(includedir)/guile$(VERSION); \
+uninstall-includeHEADERS:
+ $(NORMAL_UNINSTALL)
+ list='$(include_HEADERS)'; for p in $$list; do \
+ rm -f $(includedir)/$$p; \
done
-uninstall:
- -for h in $(h_files); do \
- rm -f $(includedir)/guile$(VERSION)/$$h; \
+install-modincludeHEADERS: $(modinclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(modincludedir)
+ @list='$(modinclude_HEADERS)'; for p in $$list; do \
+ echo " $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \
+ $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \
done
- rm -f $(includedir)/guile$(VERSION)/scmconfig.h
- -rmdir $(includedir)/guile$(VERSION)
- -rm $(libdir)/libguile$(VERSION).a
+uninstall-modincludeHEADERS:
+ $(NORMAL_UNINSTALL)
+ list='$(modinclude_HEADERS)'; for p in $$list; do \
+ rm -f $(modincludedir)/$$p; \
+ done
+
+install-pkgincludeHEADERS: $(pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(pkgincludedir)
+ @list='$(pkginclude_HEADERS)'; for p in $$list; do \
+ echo " $(INSTALL_DATA) $(srcdir)/$$p $(pkgincludedir)/$$p"; \
+ $(INSTALL_DATA) $(srcdir)/$$p $(pkgincludedir)/$$p; \
+ done
+
+uninstall-pkgincludeHEADERS:
+ $(NORMAL_UNINSTALL)
+ list='$(pkginclude_HEADERS)'; for p in $$list; do \
+ rm -f $(pkgincludedir)/$$p; \
+ done
+
+tags: TAGS
+
+ID: $(HEADERS) $(SOURCES)
+ here=`pwd` && cd $(srcdir) && mkid -f$$here/ID $(SOURCES) $(HEADERS)
+
+TAGS: $(HEADERS) $(SOURCES) scmconfig.h.in $(TAGS_DEPENDENCIES)
+ tags=; \
+ here=`pwd`; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \
+ done; \
+ test -z "$(ETAGS_ARGS)scmconfig.h.in$(SOURCES)$(HEADERS)$$tags" \
+ || (cd $(srcdir) && etags $(ETAGS_ARGS) $$tags scmconfig.h.in $(SOURCES) $(HEADERS) -o $$here/TAGS)
+
+mostlyclean-tags:
+
+clean-tags:
+
+distclean-tags:
+ rm -f TAGS ID
+
+maintainer-clean-tags:
+
+distdir = $(PACKAGE)-$(VERSION)
+# This target untars the dist file and tries a VPATH configuration. Then
+# it guarantees that the distribution is self-contained by making another
+# tarfile.
+distcheck: dist
+ rm -rf $(distdir)
+ GZIP=$(GZIP) $(TAR) zxf $(distdir).tar.gz
+ mkdir $(distdir)/=build
+ mkdir $(distdir)/=inst
+ dc_install_base=`cd $(distdir)/=inst && pwd`; \
+ cd $(distdir)/=build \
+ && ../configure --srcdir=.. --prefix=$$dc_install_base \
+ && $(MAKE) \
+ && $(MAKE) dvi \
+ && $(MAKE) check \
+ && $(MAKE) install \
+ && $(MAKE) installcheck \
+ && $(MAKE) dist
+ rm -rf $(distdir)
+ @echo "========================"; \
+ echo "$(distdir).tar.gz is ready for distribution"; \
+ echo "========================"
+dist: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+dist-all: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+distdir: $(DISTFILES)
+ rm -rf $(distdir)
+ mkdir $(distdir)
+ -chmod 755 $(distdir)
+ here=`pwd`; distdir=`cd $(distdir) && pwd` \
+ && cd $(srcdir) \
+ && $(AUTOMAKE) --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign
+ $(mkinstalldirs) $(distdir)/PLUGIN
+ @for file in $(DISTFILES); do \
+ d=$(srcdir); \
+ test -f $(distdir)/$$file \
+ || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+ || cp -p $$d/$$file $(distdir)/$$file; \
+ done
+.deps/.P:
+ test -d .deps || mkdir .deps
+ echo > $@
-TAGS:
- etags $(c_sources)
+-include $(DEP_FILES)
+$(DEP_FILES): .deps/.P
+mostlyclean-depend:
+clean-depend:
+
+distclean-depend:
+
+maintainer-clean-depend:
+ rm -rf .deps
+
+.deps/%.P: $(srcdir)/%.c
+ @echo "Computing dependencies for $<..."
+ @o='o'; \
+ test -n "$o" && o='$$o'; \
+ $(MKDEP) $< | sed "s,^\(.*\)\.o:,\1.$$o \1.l$$o $@:," > $@
info:
+dvi:
+check: all $(check_PROGRAMS)
+ $(MAKE)
+installcheck:
+install-exec: install-libLTLIBRARIES install-binSCRIPTS
+ @$(NORMAL_INSTALL)
+
+install-data: install-modincludeDATA install-includeHEADERS install-modincludeHEADERS install-pkgincludeHEADERS
+ @$(NORMAL_INSTALL)
+
+install: install-exec install-data all
+ @:
+
+uninstall: uninstall-libLTLIBRARIES uninstall-binSCRIPTS uninstall-modincludeDATA uninstall-includeHEADERS uninstall-modincludeHEADERS uninstall-pkgincludeHEADERS
+
+all: $(LTLIBRARIES) $(SCRIPTS) $(DATA) $(HEADERS) Makefile scmconfig.h
+
+install-strip:
+ $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
+installdirs:
+ $(mkinstalldirs) $(libdir) $(bindir) $(modincludedir) $(includedir) \
+ $(modincludedir) $(pkgincludedir)
+
+
+mostlyclean-generic:
+ test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
+
+clean-generic:
+ test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ rm -f Makefile $(DISTCLEANFILES)
+ rm -f config.cache config.log stamp-h
+ test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+
+maintainer-clean-generic:
+ test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+ test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+mostlyclean: mostlyclean-hdr mostlyclean-libLTLIBRARIES \
+ mostlyclean-compile mostlyclean-libtool \
+ mostlyclean-checkPROGRAMS mostlyclean-tags \
+ mostlyclean-depend mostlyclean-generic
+
+clean: clean-hdr clean-libLTLIBRARIES clean-compile clean-libtool \
+ clean-checkPROGRAMS clean-tags clean-depend \
+ clean-generic mostlyclean
+
+distclean: distclean-hdr distclean-libLTLIBRARIES distclean-compile \
+ distclean-libtool distclean-checkPROGRAMS \
+ distclean-tags distclean-depend distclean-generic clean
+ rm -f config.status
+ rm -f libtool
+
+maintainer-clean: maintainer-clean-hdr maintainer-clean-libLTLIBRARIES \
+ maintainer-clean-compile maintainer-clean-libtool \
+ maintainer-clean-checkPROGRAMS maintainer-clean-tags \
+ maintainer-clean-depend maintainer-clean-generic \
+ distclean
+ @echo "This command is intended for maintainers to use;"
+ @echo "it deletes files that may require special tools to rebuild."
+ rm -f config.status
+
+.PHONY: default mostlyclean-hdr distclean-hdr clean-hdr \
+maintainer-clean-hdr mostlyclean-libLTLIBRARIES \
+distclean-libLTLIBRARIES clean-libLTLIBRARIES \
+maintainer-clean-libLTLIBRARIES uninstall-libLTLIBRARIES \
+install-libLTLIBRARIES mostlyclean-compile distclean-compile \
+clean-compile maintainer-clean-compile mostlyclean-libtool \
+distclean-libtool clean-libtool maintainer-clean-libtool \
+mostlyclean-checkPROGRAMS distclean-checkPROGRAMS clean-checkPROGRAMS \
+maintainer-clean-checkPROGRAMS uninstall-binSCRIPTS install-binSCRIPTS \
+uninstall-modincludeDATA install-modincludeDATA \
+uninstall-includeHEADERS install-includeHEADERS \
+uninstall-modincludeHEADERS install-modincludeHEADERS \
+uninstall-pkgincludeHEADERS install-pkgincludeHEADERS tags \
+mostlyclean-tags distclean-tags clean-tags maintainer-clean-tags \
+distdir mostlyclean-depend distclean-depend clean-depend \
+maintainer-clean-depend info dvi installcheck install-exec install-data \
+install uninstall all installdirs mostlyclean-generic distclean-generic \
+clean-generic maintainer-clean-generic clean mostlyclean distclean \
+maintainer-clean
+
+
+libpath.h: Makefile
+ echo '/* generated by Makefile */' > libpath.h
+ echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h
+ echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h
+ echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h
+.c.x:
+ ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@
+
+cpp_err_symbols.c: cpp_err_symbols.in
+ $(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_err_symbols.in > \
+ cpp_err_symbols.c
+
+cpp_sig_symbols.c: cpp_sig_symbols.in
+ $(AWK) -f $(srcdir)/cpp_cnvt.awk < $(srcdir)/cpp_sig_symbols.in > \
+ cpp_sig_symbols.c
+
+check_signals:
+ gcc -undef -dM -E $(srcdir)/cpp_signal.c | egrep ' SIG[A-Z]+' \
+ | cut -f2 -d' ' | sort > cpp_sig_symbols_here
+ diff -u $(srcdir)/cpp_sig_symbols.in cpp_sig_symbols_here \
+ | egrep '^\+S' \
+ | cut -c2- > cpp_sig_symbols_diff
+ if test -s cpp_sig_symbols_diff ; then \
+ cat $(srcdir)/cpp_sig_symbols.in cpp_sig_symbols_diff \
+ | sort > cpp_sig_symbols_new ;\
+ echo "cpp_sig_symbols_new has the following additions:" ;\
+ cat cpp_sig_symbols_diff ;\
+ else echo "No new symbols found."; \
+ fi
+
+check_errnos:
+ gcc -undef -dM -E $(srcdir)/cpp_errno.c | egrep ' E.+' \
+ | cut -f2 -d' ' | sort > cpp_err_symbols_here
+ diff -u $(srcdir)/cpp_err_symbols.in cpp_err_symbols_here \
+ | egrep '^\+E' \
+ | cut -c2- > cpp_err_symbols_diff
+ if test -s cpp_err_symbols_diff ; then \
+ cat $(srcdir)/cpp_err_symbols.in cpp_err_symbols_diff \
+ | sort > cpp_err_symbols_new ;\
+ echo "cpp_err_symbols_new has the following additions:" ;\
+ cat cpp_err_symbols_diff ;\
+ else echo "No new symbols found."; \
+ fi
-clean:
- -rm -f libguile.a
- -rm -f $(libobjs)
- -rm -f $(gen_c_files)
-
-distclean: clean
- -rm -f config.cache
- -rm -f config.log
- -rm -f config.status
- -rm -f Makefile
- -rm -f scmconfig.h
-
-
-realclean: distclean
- -rm -f $(gen_c_files)
- -rm -f scmconfig.h
-
-xfiles: $(gen_c_files)
-
-DEPENDS_CFLAGS=
-
-depends:
- touch scmconfig.h
- touch $(gen_c_files)
- gcc -MM -I. $(DEPENDS_CFLAGS) $(c_files)
- rm $(gen_c_files)
- rm scmconfig.h
-
-$(srcdir)/__scm.h: __scm.hd
-
-###
-alist.o : alist.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h alist.x
-append.o : append.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h append.x
-appinit.o : appinit.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h
-arbiters.o : arbiters.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h arbiters.x
-async.o : async.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h async.x
-boolean.o : boolean.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h boolean.x
-chars.o : chars.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h chars.x
-continuations.o : continuations.c _scm.h libguile.h __scm.h tags.h smob.h params.h \
- alist.h append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h \
- eq.h error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h \
- fports.h gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h \
- kw.h list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h \
- print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h \
- socket.h stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h \
- tag.h throw.h unif.h variable.h vectors.h vports.h weaks.h continuations.x
-dynwind.o : dynwind.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h dynwind.x
-eq.o : eq.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h eq.x
-error.o : error.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h error.x
-eval.o : eval.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h eval.x
-extchrs.o : extchrs.c extchrs.h
-fdsocket.o : fdsocket.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h fdsocket.x
-feature.o : feature.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h feature.x
-files.o : files.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h files.x
-filesys.o : filesys.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h filesys.x
-fports.o : fports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h fports.x
-gc.o : gc.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h gc.x
-genio.o : genio.c extchrs.h _scm.h libguile.h __scm.h tags.h smob.h params.h \
- alist.h append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h \
- eq.h error.h pairs.h eval.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h
-gsubr.o : gsubr.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h
-hash.o : hash.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h hash.x
-hashtab.o : hashtab.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h hashtab.x
-inet_aton.o : inet_aton.c
-init.o : init.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h
-ioext.o : ioext.c ioext.x
-kw.o : kw.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h kw.x
-list.o : list.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h list.x
-load.o : load.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h load.x
-mallocs.o : mallocs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h
-markers.o : markers.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h
-markers.o : markers.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h
-marksweep.o : marksweep.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h
-mbstrings.o : mbstrings.c extchrs.h _scm.h libguile.h __scm.h tags.h smob.h \
- params.h alist.h append.h arbiters.h async.h boolean.h chars.h continuations.h \
- dynwind.h eq.h error.h pairs.h eval.h fdsocket.h feature.h files.h filesys.h \
- fports.h gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h \
- kw.h list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h \
- print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h \
- socket.h stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h \
- tag.h throw.h unif.h variable.h vectors.h vports.h weaks.h mbstrings.x
-numbers.o : numbers.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h numbers.x
-objprop.o : objprop.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h objprop.x
-pairs.o : pairs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h pairs.x
-ports.o : ports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h ports.x
-posix.o : posix.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h posix.x
-print.o : print.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h print.x
-procprop.o : procprop.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h procprop.x
-procs.o : procs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h procs.x
-ramap.o : ramap.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h ramap.x
-read.o : read.c extchrs.h _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h read.x
-root.o : root.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h
-scmsigs.o : scmsigs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h scmsigs.x
-sequences.o : sequences.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h sequences.x
-simpos.o : simpos.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h simpos.x
-smob.o : smob.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h
-socket.o : socket.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h socket.x
-stackchk.o : stackchk.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h stackchk.x
-stime.o : stime.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h stime.x
-strings.o : strings.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h strings.x
-strop.o : strop.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h strop.x
-strorder.o : strorder.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h strorder.x
-strports.o : strports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h strports.x
-struct.o : struct.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h struct.x
-symbols.o : symbols.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h symbols.x
-tag.o : tag.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h tag.x
-throw.o : throw.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h throw.x
-unif.o : unif.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h unif.x
-variable.o : variable.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h variable.x
-vectors.o : vectors.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h vectors.x
-vports.o : vports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \
- append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \
- error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \
- gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \
- list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \
- procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \
- stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \
- unif.h variable.h vectors.h vports.h weaks.h vports.x
-weaks.o : weaks.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \
- arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \
- pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \
- marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \
- load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \
- procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \
- stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
- variable.h vectors.h vports.h weaks.h weaks.x
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/libguile/__scm.h b/libguile/__scm.h
index e3c5772ca..52d175ead 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -1,5 +1,3 @@
-/* DO NOT EDIT --- AUTO-GENERATED --- DO NOT EDIT */
-#line 1 "__scm.hd"
/* classes: h_files */
#ifndef __SCMH
@@ -97,21 +95,22 @@
/* {Unsupported Options}
*
- * These must be defined.
+ * These must be defined as given here.
*/
#define CCLO
-#define SICP
+
+/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We
+ have horrible plans for their unification. */
+#undef SICP
-/* Random options (net yet supported or in final form). */
+/* Random options (not yet supported or in final form). */
-#undef DEBUG_EXTENSIONS
-#undef READER_EXTENSIONS
-#undef SCM_STACK_LIMIT 20000
-#undef NO_CEVAL_STACK_CHECK
+#define STACK_CHECKING
+#undef NO_CEVAL_STACK_CHECKING
#undef LONGLONGS
/* Some auto-generated .h files contain unused prototypes
@@ -122,20 +121,36 @@ typedef unsigned long ulong_long;
+/* What did the configure script discover about the outside world? */
+#include "libguile/scmconfig.h"
+
+
+/* Write prototype declarations like this:
+ int foo SCM_P ((int a, int b));
+ At definitions, use K&R style declarations, but make sure there's a
+ declarative prototype (as above) in scope. This will give you
+ argument type checking, when available, and be harmless otherwise. */
+#ifdef __STDC__
+# define SCM_P(x) x
+#else
+# define SCM_P(x) ()
+#endif
+
+
/* Define
*
- * SCM_CHAR_SCM_CODE_LIMIT == UCHAR_MAX + 1
+ * SCM_CHAR_CODE_LIMIT == UCHAR_MAX + 1
* SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2)
* SCM_MOST_NEGATIVE_FIXNUM == SCM_SRS((long)LONG_MIN, 2)
*/
-#ifdef HAVE_LIMITSH
+#ifdef HAVE_LIMITS_H
# include <limits.h>
# ifdef UCHAR_MAX
-# define SCM_CHAR_SCM_CODE_LIMIT (UCHAR_MAX+1L)
+# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX+1L)
# else
-# define SCM_CHAR_SCM_CODE_LIMIT 256L
+# define SCM_CHAR_CODE_LIMIT 256L
# endif /* def UCHAR_MAX */
# define SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2)
# ifdef _UNICOS /* Stupid cray bug */
@@ -144,18 +159,33 @@ typedef unsigned long ulong_long;
# define SCM_MOST_NEGATIVE_FIXNUM SCM_SRS((long)LONG_MIN, 2)
# endif /* UNICOS */
#else
-# define SCM_CHAR_SCM_CODE_LIMIT 256L
+# define SCM_CHAR_CODE_LIMIT 256L
# define SCM_MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3))
# if (0 != ~0)
# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1)
# else
# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM)
# endif /* (0 != ~0) */
-#endif /* def HAVE_LIMITSH */
+#endif /* def HAVE_LIMITS_H */
-#include <scmconfig.h>
-#include "tags.h"
+#ifdef STDC_HEADERS
+# include <stdlib.h>
+# ifdef AMIGA
+# include <stddef.h>
+# endif /* def AMIGA */
+# define scm_sizet size_t
+#else
+# ifdef _SIZE_T
+# define scm_sizet size_t
+# else
+# define scm_sizet unsigned int
+# endif /* def _SIZE_T */
+#endif /* def STDC_HEADERS */
+
+
+
+#include "libguile/tags.h"
#ifdef vms
@@ -180,7 +210,6 @@ typedef unsigned long ulong_long;
# endif /* ndef _CRAY1 */
#endif /* ndef vms */
-
/* James Clark came up with this neat one instruction fix for
* continuations on the SPARC. It flushes the register windows so
* that all the state of the process is contained in the stack.
@@ -213,8 +242,32 @@ typedef long SCM_STACKITEM;
#endif
+#ifndef USE_THREADS
+#define SCM_THREAD_DEFER
+#define SCM_THREAD_ALLOW
+#define SCM_THREAD_REDEFER
+#define SCM_THREAD_REALLOW_1
+#define SCM_THREAD_REALLOW_2
+#define SCM_THREAD_SWITCHING_CODE
+#endif
+
extern unsigned int scm_async_clock;
-#define SCM_ASYNC_TICK if (0 == --scm_async_clock) scm_async_click ()
+#if 0
+#define SCM_ASYNC_TICK \
+{ \
+ if (0 == --scm_async_clock) \
+ scm_async_click (); \
+} \
+
+#else
+#define SCM_ASYNC_TICK \
+{ \
+ if (0 == --scm_async_clock) \
+ scm_async_click (); \
+ SCM_THREAD_SWITCHING_CODE; \
+} \
+
+#endif
#ifdef SCM_CAREFUL_INTS
#define SCM_CHECK_NOT_DISABLED \
@@ -234,12 +287,14 @@ extern unsigned int scm_async_clock;
#define SCM_DEFER_INTS \
{ \
SCM_CHECK_NOT_DISABLED; \
+ SCM_THREAD_DEFER; \
scm_ints_disabled = 1; \
} \
#define SCM_ALLOW_INTS_ONLY \
{ \
+ SCM_THREAD_ALLOW; \
scm_ints_disabled = 0; \
} \
@@ -247,6 +302,7 @@ extern unsigned int scm_async_clock;
#define SCM_ALLOW_INTS \
{ \
SCM_CHECK_NOT_ENABLED; \
+ SCM_THREAD_ALLOW; \
scm_ints_disabled = 0; \
SCM_ASYNC_TICK; \
} \
@@ -254,15 +310,20 @@ extern unsigned int scm_async_clock;
#define SCM_REDEFER_INTS \
{ \
+ SCM_THREAD_REDEFER; \
++scm_ints_disabled; \
} \
#define SCM_REALLOW_INTS \
{ \
+ SCM_THREAD_REALLOW_1; \
--scm_ints_disabled; \
if (!scm_ints_disabled) \
- SCM_ASYNC_TICK; \
+ { \
+ SCM_THREAD_REALLOW_2; \
+ SCM_ASYNC_TICK; \
+ } \
} \
@@ -286,7 +347,6 @@ extern unsigned int scm_async_clock;
goto _label
#endif
-
#define SCM_ARGn 0
#define SCM_ARG1 1
#define SCM_ARG2 2
@@ -294,20 +354,21 @@ extern unsigned int scm_async_clock;
#define SCM_ARG4 4
#define SCM_ARG5 5
#define SCM_ARG6 6
-#define SCM_ARG7 7
-#define SCM_ARGERR(X) ((X) < SCM_WNA \
+#define SCM_ARG7 7
+ /* #define SCM_ARGERR(X) ((X) < SCM_WNA \
? (char *)(X) \
: "wrong type argument")
+ */
/* Following must match entry indexes in scm_errmsgs[].
* Also, SCM_WNA must follow the last SCM_ARGn in sequence.
*/
#define SCM_WNA 8
-#define SCM_OVSCM_FLOW 9
+ /* #define SCM_OVSCM_FLOW 9 */
#define SCM_OUTOFRANGE 10
#define SCM_NALLOC 11
-#define SCM_STACK_SCM_OVSCM_FLOW 12
-#define SCM_EXIT 13
+ /* #define SCM_STACK_OVFLOW 12 */
+ /* #define SCM_EXIT 13 */
/* (...still matching scm_errmsgs) These
@@ -329,6 +390,7 @@ extern unsigned int scm_async_clock;
#define SCM_ORD_SIG(X) ((X) + SCM_HUP_SIGNAL)
#define SCM_NUM_SIGS (SCM_SIG_ORD (SCM_TICK_SIGNAL) + 1)
+#if 0
struct errdesc
{
char *msg;
@@ -338,6 +400,7 @@ struct errdesc
extern struct errdesc scm_errmsgs[];
+#endif
@@ -365,11 +428,5 @@ extern struct errdesc scm_errmsgs[];
-#ifdef __STDC__
-
-#else /* STDC */
-
-#endif /* STDC */
-
#endif /* __SCMH */
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 1c7e74ebc..5d5b429dd 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -44,7 +44,32 @@
*/
-#include "libguile.h"
+#include "__scm.h"
+
+/* This file is only visible to the libguile sources */
+
+/* Include headers for those files central to the implementation. The
+ rest should be explicitly #included in the C files themselves. */
+#include "error.h" /* Everyone signals errors. */
+#include "print.h" /* Everyone needs to print. */
+#include "pairs.h" /* Everyone conses. */
+#include "list.h" /* Everyone makes lists. */
+#include "gc.h" /* Everyone allocates. */
+#include "gsubr.h" /* Everyone defines global functions. */
+#include "procs.h" /* Same. */
+#include "numbers.h" /* Everyone deals with fixnums. */
+#include "symbols.h" /* For length, chars, values, miscellany. */
+#include "boolean.h" /* Everyone wonders about the truth. */
+#include "strings.h" /* Everyone loves string. */
+#include "vectors.h" /* Vectors are used for structures a lot. */
+#include "root.h" /* Everyone uses these objects. */
+#include "ports.h" /* Everyone does I/O. */
+#include "async.h" /* Everyone allows/disallows ints. */
+#ifdef USE_THREADS
+#include "threads.h" /* The cooperative thread package does
+ switching at async ticks. */
+#endif
+#include "snarf.h" /* Everyone snarfs. */
/* On VMS, GNU C's errno.h contains a special hack to get link attributes
* for errno correct for linking to the C RTL.
@@ -88,42 +113,11 @@
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
- static char RANAME[]=STR;
-#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
- static char RANAME[]=STR;
-#else
-#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
-%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, CFN)
-#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
-%%% scm_make_subr(RANAME, TYPE, CFN)
-#endif
-
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_SYMBOL(c_name, scheme_name) \
- static SCM c_name = SCM_BOOL_F
-#else
-#define SCM_SYMBOL(C_NAME, SCHEME_NAME) \
-%%% C_NAME = scm_permanent_object (SCM_CAR (scm_intern0 (SCHEME_NAME)))
-#endif
-
-
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_GLOBAL(c_name, scheme_name) \
- static SCM c_name = SCM_BOOL_F
-#else
-#define SCM_GLOBAL(C_NAME, SCHEME_NAME) \
-%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, SCM_BOOL_F)
+#ifndef min
+#define min(A,B) ((A) <= (B) ? (A) : (B))
#endif
-
-
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \
- static SCM C_NAME = SCM_BOOL_F
-#else
-#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \
-%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, scm_long2num (VALUE))
+#ifndef max
+#define max(A,B) ((A) >= (B) ? (A) : (B))
#endif
#endif /* _SCMH */
diff --git a/libguile/def.sed b/libguile/acconfig.h
index e69de29bb..e69de29bb 100644
--- a/libguile/def.sed
+++ b/libguile/acconfig.h
diff --git a/libguile/acinclude.m4 b/libguile/acinclude.m4
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/libguile/acinclude.m4
diff --git a/libguile/aclocal.m4 b/libguile/aclocal.m4
new file mode 100644
index 000000000..7eda3e8f5
--- /dev/null
+++ b/libguile/aclocal.m4
@@ -0,0 +1,340 @@
+dnl aclocal.m4 generated automatically by aclocal 1.1n
+
+dnl On the NeXT, #including <utime.h> doesn't give you a definition for
+dnl struct utime, unless you #define _POSIX_SOURCE.
+
+AC_DEFUN(GUILE_STRUCT_UTIMBUF, [
+ AC_CACHE_CHECK([whether we need POSIX to get struct utimbuf],
+ guile_cv_struct_utimbuf_needs_posix,
+ [AC_TRY_CPP([
+#ifdef __EMX__
+#include <sys/utime.h>
+#else
+#include <utime.h>
+#endif
+struct utime blah;
+],
+ guile_cv_struct_utimbuf_needs_posix=no,
+ guile_cv_struct_utimbuf_needs_posix=yes)])
+ if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
+ AC_DEFINE(UTIMBUF_NEEDS_POSIX)
+ fi])
+
+
+
+
+dnl
+dnl Apparently, at CMU they have a weird version of libc.h that is
+dnl installed in /usr/local/include and conflicts with unistd.h.
+dnl In these situations, we should not #include libc.h.
+dnl This test arranges to #define LIBC_H_WITH_UNISTD_H iff libc.h is
+dnl present on the system, and is safe to #include.
+dnl
+AC_DEFUN([GUILE_HEADER_LIBC_WITH_UNISTD],
+ [
+ AC_CHECK_HEADERS(libc.h unistd.h)
+ AC_CACHE_CHECK(
+ "whether libc.h and unistd.h can be included together",
+ guile_cv_header_libc_with_unistd,
+ [
+ if test "$ac_cv_header_libc_h" = "no"; then
+ guile_cv_header_libc_with_unistd="no"
+ elif test "$ac_cv_header_unistd.h" = "no"; then
+ guile_cv_header_libc_with_unistd="yes"
+ else
+ AC_TRY_COMPILE(
+ [
+# include <libc.h>
+# include <unistd.h>
+ ],
+ [],
+ [guile_cv_header_libc_with_unistd=yes],
+ [guile_cv_header_libc_with_unistd=no]
+ )
+ fi
+ ]
+ )
+ if test "$guile_cv_header_libc_with_unistd" = yes; then
+ AC_DEFINE(LIBC_H_WITH_UNISTD_H)
+ fi
+ ]
+)
+
+# Like AC_CONFIG_HEADER, but automatically create stamp file.
+
+AC_DEFUN(AM_CONFIG_HEADER,
+[AC_PREREQ([2.12])
+AC_CONFIG_HEADER([$1])
+dnl When config.status generates a header, we must update the stamp-h file.
+dnl This file resides in the same directory as the config header
+dnl that is generated. We must strip everything past the first ":",
+dnl and everything past the last "/".
+AC_OUTPUT_COMMANDS(changequote(<<,>>)dnl
+test -z "<<$>>CONFIG_HEADERS" || echo timestamp > patsubst(<<$1>>, <<^\([^:]*/\)?.*>>, <<\1>>)stamp-h<<>>dnl
+changequote([,]))])
+
+
+dnl Usage: AM_INIT_GUILE_MODULE(module-name)
+dnl This macro will automatically get the guile version from the
+dnl top-level srcdir, and will initialize automake. It also
+dnl defines the `module' variable.
+AC_DEFUN([AM_INIT_GUILE_MODULE],[
+. $srcdir/../GUILE-VERSION
+AM_INIT_AUTOMAKE($PACKAGE, $VERSION, no-define)
+AC_CONFIG_AUX_DIR(..)
+module=[$1]
+AC_SUBST(module)])
+
+# Do all the work for Automake. This macro actually does too much --
+# some checks are only needed if your package does certain things.
+# But this isn't really a big deal.
+
+# serial 1
+
+dnl Usage:
+dnl AM_INIT_AUTOMAKE(package,version, [no-define])
+
+AC_DEFUN(AM_INIT_AUTOMAKE,
+[AC_REQUIRE([AM_PROG_INSTALL])
+PACKAGE=[$1]
+AC_SUBST(PACKAGE)
+VERSION=[$2]
+AC_SUBST(VERSION)
+ifelse([$3],,
+AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE")
+AC_DEFINE_UNQUOTED(VERSION, "$VERSION"))
+AM_SANITY_CHECK
+AC_ARG_PROGRAM
+dnl FIXME This is truly gross.
+missing_dir=`cd $ac_aux_dir && pwd`
+AM_MISSING_PROG(ACLOCAL, aclocal, $missing_dir)
+AM_MISSING_PROG(AUTOCONF, autoconf, $missing_dir)
+AM_MISSING_PROG(AUTOMAKE, automake, $missing_dir)
+AM_MISSING_PROG(AUTOHEADER, autoheader, $missing_dir)
+AM_MISSING_PROG(MAKEINFO, makeinfo, $missing_dir)
+AC_PROG_MAKE_SET])
+
+
+# serial 1
+
+AC_DEFUN(AM_PROG_INSTALL,
+[AC_REQUIRE([AC_PROG_INSTALL])
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
+AC_SUBST(INSTALL_SCRIPT)dnl
+])
+
+#
+# Check to make sure that the build environment is sane.
+#
+
+AC_DEFUN(AM_SANITY_CHECK,
+[AC_MSG_CHECKING([whether build environment is sane])
+# Just in case
+sleep 1
+echo timestamp > conftestfile
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments. Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+ set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
+ if test "$@" = "X"; then
+ # -L didn't work.
+ set X `ls -t $srcdir/configure conftestfile`
+ fi
+ test "[$]2" = conftestfile
+ )
+then
+ # Ok.
+ :
+else
+ AC_MSG_ERROR([newly created file is older than distributed files!
+Check your system clock])
+fi
+rm -f conftest*
+AC_MSG_RESULT(yes)])
+
+dnl AM_MISSING_PROG(NAME, PROGRAM, DIRECTORY)
+dnl The program must properly implement --version.
+AC_DEFUN(AM_MISSING_PROG,
+[AC_MSG_CHECKING(for working $2)
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if ($2 --version) > /dev/null 2>&1; then
+ $1=$2
+ AC_MSG_RESULT(found)
+else
+ $1="$3/missing $2"
+ AC_MSG_RESULT(missing)
+fi
+AC_SUBST($1)])
+
+# Add --enable-maintainer-mode option to configure.
+# From Jim Meyering
+
+# serial 1
+
+AC_DEFUN(AM_MAINTAINER_MODE,
+[AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles])
+ dnl maintainer-mode is disabled by default
+ AC_ARG_ENABLE(maintainer-mode,
+[ --enable-maintainer-mode enable make rules and dependencies not useful
+ (and sometimes confusing) to the casual installer],
+ USE_MAINTAINER_MODE=$enableval,
+ USE_MAINTAINER_MODE=no)
+ AC_MSG_RESULT($USE_MAINTAINER_MODE)
+ if test $USE_MAINTAINER_MODE = yes; then
+ MAINT=
+ else
+ MAINT='#M#'
+ fi
+ AC_SUBST(MAINT)dnl
+]
+)
+
+
+# serial 4 AM_PROG_LIBTOOL
+AC_DEFUN(AM_PROG_LIBTOOL,
+[AC_REQUIRE([AC_CANONICAL_HOST])
+AC_REQUIRE([AC_PROG_CC])
+AC_REQUIRE([AC_PROG_RANLIB])
+
+# Always use our own libtool.
+LIBTOOL='$(top_builddir)/libtool'
+AC_SUBST(LIBTOOL)
+
+dnl Allow the --disable-shared flag to stop us from building shared libs.
+AC_ARG_ENABLE(shared,
+[ --enable-shared build shared libraries [default=yes]],
+test "$enableval" = no && libtool_shared=" --disable-shared",
+libtool_shared=)
+
+libtool_flags="$libtool_shared"
+test "$silent" = yes && libtool_flags="$libtool_flags --silent"
+test "$ac_cv_prog_gcc" = yes && libtool_flags="$libtool_flags --with-gcc"
+
+[case "$host" in
+*-*-irix6*)
+ # For IRIX 6, ld needs -n32 if cc uses it.
+ if echo " $CC $CFLAGS " | egrep -e '[ ]-n32[ ]' > /dev/null; then
+ LD="${LD-ld} -n32"
+ fi
+ ;;
+
+*-*-sco3.2v5*)
+ # On SCO OpenServer 5, we need -belf to get full-featured binaries.
+ CFLAGS="$CFLAGS -belf"
+ ;;
+esac]
+
+# Actually configure libtool. ac_aux_dir is where install-sh is found.
+CC="$CC" CFLAGS="$CFLAGS" CPPFLAGS="$CPPFLAGS" LD="$LD" RANLIB="$RANLIB" \
+${CONFIG_SHELL-/bin/sh} $ac_aux_dir/ltconfig \
+$libtool_flags --no-verify $ac_aux_dir/ltmain.sh $host \
+|| AC_MSG_ERROR([libtool configure failed])
+])
+
+dnl
+dnl CY_AC_WITH_THREADS determines which thread library the user intends
+dnl to put underneath guile. Pass it the path to find the guile top-level
+dnl source directory. Eg CY_AC_WITH_THREADS(../..) for tcl/unix.
+dnl
+
+AC_DEFUN([CY_AC_WITH_THREADS],[
+AC_CACHE_CHECK("threads package type",cy_cv_threads_package,[
+AC_CACHE_VAL(cy_cv_threads_cflags,[
+AC_CACHE_VAL(cy_cv_threads_libs,[
+use_threads=no;
+AC_ARG_WITH(threads,[ --with-threads thread interface],
+ use_threads=$withval, use_threads=no)
+test -n "$use_threads" || use_threads=qt
+threads_package=unknown
+if test "$use_threads" != no; then
+dnl
+dnl Test for the qt threads package - used for cooperative threads
+dnl This may not necessarily be built yet - so just check for the
+dnl header files.
+dnl
+ if test "$use_threads" = yes || test "$use_threads" = qt; then
+ # Look for qt in source directory. This is a hack: we look in
+ # "./qt" because this check might be run at the top level.
+ if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$srcdir/../qt -I../qt"
+ cy_cv_threads_libs="../qt/libqt.a"
+ fi
+ else
+ if test -f $use_threads/qt.c; then
+ # FIXME seems as though we should try to use an installed qt here.
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$use_threads -I../qt"
+ cy_cv_threads_libs="../qt/libqt.a"
+ fi
+ fi
+ if test "$use_threads" = pthreads; then
+ # Look for pthreads in srcdir. See above to understand why
+ # we always set threads_package.
+ if test -f $srcdir/../../pthreads/pthreads/queue.c \
+ || test -f $srcdir/../pthreads/pthreads/queue.c; then
+ threads_package=MIT
+ cy_cv_threads_cflags="-I$srcdir/../../pthreads/include"
+ cy_cv_threads_libs="-L../../pthreads/lib -lpthread"
+ fi
+ fi
+ saved_CPP="$CPPFLAGS"
+ saved_LD="$LDFLAGS"
+ saved_LIBS="$LIBS"
+ if test "$threads_package" = unknown; then
+dnl
+dnl Test for the FSU threads package
+dnl
+ CPPFLAGS="-I$use_threads/include"
+ LDFLAGS="-L$use_threads/lib"
+ LIBS="-lgthreads -lmalloc"
+ AC_TRY_LINK([#include <pthread.h>],[
+pthread_equal(NULL,NULL);
+], threads_package=FSU)
+ fi
+ if test "$threads_package" = unknown; then
+dnl
+dnl Test for the MIT threads package
+dnl
+ LIBS="-lpthread"
+ AC_TRY_LINK([#include <pthread.h>],[
+pthread_equal(NULL,NULL);
+], threads_package=MIT)
+ fi
+ if test "$threads_package" = unknown; then
+dnl
+dnl Test for the PCthreads package
+dnl
+ LIBS="-lpthreads"
+ AC_TRY_LINK([#include <pthread.h>],[
+pthread_equal(NULL,NULL);
+], threads_package=PCthreads)
+ fi
+dnl
+dnl Set the appropriate flags!
+dnl
+ cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags"
+ cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs"
+ cy_cv_threads_package=$threads_package
+ CPPFLAGS="$saved_CPP"
+ LDFLAGS="$saved_LD"
+ LIBS="$saved_LIBS"
+ if test "$threads_package" = unknown; then
+ AC_MSG_ERROR("cannot find thread library installation")
+ fi
+fi
+])
+])
+],
+dnl
+dnl Set flags according to what is cached.
+dnl
+CPPFLAGS="$cy_cv_threads_cflags"
+LIBS="$cy_cv_threads_libs"
+)
+])
+
diff --git a/libguile/alist.c b/libguile/alist.c
index 85c4395af..06ede611a 100644
--- a/libguile/alist.c
+++ b/libguile/alist.c
@@ -41,54 +41,47 @@
#include <stdio.h>
#include "_scm.h"
+#include "eq.h"
+#include "list.h"
+
+#include "alist.h"
SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons);
-#ifdef __STDC__
-SCM
-scm_acons (SCM w, SCM x, SCM y)
-#else
+
SCM
scm_acons (w, x, y)
SCM w;
SCM x;
SCM y;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CAR (z) = w;
- SCM_CDR (z) = x;
+ SCM_SETCAR (z, w);
+ SCM_SETCDR (z, x);
x = z;
SCM_NEWCELL (z);
- SCM_CAR (z) = x;
- SCM_CDR (z) = y;
+ SCM_SETCAR (z, x);
+ SCM_SETCDR (z, y);
return z;
}
SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq);
-#ifdef __STDC__
-SCM
-scm_sloppy_assq(SCM x, SCM alist)
-#else
+
SCM
scm_sloppy_assq(x, alist)
SCM x;
SCM alist;
-#endif
{
- SCM tmp;
- for(;SCM_NIMP(alist);alist = SCM_CDR(alist))
+
+ for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
{
- if (SCM_CONSP(alist))
- {
- tmp = SCM_CAR(alist);
- if (SCM_NIMP (tmp) && SCM_CONSP (tmp) && (SCM_CAR (tmp)==x))
- return tmp;
- }
+ SCM tmp = SCM_CAR(alist);
+ if (SCM_NIMP (tmp) && SCM_CONSP (tmp) && (SCM_CAR (tmp)==x))
+ return tmp;
}
return SCM_BOOL_F;
}
@@ -96,54 +89,38 @@ scm_sloppy_assq(x, alist)
SCM_PROC (s_sloppy_assv, "sloppy-assv", 2, 0, 0, scm_sloppy_assv);
-#ifdef __STDC__
-SCM
-scm_sloppy_assv(SCM x, SCM alist)
-#else
+
SCM
scm_sloppy_assv(x, alist)
SCM x;
SCM alist;
-#endif
{
- SCM tmp;
- for(;SCM_NIMP(alist);alist = SCM_CDR(alist))
+ for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
{
- if (SCM_CONSP(alist))
- {
- tmp = SCM_CAR(alist);
- if ( SCM_NIMP (tmp)
- && SCM_CONSP (tmp)
- && SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), x)))
- return tmp;
- }
+ SCM tmp = SCM_CAR(alist);
+ if (SCM_NIMP (tmp)
+ && SCM_CONSP (tmp)
+ && SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), x)))
+ return tmp;
}
return SCM_BOOL_F;
}
SCM_PROC (s_sloppy_assoc, "sloppy-assoc", 2, 0, 0, scm_sloppy_assoc);
-#ifdef __STDC__
-SCM
-scm_sloppy_assoc(SCM x, SCM alist)
-#else
+
SCM
scm_sloppy_assoc(x, alist)
SCM x;
SCM alist;
-#endif
{
- SCM tmp;
- for(;SCM_NIMP(alist);alist = SCM_CDR(alist))
+ for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
{
- if (SCM_CONSP(alist))
- {
- tmp = SCM_CAR(alist);
- if ( SCM_NIMP (tmp)
- && SCM_CONSP (tmp)
- && SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), x)))
- return tmp;
- }
+ SCM tmp = SCM_CAR(alist);
+ if (SCM_NIMP (tmp)
+ && SCM_CONSP (tmp)
+ && SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), x)))
+ return tmp;
}
return SCM_BOOL_F;
}
@@ -152,15 +129,11 @@ scm_sloppy_assoc(x, alist)
SCM_PROC(s_assq, "assq", 2, 0, 0, scm_assq);
-#ifdef __STDC__
-SCM
-scm_assq(SCM x, SCM alist)
-#else
+
SCM
scm_assq(x, alist)
SCM x;
SCM alist;
-#endif
{
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
@@ -175,15 +148,11 @@ scm_assq(x, alist)
SCM_PROC(s_assv, "assv", 2, 0, 0, scm_assv);
-#ifdef __STDC__
-SCM
-scm_assv(SCM x, SCM alist)
-#else
+
SCM
scm_assv(x, alist)
SCM x;
SCM alist;
-#endif
{
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
@@ -201,15 +170,11 @@ scm_assv(x, alist)
SCM_PROC(s_assoc, "assoc", 2, 0, 0, scm_assoc);
-#ifdef __STDC__
-SCM
-scm_assoc(SCM x, SCM alist)
-#else
+
SCM
scm_assoc(x, alist)
SCM x;
SCM alist;
-#endif
{
SCM tmp;
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
@@ -226,15 +191,11 @@ scm_assoc(x, alist)
SCM_PROC (s_assq_ref, "assq-ref", 2, 0, 0, scm_assq_ref);
-#ifdef __STDC__
-SCM
-scm_assq_ref (SCM alist, SCM key)
-#else
+
SCM
scm_assq_ref (alist, key)
SCM alist;
SCM key;
-#endif
{
SCM handle;
@@ -248,15 +209,11 @@ scm_assq_ref (alist, key)
SCM_PROC (s_assv_ref, "assv-ref", 2, 0, 0, scm_assv_ref);
-#ifdef __STDC__
-SCM
-scm_assv_ref (SCM alist, SCM key)
-#else
+
SCM
scm_assv_ref (alist, key)
SCM alist;
SCM key;
-#endif
{
SCM handle;
@@ -270,15 +227,11 @@ scm_assv_ref (alist, key)
SCM_PROC (s_assoc_ref, "assoc-ref", 2, 0, 0, scm_assoc_ref);
-#ifdef __STDC__
-SCM
-scm_assoc_ref (SCM alist, SCM key)
-#else
+
SCM
scm_assoc_ref (alist, key)
SCM alist;
SCM key;
-#endif
{
SCM handle;
@@ -296,16 +249,12 @@ scm_assoc_ref (alist, key)
SCM_PROC (s_assq_set_x, "assq-set!", 3, 0, 0, scm_assq_set_x);
-#ifdef __STDC__
-SCM
-scm_assq_set_x (SCM alist, SCM key, SCM val)
-#else
+
SCM
scm_assq_set_x (alist, key, val)
SCM alist;
SCM key;
SCM val;
-#endif
{
SCM handle;
@@ -320,16 +269,12 @@ scm_assq_set_x (alist, key, val)
}
SCM_PROC (s_assv_set_x, "assv-set!", 3, 0, 0, scm_assv_set_x);
-#ifdef __STDC__
-SCM
-scm_assv_set_x (SCM alist, SCM key, SCM val)
-#else
+
SCM
scm_assv_set_x (alist, key, val)
SCM alist;
SCM key;
SCM val;
-#endif
{
SCM handle;
@@ -344,16 +289,12 @@ scm_assv_set_x (alist, key, val)
}
SCM_PROC (s_assoc_set_x, "assoc-set!", 3, 0, 0, scm_assoc_set_x);
-#ifdef __STDC__
-SCM
-scm_assoc_set_x (SCM alist, SCM key, SCM val)
-#else
+
SCM
scm_assoc_set_x (alist, key, val)
SCM alist;
SCM key;
SCM val;
-#endif
{
SCM handle;
@@ -371,15 +312,11 @@ scm_assoc_set_x (alist, key, val)
SCM_PROC (s_assq_remove_x, "assq-remove!", 2, 0, 0, scm_assq_remove_x);
-#ifdef __STDC__
-SCM
-scm_assq_remove_x (SCM alist, SCM key)
-#else
+
SCM
scm_assq_remove_x (alist, key)
SCM alist;
SCM key;
-#endif
{
SCM handle;
@@ -394,15 +331,11 @@ scm_assq_remove_x (alist, key)
SCM_PROC (s_assv_remove_x, "assv-remove!", 2, 0, 0, scm_assv_remove_x);
-#ifdef __STDC__
-SCM
-scm_assv_remove_x (SCM alist, SCM key)
-#else
+
SCM
scm_assv_remove_x (alist, key)
SCM alist;
SCM key;
-#endif
{
SCM handle;
@@ -417,15 +350,11 @@ scm_assv_remove_x (alist, key)
SCM_PROC (s_assoc_remove_x, "assoc-remove!", 2, 0, 0, scm_assoc_remove_x);
-#ifdef __STDC__
-SCM
-scm_assoc_remove_x (SCM alist, SCM key)
-#else
+
SCM
scm_assoc_remove_x (alist, key)
SCM alist;
SCM key;
-#endif
{
SCM handle;
@@ -442,13 +371,9 @@ scm_assoc_remove_x (alist, key)
-#ifdef __STDC__
-void
-scm_init_alist (void)
-#else
+
void
scm_init_alist ()
-#endif
{
#include "alist.x"
}
diff --git a/libguile/alist.h b/libguile/alist.h
index f0f90a4df..87e327fdd 100644
--- a/libguile/alist.h
+++ b/libguile/alist.h
@@ -44,54 +44,26 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
-
-
-#ifdef __STDC__
-extern SCM scm_acons (SCM w, SCM x, SCM y);
-extern SCM scm_sloppy_assq(SCM x, SCM alist);
-extern SCM scm_sloppy_assv(SCM x, SCM alist);
-extern SCM scm_sloppy_assoc(SCM x, SCM alist);
-extern SCM scm_assq(SCM x, SCM alist);
-extern SCM scm_assv(SCM x, SCM alist);
-extern SCM scm_assoc(SCM x, SCM alist);
-extern SCM scm_assq_ref (SCM alist, SCM key);
-extern SCM scm_assv_ref (SCM alist, SCM key);
-extern SCM scm_assoc_ref (SCM alist, SCM key);
-extern SCM scm_assq_set_x (SCM alist, SCM key, SCM val);
-extern SCM scm_assv_set_x (SCM alist, SCM key, SCM val);
-extern SCM scm_assoc_set_x (SCM alist, SCM key, SCM val);
-extern SCM scm_assq_remove_x (SCM alist, SCM key);
-extern SCM scm_assv_remove_x (SCM alist, SCM key);
-extern SCM scm_assoc_remove_x (SCM alist, SCM key);
-extern void scm_init_alist (void);
-
-#else /* STDC */
-extern SCM scm_acons ();
-extern SCM scm_sloppy_assq();
-extern SCM scm_sloppy_assv();
-extern SCM scm_sloppy_assoc();
-extern SCM scm_assq();
-extern SCM scm_assv();
-extern SCM scm_assoc();
-extern SCM scm_assq_ref ();
-extern SCM scm_assv_ref ();
-extern SCM scm_assoc_ref ();
-extern SCM scm_assq_set_x ();
-extern SCM scm_assv_set_x ();
-extern SCM scm_assoc_set_x ();
-extern SCM scm_assq_remove_x ();
-extern SCM scm_assv_remove_x ();
-extern SCM scm_assoc_remove_x ();
-extern void scm_init_alist ();
-
-#endif /* STDC */
-
-
-
+extern SCM scm_acons SCM_P ((SCM w, SCM x, SCM y));
+extern SCM scm_sloppy_assq SCM_P ((SCM x, SCM alist));
+extern SCM scm_sloppy_assv SCM_P ((SCM x, SCM alist));
+extern SCM scm_sloppy_assoc SCM_P ((SCM x, SCM alist));
+extern SCM scm_assq SCM_P ((SCM x, SCM alist));
+extern SCM scm_assv SCM_P ((SCM x, SCM alist));
+extern SCM scm_assoc SCM_P ((SCM x, SCM alist));
+extern SCM scm_assq_ref SCM_P ((SCM alist, SCM key));
+extern SCM scm_assv_ref SCM_P ((SCM alist, SCM key));
+extern SCM scm_assoc_ref SCM_P ((SCM alist, SCM key));
+extern SCM scm_assq_set_x SCM_P ((SCM alist, SCM key, SCM val));
+extern SCM scm_assv_set_x SCM_P ((SCM alist, SCM key, SCM val));
+extern SCM scm_assoc_set_x SCM_P ((SCM alist, SCM key, SCM val));
+extern SCM scm_assq_remove_x SCM_P ((SCM alist, SCM key));
+extern SCM scm_assv_remove_x SCM_P ((SCM alist, SCM key));
+extern SCM scm_assoc_remove_x SCM_P ((SCM alist, SCM key));
+extern void scm_init_alist SCM_P ((void));
#endif /* ALISTH */
diff --git a/libguile/alloca.c b/libguile/alloca.c
new file mode 100644
index 000000000..8f98b73db
--- /dev/null
+++ b/libguile/alloca.c
@@ -0,0 +1,504 @@
+/* alloca.c -- allocate automatically reclaimed memory
+ (Mostly) portable public-domain implementation -- D A Gwyn
+
+ This implementation of the PWB library alloca function,
+ which is used to allocate space off the run-time stack so
+ that it is automatically reclaimed upon procedure exit,
+ was inspired by discussions with J. Q. Johnson of Cornell.
+ J.Otto Tennant <jot@cray.com> contributed the Cray support.
+
+ There are some preprocessor constants that can
+ be defined when compiling for your specific system, for
+ improved efficiency; however, the defaults should be okay.
+
+ The general concept of this implementation is to keep
+ track of all alloca-allocated blocks, and reclaim any
+ that are found to be deeper in the stack than the current
+ invocation. This heuristic does not reclaim storage as
+ soon as it becomes invalid, but it will do so eventually.
+
+ As a special case, alloca(0) reclaims storage without
+ allocating any. It is a good idea to use alloca(0) in
+ your main control loop, etc. to force garbage collection. */
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef emacs
+#include "blockinput.h"
+#endif
+
+/* If compiling with GCC 2, this file's not needed. */
+#if !defined (__GNUC__) || __GNUC__ < 2
+
+/* If someone has defined alloca as a macro,
+ there must be some other way alloca is supposed to work. */
+#ifndef alloca
+
+#ifdef emacs
+#ifdef static
+/* actually, only want this if static is defined as ""
+ -- this is for usg, in which emacs must undefine static
+ in order to make unexec workable
+ */
+#ifndef STACK_DIRECTION
+you
+lose
+-- must know STACK_DIRECTION at compile-time
+#endif /* STACK_DIRECTION undefined */
+#endif /* static */
+#endif /* emacs */
+
+/* If your stack is a linked list of frames, you have to
+ provide an "address metric" ADDRESS_FUNCTION macro. */
+
+#if defined (CRAY) && defined (CRAY_STACKSEG_END)
+long i00afunc ();
+#define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg))
+#else
+#define ADDRESS_FUNCTION(arg) &(arg)
+#endif
+
+#if __STDC__
+typedef void *pointer;
+#else
+typedef char *pointer;
+#endif
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+/* Different portions of Emacs need to call different versions of
+ malloc. The Emacs executable needs alloca to call xmalloc, because
+ ordinary malloc isn't protected from input signals. On the other
+ hand, the utilities in lib-src need alloca to call malloc; some of
+ them are very simple, and don't have an xmalloc routine.
+
+ Non-Emacs programs expect this to call use xmalloc.
+
+ Callers below should use malloc. */
+
+#ifndef emacs
+#define malloc xmalloc
+#endif
+extern pointer malloc ();
+
+/* Define STACK_DIRECTION if you know the direction of stack
+ growth for your system; otherwise it will be automatically
+ deduced at run-time.
+
+ STACK_DIRECTION > 0 => grows toward higher addresses
+ STACK_DIRECTION < 0 => grows toward lower addresses
+ STACK_DIRECTION = 0 => direction of growth unknown */
+
+#ifndef STACK_DIRECTION
+#define STACK_DIRECTION 0 /* Direction unknown. */
+#endif
+
+#if STACK_DIRECTION != 0
+
+#define STACK_DIR STACK_DIRECTION /* Known at compile-time. */
+
+#else /* STACK_DIRECTION == 0; need run-time code. */
+
+static int stack_dir; /* 1 or -1 once known. */
+#define STACK_DIR stack_dir
+
+static void
+find_stack_direction ()
+{
+ static char *addr = NULL; /* Address of first `dummy', once known. */
+ auto char dummy; /* To get stack address. */
+
+ if (addr == NULL)
+ { /* Initial entry. */
+ addr = ADDRESS_FUNCTION (dummy);
+
+ find_stack_direction (); /* Recurse once. */
+ }
+ else
+ {
+ /* Second entry. */
+ if (ADDRESS_FUNCTION (dummy) > addr)
+ stack_dir = 1; /* Stack grew upward. */
+ else
+ stack_dir = -1; /* Stack grew downward. */
+ }
+}
+
+#endif /* STACK_DIRECTION == 0 */
+
+/* An "alloca header" is used to:
+ (a) chain together all alloca'ed blocks;
+ (b) keep track of stack depth.
+
+ It is very important that sizeof(header) agree with malloc
+ alignment chunk size. The following default should work okay. */
+
+#ifndef ALIGN_SIZE
+#define ALIGN_SIZE sizeof(double)
+#endif
+
+typedef union hdr
+{
+ char align[ALIGN_SIZE]; /* To force sizeof(header). */
+ struct
+ {
+ union hdr *next; /* For chaining headers. */
+ char *deep; /* For stack depth measure. */
+ } h;
+} header;
+
+static header *last_alloca_header = NULL; /* -> last alloca header. */
+
+/* Return a pointer to at least SIZE bytes of storage,
+ which will be automatically reclaimed upon exit from
+ the procedure that called alloca. Originally, this space
+ was supposed to be taken from the current stack frame of the
+ caller, but that method cannot be made to work for some
+ implementations of C, for example under Gould's UTX/32. */
+
+pointer
+alloca (size)
+ unsigned size;
+{
+ auto char probe; /* Probes stack depth: */
+ register char *depth = ADDRESS_FUNCTION (probe);
+
+#if STACK_DIRECTION == 0
+ if (STACK_DIR == 0) /* Unknown growth direction. */
+ find_stack_direction ();
+#endif
+
+ /* Reclaim garbage, defined as all alloca'd storage that
+ was allocated from deeper in the stack than currently. */
+
+ {
+ register header *hp; /* Traverses linked list. */
+
+#ifdef emacs
+ BLOCK_INPUT;
+#endif
+
+ for (hp = last_alloca_header; hp != NULL;)
+ if ((STACK_DIR > 0 && hp->h.deep > depth)
+ || (STACK_DIR < 0 && hp->h.deep < depth))
+ {
+ register header *np = hp->h.next;
+
+ free ((pointer) hp); /* Collect garbage. */
+
+ hp = np; /* -> next header. */
+ }
+ else
+ break; /* Rest are not deeper. */
+
+ last_alloca_header = hp; /* -> last valid storage. */
+
+#ifdef emacs
+ UNBLOCK_INPUT;
+#endif
+ }
+
+ if (size == 0)
+ return NULL; /* No allocation required. */
+
+ /* Allocate combined header + user data storage. */
+
+ {
+ register pointer new = malloc (sizeof (header) + size);
+ /* Address of header. */
+
+ if (new == 0)
+ abort();
+
+ ((header *) new)->h.next = last_alloca_header;
+ ((header *) new)->h.deep = depth;
+
+ last_alloca_header = (header *) new;
+
+ /* User storage begins just after header. */
+
+ return (pointer) ((char *) new + sizeof (header));
+ }
+}
+
+#if defined (CRAY) && defined (CRAY_STACKSEG_END)
+
+#ifdef DEBUG_I00AFUNC
+#include <stdio.h>
+#endif
+
+#ifndef CRAY_STACK
+#define CRAY_STACK
+#ifndef CRAY2
+/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */
+struct stack_control_header
+ {
+ long shgrow:32; /* Number of times stack has grown. */
+ long shaseg:32; /* Size of increments to stack. */
+ long shhwm:32; /* High water mark of stack. */
+ long shsize:32; /* Current size of stack (all segments). */
+ };
+
+/* The stack segment linkage control information occurs at
+ the high-address end of a stack segment. (The stack
+ grows from low addresses to high addresses.) The initial
+ part of the stack segment linkage control information is
+ 0200 (octal) words. This provides for register storage
+ for the routine which overflows the stack. */
+
+struct stack_segment_linkage
+ {
+ long ss[0200]; /* 0200 overflow words. */
+ long sssize:32; /* Number of words in this segment. */
+ long ssbase:32; /* Offset to stack base. */
+ long:32;
+ long sspseg:32; /* Offset to linkage control of previous
+ segment of stack. */
+ long:32;
+ long sstcpt:32; /* Pointer to task common address block. */
+ long sscsnm; /* Private control structure number for
+ microtasking. */
+ long ssusr1; /* Reserved for user. */
+ long ssusr2; /* Reserved for user. */
+ long sstpid; /* Process ID for pid based multi-tasking. */
+ long ssgvup; /* Pointer to multitasking thread giveup. */
+ long sscray[7]; /* Reserved for Cray Research. */
+ long ssa0;
+ long ssa1;
+ long ssa2;
+ long ssa3;
+ long ssa4;
+ long ssa5;
+ long ssa6;
+ long ssa7;
+ long sss0;
+ long sss1;
+ long sss2;
+ long sss3;
+ long sss4;
+ long sss5;
+ long sss6;
+ long sss7;
+ };
+
+#else /* CRAY2 */
+/* The following structure defines the vector of words
+ returned by the STKSTAT library routine. */
+struct stk_stat
+ {
+ long now; /* Current total stack size. */
+ long maxc; /* Amount of contiguous space which would
+ be required to satisfy the maximum
+ stack demand to date. */
+ long high_water; /* Stack high-water mark. */
+ long overflows; /* Number of stack overflow ($STKOFEN) calls. */
+ long hits; /* Number of internal buffer hits. */
+ long extends; /* Number of block extensions. */
+ long stko_mallocs; /* Block allocations by $STKOFEN. */
+ long underflows; /* Number of stack underflow calls ($STKRETN). */
+ long stko_free; /* Number of deallocations by $STKRETN. */
+ long stkm_free; /* Number of deallocations by $STKMRET. */
+ long segments; /* Current number of stack segments. */
+ long maxs; /* Maximum number of stack segments so far. */
+ long pad_size; /* Stack pad size. */
+ long current_address; /* Current stack segment address. */
+ long current_size; /* Current stack segment size. This
+ number is actually corrupted by STKSTAT to
+ include the fifteen word trailer area. */
+ long initial_address; /* Address of initial segment. */
+ long initial_size; /* Size of initial segment. */
+ };
+
+/* The following structure describes the data structure which trails
+ any stack segment. I think that the description in 'asdef' is
+ out of date. I only describe the parts that I am sure about. */
+
+struct stk_trailer
+ {
+ long this_address; /* Address of this block. */
+ long this_size; /* Size of this block (does not include
+ this trailer). */
+ long unknown2;
+ long unknown3;
+ long link; /* Address of trailer block of previous
+ segment. */
+ long unknown5;
+ long unknown6;
+ long unknown7;
+ long unknown8;
+ long unknown9;
+ long unknown10;
+ long unknown11;
+ long unknown12;
+ long unknown13;
+ long unknown14;
+ };
+
+#endif /* CRAY2 */
+#endif /* not CRAY_STACK */
+
+#ifdef CRAY2
+/* Determine a "stack measure" for an arbitrary ADDRESS.
+ I doubt that "lint" will like this much. */
+
+static long
+i00afunc (long *address)
+{
+ struct stk_stat status;
+ struct stk_trailer *trailer;
+ long *block, size;
+ long result = 0;
+
+ /* We want to iterate through all of the segments. The first
+ step is to get the stack status structure. We could do this
+ more quickly and more directly, perhaps, by referencing the
+ $LM00 common block, but I know that this works. */
+
+ STKSTAT (&status);
+
+ /* Set up the iteration. */
+
+ trailer = (struct stk_trailer *) (status.current_address
+ + status.current_size
+ - 15);
+
+ /* There must be at least one stack segment. Therefore it is
+ a fatal error if "trailer" is null. */
+
+ if (trailer == 0)
+ abort ();
+
+ /* Discard segments that do not contain our argument address. */
+
+ while (trailer != 0)
+ {
+ block = (long *) trailer->this_address;
+ size = trailer->this_size;
+ if (block == 0 || size == 0)
+ abort ();
+ trailer = (struct stk_trailer *) trailer->link;
+ if ((block <= address) && (address < (block + size)))
+ break;
+ }
+
+ /* Set the result to the offset in this segment and add the sizes
+ of all predecessor segments. */
+
+ result = address - block;
+
+ if (trailer == 0)
+ {
+ return result;
+ }
+
+ do
+ {
+ if (trailer->this_size <= 0)
+ abort ();
+ result += trailer->this_size;
+ trailer = (struct stk_trailer *) trailer->link;
+ }
+ while (trailer != 0);
+
+ /* We are done. Note that if you present a bogus address (one
+ not in any segment), you will get a different number back, formed
+ from subtracting the address of the first block. This is probably
+ not what you want. */
+
+ return (result);
+}
+
+#else /* not CRAY2 */
+/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP.
+ Determine the number of the cell within the stack,
+ given the address of the cell. The purpose of this
+ routine is to linearize, in some sense, stack addresses
+ for alloca. */
+
+static long
+i00afunc (long address)
+{
+ long stkl = 0;
+
+ long size, pseg, this_segment, stack;
+ long result = 0;
+
+ struct stack_segment_linkage *ssptr;
+
+ /* Register B67 contains the address of the end of the
+ current stack segment. If you (as a subprogram) store
+ your registers on the stack and find that you are past
+ the contents of B67, you have overflowed the segment.
+
+ B67 also points to the stack segment linkage control
+ area, which is what we are really interested in. */
+
+ stkl = CRAY_STACKSEG_END ();
+ ssptr = (struct stack_segment_linkage *) stkl;
+
+ /* If one subtracts 'size' from the end of the segment,
+ one has the address of the first word of the segment.
+
+ If this is not the first segment, 'pseg' will be
+ nonzero. */
+
+ pseg = ssptr->sspseg;
+ size = ssptr->sssize;
+
+ this_segment = stkl - size;
+
+ /* It is possible that calling this routine itself caused
+ a stack overflow. Discard stack segments which do not
+ contain the target address. */
+
+ while (!(this_segment <= address && address <= stkl))
+ {
+#ifdef DEBUG_I00AFUNC
+ fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl);
+#endif
+ if (pseg == 0)
+ break;
+ stkl = stkl - pseg;
+ ssptr = (struct stack_segment_linkage *) stkl;
+ size = ssptr->sssize;
+ pseg = ssptr->sspseg;
+ this_segment = stkl - size;
+ }
+
+ result = address - this_segment;
+
+ /* If you subtract pseg from the current end of the stack,
+ you get the address of the previous stack segment's end.
+ This seems a little convoluted to me, but I'll bet you save
+ a cycle somewhere. */
+
+ while (pseg != 0)
+ {
+#ifdef DEBUG_I00AFUNC
+ fprintf (stderr, "%011o %011o\n", pseg, size);
+#endif
+ stkl = stkl - pseg;
+ ssptr = (struct stack_segment_linkage *) stkl;
+ size = ssptr->sssize;
+ pseg = ssptr->sspseg;
+ result += size;
+ }
+ return (result);
+}
+
+#endif /* not CRAY2 */
+#endif /* CRAY */
+
+#endif /* no alloca */
+#endif /* not GCC version 2 */
diff --git a/libguile/append.c b/libguile/append.c
index 4f09a1dcf..204d57ab8 100644
--- a/libguile/append.c
+++ b/libguile/append.c
@@ -42,32 +42,27 @@
#include <stdio.h>
#include "_scm.h"
+#include "list.h"
+
+#include "append.h"
SCM_PROC (s_append, "append", 0, 0, 1, scm_append);
-#ifdef __STDC__
-SCM
-scm_append (SCM objs)
-#else
+
SCM
scm_append (objs)
SCM objs;
-#endif
{
return scm_list_append (objs);
}
SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x);
-#ifdef __STDC__
-SCM
-scm_append_x (SCM objs)
-#else
+
SCM
scm_append_x (objs)
SCM objs;
-#endif
{
return scm_list_append_x (objs);
}
@@ -75,13 +70,8 @@ scm_append_x (objs)
-#ifdef __STDC__
-void
-scm_init_append (void)
-#else
void
scm_init_append ()
-#endif
{
#include "append.x"
}
diff --git a/libguile/append.h b/libguile/append.h
index 33197f976..9c13d6356 100644
--- a/libguile/append.h
+++ b/libguile/append.h
@@ -44,25 +44,12 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
-
-
-#ifdef __STDC__
-extern SCM scm_append (SCM objs);
-extern SCM scm_append_x (SCM objs);
-extern void scm_init_append (void);
-
-#else /* STDC */
-extern SCM scm_append ();
-extern SCM scm_append_x ();
-extern void scm_init_append ();
-
-#endif /* STDC */
-
-
+extern SCM scm_append SCM_P ((SCM objs));
+extern SCM scm_append_x SCM_P ((SCM objs));
+extern void scm_init_append SCM_P ((void));
#endif /* APPENDH */
diff --git a/libguile/appinit.c b/libguile/appinit.c
index 3af008123..1dff367f3 100644
--- a/libguile/appinit.c
+++ b/libguile/appinit.c
@@ -45,13 +45,8 @@
-#ifdef __STDC__
-void
-scm_appinit (void)
-#else
+
void
scm_appinit ()
-#endif
{
}
-
diff --git a/libguile/arbiters.c b/libguile/arbiters.c
index d5e374b42..4c5b966c7 100644
--- a/libguile/arbiters.c
+++ b/libguile/arbiters.c
@@ -42,6 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "smob.h"
+
+#include "arbiters.h"
/* {Arbiters}
@@ -53,21 +56,17 @@
static long scm_tc16_arbiter;
-#ifdef __STDC__
-static int
-prinarb (SCM exp, SCM port, int writing)
-#else
+
static int
-prinarb (exp, port, writing)
+prinarb (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_gen_puts (scm_regular_string, "#<arbiter ", port);
if (SCM_CAR (exp) & (1L << 16))
scm_gen_puts (scm_regular_string, "locked ", port);
- scm_iprin1 (SCM_CDR (exp), port, writing);
+ scm_iprin1 (SCM_CDR (exp), port, pstate);
scm_gen_putc ('>', port);
return !0;
}
@@ -78,31 +77,25 @@ static scm_smobfuns arbsmob =
};
SCM_PROC(s_make_arbiter, "make-arbiter", 1, 0, 0, scm_make_arbiter);
-#ifdef __STDC__
-SCM
-scm_make_arbiter (SCM name)
-#else
+
SCM
scm_make_arbiter (name)
SCM name;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = name;
- SCM_CAR (z) = scm_tc16_arbiter;
+ SCM_DEFER_INTS;
+ SCM_SETCDR (z, name);
+ SCM_SETCAR (z, scm_tc16_arbiter);
+ SCM_ALLOW_INTS;
return z;
}
SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter);
-#ifdef __STDC__
-SCM
-scm_try_arbiter (SCM arb)
-#else
+
SCM
scm_try_arbiter (arb)
SCM arb;
-#endif
{
SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_try_arbiter);
SCM_DEFER_INTS;
@@ -110,7 +103,7 @@ scm_try_arbiter (arb)
arb = SCM_BOOL_F;
else
{
- SCM_CAR (arb) = scm_tc16_arbiter | (1L << 16);
+ SCM_SETCAR (arb, scm_tc16_arbiter | (1L << 16));
arb = SCM_BOOL_T;
}
SCM_ALLOW_INTS;
@@ -119,30 +112,22 @@ scm_try_arbiter (arb)
SCM_PROC(s_release_arbiter, "release-arbiter", 1, 0, 0, scm_release_arbiter);
-#ifdef __STDC__
-SCM
-scm_release_arbiter (SCM arb)
-#else
+
SCM
scm_release_arbiter (arb)
SCM arb;
-#endif
{
SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_release_arbiter);
if (!(SCM_CAR (arb) & (1L << 16)))
return SCM_BOOL_F;
- SCM_CAR (arb) = scm_tc16_arbiter;
+ SCM_SETCAR (arb, scm_tc16_arbiter);
return SCM_BOOL_T;
}
-#ifdef __STDC__
-void
-scm_init_arbiters (void)
-#else
+
void
scm_init_arbiters ()
-#endif
{
scm_tc16_arbiter = scm_newsmob (&arbsmob);
#include "arbiters.x"
diff --git a/libguile/arbiters.h b/libguile/arbiters.h
index 2a88a6ebc..5e34ce297 100644
--- a/libguile/arbiters.h
+++ b/libguile/arbiters.h
@@ -44,25 +44,13 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_make_arbiter (SCM name);
-extern SCM scm_try_arbiter (SCM arb);
-extern SCM scm_release_arbiter (SCM arb);
-extern void scm_init_arbiters (void);
-
-#else /* STDC */
-extern SCM scm_make_arbiter ();
-extern SCM scm_try_arbiter ();
-extern SCM scm_release_arbiter ();
-extern void scm_init_arbiters ();
-
-#endif /* STDC */
-
-
-
+extern SCM scm_make_arbiter SCM_P ((SCM name));
+extern SCM scm_try_arbiter SCM_P ((SCM arb));
+extern SCM scm_release_arbiter SCM_P ((SCM arb));
+extern void scm_init_arbiters SCM_P ((void));
#endif /* ARBITERSH */
diff --git a/libguile/async.c b/libguile/async.c
index 7a942270e..115cc8c2f 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -43,7 +43,15 @@
#include <stdio.h>
#include <signal.h>
#include "_scm.h"
+#include "eval.h"
+#include "throw.h"
+#include "smob.h"
+#include "async.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -76,9 +84,10 @@
*
*/
-
-#define min(A,B) ((A) < (B) ? (A) : (B))
-
+/* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
+ * when the interpreter is not running at all.
+ */
+int scm_ints_disabled = 1;
unsigned int scm_async_clock = 20;
static unsigned int scm_async_rate = 20;
@@ -113,13 +122,10 @@ static long scm_tc16_async;
-#ifdef __STDC__
-static int
-asyncs_pending (void)
-#else
+static int asyncs_pending SCM_P ((void));
+
static int
asyncs_pending ()
-#endif
{
SCM pos;
pos = scm_asyncs;
@@ -137,13 +143,9 @@ asyncs_pending ()
}
-#ifdef __STDC__
-void
-scm_async_click (void)
-#else
+
void
scm_async_click ()
-#endif
{
int owe_switch;
int owe_tick;
@@ -258,24 +260,24 @@ scm_async_click ()
-#ifdef __STDC__
-void
-scm_switch (void)
-#else
+
void
scm_switch ()
+{
+#if 0 /* Thread switching code should probably reside here, but the
+ async switching code doesn't seem to work, so it's put in the
+ SCM_ASYNC_TICK macro instead. /mdj */
+ SCM_THREAD_SWITCHING_CODE;
#endif
-{}
+}
-#ifdef __STDC__
-static void
-scm_deliver_signal (int num)
-#else
+
+static void scm_deliver_signal SCM_P ((int num));
+
static void
scm_deliver_signal (num)
int num;
-#endif
{
SCM handler;
handler = SCM_CDR (handler_var);
@@ -292,16 +294,14 @@ scm_deliver_signal (num)
-#ifdef __STDC__
-static int
-print_async (SCM exp, SCM port, int writing)
-#else
+
+static int print_async SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-print_async (exp, port, writing)
+print_async (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_gen_puts (scm_regular_string, "#<async ", port);
scm_intprint(exp, 16, port);
@@ -309,14 +309,12 @@ print_async (exp, port, writing)
return 1;
}
-#ifdef __STDC__
-static SCM
-mark_async (SCM obj)
-#else
+
+static SCM mark_async SCM_P ((SCM obj));
+
static SCM
mark_async (obj)
SCM obj;
-#endif
{
struct scm_async * it;
if (SCM_GC8MARKP (obj))
@@ -326,14 +324,12 @@ mark_async (obj)
return it->thunk;
}
-#ifdef __STDC__
-static scm_sizet
-free_async (SCM obj)
-#else
+
+static scm_sizet free_async SCM_P ((SCM obj));
+
static scm_sizet
-free_async (SCM obj)
+free_async (obj)
SCM obj;
-#endif
{
struct scm_async * it;
it = SCM_ASYNC (obj);
@@ -354,14 +350,10 @@ static scm_smobfuns async_smob =
SCM_PROC(s_async, "async", 1, 0, 0, scm_async);
-#ifdef __STDC__
-SCM
-scm_async (SCM thunk)
-#else
+
SCM
scm_async (thunk)
SCM thunk;
-#endif
{
SCM it;
struct scm_async * async;
@@ -379,14 +371,10 @@ scm_async (thunk)
}
SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async);
-#ifdef __STDC__
-SCM
-scm_system_async (SCM thunk)
-#else
+
SCM
scm_system_async (thunk)
SCM thunk;
-#endif
{
SCM it;
SCM list;
@@ -402,14 +390,10 @@ scm_system_async (thunk)
}
SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark);
-#ifdef __STDC__
-SCM
-scm_async_mark (SCM a)
-#else
+
SCM
scm_async_mark (a)
SCM a;
-#endif
{
struct scm_async * it;
SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
@@ -420,14 +404,10 @@ scm_async_mark (a)
SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark);
-#ifdef __STDC__
-SCM
-scm_system_async_mark (SCM a)
-#else
+
SCM
scm_system_async_mark (a)
SCM a;
-#endif
{
struct scm_async * it;
SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
@@ -442,14 +422,10 @@ scm_system_async_mark (a)
SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs);
-#ifdef __STDC__
-SCM
-scm_run_asyncs (SCM list_of_a)
-#else
+
SCM
scm_run_asyncs (list_of_a)
SCM list_of_a;
-#endif
{
SCM pos;
@@ -480,14 +456,10 @@ scm_run_asyncs (list_of_a)
SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop);
-#ifdef __STDC__
-SCM
-scm_noop (SCM args)
-#else
+
SCM
scm_noop (args)
SCM args;
-#endif
{
return (SCM_NULLP (args)
? SCM_BOOL_F
@@ -498,14 +470,10 @@ scm_noop (args)
SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate);
-#ifdef __STDC__
-SCM
-scm_set_tick_rate (SCM n)
-#else
+
SCM
scm_set_tick_rate (n)
SCM n;
-#endif
{
unsigned int old_n;
SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate);
@@ -520,14 +488,10 @@ scm_set_tick_rate (n)
SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate);
-#ifdef __STDC__
-SCM
-scm_set_switch_rate (SCM n)
-#else
+
SCM
scm_set_switch_rate (n)
SCM n;
-#endif
{
unsigned int old_n;
SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate);
@@ -540,97 +504,81 @@ scm_set_switch_rate (n)
-#ifdef __STDC__
-static SCM
-scm_sys_hup_async_thunk (void)
-#else
+
+static SCM scm_sys_hup_async_thunk SCM_P ((void));
+
static SCM
scm_sys_hup_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_HUP_SIGNAL);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-static SCM
-scm_sys_int_async_thunk (void)
-#else
+
+static SCM scm_sys_int_async_thunk SCM_P ((void));
+
static SCM
scm_sys_int_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_INT_SIGNAL);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-static SCM
-scm_sys_fpe_async_thunk (void)
-#else
+
+static SCM scm_sys_fpe_async_thunk SCM_P ((void));
+
static SCM
scm_sys_fpe_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_FPE_SIGNAL);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-static SCM
-scm_sys_bus_async_thunk (void)
-#else
+
+static SCM scm_sys_bus_async_thunk SCM_P ((void));
+
static SCM
scm_sys_bus_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_BUS_SIGNAL);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-static SCM
-scm_sys_segv_async_thunk (void)
-#else
+
+static SCM scm_sys_segv_async_thunk SCM_P ((void));
+
static SCM
scm_sys_segv_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_SEGV_SIGNAL);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-static SCM
-scm_sys_alrm_async_thunk (void)
-#else
+
+static SCM scm_sys_alrm_async_thunk SCM_P ((void));
+
static SCM
scm_sys_alrm_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_ALRM_SIGNAL);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-static SCM
-scm_sys_gc_async_thunk (void)
-#else
+
+static SCM scm_sys_gc_async_thunk SCM_P ((void));
+
static SCM
scm_sys_gc_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_GC_SIGNAL);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-static SCM
-scm_sys_tick_async_thunk (void)
-#else
+
+static SCM scm_sys_tick_async_thunk SCM_P ((void));
+
static SCM
scm_sys_tick_async_thunk ()
-#endif
{
scm_deliver_signal (SCM_TICK_SIGNAL);
return SCM_BOOL_F;
@@ -640,22 +588,26 @@ scm_sys_tick_async_thunk ()
-#ifdef __STDC__
-SCM
-scm_take_signal (int n)
-#else
+
SCM
scm_take_signal (n)
int n;
-#endif
{
SCM ignored;
if (!scm_ints_disabled)
{
- SCM_NEWCELL (ignored); /* In case we interrupted SCM_NEWCELL,
- * throw out the possibly already allocated
- * free cell.
- */
+ /* For reasons of speed, the SCM_NEWCELL macro doesn't defer
+ interrupts. Instead, it first sets its argument to point to
+ the first cell in the list, and then advances the freelist
+ pointer to the next cell. Now, if this procedure is
+ interrupted, the only anomalous state possible is to have
+ both SCM_NEWCELL's argument and scm_freelist pointing to the
+ same cell. To deal with this case, we always throw away the
+ first cell in scm_freelist here.
+
+ At least, that's the theory. I'm not convinced that that's
+ the only anomalous path we need to worry about. */
+ SCM_NEWCELL (ignored);
}
scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]);
return SCM_BOOL_F;
@@ -664,13 +616,9 @@ scm_take_signal (n)
SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals);
-#ifdef __STDC__
-SCM
-scm_unmask_signals (void)
-#else
+
SCM
scm_unmask_signals ()
-#endif
{
scm_mask_ints = 0;
return SCM_UNSPECIFIED;
@@ -678,13 +626,9 @@ scm_unmask_signals ()
SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals);
-#ifdef __STDC__
-SCM
-scm_mask_signals (void)
-#else
+
SCM
scm_mask_signals ()
-#endif
{
scm_mask_ints = 1;
return SCM_UNSPECIFIED;
@@ -692,17 +636,13 @@ scm_mask_signals ()
-#ifdef __STDC__
-void
-scm_init_async (void)
-#else
+
void
scm_init_async ()
-#endif
{
SCM a_thunk;
scm_tc16_async = scm_newsmob (&async_smob);
- symbol_signal = SCM_CAR (scm_sysintern ("signal", strlen ("signal")));
+ symbol_signal = SCM_CAR (scm_sysintern ("signal", SCM_UNDEFINED));
scm_permanent_object (symbol_signal);
/* These are in the opposite order of delivery priortity.
@@ -730,7 +670,7 @@ scm_init_async ()
a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk);
system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk);
- handler_var = scm_sysintern ("signal-handler", strlen ("signal"));
+ handler_var = scm_sysintern ("signal-handler", SCM_UNDEFINED);
SCM_SETCDR (handler_var, SCM_BOOL_F);
scm_permanent_object (handler_var);
#include "async.x"
diff --git a/libguile/async.h b/libguile/async.h
index 2e99025ac..217603ba6 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -44,48 +44,28 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-extern unsigned int scm_async_clock;
extern unsigned int scm_mask_ints;
-#ifdef __STDC__
-extern void scm_async_click (void);
-extern void scm_switch (void);
-extern SCM scm_async (SCM thunk);
-extern SCM scm_system_async (SCM thunk);
-extern SCM scm_async_mark (SCM a);
-extern SCM scm_system_async_mark (SCM a);
-extern SCM scm_run_asyncs (SCM list_of_a);
-extern SCM scm_noop (SCM args);
-extern SCM scm_set_tick_rate (SCM n);
-extern SCM scm_set_switch_rate (SCM n);
-extern SCM scm_take_signal (int n);
-extern SCM scm_unmask_signals (void);
-extern SCM scm_mask_signals (void);
-extern void scm_init_async (void);
-
-#else /* STDC */
-extern void scm_async_click ();
-extern void scm_switch ();
-extern SCM scm_async ();
-extern SCM scm_system_async ();
-extern SCM scm_async_mark ();
-extern SCM scm_system_async_mark ();
-extern SCM scm_run_asyncs ();
-extern SCM scm_noop ();
-extern SCM scm_set_tick_rate ();
-extern SCM scm_set_switch_rate ();
-extern SCM scm_take_signal ();
-extern SCM scm_unmask_signals ();
-extern SCM scm_mask_signals ();
-extern void scm_init_async ();
-
-#endif /* STDC */
+extern void scm_async_click SCM_P ((void));
+extern void scm_switch SCM_P ((void));
+extern SCM scm_async SCM_P ((SCM thunk));
+extern SCM scm_system_async SCM_P ((SCM thunk));
+extern SCM scm_async_mark SCM_P ((SCM a));
+extern SCM scm_system_async_mark SCM_P ((SCM a));
+extern SCM scm_run_asyncs SCM_P ((SCM list_of_a));
+extern SCM scm_noop SCM_P ((SCM args));
+extern SCM scm_set_tick_rate SCM_P ((SCM n));
+extern SCM scm_set_switch_rate SCM_P ((SCM n));
+extern SCM scm_take_signal SCM_P ((int n));
+extern SCM scm_unmask_signals SCM_P ((void));
+extern SCM scm_mask_signals SCM_P ((void));
+extern void scm_init_async SCM_P ((void));
#endif /* ASYNCH */
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
new file mode 100644
index 000000000..f10fc5791
--- /dev/null
+++ b/libguile/backtrace.c
@@ -0,0 +1,510 @@
+/* Printing of backtraces and error messages
+ * Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+#include "stacks.h"
+#include "srcprop.h"
+#include "genio.h"
+#include "struct.h"
+#include "strports.h"
+
+#include "backtrace.h"
+
+/* {Error reporting and backtraces}
+ * (A first approximation.)
+ *
+ * Note that these functions shouldn't generate errors themselves.
+ */
+
+#ifndef SCM_RECKLESS
+#undef SCM_ASSERT
+#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
+ if (!(_cond)) \
+ return SCM_BOOL_F;
+#endif
+
+static void display_header SCM_P ((SCM source, SCM port));
+static void
+display_header (source, port)
+ SCM source;
+ SCM port;
+{
+ SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source)
+ ? scm_source_property (source, scm_i_filename)
+ : SCM_BOOL_F);
+ if (SCM_NIMP (fname) && SCM_STRINGP (fname))
+ {
+ scm_prin1 (fname, port, 0);
+ scm_gen_putc (':', port);
+ scm_prin1 (scm_source_property (source, scm_i_line), port, 0);
+ scm_gen_putc (':', port);
+ scm_prin1 (scm_source_property (source, scm_i_column), port, 0);
+ }
+ else
+ scm_gen_puts (scm_regular_string, "ERROR", port);
+ scm_gen_puts (scm_regular_string, ": ", port);
+}
+
+
+void
+scm_display_error_message (message, args, port)
+ SCM message;
+ SCM args;
+ SCM port;
+{
+ int writingp;
+ char *start;
+ char *p;
+
+ if (SCM_IMP (message) || !SCM_STRINGP (message) || SCM_IMP (args)
+ || !scm_list_p (args))
+ {
+ scm_prin1 (message, port, 0);
+ scm_gen_putc ('\n', port);
+ return;
+ }
+
+ start = SCM_CHARS (message);
+ for (p = start; *p != '\0'; ++p)
+ if (*p == '%')
+ {
+ if (SCM_IMP (args) || SCM_NCONSP (args))
+ continue;
+
+ ++p;
+ if (*p == 's')
+ writingp = 0;
+ else if (*p == 'S')
+ writingp = 1;
+ else
+ continue;
+
+ scm_gen_write (scm_regular_string, start, p - start - 1, port);
+ scm_prin1 (SCM_CAR (args), port, writingp);
+ args = SCM_CDR (args);
+ start = p + 1;
+ }
+ scm_gen_write (scm_regular_string, start, p - start, port);
+ scm_gen_putc ('\n', port);
+}
+
+static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
+static void
+display_expression (frame, pname, source, port)
+ SCM frame;
+ SCM pname;
+ SCM source;
+ SCM port;
+{
+ SCM print_state = scm_make_print_state ();
+ scm_print_state *pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 0;
+ pstate->fancyp = 1;
+ pstate->level = 2;
+ pstate->length = 3;
+ if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
+ {
+ if (SCM_NIMP (frame)
+ && SCM_FRAMEP (frame)
+ && SCM_FRAME_EVAL_ARGS_P (frame))
+ scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port);
+ else
+ scm_gen_puts (scm_regular_string, "In procedure ", port);
+ scm_iprin1 (pname, port, pstate);
+ if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
+ {
+ scm_gen_puts (scm_regular_string, " in expression ", port);
+ pstate->writingp = 1;
+ scm_iprin1 (scm_unmemoize (source), port, pstate);
+ }
+ }
+ else if (SCM_NIMP (source))
+ {
+ scm_gen_puts (scm_regular_string, "In expression ", port);
+ pstate->writingp = 1;
+ scm_iprin1 (scm_unmemoize (source), port, pstate);
+ }
+ scm_gen_puts (scm_regular_string, ":\n", port);
+ scm_free_print_state (print_state);
+}
+
+SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
+SCM
+scm_display_error (stack, port, subr, message, args, rest)
+ SCM stack;
+ SCM port;
+ SCM subr;
+ SCM message;
+ SCM args;
+ SCM rest;
+{
+ SCM current_frame = SCM_BOOL_F;
+ SCM source = SCM_BOOL_F;
+ SCM pname = SCM_BOOL_F;
+ if (SCM_DEBUGGINGP
+ && SCM_NIMP (stack)
+ && SCM_STACKP (stack)
+ && SCM_STACK_LENGTH (stack) > 0)
+ {
+ current_frame = scm_stack_ref (stack, SCM_INUM0);
+ source = SCM_FRAME_SOURCE (current_frame);
+ if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
+ source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
+ if (SCM_FRAME_PROC_P (current_frame)
+ && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T)
+ pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
+ }
+ if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
+ pname = subr;
+ if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
+ || (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
+ {
+ display_header (source, port);
+ display_expression (current_frame, pname, source, port);
+ }
+ display_header (source, port);
+ scm_display_error_message (message, args, port);
+ return SCM_UNSPECIFIED;
+}
+
+static void indent SCM_P ((int n, SCM port));
+static void
+indent (n, port)
+ int n;
+ SCM port;
+{
+ int i;
+ for (i = 0; i < n; ++i)
+ scm_gen_putc (' ', port);
+}
+
+static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
+static void
+display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
+ char *hdr;
+ SCM exp;
+ char *tlr;
+ int indentation;
+ SCM sport;
+ SCM port;
+ scm_print_state *pstate;
+{
+ if (SCM_NIMP (exp) && SCM_CONSP (exp))
+ {
+ scm_iprlist (hdr, exp, tlr[0], port, pstate);
+ scm_gen_puts (scm_regular_string, &tlr[1], port);
+ }
+ else
+ scm_iprin1 (exp, port, pstate);
+ scm_gen_putc ('\n', port);
+}
+
+static void display_application SCM_P ((SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate));
+static void
+display_application (frame, indentation, sport, port, pstate)
+ SCM frame;
+ int indentation;
+ SCM sport;
+ SCM port;
+ scm_print_state *pstate;
+{
+ SCM proc = SCM_FRAME_PROC (frame);
+ SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
+ ? scm_procedure_name (proc)
+ : SCM_BOOL_F);
+ display_frame_expr ("[",
+ scm_cons (SCM_NFALSEP (name) ? name : proc,
+ SCM_FRAME_ARGS (frame)),
+ SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
+ indentation,
+ sport,
+ port,
+ pstate);
+}
+
+SCM_PROC(s_display_application, "display-application", 1, 1, 0, scm_display_application);
+
+SCM
+scm_display_application (SCM frame, SCM port)
+{
+ if (SCM_UNBNDP (port))
+ port = scm_cur_outp;
+ if (SCM_FRAME_PROC_P (frame))
+ /* Display an application. */
+ {
+ SCM print_state;
+ scm_print_state *pstate;
+
+ /* Create a print state for printing of frames. */
+ print_state = scm_make_print_state ();
+ pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 1;
+ pstate->fancyp = 1;
+ pstate->level = 2;
+ pstate->length = 9;
+
+ display_application (frame, 0, SCM_BOOL_F, port, pstate); /*fixme*/
+ return SCM_BOOL_T;
+ }
+ else
+ return SCM_BOOL_F;
+}
+
+static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
+static void
+display_frame (frame, nfield, indentation, sport, port, pstate)
+ SCM frame;
+ int nfield;
+ int indentation;
+ SCM sport;
+ SCM port;
+ scm_print_state *pstate;
+{
+ int n, i, j;
+
+ /* Announce missing frames? */
+ if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
+ {
+ indent (nfield + 1 + indentation, port);
+ scm_gen_puts (scm_regular_string, "...\n", port);
+ }
+
+ /* Check size of frame number. */
+ n = SCM_FRAME_NUMBER (frame);
+ for (i = 0, j = n; j > 0; ++i) j /= 10;
+
+ /* Number indentation. */
+ indent (nfield - (i ? i : 1), port);
+
+ /* Frame number. */
+ scm_iprin1 (SCM_MAKINUM (n), port, pstate);
+
+ /* Real frame marker */
+ scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
+
+ /* Indentation. */
+ indent (indentation, port);
+
+ if (SCM_FRAME_PROC_P (frame))
+ /* Display an application. */
+ display_application (frame, nfield + 1 + indentation, sport, port, pstate);
+ else
+ /* Display a special form. */
+ {
+ SCM source = SCM_FRAME_SOURCE (frame);
+ SCM copy = scm_source_property (source, scm_i_copy);
+ display_frame_expr ("(",
+ SCM_NIMP (copy) && SCM_CONSP (copy)
+ ? copy
+ : scm_unmemoize (source),
+ ")",
+ nfield + 1 + indentation,
+ sport,
+ port,
+ pstate);
+ }
+
+ /* Announce missing frames? */
+ if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
+ {
+ indent (nfield + 1 + indentation, port);
+ scm_gen_puts (scm_regular_string, "...\n", port);
+ }
+}
+
+SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
+SCM
+scm_display_backtrace (stack, port, first, depth)
+ SCM stack;
+ SCM port;
+ SCM first;
+ SCM depth;
+{
+ int n_frames, beg, end, n, i, j;
+ int nfield, indent_p, indentation;
+ SCM frame, sport, print_state;
+ scm_print_state *pstate;
+
+ /* Argument checking and extraction. */
+ SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
+ stack,
+ SCM_ARG1,
+ s_display_backtrace);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
+ port,
+ SCM_ARG2,
+ s_display_backtrace);
+ n_frames = SCM_INUM (scm_stack_length (stack));
+ n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
+ if (SCM_BACKWARDS_P)
+ {
+ beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
+ end = beg + n - 1;
+ if (end >= n_frames)
+ end = n_frames - 1;
+ n = end - beg + 1;
+ }
+ else
+ {
+ if (SCM_INUMP (first))
+ {
+ beg = SCM_INUM (first);
+ end = beg - n + 1;
+ if (end < 0)
+ end = 0;
+ }
+ else
+ {
+ beg = n - 1;
+ end = 0;
+ if (beg >= n_frames)
+ beg = n_frames - 1;
+ }
+ n = beg - end + 1;
+ }
+ SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace);
+ SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace);
+
+ /* Create a string port used for adaptation of printing parameters. */
+ sport = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ s_display_backtrace);
+
+ /* Create a print state for printing of frames. */
+ print_state = scm_make_print_state ();
+ pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 1;
+ pstate->fancyp = 1;
+ pstate->level = 2;
+ pstate->length = 3;
+
+ /* First find out if it's reasonable to do indentation. */
+ if (SCM_BACKWARDS_P)
+ indent_p = 0;
+ else
+ {
+ indent_p = 1;
+ frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
+ for (i = 0, j = 0; i < n; ++i)
+ {
+ if (SCM_FRAME_REAL_P (frame))
+ ++j;
+ if (j > SCM_BACKTRACE_INDENT)
+ {
+ indent_p = 0;
+ break;
+ }
+ frame = (SCM_BACKWARDS_P
+ ? SCM_FRAME_PREV (frame)
+ : SCM_FRAME_NEXT (frame));
+ }
+ }
+
+ /* Determine size of frame number field. */
+ j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end)));
+ for (i = 0; j > 0; ++i) j /= 10;
+ nfield = i ? i : 1;
+
+ scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
+
+ /* Print frames. */
+ frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
+ indentation = 1;
+ display_frame (frame, nfield, indentation, sport, port, pstate);
+ for (i = 1; i < n; ++i)
+ {
+ if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
+ ++indentation;
+ frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
+ display_frame (frame, nfield, indentation, sport, port, pstate);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+SCM_VCELL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
+
+SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
+SCM
+scm_backtrace ()
+{
+ if (SCM_NFALSEP (SCM_CDR (scm_the_last_stack_var)))
+ {
+ scm_newline (scm_cur_outp);
+ scm_display_backtrace (SCM_CDR (scm_the_last_stack_var),
+ scm_cur_outp,
+ SCM_UNDEFINED,
+ SCM_UNDEFINED);
+ scm_newline (scm_cur_outp);
+ if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
+ && !SCM_BACKTRACE_P)
+ {
+ scm_gen_puts (scm_regular_string,
+ "Type \"(debug-enable 'backtrace)\" if you would like a backtrace
+automatically if an error occurs in the future.\n",
+ scm_cur_outp);
+ SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
+ }
+ }
+ else
+ {
+ scm_gen_puts (scm_regular_string,
+ "No backtrace available.\n",
+ scm_cur_outp);
+ }
+ return SCM_UNSPECIFIED;
+}
+
+
+
+void
+scm_init_backtrace ()
+{
+ scm_the_last_stack_var = scm_sysintern ("the-last-stack", SCM_BOOL_F);
+
+#include "backtrace.x"
+}
diff --git a/libguile/backtrace.h b/libguile/backtrace.h
new file mode 100644
index 000000000..830a1eb2a
--- /dev/null
+++ b/libguile/backtrace.h
@@ -0,0 +1,58 @@
+/* classes: h_files */
+
+#ifndef BACKTRACEH
+#define BACKTRACEH
+/* Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+void scm_display_error_message SCM_P ((SCM message, SCM args, SCM port));
+SCM scm_display_error SCM_P ((SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest));
+SCM scm_display_backtrace SCM_P ((SCM stack, SCM port, SCM first, SCM depth));
+
+void scm_init_backtrace SCM_P ((void));
+
+#endif /* BACKTRACEH */
diff --git a/libguile/boolean.c b/libguile/boolean.c
index cc8c63382..3267f28eb 100644
--- a/libguile/boolean.c
+++ b/libguile/boolean.c
@@ -42,32 +42,26 @@
#include <stdio.h>
#include "_scm.h"
+
+#include "boolean.h"
SCM_PROC(s_not, "not", 1, 0, 0, scm_not);
-#ifdef __STDC__
-SCM
-scm_not(SCM x)
-#else
+
SCM
scm_not(x)
SCM x;
-#endif
{
return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_boolean_p, "boolean?", 1, 0, 0, scm_boolean_p);
-#ifdef __STDC__
-SCM
-scm_boolean_p(SCM obj)
-#else
+
SCM
scm_boolean_p(obj)
SCM obj;
-#endif
{
if (SCM_BOOL_F==obj) return SCM_BOOL_T;
if (SCM_BOOL_T==obj) return SCM_BOOL_T;
@@ -75,13 +69,9 @@ scm_boolean_p(obj)
}
-#ifdef __STDC__
-void
-scm_init_boolean (void)
-#else
+
void
scm_init_boolean ()
-#endif
{
#include "boolean.x"
}
diff --git a/libguile/boolean.h b/libguile/boolean.h
index 8c9b6a7e7..c9945e566 100644
--- a/libguile/boolean.h
+++ b/libguile/boolean.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -60,17 +60,8 @@
-#ifdef __STDC__
-extern SCM scm_not(SCM x);
-extern SCM scm_boolean_p(SCM obj);
-extern void scm_init_boolean (void);
-
-#else /* STDC */
-extern SCM scm_not();
-extern SCM scm_boolean_p();
-extern void scm_init_boolean ();
-
-#endif /* STDC */
-
+extern SCM scm_not SCM_P ((SCM x));
+extern SCM scm_boolean_p SCM_P ((SCM obj));
+extern void scm_init_boolean SCM_P ((void));
#endif /* BOOLEANH */
diff --git a/libguile/chars.c b/libguile/chars.c
index 70ec0ab82..cc77d3d09 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -44,33 +44,26 @@
#include <ctype.h>
#include "_scm.h"
+#include "chars.h"
SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p);
-#ifdef __STDC__
-SCM
-scm_char_p(SCM x)
-#else
+
SCM
scm_char_p(x)
SCM x;
-#endif
{
return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p);
-#ifdef __STDC__
-SCM
-scm_char_eq_p(SCM x, SCM y)
-#else
+
SCM
scm_char_eq_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p);
@@ -79,15 +72,11 @@ scm_char_eq_p(x, y)
SCM_PROC1 (s_char_less_p, "char<?", scm_tc7_rpsubr, scm_char_less_p);
-#ifdef __STDC__
-SCM
-scm_char_less_p(SCM x, SCM y)
-#else
+
SCM
scm_char_less_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_p);
@@ -95,15 +84,11 @@ scm_char_less_p(x, y)
}
SCM_PROC1 (s_char_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p);
-#ifdef __STDC__
-SCM
-scm_char_leq_p(SCM x, SCM y)
-#else
+
SCM
scm_char_leq_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_p);
@@ -111,15 +96,11 @@ scm_char_leq_p(x, y)
}
SCM_PROC1 (s_char_gr_p, "char>?", scm_tc7_rpsubr, scm_char_gr_p);
-#ifdef __STDC__
-SCM
-scm_char_gr_p(SCM x, SCM y)
-#else
+
SCM
scm_char_gr_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p);
@@ -127,15 +108,11 @@ scm_char_gr_p(x, y)
}
SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p);
-#ifdef __STDC__
-SCM
-scm_char_geq_p(SCM x, SCM y)
-#else
+
SCM
scm_char_geq_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p);
@@ -143,15 +120,11 @@ scm_char_geq_p(x, y)
}
SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p);
-#ifdef __STDC__
-SCM
-scm_char_ci_eq_p(SCM x, SCM y)
-#else
+
SCM
scm_char_ci_eq_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p);
@@ -159,15 +132,11 @@ scm_char_ci_eq_p(x, y)
}
SCM_PROC1 (s_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, scm_char_ci_less_p);
-#ifdef __STDC__
-SCM
-scm_char_ci_less_p(SCM x, SCM y)
-#else
+
SCM
scm_char_ci_less_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_p);
@@ -175,15 +144,11 @@ scm_char_ci_less_p(x, y)
}
SCM_PROC1 (s_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p);
-#ifdef __STDC__
-SCM
-scm_char_ci_leq_p(SCM x, SCM y)
-#else
+
SCM
scm_char_ci_leq_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_p);
@@ -191,15 +156,11 @@ scm_char_ci_leq_p(x, y)
}
SCM_PROC1 (s_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, scm_char_ci_gr_p);
-#ifdef __STDC__
-SCM
-scm_char_ci_gr_p(SCM x, SCM y)
-#else
+
SCM
scm_char_ci_gr_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p);
@@ -207,15 +168,11 @@ scm_char_ci_gr_p(x, y)
}
SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p);
-#ifdef __STDC__
-SCM
-scm_char_ci_geq_p(SCM x, SCM y)
-#else
+
SCM
scm_char_ci_geq_p(x, y)
SCM x;
SCM y;
-#endif
{
SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p);
SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p);
@@ -224,42 +181,30 @@ scm_char_ci_geq_p(x, y)
SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p);
-#ifdef __STDC__
-SCM
-scm_char_alphabetic_p(SCM chr)
-#else
+
SCM
scm_char_alphabetic_p(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p);
return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p);
-#ifdef __STDC__
-SCM
-scm_char_numeric_p(SCM chr)
-#else
+
SCM
scm_char_numeric_p(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p);
return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p);
-#ifdef __STDC__
-SCM
-scm_char_whitespace_p(SCM chr)
-#else
+
SCM
scm_char_whitespace_p(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p);
return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
@@ -268,14 +213,10 @@ scm_char_whitespace_p(chr)
SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p);
-#ifdef __STDC__
-SCM
-scm_char_upper_case_p(SCM chr)
-#else
+
SCM
scm_char_upper_case_p(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
@@ -283,14 +224,10 @@ scm_char_upper_case_p(chr)
SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p);
-#ifdef __STDC__
-SCM
-scm_char_lower_case_p(SCM chr)
-#else
+
SCM
scm_char_lower_case_p(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p);
return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
@@ -299,14 +236,10 @@ scm_char_lower_case_p(chr)
SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p);
-#ifdef __STDC__
-SCM
-scm_char_is_both_p (SCM chr)
-#else
+
SCM
scm_char_is_both_p (chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr))))
@@ -318,14 +251,10 @@ scm_char_is_both_p (chr)
SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer);
-#ifdef __STDC__
-SCM
-scm_char_to_integer(SCM chr)
-#else
+
SCM
scm_char_to_integer(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer);
return scm_ulong2num((unsigned long)SCM_ICHR(chr));
@@ -334,14 +263,10 @@ scm_char_to_integer(chr)
SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char);
-#ifdef __STDC__
-SCM
-scm_integer_to_char(SCM n)
-#else
+
SCM
scm_integer_to_char(n)
SCM n;
-#endif
{
unsigned long ni;
@@ -351,14 +276,10 @@ scm_integer_to_char(n)
SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase);
-#ifdef __STDC__
-SCM
-scm_char_upcase(SCM chr)
-#else
+
SCM
scm_char_upcase(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase);
return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr)));
@@ -366,14 +287,10 @@ scm_char_upcase(chr)
SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase);
-#ifdef __STDC__
-SCM
-scm_char_downcase(SCM chr)
-#else
+
SCM
scm_char_downcase(chr)
SCM chr;
-#endif
{
SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase);
return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr)));
@@ -383,21 +300,17 @@ scm_char_downcase(chr)
-static unsigned char scm_upcase_table[SCM_CHAR_SCM_CODE_LIMIT];
-static unsigned char scm_downcase_table[SCM_CHAR_SCM_CODE_LIMIT];
+static unsigned char scm_upcase_table[SCM_CHAR_CODE_LIMIT];
+static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT];
static unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
static unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-#ifdef __STDC__
-void
-scm_tables_prehistory (void)
-#else
+
void
scm_tables_prehistory ()
-#endif
{
int i;
- for (i = 0; i < SCM_CHAR_SCM_CODE_LIMIT; i++)
+ for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++)
scm_upcase_table[i] = scm_downcase_table[i] = i;
for (i = 0; i < sizeof scm_lowers / sizeof (char); i++)
{
@@ -406,14 +319,10 @@ scm_tables_prehistory ()
}
}
-#ifdef __STDC__
-int
-scm_upcase (unsigned int c)
-#else
+
int
scm_upcase (c)
unsigned int c;
-#endif
{
if (c < sizeof (scm_upcase_table))
return scm_upcase_table[c];
@@ -421,14 +330,10 @@ scm_upcase (c)
return c;
}
-#ifdef __STDC__
-int
-scm_downcase (unsigned int c)
-#else
+
int
scm_downcase (c)
unsigned int c;
-#endif
{
if (c < sizeof (scm_downcase_table))
return scm_downcase_table[c];
@@ -494,13 +399,9 @@ int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
-#ifdef __STDC__
-void
-scm_init_chars (void)
-#else
+
void
scm_init_chars ()
-#endif
{
#include "chars.x"
}
diff --git a/libguile/chars.h b/libguile/chars.h
index 83afcfa7e..8ad7672d3 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
/* Immediate Characters
@@ -60,67 +60,31 @@ extern int scm_n_charnames;
extern char scm_charnums[];
-#ifdef __STDC__
-extern SCM scm_char_p(SCM x);
-extern SCM scm_char_eq_p(SCM x, SCM y);
-extern SCM scm_char_less_p(SCM x, SCM y);
-extern SCM scm_char_leq_p(SCM x, SCM y);
-extern SCM scm_char_gr_p(SCM x, SCM y);
-extern SCM scm_char_geq_p(SCM x, SCM y);
-extern SCM scm_char_ci_eq_p(SCM x, SCM y);
-extern SCM scm_char_ci_less_p(SCM x, SCM y);
-extern SCM scm_char_ci_leq_p(SCM x, SCM y);
-extern SCM scm_char_ci_gr_p(SCM x, SCM y);
-extern SCM scm_char_ci_geq_p(SCM x, SCM y);
-extern SCM scm_char_alphabetic_p(SCM chr);
-extern SCM scm_char_numeric_p(SCM chr);
-extern SCM scm_char_whitespace_p(SCM chr);
-extern SCM scm_char_upper_case_p(SCM chr);
-extern SCM scm_char_lower_case_p(SCM chr);
-extern SCM scm_char_is_both_p (SCM chr);
-extern SCM scm_char_to_integer(SCM chr);
-extern SCM scm_integer_to_char(SCM n);
-extern SCM scm_char_upcase(SCM chr);
-extern SCM scm_char_downcase(SCM chr);
-extern void scm_tables_prehistory (void);
-extern int scm_upcase (unsigned int c);
-extern int scm_downcase (unsigned int c);
-extern void scm_init_chars (void);
-
-#else /* STDC */
-extern SCM scm_char_p();
-extern SCM scm_char_eq_p();
-extern SCM scm_char_less_p();
-extern SCM scm_char_leq_p();
-extern SCM scm_char_gr_p();
-extern SCM scm_char_geq_p();
-extern SCM scm_char_ci_eq_p();
-extern SCM scm_char_ci_less_p();
-extern SCM scm_char_ci_leq_p();
-extern SCM scm_char_ci_gr_p();
-extern SCM scm_char_ci_geq_p();
-extern SCM scm_char_alphabetic_p();
-extern SCM scm_char_numeric_p();
-extern SCM scm_char_whitespace_p();
-extern SCM scm_char_upper_case_p();
-extern SCM scm_char_lower_case_p();
-extern SCM scm_char_is_both_p ();
-extern SCM scm_char_to_integer();
-extern SCM scm_integer_to_char();
-extern SCM scm_char_upcase();
-extern SCM scm_char_downcase();
-extern void scm_tables_prehistory ();
-extern int scm_upcase ();
-extern int scm_downcase ();
-extern void scm_init_chars ();
-
-#endif /* STDC */
-
-
-
-
-
-
+extern SCM scm_char_p SCM_P ((SCM x));
+extern SCM scm_char_eq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_less_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_leq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_gr_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_geq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_ci_eq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_ci_less_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_ci_leq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_ci_gr_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_ci_geq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_char_alphabetic_p SCM_P ((SCM chr));
+extern SCM scm_char_numeric_p SCM_P ((SCM chr));
+extern SCM scm_char_whitespace_p SCM_P ((SCM chr));
+extern SCM scm_char_upper_case_p SCM_P ((SCM chr));
+extern SCM scm_char_lower_case_p SCM_P ((SCM chr));
+extern SCM scm_char_is_both_p SCM_P ((SCM chr));
+extern SCM scm_char_to_integer SCM_P ((SCM chr));
+extern SCM scm_integer_to_char SCM_P ((SCM n));
+extern SCM scm_char_upcase SCM_P ((SCM chr));
+extern SCM scm_char_downcase SCM_P ((SCM chr));
+extern void scm_tables_prehistory SCM_P ((void));
+extern int scm_upcase SCM_P ((unsigned int c));
+extern int scm_downcase SCM_P ((unsigned int c));
+extern void scm_init_chars SCM_P ((void));
#endif /* SCM_CHARSH */
diff --git a/libguile/configure b/libguile/configure
index 83e29e67b..98884ce31 100755
--- a/libguile/configure
+++ b/libguile/configure
@@ -1,7 +1,7 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.9
+# Generated automatically using autoconf version 2.12
# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
#
# This configure script is free software; the Free Software Foundation
@@ -11,6 +11,19 @@
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
+ac_help="$ac_help
+ --enable-maintainer-mode enable make rules and dependencies not useful
+ (and sometimes confusing) to the casual installer"
+ac_help="$ac_help
+ --disable-debug Don't include debugging support"
+ac_help="$ac_help
+ --enable-dynamic-linking Include support for dynamic linking"
+ac_help="$ac_help
+ --enable-guile-debug Include internal debugging functions"
+ac_help="$ac_help
+ --enable-shared build shared libraries [default=yes]"
+ac_help="$ac_help
+ --with-threads thread interface"
# Initialize some variables set by options.
# The variables have the same names as the options, with
@@ -49,6 +62,8 @@ mandir='${prefix}/man'
# Initialize some other variables.
subdirs=
MFLAGS= MAKEFLAGS=
+# Maximum number of lines to put in a shell here document.
+ac_max_here_lines=12
ac_prev=
for ac_option
@@ -330,7 +345,7 @@ EOF
verbose=yes ;;
-version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.9"
+ echo "configure generated by autoconf version 2.12"
exit 0 ;;
-with-* | --with-*)
@@ -432,11 +447,14 @@ do
done
# NLS nuisances.
-# Only set LANG and LC_ALL to C if already set.
-# These must not be set unconditionally because not all systems understand
-# e.g. LANG=C (notably SCO).
-if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+# Only set these to C if already set. These must not be set unconditionally
+# because not all systems understand e.g. LANG=C (notably SCO).
+# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
+# Non-C LC_CTYPE values break the ctype check.
if test "${LANG+set}" = set; then LANG=C; export LANG; fi
+if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
+if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -rf conftest* confdefs.h
@@ -498,6 +516,7 @@ ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
# Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
@@ -514,14 +533,321 @@ fi
+
+ac_aux_dir=
+for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
+ if test -f $ac_dir/install-sh; then
+ ac_aux_dir=$ac_dir
+ ac_install_sh="$ac_aux_dir/install-sh -c"
+ break
+ elif test -f $ac_dir/install.sh; then
+ ac_aux_dir=$ac_dir
+ ac_install_sh="$ac_aux_dir/install.sh -c"
+ break
+ fi
+done
+if test -z "$ac_aux_dir"; then
+ { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
+fi
+ac_config_guess=$ac_aux_dir/config.guess
+ac_config_sub=$ac_aux_dir/config.sub
+ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
+
+# Find a good install program. We prefer a C program (faster),
+# so one script is as good as another. But avoid the broken or
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# ./install, which can be erroneously created by make from ./install.sh.
+echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
+echo "configure:568: checking for a BSD compatible install" >&5
+if test -z "$INSTALL"; then
+if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:"
+ for ac_dir in $PATH; do
+ # Account for people who put trailing slashes in PATH elements.
+ case "$ac_dir/" in
+ /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
+ *)
+ # OSF1 and SCO ODT 3.0 have their own names for install.
+ for ac_prog in ginstall installbsd scoinst install; do
+ if test -f $ac_dir/$ac_prog; then
+ if test $ac_prog = install &&
+ grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
+ # AIX install. It has an incompatible calling convention.
+ # OSF/1 installbsd also uses dspmsg, but is usable.
+ :
+ else
+ ac_cv_path_install="$ac_dir/$ac_prog -c"
+ break 2
+ fi
+ fi
+ done
+ ;;
+ esac
+ done
+ IFS="$ac_save_IFS"
+
+fi
+ if test "${ac_cv_path_install+set}" = set; then
+ INSTALL="$ac_cv_path_install"
+ else
+ # As a last resort, use the slow shell script. We don't cache a
+ # path for INSTALL within a source directory, because that will
+ # break other packages using the cache if that directory is
+ # removed, or if the path is relative.
+ INSTALL="$ac_install_sh"
+ fi
+fi
+echo "$ac_t""$INSTALL" 1>&6
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+
+
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
+
+
. $srcdir/../GUILE-VERSION
-test -z "$CFLAGS" && CFLAGS=-g
-test -z "$LDFLAGS" && LDFLAGS=-g
+PACKAGE=$PACKAGE
+
+VERSION=$VERSION
+
+
+echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6
+echo "configure:629: checking whether build environment is sane" >&5
+# Just in case
+sleep 1
+echo timestamp > conftestfile
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments. Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+ set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
+ if test "" = "X"; then
+ # -L didn't work.
+ set X `ls -t $srcdir/configure conftestfile`
+ fi
+ test "$2" = conftestfile
+ )
+then
+ # Ok.
+ :
+else
+ { echo "configure: error: newly created file is older than distributed files!
+Check your system clock" 1>&2; exit 1; }
+fi
+rm -f conftest*
+echo "$ac_t""yes" 1>&6
+if test "$program_transform_name" = s,x,x,; then
+ program_transform_name=
+else
+ # Double any \ or $. echo might interpret backslashes.
+ cat <<\EOF_SED > conftestsed
+s,\\,\\\\,g; s,\$,$$,g
+EOF_SED
+ program_transform_name="`echo $program_transform_name|sed -f conftestsed`"
+ rm -f conftestsed
+fi
+test "$program_prefix" != NONE &&
+ program_transform_name="s,^,${program_prefix},; $program_transform_name"
+# Use a double $ so make ignores it.
+test "$program_suffix" != NONE &&
+ program_transform_name="s,\$\$,${program_suffix},; $program_transform_name"
+
+# sed with no file args requires a program.
+test "$program_transform_name" = "" && program_transform_name="s,x,x,"
+
+missing_dir=`cd $ac_aux_dir && pwd`
+echo $ac_n "checking for working aclocal""... $ac_c" 1>&6
+echo "configure:676: checking for working aclocal" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (aclocal --version) > /dev/null 2>&1; then
+ ACLOCAL=aclocal
+ echo "$ac_t""found" 1>&6
+else
+ ACLOCAL="$missing_dir/missing aclocal"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working autoconf""... $ac_c" 1>&6
+echo "configure:688: checking for working autoconf" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (autoconf --version) > /dev/null 2>&1; then
+ AUTOCONF=autoconf
+ echo "$ac_t""found" 1>&6
+else
+ AUTOCONF="$missing_dir/missing autoconf"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working automake""... $ac_c" 1>&6
+echo "configure:700: checking for working automake" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (automake --version) > /dev/null 2>&1; then
+ AUTOMAKE=automake
+ echo "$ac_t""found" 1>&6
+else
+ AUTOMAKE="$missing_dir/missing automake"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working autoheader""... $ac_c" 1>&6
+echo "configure:712: checking for working autoheader" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (autoheader --version) > /dev/null 2>&1; then
+ AUTOHEADER=autoheader
+ echo "$ac_t""found" 1>&6
+else
+ AUTOHEADER="$missing_dir/missing autoheader"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working makeinfo""... $ac_c" 1>&6
+echo "configure:724: checking for working makeinfo" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+if (makeinfo --version) > /dev/null 2>&1; then
+ MAKEINFO=makeinfo
+ echo "$ac_t""found" 1>&6
+else
+ MAKEINFO="$missing_dir/missing makeinfo"
+ echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
+echo "configure:736: checking whether ${MAKE-make} sets \${MAKE}" >&5
+set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftestmake <<\EOF
+all:
+ @echo 'ac_maketemp="${MAKE}"'
+EOF
+# GNU make sometimes prints "make[1]: Entering...", which would confuse us.
+eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=`
+if test -n "$ac_maketemp"; then
+ eval ac_cv_prog_make_${ac_make}_set=yes
+else
+ eval ac_cv_prog_make_${ac_make}_set=no
+fi
+rm -f conftestmake
+fi
+if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ SET_MAKE=
+else
+ echo "$ac_t""no" 1>&6
+ SET_MAKE="MAKE=${MAKE-make}"
+fi
+
+ac_aux_dir=
+for ac_dir in .. $srcdir/..; do
+ if test -f $ac_dir/install-sh; then
+ ac_aux_dir=$ac_dir
+ ac_install_sh="$ac_aux_dir/install-sh -c"
+ break
+ elif test -f $ac_dir/install.sh; then
+ ac_aux_dir=$ac_dir
+ ac_install_sh="$ac_aux_dir/install.sh -c"
+ break
+ fi
+done
+if test -z "$ac_aux_dir"; then
+ { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; }
+fi
+ac_config_guess=$ac_aux_dir/config.guess
+ac_config_sub=$ac_aux_dir/config.sub
+ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
+
+module=libguile
+
+echo $ac_n "checking whether to enable maintainer-specific portions of Makefiles""... $ac_c" 1>&6
+echo "configure:784: checking whether to enable maintainer-specific portions of Makefiles" >&5
+ # Check whether --enable-maintainer-mode or --disable-maintainer-mode was given.
+if test "${enable_maintainer_mode+set}" = set; then
+ enableval="$enable_maintainer_mode"
+ USE_MAINTAINER_MODE=$enableval
+else
+ USE_MAINTAINER_MODE=no
+fi
+
+ echo "$ac_t""$USE_MAINTAINER_MODE" 1>&6
+ if test $USE_MAINTAINER_MODE = yes; then
+ MAINT=
+ else
+ MAINT='#M#'
+ fi
+
+
+
+#--------------------------------------------------------------------
+#
+# User options
+#
+#--------------------------------------------------------------------
+
+# Check whether --enable-debug or --disable-debug was given.
+if test "${enable_debug+set}" = set; then
+ enableval="$enable_debug"
+ :
+fi
+
+if test "$enableval" != n && test "$enableval" != no; then
+ cat >> confdefs.h <<\EOF
+#define DEBUG_EXTENSIONS 1
+EOF
+
+ cat >> confdefs.h <<\EOF
+#define READER_EXTENSIONS 1
+EOF
+
+ LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS"
+fi
+
+# Check whether --enable-dynamic-linking or --disable-dynamic-linking was given.
+if test "${enable_dynamic_linking+set}" = set; then
+ enableval="$enable_dynamic_linking"
+ :
+fi
+
+
+# Check whether --enable-guile-debug or --disable-guile-debug was given.
+if test "${enable_guile_debug+set}" = set; then
+ enableval="$enable_guile_debug"
+ :
+fi
+
+if test "$enableval" = y || test "$enableval" = yes; then
+ cat >> confdefs.h <<\EOF
+#define GUILE_DEBUG 1
+EOF
+
+fi
+
+#--------------------------------------------------------------------
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:851: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -550,6 +876,7 @@ if test -z "$CC"; then
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:880: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -596,7 +923,47 @@ fi
test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
fi
+echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
+echo "configure:928: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
+
+ac_ext=c
+# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
+ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
+
+cat > conftest.$ac_ext <<EOF
+#line 938 "configure"
+#include "confdefs.h"
+main(){return(0);}
+EOF
+if { (eval echo configure:942: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ ac_cv_prog_cc_works=yes
+ # If we can't run a trivial program, we are probably using a cross compiler.
+ if (./conftest; exit) 2>/dev/null; then
+ ac_cv_prog_cc_cross=no
+ else
+ ac_cv_prog_cc_cross=yes
+ fi
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ ac_cv_prog_cc_works=no
+fi
+rm -fr conftest*
+
+echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
+if test $ac_cv_prog_cc_works = no; then
+ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
+fi
+echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
+echo "configure:962: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
+echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
+cross_compiling=$ac_cv_prog_cc_cross
+
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
+echo "configure:967: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -605,7 +972,7 @@ else
yes;
#endif
EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:609: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:976: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
@@ -613,29 +980,34 @@ fi
fi
echo "$ac_t""$ac_cv_prog_gcc" 1>&6
+
if test $ac_cv_prog_gcc = yes; then
GCC=yes
- if test "${CFLAGS+set}" != set; then
- echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-if eval "test \"`echo '$''{'ac_cv_prog_gcc_g'+set}'`\" = set"; then
+ ac_test_CFLAGS="${CFLAGS+set}"
+ ac_save_CFLAGS="$CFLAGS"
+ CFLAGS=
+ echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
+echo "configure:991: checking whether ${CC-cc} accepts -g" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
- ac_cv_prog_gcc_g=yes
+ ac_cv_prog_cc_g=yes
else
- ac_cv_prog_gcc_g=no
+ ac_cv_prog_cc_g=no
fi
rm -f conftest*
fi
-echo "$ac_t""$ac_cv_prog_gcc_g" 1>&6
- if test $ac_cv_prog_gcc_g = yes; then
- CFLAGS="-g -O"
- else
- CFLAGS="-O"
- fi
+echo "$ac_t""$ac_cv_prog_cc_g" 1>&6
+ if test "$ac_test_CFLAGS" = set; then
+ CFLAGS="$ac_save_CFLAGS"
+ elif test $ac_cv_prog_cc_g = yes; then
+ CFLAGS="-g -O2"
+ else
+ CFLAGS="-O2"
fi
else
GCC=
@@ -643,6 +1015,7 @@ else
fi
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
+echo "configure:1019: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
@@ -657,33 +1030,37 @@ else
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
-#line 661 "configure"
+#line 1034 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:667: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1040: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
:
else
echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
-#line 676 "configure"
+#line 1051 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:682: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1057: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
:
else
echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
CPP=/lib/cpp
fi
@@ -698,9 +1075,37 @@ else
fi
echo "$ac_t""$CPP" 1>&6
+
+# Make sure we can run config.sub.
+if $ac_config_sub sun4 >/dev/null 2>&1; then :
+else { echo "configure: error: can not run $ac_config_sub" 1>&2; exit 1; }
+fi
+
+echo $ac_n "checking host system type""... $ac_c" 1>&6
+echo "configure:1086: checking host system type" >&5
+
+host_alias=$host
+case "$host_alias" in
+NONE)
+ case $nonopt in
+ NONE)
+ if host_alias=`$ac_config_guess`; then :
+ else { echo "configure: error: can not guess host type; you must specify one" 1>&2; exit 1; }
+ fi ;;
+ *) host_alias=$nonopt ;;
+ esac ;;
+esac
+
+host=`$ac_config_sub $host_alias`
+host_cpu=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
+host_vendor=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
+host_os=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
+echo "$ac_t""$host" 1>&6
+
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:1109: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -727,9 +1132,51 @@ else
fi
+
+
+
+# Always use our own libtool.
+LIBTOOL='$(top_builddir)/libtool'
+
+
+# Check whether --enable-shared or --disable-shared was given.
+if test "${enable_shared+set}" = set; then
+ enableval="$enable_shared"
+ test "$enableval" = no && libtool_shared=" --disable-shared"
+else
+ libtool_shared=
+fi
+
+
+libtool_flags="$libtool_shared"
+test "$silent" = yes && libtool_flags="$libtool_flags --silent"
+test "$ac_cv_prog_gcc" = yes && libtool_flags="$libtool_flags --with-gcc"
+
+case "$host" in
+*-*-irix6*)
+ # For IRIX 6, ld needs -n32 if cc uses it.
+ if echo " $CC $CFLAGS " | egrep -e '[ ]-n32[ ]' > /dev/null; then
+ LD="${LD-ld} -n32"
+ fi
+ ;;
+
+*-*-sco3.2v5*)
+ # On SCO OpenServer 5, we need -belf to get full-featured binaries.
+ CFLAGS="$CFLAGS -belf"
+ ;;
+esac
+
+# Actually configure libtool. ac_aux_dir is where install-sh is found.
+CC="$CC" CFLAGS="$CFLAGS" CPPFLAGS="$CPPFLAGS" LD="$LD" RANLIB="$RANLIB" \
+${CONFIG_SHELL-/bin/sh} $ac_aux_dir/ltconfig \
+$libtool_flags --no-verify $ac_aux_dir/ltmain.sh $host \
+|| { echo "configure: error: libtool configure failed" 1>&2; exit 1; }
+
+
echo $ac_n "checking for AIX""... $ac_c" 1>&6
+echo "configure:1178: checking for AIX" >&5
cat > conftest.$ac_ext <<EOF
-#line 733 "configure"
+#line 1180 "configure"
#include "confdefs.h"
#ifdef _AIX
yes
@@ -751,6 +1198,7 @@ rm -f conftest*
echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6
+echo "configure:1202: checking for POSIXized ISC" >&5
if test -d /etc/conf/kconfig.d &&
grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1
then
@@ -770,24 +1218,27 @@ else
ISC=
fi
-ac_safe=`echo "minix/config.h" | tr './\055' '___'`
+ac_safe=`echo "minix/config.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for minix/config.h""... $ac_c" 1>&6
+echo "configure:1224: checking for minix/config.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 780 "configure"
+#line 1229 "configure"
#include "confdefs.h"
#include <minix/config.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:785: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1234: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
eval "ac_cv_header_$ac_safe=yes"
else
echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_header_$ac_safe=no"
fi
@@ -817,16 +1268,162 @@ EOF
fi
+
+echo $ac_n "checking "threads package type"""... $ac_c" 1>&6
+echo "configure:1274: checking "threads package type"" >&5
+if eval "test \"`echo '$''{'cy_cv_threads_package'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+if eval "test \"`echo '$''{'cy_cv_threads_cflags'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+if eval "test \"`echo '$''{'cy_cv_threads_libs'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+use_threads=no;
+# Check whether --with-threads or --without-threads was given.
+if test "${with_threads+set}" = set; then
+ withval="$with_threads"
+ use_threads=$withval
+else
+ use_threads=no
+fi
+
+test -n "$use_threads" || use_threads=qt
+threads_package=unknown
+if test "$use_threads" != no; then
+ if test "$use_threads" = yes || test "$use_threads" = qt; then
+ # Look for qt in source directory. This is a hack: we look in
+ # "./qt" because this check might be run at the top level.
+ if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$srcdir/../qt -I../qt"
+ cy_cv_threads_libs="../qt/libqt.a"
+ fi
+ else
+ if test -f $use_threads/qt.c; then
+ # FIXME seems as though we should try to use an installed qt here.
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$use_threads -I../qt"
+ cy_cv_threads_libs="../qt/libqt.a"
+ fi
+ fi
+ if test "$use_threads" = pthreads; then
+ # Look for pthreads in srcdir. See above to understand why
+ # we always set threads_package.
+ if test -f $srcdir/../../pthreads/pthreads/queue.c \
+ || test -f $srcdir/../pthreads/pthreads/queue.c; then
+ threads_package=MIT
+ cy_cv_threads_cflags="-I$srcdir/../../pthreads/include"
+ cy_cv_threads_libs="-L../../pthreads/lib -lpthread"
+ fi
+ fi
+ saved_CPP="$CPPFLAGS"
+ saved_LD="$LDFLAGS"
+ saved_LIBS="$LIBS"
+ if test "$threads_package" = unknown; then
+ CPPFLAGS="-I$use_threads/include"
+ LDFLAGS="-L$use_threads/lib"
+ LIBS="-lgthreads -lmalloc"
+ cat > conftest.$ac_ext <<EOF
+#line 1333 "configure"
+#include "confdefs.h"
+#include <pthread.h>
+int main() {
+
+pthread_equal(NULL,NULL);
+
+; return 0; }
+EOF
+if { (eval echo configure:1342: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ threads_package=FSU
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+fi
+rm -f conftest*
+ fi
+ if test "$threads_package" = unknown; then
+ LIBS="-lpthread"
+ cat > conftest.$ac_ext <<EOF
+#line 1354 "configure"
+#include "confdefs.h"
+#include <pthread.h>
+int main() {
+
+pthread_equal(NULL,NULL);
+
+; return 0; }
+EOF
+if { (eval echo configure:1363: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ threads_package=MIT
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+fi
+rm -f conftest*
+ fi
+ if test "$threads_package" = unknown; then
+ LIBS="-lpthreads"
+ cat > conftest.$ac_ext <<EOF
+#line 1375 "configure"
+#include "confdefs.h"
+#include <pthread.h>
+int main() {
+
+pthread_equal(NULL,NULL);
+
+; return 0; }
+EOF
+if { (eval echo configure:1384: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ threads_package=PCthreads
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+fi
+rm -f conftest*
+ fi
+ cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags"
+ cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs"
+ cy_cv_threads_package=$threads_package
+ CPPFLAGS="$saved_CPP"
+ LDFLAGS="$saved_LD"
+ LIBS="$saved_LIBS"
+ if test "$threads_package" = unknown; then
+ { echo "configure: error: "cannot find thread library installation"" 1>&2; exit 1; }
+ fi
+fi
+
+fi
+
+
+fi
+
+
+fi
+
+echo "$ac_t""$cy_cv_threads_package" 1>&6
+
+CFLAGS="$CFLAGS $cy_cv_threads_cflags"
+THREAD_LIBS="$cy_cv_threads_libs"
+
+
echo $ac_n "checking for working const""... $ac_c" 1>&6
+echo "configure:1419: checking for working const" >&5
if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 826 "configure"
+#line 1424 "configure"
#include "confdefs.h"
-int main() { return 0; }
-int t() {
+int main() {
/* Ultrix mips cc rejects this. */
typedef int charset[2]; const charset x;
@@ -872,15 +1469,16 @@ ccp = (char const *const *) p;
; return 0; }
EOF
-if { (eval echo configure:876: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1473: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_c_const=yes
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_c_const=no
fi
rm -f conftest*
-
fi
echo "$ac_t""$ac_cv_c_const" 1>&6
@@ -892,38 +1490,13 @@ EOF
fi
-# If we cannot run a trivial program, we must be cross compiling.
-echo $ac_n "checking whether cross-compiling""... $ac_c" 1>&6
-if eval "test \"`echo '$''{'ac_cv_c_cross'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test "$cross_compiling" = yes; then
- ac_cv_c_cross=yes
-else
-cat > conftest.$ac_ext <<EOF
-#line 905 "configure"
-#include "confdefs.h"
-main(){return(0);}
-EOF
-{ (eval echo configure:909: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
-if test -s conftest && (./conftest; exit) 2>/dev/null; then
- ac_cv_c_cross=no
-else
- ac_cv_c_cross=yes
-fi
-fi
-rm -fr conftest*
-fi
-
-echo "$ac_t""$ac_cv_c_cross" 1>&6
-cross_compiling=$ac_cv_c_cross
-
echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6
+echo "configure:1495: checking for ANSI C header files" >&5
if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 927 "configure"
+#line 1500 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
@@ -931,13 +1504,15 @@ else
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:935: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1508: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
ac_cv_header_stdc=yes
else
echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_header_stdc=no
fi
@@ -946,7 +1521,7 @@ rm -f conftest*
if test $ac_cv_header_stdc = yes; then
# SunOS 4.x string.h does not declare mem*, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 950 "configure"
+#line 1525 "configure"
#include "confdefs.h"
#include <string.h>
EOF
@@ -964,7 +1539,7 @@ fi
if test $ac_cv_header_stdc = yes; then
# ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 968 "configure"
+#line 1543 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -984,8 +1559,8 @@ if test $ac_cv_header_stdc = yes; then
if test "$cross_compiling" = yes; then
:
else
-cat > conftest.$ac_ext <<EOF
-#line 989 "configure"
+ cat > conftest.$ac_ext <<EOF
+#line 1564 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
@@ -996,15 +1571,19 @@ if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2);
exit (0); }
EOF
-{ (eval echo configure:1000: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
-if test -s conftest && (./conftest; exit) 2>/dev/null; then
+if { (eval echo configure:1575: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
+then
:
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
ac_cv_header_stdc=no
fi
-fi
rm -fr conftest*
fi
+
+fi
fi
echo "$ac_t""$ac_cv_header_stdc" 1>&6
@@ -1018,34 +1597,35 @@ fi
ac_header_dirent=no
for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h
do
-ac_safe=`echo "$ac_hdr" | tr './\055' '___'`
+ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr that defines DIR""... $ac_c" 1>&6
+echo "configure:1603: checking for $ac_hdr that defines DIR" >&5
if eval "test \"`echo '$''{'ac_cv_header_dirent_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1028 "configure"
+#line 1608 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_hdr>
-int main() { return 0; }
-int t() {
+int main() {
DIR *dirp = 0;
; return 0; }
EOF
-if { (eval echo configure:1037: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1616: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
eval "ac_cv_header_dirent_$ac_safe=yes"
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_header_dirent_$ac_safe=no"
fi
rm -f conftest*
-
fi
if eval "test \"`echo '$ac_cv_header_dirent_'$ac_safe`\" = yes"; then
echo "$ac_t""yes" 1>&6
- ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdedfghijklmnopqrstuvwxyz./\055' 'ABCDEDFGHIJKLMNOPQRSTUVWXYZ___'`
+ ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
cat >> confdefs.h <<EOF
#define $ac_tr_hdr 1
EOF
@@ -1056,28 +1636,32 @@ fi
done
# Two versions of opendir et al. are in -ldir and -lx on SCO Xenix.
if test $ac_header_dirent = dirent.h; then
-echo $ac_n "checking for -ldir""... $ac_c" 1>&6
-ac_lib_var=`echo dir_opendir | tr '.-/+' '___p'`
+echo $ac_n "checking for opendir in -ldir""... $ac_c" 1>&6
+echo "configure:1641: checking for opendir in -ldir" >&5
+ac_lib_var=`echo dir'_'opendir | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-ldir $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1068 "configure"
+#line 1649 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char opendir();
-int main() { return 0; }
-int t() {
+int main() {
opendir()
; return 0; }
EOF
-if { (eval echo configure:1078: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:1660: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
fi
@@ -1093,28 +1677,32 @@ else
fi
else
-echo $ac_n "checking for -lx""... $ac_c" 1>&6
-ac_lib_var=`echo x_opendir | tr '.-/+' '___p'`
+echo $ac_n "checking for opendir in -lx""... $ac_c" 1>&6
+echo "configure:1682: checking for opendir in -lx" >&5
+ac_lib_var=`echo x'_'opendir | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lx $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1105 "configure"
+#line 1690 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char opendir();
-int main() { return 0; }
-int t() {
+int main() {
opendir()
; return 0; }
EOF
-if { (eval echo configure:1115: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:1701: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
fi
@@ -1132,29 +1720,30 @@ fi
fi
echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
+echo "configure:1724: checking whether time.h and sys/time.h may both be included" >&5
if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1140 "configure"
+#line 1729 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
#include <time.h>
-int main() { return 0; }
-int t() {
+int main() {
struct tm *tp;
; return 0; }
EOF
-if { (eval echo configure:1150: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1738: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_time=yes
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_header_time=no
fi
rm -f conftest*
-
fi
echo "$ac_t""$ac_cv_header_time" 1>&6
@@ -1166,11 +1755,12 @@ EOF
fi
echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6
+echo "configure:1759: checking for sys/wait.h that is POSIX.1 compatible" >&5
if eval "test \"`echo '$''{'ac_cv_header_sys_wait_h'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1174 "configure"
+#line 1764 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/wait.h>
@@ -1180,22 +1770,22 @@ else
#ifndef WIFEXITED
#define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
#endif
-int main() { return 0; }
-int t() {
+int main() {
int s;
wait (&s);
s = WIFEXITED (s) ? WEXITSTATUS (s) : 1;
; return 0; }
EOF
-if { (eval echo configure:1191: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1780: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_sys_wait_h=yes
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_header_sys_wait_h=no
fi
rm -f conftest*
-
fi
echo "$ac_t""$ac_cv_header_sys_wait_h" 1>&6
@@ -1206,26 +1796,70 @@ EOF
fi
-for ac_hdr in unistd.h string.h malloc.h memory.h limits.h time.h sys/types.h sys/select.h sys/time.h sys/timeb.h sys/times.h
+for ac_hdr in libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h
+do
+ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+echo "configure:1804: checking for $ac_hdr" >&5
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1809 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1814: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out`
+if test -z "$ac_err"; then
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=yes"
+else
+ echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_hdr 1
+EOF
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+done
+
+
+ for ac_hdr in libc.h unistd.h
do
-ac_safe=`echo "$ac_hdr" | tr './\055' '___'`
+ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+echo "configure:1845: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1218 "configure"
+#line 1850 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1223: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1855: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
eval "ac_cv_header_$ac_safe=yes"
else
echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_header_$ac_safe=no"
fi
@@ -1233,7 +1867,7 @@ rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
echo "$ac_t""yes" 1>&6
- ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'`
+ ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
cat >> confdefs.h <<EOF
#define $ac_tr_hdr 1
EOF
@@ -1243,13 +1877,61 @@ else
fi
done
+ echo $ac_n "checking "whether libc.h and unistd.h can be included together"""... $ac_c" 1>&6
+echo "configure:1882: checking "whether libc.h and unistd.h can be included together"" >&5
+if eval "test \"`echo '$''{'guile_cv_header_libc_with_unistd'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+ if test "$ac_cv_header_libc_h" = "no"; then
+ guile_cv_header_libc_with_unistd="no"
+ elif test "$ac_cv_header_unistd.h" = "no"; then
+ guile_cv_header_libc_with_unistd="yes"
+ else
+ cat > conftest.$ac_ext <<EOF
+#line 1893 "configure"
+#include "confdefs.h"
+
+# include <libc.h>
+# include <unistd.h>
+
+int main() {
+
+; return 0; }
+EOF
+if { (eval echo configure:1903: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ guile_cv_header_libc_with_unistd=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ guile_cv_header_libc_with_unistd=no
+
+fi
+rm -f conftest*
+ fi
+
+
+fi
+
+echo "$ac_t""$guile_cv_header_libc_with_unistd" 1>&6
+ if test "$guile_cv_header_libc_with_unistd" = yes; then
+ cat >> confdefs.h <<\EOF
+#define LIBC_H_WITH_UNISTD_H 1
+EOF
+
+ fi
+
+
echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6
+echo "configure:1930: checking for uid_t in sys/types.h" >&5
if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1253 "configure"
+#line 1935 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
@@ -1278,14 +1960,15 @@ EOF
fi
echo $ac_n "checking type of array argument to getgroups""... $ac_c" 1>&6
+echo "configure:1964: checking type of array argument to getgroups" >&5
if eval "test \"`echo '$''{'ac_cv_type_getgroups'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$cross_compiling" = yes; then
ac_cv_type_getgroups=cross
else
-cat > conftest.$ac_ext <<EOF
-#line 1289 "configure"
+ cat > conftest.$ac_ext <<EOF
+#line 1972 "configure"
#include "confdefs.h"
/* Thanks to Mike Rendell for this test. */
@@ -1310,17 +1993,21 @@ main()
}
EOF
-{ (eval echo configure:1314: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
-if test -s conftest && (./conftest; exit) 2>/dev/null; then
+if { (eval echo configure:1997: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
+then
ac_cv_type_getgroups=gid_t
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
ac_cv_type_getgroups=int
fi
-fi
rm -fr conftest*
+fi
+
if test $ac_cv_type_getgroups = cross; then
cat > conftest.$ac_ext <<EOF
-#line 1324 "configure"
+#line 2011 "configure"
#include "confdefs.h"
#include <unistd.h>
EOF
@@ -1344,11 +2031,12 @@ EOF
echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6
+echo "configure:2035: checking return type of signal handlers" >&5
if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1352 "configure"
+#line 2040 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <signal.h>
@@ -1361,20 +2049,20 @@ extern "C" void (*signal (int, void (*)(int)))(int);
void (*signal ()) ();
#endif
-int main() { return 0; }
-int t() {
+int main() {
int i;
; return 0; }
EOF
-if { (eval echo configure:1370: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:2057: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_type_signal=void
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_type_signal=int
fi
rm -f conftest*
-
fi
echo "$ac_t""$ac_cv_type_signal" 1>&6
@@ -1383,24 +2071,59 @@ cat >> confdefs.h <<EOF
EOF
+echo $ac_n "checking for mode_t""... $ac_c" 1>&6
+echo "configure:2076: checking for mode_t" >&5
+if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2081 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#if STDC_HEADERS
+#include <stdlib.h>
+#include <stddef.h>
+#endif
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ egrep "mode_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then
+ rm -rf conftest*
+ ac_cv_type_mode_t=yes
+else
+ rm -rf conftest*
+ ac_cv_type_mode_t=no
+fi
+rm -f conftest*
-for ac_func in ftime times geteuid select uname mkdir rmdir getcwd rename putenv setlocale strftime strptime mknod nice lstat readlink symlink sync
+fi
+echo "$ac_t""$ac_cv_type_mode_t" 1>&6
+if test $ac_cv_type_mode_t = no; then
+ cat >> confdefs.h <<\EOF
+#define mode_t int
+EOF
+
+fi
+
+
+for ac_func in ctermid ftime getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:2112: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1395 "configure"
+#line 2117 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char $ac_func();
-int main() { return 0; }
-int t() {
+int main() {
/* The GNU C library defines this for functions which it implements
to always fail with ENOSYS. Some functions are actually named
@@ -1413,16 +2136,18 @@ $ac_func();
; return 0; }
EOF
-if { (eval echo configure:1417: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:2140: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
fi
rm -f conftest*
-
fi
+
if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
echo "$ac_t""yes" 1>&6
ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
@@ -1436,23 +2161,25 @@ fi
done
-for ac_func in inet_aton
+for ac_func in inet_aton putenv strerror
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:2168: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1447 "configure"
+#line 2173 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char $ac_func();
-int main() { return 0; }
-int t() {
+int main() {
/* The GNU C library defines this for functions which it implements
to always fail with ENOSYS. Some functions are actually named
@@ -1465,50 +2192,287 @@ $ac_func();
; return 0; }
EOF
-if { (eval echo configure:1469: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:2196: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
fi
rm -f conftest*
-
fi
+
if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
echo "$ac_t""yes" 1>&6
- :
+ ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
+EOF
+
else
echo "$ac_t""no" 1>&6
LIBOBJS="$LIBOBJS ${ac_func}.o"
fi
+done
+
+
+
+# The Ultrix 4.2 mips builtin alloca declared by alloca.h only works
+# for constant arguments. Useless!
+echo $ac_n "checking for working alloca.h""... $ac_c" 1>&6
+echo "configure:2226: checking for working alloca.h" >&5
+if eval "test \"`echo '$''{'ac_cv_header_alloca_h'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2231 "configure"
+#include "confdefs.h"
+#include <alloca.h>
+int main() {
+char *p = alloca(2 * sizeof(int));
+; return 0; }
+EOF
+if { (eval echo configure:2238: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ ac_cv_header_alloca_h=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ ac_cv_header_alloca_h=no
+fi
+rm -f conftest*
+fi
+
+echo "$ac_t""$ac_cv_header_alloca_h" 1>&6
+if test $ac_cv_header_alloca_h = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_ALLOCA_H 1
+EOF
+
+fi
+
+echo $ac_n "checking for alloca""... $ac_c" 1>&6
+echo "configure:2259: checking for alloca" >&5
+if eval "test \"`echo '$''{'ac_cv_func_alloca_works'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2264 "configure"
+#include "confdefs.h"
+
+#ifdef __GNUC__
+# define alloca __builtin_alloca
+#else
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# else
+# ifdef _AIX
+ #pragma alloca
+# else
+# ifndef alloca /* predefined by HP cc +Olibcalls */
+char *alloca ();
+# endif
+# endif
+# endif
+#endif
+
+int main() {
+char *p = (char *) alloca(1);
+; return 0; }
+EOF
+if { (eval echo configure:2287: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ ac_cv_func_alloca_works=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ ac_cv_func_alloca_works=no
+fi
+rm -f conftest*
+fi
+
+echo "$ac_t""$ac_cv_func_alloca_works" 1>&6
+if test $ac_cv_func_alloca_works = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_ALLOCA 1
+EOF
+
+fi
+
+if test $ac_cv_func_alloca_works = no; then
+ # The SVR3 libPW and SVR4 libucb both contain incompatible functions
+ # that cause trouble. Some versions do not even contain alloca or
+ # contain a buggy version. If you still want to use their alloca,
+ # use ar to extract alloca.o from them instead of compiling alloca.c.
+ ALLOCA=alloca.o
+ cat >> confdefs.h <<\EOF
+#define C_ALLOCA 1
+EOF
+
+
+echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6
+echo "configure:2319: checking whether alloca needs Cray hooks" >&5
+if eval "test \"`echo '$''{'ac_cv_os_cray'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2324 "configure"
+#include "confdefs.h"
+#if defined(CRAY) && ! defined(CRAY2)
+webecray
+#else
+wenotbecray
+#endif
+
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ egrep "webecray" >/dev/null 2>&1; then
+ rm -rf conftest*
+ ac_cv_os_cray=yes
+else
+ rm -rf conftest*
+ ac_cv_os_cray=no
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$ac_cv_os_cray" 1>&6
+if test $ac_cv_os_cray = yes; then
+for ac_func in _getb67 GETB67 getb67; do
+ echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:2349: checking for $ac_func" >&5
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2354 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char $ac_func();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:2377: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ cat >> confdefs.h <<EOF
+#define CRAY_STACKSEG_END $ac_func
+EOF
+
+ break
+else
+ echo "$ac_t""no" 1>&6
+fi
done
+fi
+
+echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6
+echo "configure:2404: checking stack direction for C alloca" >&5
+if eval "test \"`echo '$''{'ac_cv_c_stack_direction'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ if test "$cross_compiling" = yes; then
+ ac_cv_c_stack_direction=0
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2412 "configure"
+#include "confdefs.h"
+find_stack_direction ()
+{
+ static char *addr = 0;
+ auto char dummy;
+ if (addr == 0)
+ {
+ addr = &dummy;
+ return find_stack_direction ();
+ }
+ else
+ return (&dummy > addr) ? 1 : -1;
+}
+main ()
+{
+ exit (find_stack_direction() < 0);
+}
+EOF
+if { (eval echo configure:2431: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
+then
+ ac_cv_c_stack_direction=1
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ ac_cv_c_stack_direction=-1
+fi
+rm -fr conftest*
+fi
+
+fi
+
+echo "$ac_t""$ac_cv_c_stack_direction" 1>&6
+cat >> confdefs.h <<EOF
+#define STACK_DIRECTION $ac_cv_c_stack_direction
+EOF
+
+fi
echo $ac_n "checking for st_rdev in struct stat""... $ac_c" 1>&6
+echo "configure:2454: checking for st_rdev in struct stat" >&5
if eval "test \"`echo '$''{'ac_cv_struct_st_rdev'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1495 "configure"
+#line 2459 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
-int main() { return 0; }
-int t() {
+int main() {
struct stat s; s.st_rdev;
; return 0; }
EOF
-if { (eval echo configure:1504: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:2467: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_rdev=yes
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_struct_st_rdev=no
fi
rm -f conftest*
-
fi
echo "$ac_t""$ac_cv_struct_st_rdev" 1>&6
@@ -1520,28 +2484,29 @@ EOF
fi
echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6
+echo "configure:2488: checking for st_blksize in struct stat" >&5
if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1528 "configure"
+#line 2493 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
-int main() { return 0; }
-int t() {
+int main() {
struct stat s; s.st_blksize;
; return 0; }
EOF
-if { (eval echo configure:1537: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:2501: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_blksize=yes
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_struct_st_blksize=no
fi
rm -f conftest*
-
fi
echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6
@@ -1553,28 +2518,29 @@ EOF
fi
echo $ac_n "checking for st_blocks in struct stat""... $ac_c" 1>&6
+echo "configure:2522: checking for st_blocks in struct stat" >&5
if eval "test \"`echo '$''{'ac_cv_struct_st_blocks'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1561 "configure"
+#line 2527 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
-int main() { return 0; }
-int t() {
+int main() {
struct stat s; s.st_blocks;
; return 0; }
EOF
-if { (eval echo configure:1570: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:2535: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_blocks=yes
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_struct_st_blocks=no
fi
rm -f conftest*
-
fi
echo "$ac_t""$ac_cv_struct_st_blocks" 1>&6
@@ -1587,6 +2553,461 @@ else
LIBOBJS="$LIBOBJS fileblocks.o"
fi
+echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6
+echo "configure:2558: checking whether struct tm is in sys/time.h or time.h" >&5
+if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2563 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#include <time.h>
+int main() {
+struct tm *tp; tp->tm_sec;
+; return 0; }
+EOF
+if { (eval echo configure:2571: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ ac_cv_struct_tm=time.h
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ ac_cv_struct_tm=sys/time.h
+fi
+rm -f conftest*
+fi
+
+echo "$ac_t""$ac_cv_struct_tm" 1>&6
+if test $ac_cv_struct_tm = sys/time.h; then
+ cat >> confdefs.h <<\EOF
+#define TM_IN_SYS_TIME 1
+EOF
+
+fi
+
+echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6
+echo "configure:2592: checking for tm_zone in struct tm" >&5
+if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2597 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#include <$ac_cv_struct_tm>
+int main() {
+struct tm tm; tm.tm_zone;
+; return 0; }
+EOF
+if { (eval echo configure:2605: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ ac_cv_struct_tm_zone=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ ac_cv_struct_tm_zone=no
+fi
+rm -f conftest*
+fi
+
+echo "$ac_t""$ac_cv_struct_tm_zone" 1>&6
+if test "$ac_cv_struct_tm_zone" = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_TM_ZONE 1
+EOF
+
+else
+ echo $ac_n "checking for tzname""... $ac_c" 1>&6
+echo "configure:2625: checking for tzname" >&5
+if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2630 "configure"
+#include "confdefs.h"
+#include <time.h>
+#ifndef tzname /* For SGI. */
+extern char *tzname[]; /* RS6000 and others reject char **tzname. */
+#endif
+int main() {
+atoi(*tzname);
+; return 0; }
+EOF
+if { (eval echo configure:2640: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ ac_cv_var_tzname=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ ac_cv_var_tzname=no
+fi
+rm -f conftest*
+fi
+
+echo "$ac_t""$ac_cv_var_tzname" 1>&6
+ if test $ac_cv_var_tzname = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_TZNAME 1
+EOF
+
+ fi
+fi
+
+
+ echo $ac_n "checking whether we need POSIX to get struct utimbuf""... $ac_c" 1>&6
+echo "configure:2663: checking whether we need POSIX to get struct utimbuf" >&5
+if eval "test \"`echo '$''{'guile_cv_struct_utimbuf_needs_posix'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2668 "configure"
+#include "confdefs.h"
+
+#ifdef __EMX__
+#include <sys/utime.h>
+#else
+#include <utime.h>
+#endif
+struct utime blah;
+
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:2680: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out`
+if test -z "$ac_err"; then
+ rm -rf conftest*
+ guile_cv_struct_utimbuf_needs_posix=no
+else
+ echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ guile_cv_struct_utimbuf_needs_posix=yes
+fi
+rm -f conftest*
+fi
+
+echo "$ac_t""$guile_cv_struct_utimbuf_needs_posix" 1>&6
+ if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
+ cat >> confdefs.h <<\EOF
+#define UTIMBUF_NEEDS_POSIX 1
+EOF
+
+ fi
+
+# Checks for dynamic linking
+
+xtra_PLUGIN_guile_libs=""
+
+
+if test "$enable_dynamic_linking" = "yes"; then
+
+echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
+echo "configure:2711: checking for dlopen in -ldl" >&5
+ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_save_LIBS="$LIBS"
+LIBS="-ldl $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2719 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char dlopen();
+
+int main() {
+dlopen()
+; return 0; }
+EOF
+if { (eval echo configure:2730: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_lib=HAVE_LIB`echo dl | sed -e 's/[^a-zA-Z0-9_]/_/g' \
+ -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+ LIBS="-ldl $LIBS"
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+
+if test "$ac_cv_lib_dl_dlopen" = "yes"; then
+ xtra_PLUGIN_guile_libs="-lguile -ldl"
+ cat >> confdefs.h <<\EOF
+#define DYNAMIC_LINKING 1
+EOF
+
+else
+echo $ac_n "checking for dld_link in -ldld""... $ac_c" 1>&6
+echo "configure:2765: checking for dld_link in -ldld" >&5
+ac_lib_var=`echo dld'_'dld_link | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_save_LIBS="$LIBS"
+LIBS="-ldld $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2773 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char dld_link();
+
+int main() {
+dld_link()
+; return 0; }
+EOF
+if { (eval echo configure:2784: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_lib=HAVE_LIB`echo dld | sed -e 's/[^a-zA-Z0-9_]/_/g' \
+ -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+ LIBS="-ldld $LIBS"
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+
+if test "$ac_cv_lib_dld_dld_link" = "yes"; then
+ xtra_PLUGIN_guile_libs="-lguile -ldld"
+ cat >> confdefs.h <<\EOF
+#define DYNAMIC_LINKING 1
+EOF
+
+else
+echo $ac_n "checking for main in -lm""... $ac_c" 1>&6
+echo "configure:2819: checking for main in -lm" >&5
+ac_lib_var=`echo m'_'main | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_save_LIBS="$LIBS"
+LIBS="-lm $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2827 "configure"
+#include "confdefs.h"
+
+int main() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:2834: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_lib=HAVE_LIB`echo m | sed -e 's/[^a-zA-Z0-9_]/_/g' \
+ -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+ LIBS="-lm $LIBS"
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+
+echo $ac_n "checking for main in -lsocket""... $ac_c" 1>&6
+echo "configure:2862: checking for main in -lsocket" >&5
+ac_lib_var=`echo socket'_'main | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_save_LIBS="$LIBS"
+LIBS="-lsocket $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2870 "configure"
+#include "confdefs.h"
+
+int main() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:2877: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_lib=HAVE_LIB`echo socket | sed -e 's/[^a-zA-Z0-9_]/_/g' \
+ -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+ LIBS="-lsocket $LIBS"
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+
+echo $ac_n "checking for main in -lnsl""... $ac_c" 1>&6
+echo "configure:2905: checking for main in -lnsl" >&5
+ac_lib_var=`echo nsl'_'main | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_save_LIBS="$LIBS"
+LIBS="-lnsl $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2913 "configure"
+#include "confdefs.h"
+
+int main() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:2920: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_lib=HAVE_LIB`echo nsl | sed -e 's/[^a-zA-Z0-9_]/_/g' \
+ -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+ LIBS="-lnsl $LIBS"
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+
+for ac_func in shl_load
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:2950: checking for $ac_func" >&5
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2955 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char $ac_func();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:2978: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
+EOF
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+done
+
+if test "$ac_cv_func_shl_load" = "yes"; then
+ cat >> confdefs.h <<\EOF
+#define DYNAMIC_LINKING 1
+EOF
+
+fi
+fi
+fi
+
+fi
#--------------------------------------------------------------------
#
@@ -1597,22 +3018,26 @@ fi
if test "$cross_compiling" = yes; then
echo "configure: warning: Guessing that stack grows down -- see scmconfig.h.in" 1>&2
else
-cat > conftest.$ac_ext <<EOF
-#line 1602 "configure"
+ cat > conftest.$ac_ext <<EOF
+#line 3023 "configure"
#include "confdefs.h"
aux (l) unsigned long l;
{ int x; exit (l >= ((unsigned long)&x)); }
main () { int q; aux((unsigned long)&q); }
EOF
-{ (eval echo configure:1608: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
-if test -s conftest && (./conftest; exit) 2>/dev/null; then
+if { (eval echo configure:3029: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
+then
cat >> confdefs.h <<\EOF
#define SCM_STACK_GROWS_UP 1
EOF
-fi
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
fi
rm -fr conftest*
+fi
+
if test "$cross_compiling" = yes; then
@@ -1622,84 +3047,357 @@ EOF
echo "configure: warning: Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in" 1>&2
else
-cat > conftest.$ac_ext <<EOF
-#line 1627 "configure"
+ cat > conftest.$ac_ext <<EOF
+#line 3052 "configure"
#include "confdefs.h"
main () { exit (sizeof(float) != sizeof(long)); }
EOF
-{ (eval echo configure:1631: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
-if test -s conftest && (./conftest; exit) 2>/dev/null; then
+if { (eval echo configure:3056: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
+then
cat >> confdefs.h <<\EOF
#define SCM_SINGLES 1
EOF
-fi
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
fi
rm -fr conftest*
+fi
+echo $ac_n "checking for struct linger""... $ac_c" 1>&6
+echo "configure:3071: checking for struct linger" >&5
+if eval "test \"`echo '$''{'scm_cv_struct_linger'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3076 "configure"
+#include "confdefs.h"
+
+#include <sys/types.h>
+#include <sys/socket.h>
+int main() {
+struct linger lgr; lgr.l_linger = 100
+; return 0; }
+EOF
+if { (eval echo configure:3085: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ scm_cv_struct_linger="yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ scm_cv_struct_linger="no"
+fi
+rm -f conftest*
+fi
+echo "$ac_t""$scm_cv_struct_linger" 1>&6
+if test $scm_cv_struct_linger = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_STRUCT_LINGER 1
+EOF
+fi
+
#--------------------------------------------------------------------
#
# How can you violate a stdio abstraction by setting a stream's fd?
#
#--------------------------------------------------------------------
-FD_SETTER=""
-
-if test "x$FD_SETTER" = x; then
+echo $ac_n "checking how to set a stream file descriptor""... $ac_c" 1>&6
+echo "configure:3112: checking how to set a stream file descriptor" >&5
+if eval "test \"`echo '$''{'scm_cv_fd_setter'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
cat > conftest.$ac_ext <<EOF
-#line 1654 "configure"
+#line 3117 "configure"
#include "confdefs.h"
#include <stdio.h>
-
-int main() { return 0; }
-int t() {
+int main() {
stdout->_file = 1
; return 0; }
EOF
-if { (eval echo configure:1663: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3124: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
- FD_SETTER="((F)->_file = (D))"
+ scm_cv_fd_setter="_file"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ cat > conftest.$ac_ext <<EOF
+#line 3132 "configure"
+#include "confdefs.h"
+#include <stdio.h>
+int main() {
+stdout->_fileno = 1
+; return 0; }
+EOF
+if { (eval echo configure:3139: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ scm_cv_fd_setter="_fileno"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ scm_cv_fd_setter=""
+fi
+rm -f conftest*
fi
rm -f conftest*
+fi
+
+if test "$scm_cv_fd_setter"; then
+ echo "$ac_t""$scm_cv_fd_setter" 1>&6
+ cat >> confdefs.h <<EOF
+#define FD_SETTER $scm_cv_fd_setter
+EOF
+
+else
+ echo "$ac_t""we couldn't do it!" 1>&6
+fi
+
+#--------------------------------------------------------------------
+# How to find out whether a FILE structure contains buffered data.
+# From Tk we have the following list:
+# _cnt: Most UNIX systems
+# __cnt: HPUX
+# _r: BSD
+# readCount: Sprite
+# Or, in GNU libc there are two fields, _gptr and _egptr, which
+# have to be compared.
+# These can also be known as _IO_read_ptr and _IO_read_end.
+#--------------------------------------------------------------------
+
+echo $ac_n "checking how to get buffer char count from FILE structure""... $ac_c" 1>&6
+echo "configure:3177: checking how to get buffer char count from FILE structure" >&5
+if eval "test \"`echo '$''{'scm_cv_struct_file_count'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3182 "configure"
+#include "confdefs.h"
+#include <stdio.h>
+int main() {
+FILE *f = stdin; f->_cnt = 0
+; return 0; }
+EOF
+if { (eval echo configure:3189: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ scm_cv_struct_file_count="_cnt"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ cat > conftest.$ac_ext <<EOF
+#line 3197 "configure"
+#include "confdefs.h"
+#include <stdio.h>
+int main() {
+FILE *f = stdin; f->_r = 0
+; return 0; }
+EOF
+if { (eval echo configure:3204: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ scm_cv_struct_file_count="_r"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ cat > conftest.$ac_ext <<EOF
+#line 3212 "configure"
+#include "confdefs.h"
+#include <stdio.h>
+int main() {
+FILE *f = stdin; f->readCount = 0
+; return 0; }
+EOF
+if { (eval echo configure:3219: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ scm_cv_struct_file_count="readCount"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ scm_cv_struct_file_count=""
+fi
+rm -f conftest*
+fi
+rm -f conftest*
+fi
+rm -f conftest*
fi
-if test "x$FD_SETTER" = x; then
- cat > conftest.$ac_ext <<EOF
-#line 1673 "configure"
+if test "$scm_cv_struct_file_count"; then
+ echo "$ac_t""$scm_cv_struct_file_count" 1>&6
+ cat >> confdefs.h <<EOF
+#define FILE_CNT_FIELD $scm_cv_struct_file_count
+EOF
+
+else
+if eval "test \"`echo '$''{'scm_cv_struct_file_gptr'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3246 "configure"
#include "confdefs.h"
#include <stdio.h>
+int main() {
+FILE *f = stdin; f->_gptr = f->egptr;
+; return 0; }
+EOF
+if { (eval echo configure:3253: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ scm_cv_struct_file_gptr=1
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ scm_cv_struct_file_gptr=""
+fi
+rm -f conftest*
+fi
-int main() { return 0; }
-int t() {
-stdout->_fileno
+if test "$scm_cv_struct_gptr"; then
+ echo "$ac_t""gptr" 1>&6
+ cat >> confdefs.h <<EOF
+#define FILE_CNT_GPTR $scm_cv_struct_file_gptr
+EOF
+
+else
+if eval "test \"`echo '$''{'scm_cv_struct_file_readptr'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3276 "configure"
+#include "confdefs.h"
+#include <stdio.h>
+int main() {
+FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end;
; return 0; }
EOF
-if { (eval echo configure:1682: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3283: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
- FD_SETTER="((F)->_fileno = (D))"
+ scm_cv_struct_file_readptr=1
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
fi
rm -f conftest*
+fi
+
+if test "$scm_cv_struct_file_readptr"; then
+ echo "$ac_t""read_ptr" 1>&6
+ cat >> confdefs.h <<EOF
+#define FILE_CNT_READPTR $scm_cv_struct_file_readptr
+EOF
+else
+ echo "$ac_t""we couldn't do it!" 1>&6
+fi
+fi
fi
+#--------------------------------------------------------------------
+#
+# Flags for thread support
+#
+#--------------------------------------------------------------------
+
+if test "$cy_cv_threads_package" = FSU; then
+ cat >> confdefs.h <<\EOF
+#define USE_FSU_PTHREADS 1
+EOF
+
+ else if test "$cy_cv_threads_package" = COOP; then
+ cat >> confdefs.h <<\EOF
+#define USE_COOP_THREADS 1
+EOF
+
+ else if test "$cy_cv_threads_package" = MIT; then
+ cat >> confdefs.h <<\EOF
+#define USE_MIT_PTHREADS 1
+EOF
-test "x$FD_SETTER" != x && cat >> confdefs.h <<\EOF
-#define HAVE_FD_SETTER 1
+ else if test "$cy_cv_threads_package" = PCthreads; then
+ cat >> confdefs.h <<\EOF
+#define USE_PCTHREADS_PTHREADS 1
EOF
+ else if test "$cy_cv_threads_package" = unknown; then
+ { echo "configure: error: "cannot find threads installation"" 1>&2; exit 1; }
+ fi
+ fi
+ fi
+ fi
+fi
+
+if test "$cy_cv_threads_package" != ""; then
+ cat >> confdefs.h <<\EOF
+#define USE_THREADS 1
+EOF
+ LIBOBJS="$LIBOBJS threads.o"
+fi
+## If we're using GCC, ask for aggressive warnings.
+case "$GCC" in
+ yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;;
+esac
+for ac_prog in mawk gawk nawk awk
+do
+# Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:3357: checking for $ac_word" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_AWK'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ if test -n "$AWK"; then
+ ac_cv_prog_AWK="$AWK" # Let the user override the test.
+else
+ IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:"
+ for ac_dir in $PATH; do
+ test -z "$ac_dir" && ac_dir=.
+ if test -f $ac_dir/$ac_word; then
+ ac_cv_prog_AWK="$ac_prog"
+ break
+ fi
+ done
+ IFS="$ac_save_ifs"
+fi
+fi
+AWK="$ac_cv_prog_AWK"
+if test -n "$AWK"; then
+ echo "$ac_t""$AWK" 1>&6
+else
+ echo "$ac_t""no" 1>&6
+fi
+test -n "$AWK" && break
+done
+## If we're creating a shared library (using libtool!), then we'll
+## need to generate a list of .lo files corresponding to the .o files
+## given in LIBOBJS. We'll call it LIBLOBJS.
+LIBLOBJS="`echo ${LIBOBJS} | sed 's/\.o/.lo/g'`"
+cat >> confdefs.h <<EOF
+#define GUILE_MAJOR_VERSION "$GUILE_MAJOR_VERSION"
+EOF
+cat >> confdefs.h <<EOF
+#define GUILE_MINOR_VERSION "$GUILE_MINOR_VERSION"
+EOF
+cat >> confdefs.h <<EOF
+#define GUILE_VERSION "$GUILE_VERSION"
+EOF
@@ -1721,11 +3419,25 @@ cat > confcache <<\EOF
# --recheck option to rerun configure.
#
EOF
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, don't put newlines in cache variables' values.
# Ultrix sh set writes to stderr and can't be redirected directly,
# and sets the high bit in the cache file unless we assign to the vars.
(set) 2>&1 |
- sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \
- >> confcache
+ case `(ac_space=' '; set) 2>&1` in
+ *ac_space=\ *)
+ # `set' does not quote correctly, so add quotes (double-quote substitution
+ # turns \\\\ into \\, and sed turns \\ into \).
+ sed -n \
+ -e "s/'/'\\\\''/g" \
+ -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
+ ;;
+ *)
+ # `set' quotes correctly as required by POSIX, so do not add quotes.
+ sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
+ ;;
+ esac >> confcache
if cmp -s $cache_file confcache; then
:
else
@@ -1780,7 +3492,7 @@ do
echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
-version | --version | --versio | --versi | --vers | --ver | --ve | --v)
- echo "$CONFIG_STATUS generated by autoconf version 2.9"
+ echo "$CONFIG_STATUS generated by autoconf version 2.12"
exit 0 ;;
-help | --help | --hel | --he | --h)
echo "\$ac_cs_usage"; exit 0 ;;
@@ -1789,8 +3501,9 @@ do
done
ac_given_srcdir=$srcdir
+ac_given_INSTALL="$INSTALL"
-trap 'rm -fr `echo "Makefile fd.h scmconfig.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
+trap 'rm -fr `echo "Makefile guile-snarf PLUGIN/guile.libs scmconfig.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
EOF
cat >> $CONFIG_STATUS <<EOF
@@ -1820,34 +3533,87 @@ s%@includedir@%$includedir%g
s%@oldincludedir@%$oldincludedir%g
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g
+s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
+s%@INSTALL_DATA@%$INSTALL_DATA%g
+s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g
+s%@PACKAGE@%$PACKAGE%g
+s%@VERSION@%$VERSION%g
+s%@ACLOCAL@%$ACLOCAL%g
+s%@AUTOCONF@%$AUTOCONF%g
+s%@AUTOMAKE@%$AUTOMAKE%g
+s%@AUTOHEADER@%$AUTOHEADER%g
+s%@MAKEINFO@%$MAKEINFO%g
+s%@SET_MAKE@%$SET_MAKE%g
+s%@module@%$module%g
+s%@MAINT@%$MAINT%g
s%@CC@%$CC%g
s%@CPP@%$CPP%g
+s%@host@%$host%g
+s%@host_alias@%$host_alias%g
+s%@host_cpu@%$host_cpu%g
+s%@host_vendor@%$host_vendor%g
+s%@host_os@%$host_os%g
s%@RANLIB@%$RANLIB%g
+s%@LIBTOOL@%$LIBTOOL%g
+s%@THREAD_LIBS@%$THREAD_LIBS%g
s%@LIBOBJS@%$LIBOBJS%g
-s%@FD_SETTER@%$FD_SETTER%g
-s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g
-s%@TK_SRC_DIR@%$TK_SRC_DIR%g
-s%@XINCLUDES@%$XINCLUDES%g
-s%@GUILE_MAJOR_VERSION@%$GUILE_MAJOR_VERSION%g
-s%@GUILE_MINOR_VERSION@%$GUILE_MINOR_VERSION%g
-s%@GUILE_VERSION@%$GUILE_VERSION%g
+s%@ALLOCA@%$ALLOCA%g
+s%@xtra_PLUGIN_guile_libs@%$xtra_PLUGIN_guile_libs%g
+s%@AWK@%$AWK%g
+s%@LIBLOBJS@%$LIBLOBJS%g
CEOF
EOF
+
+cat >> $CONFIG_STATUS <<\EOF
+
+# Split the substitutions into bite-sized pieces for seds with
+# small command number limits, like on Digital OSF/1 and HP-UX.
+ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
+ac_file=1 # Number of current file.
+ac_beg=1 # First line for current file.
+ac_end=$ac_max_sed_cmds # Line after last line for current file.
+ac_more_lines=:
+ac_sed_cmds=""
+while $ac_more_lines; do
+ if test $ac_beg -gt 1; then
+ sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
+ else
+ sed "${ac_end}q" conftest.subs > conftest.s$ac_file
+ fi
+ if test ! -s conftest.s$ac_file; then
+ ac_more_lines=false
+ rm -f conftest.s$ac_file
+ else
+ if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds="sed -f conftest.s$ac_file"
+ else
+ ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
+ fi
+ ac_file=`expr $ac_file + 1`
+ ac_beg=$ac_end
+ ac_end=`expr $ac_end + $ac_max_sed_cmds`
+ fi
+done
+if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds=cat
+fi
+EOF
+
cat >> $CONFIG_STATUS <<EOF
-CONFIG_FILES=\${CONFIG_FILES-"Makefile fd.h"}
+CONFIG_FILES=\${CONFIG_FILES-"Makefile guile-snarf PLUGIN/guile.libs"}
EOF
cat >> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile]", defaulting infile="outfile.in".
+ # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
+ *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
*) ac_file_in="${ac_file}.in" ;;
esac
- # Adjust relative srcdir, etc. for subdirectories.
+ # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
# Remove last slash and all that follows it. Not all systems have dirname.
ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
@@ -1871,6 +3637,11 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
top_srcdir="$ac_dots$ac_given_srcdir" ;;
esac
+ case "$ac_given_INSTALL" in
+ [/$]*) INSTALL="$ac_given_INSTALL" ;;
+ *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
+ esac
+
echo creating "$ac_file"
rm -f "$ac_file"
configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
@@ -1879,13 +3650,16 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
# $configure_input" ;;
*) ac_comsub= ;;
esac
+
+ ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
sed -e "$ac_comsub
s%@configure_input@%$configure_input%g
s%@srcdir@%$srcdir%g
s%@top_srcdir@%$top_srcdir%g
-" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file
+s%@INSTALL@%$INSTALL%g
+" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
fi; done
-rm -f conftest.subs
+rm -f conftest.s*
# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where
# NAME is the cpp macro being defined and VALUE is the value it is being given.
@@ -1906,11 +3680,17 @@ ac_eB='$%\1#\2define\3'
ac_eC=' '
ac_eD='%g'
-CONFIG_HEADERS=${CONFIG_HEADERS-"scmconfig.h"}
+if test "${CONFIG_HEADERS+set}" != set; then
+EOF
+cat >> $CONFIG_STATUS <<EOF
+ CONFIG_HEADERS="scmconfig.h"
+EOF
+cat >> $CONFIG_STATUS <<\EOF
+fi
for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile]", defaulting infile="outfile.in".
+ # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
+ *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
*) ac_file_in="${ac_file}.in" ;;
esac
@@ -1918,7 +3698,8 @@ for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then
echo creating $ac_file
rm -f conftest.frag conftest.in conftest.out
- cp $ac_given_srcdir/$ac_file_in conftest.in
+ ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
+ cat $ac_file_inputs > conftest.in
EOF
@@ -1946,8 +3727,6 @@ EOF
# Break up conftest.vals because some shells have a limit on
# the size of here documents, and old seds have small limits too.
-# Maximum number of lines to put in a single here document.
-ac_max_here_lines=12
rm -f conftest.tail
while :
@@ -1978,13 +3757,25 @@ cat >> $CONFIG_STATUS <<\EOF
echo "$ac_file is unchanged"
rm -f conftest.h
else
+ # Remove last slash and all that follows it. Not all systems have dirname.
+ ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
+ if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
+ # The file is in a subdirectory.
+ test ! -d "$ac_dir" && mkdir "$ac_dir"
+ fi
rm -f $ac_file
mv conftest.h $ac_file
fi
fi; done
+EOF
+cat >> $CONFIG_STATUS <<EOF
+EOF
+cat >> $CONFIG_STATUS <<\EOF
+test -z "$CONFIG_HEADERS" || echo timestamp > stamp-h
+chmod +x guile-snarf
exit 0
EOF
chmod +x $CONFIG_STATUS
diff --git a/libguile/configure.in b/libguile/configure.in
index ae71726d5..c5ed06a3e 100644
--- a/libguile/configure.in
+++ b/libguile/configure.in
@@ -1,37 +1,99 @@
AC_INIT(eval.c)
-AC_CONFIG_HEADER(scmconfig.h)
+AM_CONFIG_HEADER(scmconfig.h)
+AM_INIT_GUILE_MODULE(libguile)
+AM_MAINTAINER_MODE
-. $srcdir/../GUILE-VERSION
+#--------------------------------------------------------------------
+#
+# User options
+#
+#--------------------------------------------------------------------
+
+AC_ARG_ENABLE(debug,
+[ --disable-debug Don't include debugging support])
+if test "$enableval" != n && test "$enableval" != no; then
+ AC_DEFINE(DEBUG_EXTENSIONS)
+ AC_DEFINE(READER_EXTENSIONS)
+ LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS"
+fi
+
+AC_ARG_ENABLE(dynamic-linking,
+ [ --enable-dynamic-linking Include support for dynamic linking])
-test -z "$CFLAGS" && CFLAGS=-g
-test -z "$LDFLAGS" && LDFLAGS=-g
+AC_ARG_ENABLE(guile-debug,
+[ --enable-guile-debug Include internal debugging functions])
+if test "$enableval" = y || test "$enableval" = yes; then
+ AC_DEFINE(GUILE_DEBUG)
+fi
+
+#--------------------------------------------------------------------
AC_PROG_CC
AC_PROG_CPP
-AC_PROG_RANLIB
+AM_PROG_LIBTOOL
AC_AIX
AC_ISC_POSIX
AC_MINIX
+CY_AC_WITH_THREADS
+CFLAGS="$CFLAGS $cy_cv_threads_cflags"
+THREAD_LIBS="$cy_cv_threads_libs"
+AC_SUBST(THREAD_LIBS)
+
AC_C_CONST
AC_HEADER_STDC
AC_HEADER_DIRENT
AC_HEADER_TIME
AC_HEADER_SYS_WAIT
-AC_CHECK_HEADERS(unistd.h string.h malloc.h memory.h limits.h time.h sys/types.h sys/select.h sys/time.h sys/timeb.h sys/times.h)
+AC_CHECK_HEADERS(libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h)
+GUILE_HEADER_LIBC_WITH_UNISTD
AC_TYPE_GETGROUPS
AC_TYPE_SIGNAL
+AC_TYPE_MODE_T
+
+AC_CHECK_FUNCS(ctermid ftime getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid)
-AC_CHECK_FUNCS(ftime times geteuid seteuid setegid select uname mkdir rmdir getcwd rename putenv setlocale strftime strptime mknod nice lstat readlink symlink sync)
+AC_REPLACE_FUNCS(inet_aton putenv strerror)
-AC_REPLACE_FUNCS(inet_aton)
+AC_FUNC_ALLOCA
AC_STRUCT_ST_RDEV
AC_STRUCT_ST_BLKSIZE
AC_STRUCT_ST_BLOCKS
+AC_STRUCT_TIMEZONE
+GUILE_STRUCT_UTIMBUF
+
+# Checks for dynamic linking
+
+xtra_PLUGIN_guile_libs=""
+AC_SUBST(xtra_PLUGIN_guile_libs)
+
+if test "$enable_dynamic_linking" = "yes"; then
+
+AC_CHECK_LIB(dl,dlopen)
+if test "$ac_cv_lib_dl_dlopen" = "yes"; then
+ xtra_PLUGIN_guile_libs="-lguile -ldl"
+ AC_DEFINE(DYNAMIC_LINKING)
+else
+AC_CHECK_LIB(dld,dld_link)
+if test "$ac_cv_lib_dld_dld_link" = "yes"; then
+ xtra_PLUGIN_guile_libs="-lguile -ldld"
+ AC_DEFINE(DYNAMIC_LINKING)
+else
+AC_CHECK_LIB(m, main)
+AC_CHECK_LIB(socket, main)
+AC_CHECK_LIB(nsl, main)
+AC_CHECK_FUNCS(shl_load)
+if test "$ac_cv_func_shl_load" = "yes"; then
+ AC_DEFINE(DYNAMIC_LINKING)
+fi
+fi
+fi
+
+fi
#--------------------------------------------------------------------
#
@@ -49,56 +111,141 @@ AC_TRY_RUN(main () { exit (sizeof(float) != sizeof(long)); },
AC_DEFINE(SCM_SINGLES),,AC_DEFINE(SCM_SINGLES)
AC_MSG_WARN(Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in))
-
-
-
+AC_MSG_CHECKING(for struct linger)
+AC_CACHE_VAL(scm_cv_struct_linger,
+ AC_TRY_COMPILE([
+#include <sys/types.h>
+#include <sys/socket.h>],
+ [struct linger lgr; lgr.l_linger = 100],
+ scm_cv_struct_linger="yes",
+ scm_cv_struct_linger="no"))
+AC_MSG_RESULT($scm_cv_struct_linger)
+if test $scm_cv_struct_linger = yes; then
+ AC_DEFINE(HAVE_STRUCT_LINGER)
+fi
+
#--------------------------------------------------------------------
#
# How can you violate a stdio abstraction by setting a stream's fd?
#
#--------------------------------------------------------------------
-FD_SETTER=""
-
-if test "x$FD_SETTER" = x; then
- AC_TRY_COMPILE(#include <stdio.h>
-, stdout->_file = 1,
- FD_SETTER="((F)->_file = (D))")
+AC_MSG_CHECKING(how to set a stream file descriptor)
+AC_CACHE_VAL(scm_cv_fd_setter,
+ AC_TRY_COMPILE([#include <stdio.h>],
+ [stdout->_file = 1],
+ scm_cv_fd_setter="_file",
+ AC_TRY_COMPILE([#include <stdio.h>],
+ [stdout->_fileno = 1],
+ scm_cv_fd_setter="_fileno",
+ scm_cv_fd_setter="")))
+
+if test "$scm_cv_fd_setter"; then
+ AC_MSG_RESULT($scm_cv_fd_setter)
+ AC_DEFINE_UNQUOTED(FD_SETTER, $scm_cv_fd_setter)
+else
+ AC_MSG_RESULT(we couldn't do it!)
fi
-if test "x$FD_SETTER" = x; then
- AC_TRY_COMPILE(#include <stdio.h>
-, stdout->_fileno,
- FD_SETTER="((F)->_fileno = (D))")
+#--------------------------------------------------------------------
+# How to find out whether a FILE structure contains buffered data.
+# From Tk we have the following list:
+# _cnt: Most UNIX systems
+# __cnt: HPUX
+# _r: BSD
+# readCount: Sprite
+# Or, in GNU libc there are two fields, _gptr and _egptr, which
+# have to be compared.
+# These can also be known as _IO_read_ptr and _IO_read_end.
+#--------------------------------------------------------------------
+
+AC_MSG_CHECKING(how to get buffer char count from FILE structure)
+AC_CACHE_VAL(scm_cv_struct_file_count,
+ AC_TRY_COMPILE([#include <stdio.h>],
+ [FILE *f = stdin; f->_cnt = 0],
+ scm_cv_struct_file_count="_cnt",
+ AC_TRY_COMPILE([#include <stdio.h>],
+ [FILE *f = stdin; f->_r = 0],
+ scm_cv_struct_file_count="_r",
+ AC_TRY_COMPILE([#include <stdio.h>],
+ [FILE *f = stdin; f->readCount = 0],
+ scm_cv_struct_file_count="readCount",
+ scm_cv_struct_file_count=""))))
+if test "$scm_cv_struct_file_count"; then
+ AC_MSG_RESULT($scm_cv_struct_file_count)
+ AC_DEFINE_UNQUOTED(FILE_CNT_FIELD, $scm_cv_struct_file_count)
+else
+AC_CACHE_VAL(scm_cv_struct_file_gptr,
+ AC_TRY_COMPILE([#include <stdio.h>],
+ [FILE *f = stdin; f->_gptr = f->egptr;],
+ scm_cv_struct_file_gptr=1,
+ scm_cv_struct_file_gptr=""))
+if test "$scm_cv_struct_gptr"; then
+ AC_MSG_RESULT(gptr)
+ AC_DEFINE_UNQUOTED(FILE_CNT_GPTR, $scm_cv_struct_file_gptr)
+else
+AC_CACHE_VAL(scm_cv_struct_file_readptr,
+ AC_TRY_COMPILE([#include <stdio.h>],
+ [FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end;],
+ scm_cv_struct_file_readptr=1))
+if test "$scm_cv_struct_file_readptr"; then
+ AC_MSG_RESULT(read_ptr)
+ AC_DEFINE_UNQUOTED(FILE_CNT_READPTR, $scm_cv_struct_file_readptr)
+else
+ AC_MSG_RESULT(we couldn't do it!)
+fi
+fi
fi
+#--------------------------------------------------------------------
+#
+# Flags for thread support
+#
+#--------------------------------------------------------------------
+
dnl
-dnl Add FD_SETTER tests for other systems here. Your test should
-dnl try a particular style of assigning to the descriptor
-dnl field(s) of a FILE* and define FD_SETTER accordingly.
-dnl
-dnl The value of FD_SETTER is used as a macro body, as in:
+dnl Set the appropriate flags!
dnl
-dnl #define SET_FILE_FD_FIELD(F,D) @FD_SETTER@
-dnl
-dnl F is a FILE* and D a descriptor (int).
-dnl
+if test "$cy_cv_threads_package" = FSU; then
+ AC_DEFINE(USE_FSU_PTHREADS, 1)
+ else if test "$cy_cv_threads_package" = COOP; then
+ AC_DEFINE(USE_COOP_THREADS, 1)
+ else if test "$cy_cv_threads_package" = MIT; then
+ AC_DEFINE(USE_MIT_PTHREADS, 1)
+ else if test "$cy_cv_threads_package" = PCthreads; then
+ AC_DEFINE(USE_PCTHREADS_PTHREADS, 1)
+ else if test "$cy_cv_threads_package" = unknown; then
+ AC_MSG_ERROR("cannot find threads installation")
+ fi
+ fi
+ fi
+ fi
+fi
+
+if test "$cy_cv_threads_package" != ""; then
+ AC_DEFINE(USE_THREADS)
+ LIBOBJS="$LIBOBJS threads.o"
+fi
+
+## If we're using GCC, ask for aggressive warnings.
+case "$GCC" in
+ yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;;
+esac
-test "x$FD_SETTER" != x && AC_DEFINE(HAVE_FD_SETTER)
+AC_PROG_AWK
+## If we're creating a shared library (using libtool!), then we'll
+## need to generate a list of .lo files corresponding to the .o files
+## given in LIBOBJS. We'll call it LIBLOBJS.
+LIBLOBJS="`echo ${LIBOBJS} | sed 's/\.o/.lo/g'`"
+AC_DEFINE_UNQUOTED(GUILE_MAJOR_VERSION, "$GUILE_MAJOR_VERSION")
+AC_DEFINE_UNQUOTED(GUILE_MINOR_VERSION, "$GUILE_MINOR_VERSION")
+AC_DEFINE_UNQUOTED(GUILE_VERSION, "$GUILE_VERSION")
-AC_SUBST(CFLAGS)
-AC_SUBST(LDFLAGS)
-AC_SUBST(LIBOBJS)
-AC_SUBST(FD_SETTER)
-AC_SUBST(TCL_SRC_DIR)
-AC_SUBST(TK_SRC_DIR)
-AC_SUBST(XINCLUDES)
-AC_SUBST(GUILE_MAJOR_VERSION)
-AC_SUBST(GUILE_MINOR_VERSION)
-AC_SUBST(GUILE_VERSION)
-AC_OUTPUT(Makefile fd.h)
+AC_SUBST(AWK)
+AC_SUBST(LIBLOBJS)
+AC_OUTPUT([Makefile guile-snarf PLUGIN/guile.libs], [chmod +x guile-snarf])
dnl Local Variables:
dnl comment-start: "dnl "
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 054ed8e56..f04912c8a 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -42,7 +42,13 @@
#include <stdio.h>
#include "_scm.h"
+#include "stackchk.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif
+#include "dynwind.h"
+#include "continuations.h"
/* {Continuations}
@@ -50,14 +56,10 @@
static char s_cont[] = "continuation";
-#ifdef __STDC__
-SCM
-scm_make_cont (SCM * answer)
-#else
+
SCM
scm_make_cont (answer)
SCM * answer;
-#endif
{
long j;
SCM cont;
@@ -66,9 +68,9 @@ scm_make_cont (answer)
SCM_NEWCELL (cont);
*answer = cont;
SCM_DEFER_INTS;
- SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (regs), s_cont));
- SCM_CAR (cont) = scm_tc7_contin;
- SCM_DYNENV (cont) = dynwinds;
+ SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (scm_contregs), s_cont));
+ SCM_SETCAR (cont, scm_tc7_contin);
+ SCM_DYNENV (cont) = scm_dynwinds;
SCM_THROW_VALUE = SCM_EOL;
SCM_BASE (cont) = SCM_BASE (rootcont);
SCM_SEQ (cont) = SCM_SEQ (rootcont);
@@ -76,19 +78,19 @@ scm_make_cont (answer)
#else
register SCM_STACKITEM *src, *dst;
+#if 0
{
SCM winds;
for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds))
{
-#if 0
if (SCM_INUMP (SCM_CAR (winds)))
{
scm_relocate_chunk_to_heap (SCM_CAR (winds));
}
-#endif
}
}
+#endif
SCM_NEWCELL (cont);
*answer = cont;
@@ -96,7 +98,7 @@ scm_make_cont (answer)
SCM_FLUSH_REGISTER_WINDOWS;
j = scm_stack_size (SCM_BASE (scm_rootcont));
SCM_SETJMPBUF (cont,
- scm_must_malloc ((long) (sizeof (regs) + j * sizeof (SCM_STACKITEM)),
+ scm_must_malloc ((long) (sizeof (scm_contregs) + j * sizeof (SCM_STACKITEM)),
s_cont));
SCM_SETLENGTH (cont, j, scm_tc7_contin);
SCM_DYNENV (cont) = scm_dynwinds;
@@ -107,30 +109,25 @@ scm_make_cont (answer)
#ifndef SCM_STACK_GROWS_UP
src -= SCM_LENGTH (cont);
#endif /* ndef SCM_STACK_GROWS_UP */
- dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (regs));
+ dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
for (j = SCM_LENGTH (cont); 0 <= --j;)
*dst++ = *src++;
#endif /* def CHEAP_CONTINUATIONS */
#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (cont) = last_debug_info_frame;
+ SCM_DFRAME (cont) = scm_last_debug_frame;
#endif
return cont;
}
-
-void scm_dynthrow SCM_P ((SCM *a));
-
/* Grow the stack so that there is room */
/* to copy in the continuation. Then */
#ifndef CHEAP_CONTINUATIONS
-#ifdef __STDC__
-static void
-grow_throw (SCM *a)
-#else
+
+static void grow_throw SCM_P ((SCM *a));
+
static void
grow_throw (a)
SCM *a;
-#endif
{ /* retry the throw. */
SCM growth[100];
growth[0] = a[0];
@@ -141,14 +138,10 @@ grow_throw (a)
}
#endif /* ndef CHEAP_CONTINUATIONS */
-#ifdef __STDC__
-void
-scm_dynthrow (SCM *a)
-#else
+
void
scm_dynthrow (a)
SCM *a;
-#endif
{
SCM cont = a[0], val = a[1];
#ifndef CHEAP_CONTINUATIONS
@@ -172,7 +165,7 @@ scm_dynthrow (a)
grow_throw (a);
#endif /* def SCM_STACK_GROWS_UP */
SCM_FLUSH_REGISTER_WINDOWS;
- src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (regs));
+ src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
for (j = SCM_LENGTH (cont); 0 <= --j;)
*dst++ = *src++;
#ifdef sparc /* clear out stack up to this stackframe */
@@ -182,21 +175,17 @@ scm_dynthrow (a)
#endif
#endif /* ndef CHEAP_CONTINUATIONS */
#ifdef DEBUG_EXTENSIONS
- last_debug_info_frame = SCM_DFRAME (cont);
+ scm_last_debug_frame = SCM_DFRAME (cont);
#endif
SCM_THROW_VALUE(cont) = val;
longjmp (SCM_JMPBUF (cont), 1);
}
-#ifdef __STDC__
-SCM
-scm_call_continuation (SCM cont, SCM val)
-#else
+
SCM
scm_call_continuation (cont, val)
SCM cont;
SCM val;
-#endif
{
SCM a[3];
a[0] = cont;
@@ -214,13 +203,9 @@ scm_call_continuation (cont, val)
}
-#ifdef __STDC__
-void
-scm_init_continuations (void)
-#else
+
void
scm_init_continuations ()
-#endif
{
#include "continuations.x"
}
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 176d423fc..0bd18296e 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -58,29 +58,21 @@ typedef struct
#ifdef DEBUG_EXTENSIONS
struct scm_debug_frame *dframe;
#endif
-} regs;
+} scm_contregs;
-#define SCM_JMPBUF(x) (((regs *)SCM_CHARS(x))->jmpbuf)
+#define SCM_JMPBUF(x) (((scm_contregs *)SCM_CHARS(x))->jmpbuf)
#define SCM_SETJMPBUF SCM_SETCDR
-#define SCM_DYNENV(x) (((regs *)SCM_CHARS(x))->dynenv)
-#define SCM_THROW_VALUE(x) (((regs *)SCM_CHARS(x))->throw_value)
-#define SCM_BASE(x) (((regs *)SCM_CHARS(x))->base)
-#define SCM_SEQ(x) (((regs *)SCM_CHARS(x))->seq)
-#define SCM_DFRAME(x) (((regs *)SCM_CHARS(x))->dframe)
+#define SCM_DYNENV(x) (((scm_contregs *)SCM_CHARS(x))->dynenv)
+#define SCM_THROW_VALUE(x) (((scm_contregs *)SCM_CHARS(x))->throw_value)
+#define SCM_BASE(x) (((scm_contregs *)SCM_CHARS(x))->base)
+#define SCM_SEQ(x) (((scm_contregs *)SCM_CHARS(x))->seq)
+#define SCM_DFRAME(x) (((scm_contregs *)SCM_CHARS(x))->dframe)
-#ifdef __STDC__
-extern SCM scm_make_cont (SCM * answer);
-extern void scm_dynthrow (SCM *a);
-extern SCM scm_call_continuation (SCM cont, SCM val);
-extern void scm_init_continuations (void);
+extern SCM scm_make_cont SCM_P ((SCM * answer));
+extern void scm_dynthrow SCM_P ((SCM *a));
+extern SCM scm_call_continuation SCM_P ((SCM cont, SCM val));
+extern void scm_init_continuations SCM_P ((void));
-#else /* STDC */
-extern SCM scm_make_cont ();
-extern void scm_dynthrow ();
-extern SCM scm_call_continuation ();
-extern void scm_init_continuations ();
-
-#endif /* STDC */
#endif /* CONTINUATIONSH */
diff --git a/libguile/coop-defs.h b/libguile/coop-defs.h
new file mode 100644
index 000000000..d9a6b9eec
--- /dev/null
+++ b/libguile/coop-defs.h
@@ -0,0 +1,149 @@
+/* classes: h_files */
+
+#ifndef COOP_DEFSH
+#define COOP_DEFSH
+
+/* Copyright (C) 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+# ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+# else
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# ifdef HAVE_TIME_H
+# include <time.h>
+# endif
+# endif
+# endif
+
+/* This file is included by threads.h, which, in turn, is included by
+ libguile.h while coop-threads.h only is included by
+ coop-threads.c. */
+
+/* The coop_t struct must be declared here, since macros in this file
+ refer to the data member. */
+
+/* The notion of a thread is merged with the notion of a queue.
+ Thread stuff: thread status (sp) and stuff to use during
+ (re)initialization. Queue stuff: next thread in the queue
+ (next). */
+
+struct qt_t;
+
+typedef struct coop_t {
+ struct qt_t *sp; /* QuickThreads handle. */
+ void *sto; /* `malloc'-allocated stack. */
+
+ struct coop_t *next; /* Next thread in the queue. */
+
+ struct coop_t *all_next;
+ struct coop_t *all_prev;
+
+ void *data; /* Thread local data */
+
+ void *base; /* Base of stack */
+ void *top; /* Top of stack */
+
+ void *joining; /* A queue of threads waiting to join this
+ thread */
+
+ time_t wakeup_time; /* Time to stop sleeping */
+
+} coop_t;
+
+extern coop_t *coop_global_curr; /* Currently-executing thread. */
+
+extern void coop_yield (void);
+
+extern size_t scm_switch_counter;
+extern size_t scm_thread_count;
+
+
+
+/* Cooperative threads don't need to have these defined */
+
+#define SCM_THREAD_CRITICAL_SECTION_START
+#define SCM_THREAD_CRITICAL_SECTION_END
+
+
+
+#define SCM_NO_CRITICAL_SECTION_OWNER 0
+#define SCM_THREAD_SWITCH_COUNT 50 /* was 10 /mdj */
+
+
+
+#define SCM_THREAD_DEFER
+#define SCM_THREAD_ALLOW
+#define SCM_THREAD_REDEFER
+#define SCM_THREAD_REALLOW_1
+#define SCM_THREAD_REALLOW_2
+
+#if 0
+#define SCM_THREAD_SWITCHING_CODE \
+{ \
+ if (scm_thread_count > 1) \
+ coop_yield(); \
+} \
+
+#else
+#define SCM_THREAD_SWITCHING_CODE \
+{ \
+ if (scm_thread_count > 1) \
+ { \
+ scm_switch_counter--; \
+ if (scm_switch_counter == 0) \
+ { \
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT; \
+ coop_yield(); \
+ } \
+ } \
+} \
+
+#endif
+
+#define SCM_THREAD_LOCAL_DATA (coop_global_curr->data)
+#define SCM_SET_THREAD_LOCAL_DATA(ptr) (coop_global_curr->data = (ptr))
+
+#endif /* COOP_DEFSH */
diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c
new file mode 100644
index 000000000..a8860fc62
--- /dev/null
+++ b/libguile/coop-threads.c
@@ -0,0 +1,439 @@
+/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include "coop-threads.h"
+
+/* A counter of the current number of threads */
+size_t scm_thread_count = 0;
+
+/* This is included rather than compiled separately in order
+ to simplify the configuration mechanism. */
+#include "coop.c"
+
+/* A count-down counter used to determine when to switch
+ contexts */
+size_t scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+
+coop_m scm_critical_section_mutex;
+
+#ifdef __STDC__
+size_t
+scm_threads_free_thread (SCM t)
+#else
+size_t
+scm_threads_free_thread (t)
+ SCM t;
+#endif
+{
+ scm_must_free (SCM_THREAD_DATA (t));
+ return sizeof (coop_t);
+}
+
+#ifdef __STDC__
+size_t
+scm_threads_free_mutex (SCM m)
+#else
+size_t
+scm_threads_free_mutex (m)
+ SCM m;
+#endif
+{
+ scm_must_free (SCM_MUTEX_DATA (m));
+ return sizeof (coop_m);
+}
+
+#ifdef __STDC__
+size_t
+scm_threads_free_condvar (SCM c)
+#else
+size_t
+scm_threads_free_condvar (c)
+ SCM c;
+#endif
+{
+ scm_must_free (SCM_CONDVAR_DATA (c));
+ return sizeof (coop_c);
+}
+
+#ifdef __STDC__
+void
+scm_threads_init (SCM_STACKITEM *i)
+#else
+void
+scm_threads_init (i)
+ SCM_STACKITEM *i;
+#endif
+{
+ coop_init();
+
+ scm_thread_count = 1;
+
+ coop_global_main.sto = i;
+ coop_global_main.base = i;
+ coop_global_curr = &coop_global_main;
+ coop_all_qput (&coop_global_allq, coop_global_curr);
+
+ coop_mutex_init (&scm_critical_section_mutex);
+
+ coop_global_main.data = 0; /* Initialized in init.c */
+}
+
+#ifdef __STDC__
+void
+scm_threads_mark_stacks ()
+#else
+void
+scm_threads_mark_stacks ()
+#endif
+{
+ coop_t *thread;
+
+ for (thread = coop_global_allq.t.all_next;
+ thread != NULL; thread = thread->all_next)
+ {
+ if (thread == coop_global_curr)
+ {
+ /* Active thread */
+ /* stack_len is long rather than sizet in order to guarantee
+ that &stack_len is long aligned */
+#ifdef STACK_GROWS_UP
+ long stack_len = ((SCM_STACKITEM *) (&thread) -
+ (SCM_STACKITEM *) thread->base);
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the values from SCM_LENGTH and SCM_CHARS must remain
+ * usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((scm_sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations (((size_t) thread->base,
+ (sizet) stack_len));
+#else
+ long stack_len = ((SCM_STACKITEM *) thread->base -
+ (SCM_STACKITEM *) (&thread));
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the values from SCM_LENGTH and SCM_CHARS must remain
+ * usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((scm_sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations ((SCM_STACKITEM *) &thread,
+ stack_len);
+#endif
+ }
+ else
+ {
+ /* Suspended thread */
+#ifdef STACK_GROWS_UP
+ long stack_len = ((SCM_STACKITEM *) (thread->sp) -
+ (SCM_STACKITEM *) thread->base);
+
+ scm_mark_locations ((size_t)thread->base,
+ (sizet) stack_len);
+#else
+ long stack_len = ((SCM_STACKITEM *) thread->base -
+ (SCM_STACKITEM *) (thread->sp));
+
+ /* Registers are already on the stack. No need to mark. */
+
+ scm_mark_locations ((SCM_STACKITEM *) (size_t)thread->sp,
+ stack_len);
+#endif
+ }
+
+ /* Mark this thread's root */
+ scm_gc_mark (((scm_root_state *) thread->data) -> handle);
+ }
+}
+
+#ifdef __STDC__
+void
+launch_thread (void *p)
+#else
+void
+launch_thread (p)
+ void *p;
+#endif
+{
+ /* The thread object will be GC protected by being a member of the
+ list given as argument to launch_thread. It will be marked
+ during the conservative sweep of the stack. */
+ SCM args = (SCM) p;
+ scm_call_with_dynamic_root (SCM_CADR (args), SCM_CADDR (args));
+ scm_thread_count--;
+}
+
+#ifdef __STDC__
+SCM
+scm_call_with_new_thread (SCM argl)
+#else
+SCM
+scm_call_with_new_thread (argl)
+ SCM argl;
+#endif
+{
+ SCM thread;
+
+ /* Check arguments. */
+ {
+ register SCM args = argl;
+ SCM thunk, handler;
+ SCM_ASSERT (SCM_NIMP (args), argl, SCM_WNA, s_call_with_new_thread);
+ thunk = SCM_CAR (args);
+ SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
+ thunk,
+ SCM_ARG1,
+ s_call_with_new_thread);
+ args = SCM_CDR (args);
+ SCM_ASSERT (SCM_NIMP (args), argl, SCM_WNA, s_call_with_new_thread);
+ handler = SCM_CAR (args);
+ SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)),
+ handler,
+ SCM_ARG2,
+ s_call_with_new_thread);
+ SCM_ASSERT (SCM_NULLP (SCM_CDR (args)), argl, SCM_WNA, s_call_with_new_thread);
+ }
+
+ /* Make new thread. */
+ {
+ coop_t *t;
+ SCM root, old_winds;
+
+ /* Unwind wind chain. */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
+
+ /* Allocate thread locals. */
+ root = scm_make_root (scm_root->handle);
+ /* Make thread. */
+ SCM_NEWCELL (thread);
+ SCM_DEFER_INTS;
+ SCM_SETCAR (thread, scm_tc16_thread);
+ argl = scm_cons (thread, argl);
+ t = coop_create (launch_thread, (void *) argl);
+ t->data = SCM_ROOT_STATE (root);
+ SCM_SETCDR (thread, t);
+ scm_thread_count++;
+ /* Note that the following statement also could cause coop_yield.*/
+ SCM_ALLOW_INTS;
+
+ /* We're now ready for the thread to begin. */
+ coop_yield();
+
+ /* Return to old dynamic context. */
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+ }
+
+ return thread;
+}
+
+#ifdef __STDC__
+SCM
+scm_join_thread (SCM t)
+#else
+SCM
+scm_join_thread (t)
+ SCM t;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (t) && SCM_THREADP (t), t, SCM_ARG1, s_join_thread);
+ coop_join (SCM_THREAD_DATA (t));
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_yield ()
+#else
+SCM
+scm_yield ()
+#endif
+{
+ /* Yield early */
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+ coop_yield();
+
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_single_thread_p ()
+#else
+SCM
+scm_single_thread_p ()
+#endif
+{
+ return (coop_global_runq.tail == &coop_global_runq.t
+ ? SCM_BOOL_T
+ : SCM_BOOL_F);
+}
+
+#ifdef __STDC__
+SCM
+scm_make_mutex ()
+#else
+SCM
+scm_make_mutex ()
+#endif
+{
+ SCM m;
+ coop_m *data = (coop_m *) scm_must_malloc (sizeof (coop_m), "mutex");
+ SCM_NEWCELL (m);
+ SCM_DEFER_INTS;
+ SCM_SETCAR (m, scm_tc16_mutex);
+ SCM_SETCDR (m, data);
+ SCM_ALLOW_INTS;
+ coop_mutex_init (data);
+ return m;
+}
+
+#ifdef __STDC__
+SCM
+scm_lock_mutex (SCM m)
+#else
+SCM
+scm_lock_mutex (m)
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
+ coop_mutex_lock (SCM_MUTEX_DATA (m));
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_unlock_mutex (SCM m)
+#else
+SCM
+scm_unlock_mutex (m)
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
+ coop_mutex_unlock(SCM_MUTEX_DATA (m));
+
+ /* Yield early */
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+ coop_yield();
+
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_make_condition_variable ()
+#else
+SCM
+scm_make_condition_variable ()
+#endif
+{
+ SCM c;
+ coop_c *data = (coop_c *) scm_must_malloc (sizeof (coop_c), "condvar");
+ SCM_NEWCELL (c);
+ SCM_DEFER_INTS;
+ SCM_SETCAR (c, scm_tc16_condvar);
+ SCM_SETCDR (c, data);
+ SCM_ALLOW_INTS;
+ coop_condition_variable_init (SCM_CONDVAR_DATA (c));
+ return c;
+}
+
+#ifdef __STDC__
+SCM
+scm_wait_condition_variable (SCM c, SCM m)
+#else
+SCM
+scm_wait_condition_variable (c, m)
+ SCM c;
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
+ c,
+ SCM_ARG1,
+ s_wait_condition_variable);
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m),
+ m,
+ SCM_ARG2,
+ s_wait_condition_variable);
+ coop_mutex_unlock (SCM_MUTEX_DATA (m));
+ coop_condition_variable_wait (SCM_CONDVAR_DATA (c));
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_signal_condition_variable (SCM c)
+#else
+SCM
+scm_signal_condition_variable (c)
+ SCM c;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
+ c,
+ SCM_ARG1,
+ s_signal_condition_variable);
+ coop_condition_variable_signal (SCM_CONDVAR_DATA (c));
+ return SCM_BOOL_T;
+}
diff --git a/libguile/coop-threads.c.cygnus b/libguile/coop-threads.c.cygnus
new file mode 100644
index 000000000..5393d6fe0
--- /dev/null
+++ b/libguile/coop-threads.c.cygnus
@@ -0,0 +1,469 @@
+/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* A counter of the current number of threads */
+size_t scm_thread_count = 0;
+
+/* This is included rather than compiled seperately in order
+ to simplify the configuration mechanism. */
+#include "coop.c"
+
+/* A count-down counter used to determine when to switch
+ contexts */
+size_t scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+
+coop_m scm_critical_section_mutex;
+
+static struct gscm_type scm_thread_type;
+static struct gscm_type scm_mutex_type;
+static struct gscm_type scm_condition_variable_type;
+
+/* This mutex is used to synchronize thread creation */
+static coop_m scm_coop_create_mutex;
+
+/* Support structure for thread creation */
+struct scm_coop_create_info_type scm_coop_create_info;
+
+#ifdef __STDC__
+int
+gscm_threads_thread_equal (SCM t1, SCM t2)
+#else
+int
+gscm_threads_thread_equal (t1, t2)
+ SCM t1, t2;
+#endif
+{
+ return (*(coop_t **) gscm_unwrap_obj (&scm_thread_type, &t1) ==
+ *(coop_t **) gscm_unwrap_obj (&scm_thread_type, &t2));
+}
+
+#ifdef __STDC__
+void
+gscm_threads_thread_die (SCM t)
+#else
+void
+gscm_threads_thread_die (t)
+ SCM t;
+#endif
+{
+ coop_t **thread = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);
+ free(*thread);
+}
+
+#ifdef __STDC__
+void
+gscm_threads_mutex_die (SCM m)
+#else
+void
+gscm_threads_scm_mutex_die (m)
+ SCM m;
+#endif
+{
+ /* He's dead, Jim */
+}
+
+#ifdef __STDC__
+void
+gscm_threads_condition_variable_die (SCM c)
+#else
+void
+gscm_threads_condition_variable_die (c)
+ SCM c;
+#endif
+{
+ /* He's dead, Jim */
+}
+
+#ifdef __STDC__
+void
+gscm_threads_init ()
+#else
+void
+gscm_threads_init ()
+#endif
+{
+}
+
+/* cleanup for info structure
+ */
+#ifdef __STDC__
+static void
+scm_pthread_delete_info (void *ptr)
+#else
+static void
+scm_pthread_delete_info (ptr)
+ void *ptr;
+#endif
+{
+}
+
+#ifdef __STDC__
+void
+gscm_threads_init_coop_threads ()
+#else
+void
+gscm_threads_init_coop_threads ()
+#endif
+{
+ SCM *prots;
+
+ coop_init();
+
+ scm_thread_count = 1;
+
+ prots = (SCM *)malloc (sizeof (SCM) * scm_num_thread_local_protects);
+
+ coop_global_main.sto = &prots;
+ coop_global_main.base = &prots;
+ coop_global_curr = &coop_global_main;
+ coop_all_qput (&coop_global_allq, coop_global_curr);
+
+ coop_mutex_init(&scm_coop_create_mutex);
+ coop_mutex_init(&scm_critical_section_mutex);
+
+ coop_global_main.data = prots;
+
+ /* Initialize the root thread specific data pointer. All new threads
+ get a copy of this buffer.
+ scm_root_prots = prots; */
+}
+
+#ifdef __STDC__
+void
+gscm_threads_mark_stacks ()
+#else
+void
+gscm_threads_mark_stacks ()
+#endif
+{
+ coop_t *thread;
+ int j;
+ jmp_buf scm_save_regs_gc_mark;
+
+ for (thread = coop_global_allq.t.all_next;
+ thread != NULL; thread = thread->all_next)
+ {
+ if (thread == coop_global_curr)
+ {
+ /* Active thread */
+ /* stack_len is long rather than sizet in order to guarantee
+ that &stack_len is long aligned */
+#ifdef STACK_GROWS_UP
+ long stack_len = (STACKITEM *) (&thread) -
+ (STACKITEM *) thread->base;
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the values from LENGTH and CHARS must remain
+ * usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((STACKITEM *) scm_save_regs_gc_mark,
+ ((sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (STACKITEM)), BOOL_T);
+
+ scm_mark_locations (((size_t) thread->base,
+ (sizet) stack_len, BOOL_T));
+#else
+ long stack_len = (STACKITEM *) thread->base -
+ (STACKITEM *) (&thread);
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the values from LENGTH and CHARS must remain
+ * usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((STACKITEM *) scm_save_regs_gc_mark,
+ ((sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (STACKITEM)), BOOL_T);
+
+ scm_mark_locations ((STACKITEM *) &thread,
+ stack_len, BOOL_T);
+#endif
+ }
+ else
+ {
+ /* Suspended thread */
+#ifdef STACK_GROWS_UP
+ long stack_len = (STACKITEM *) (thread->sp) -
+ (STACKITEM *) thread->base;
+
+ scm_mark_locations (((size_t)thread->base,
+ (sizet) stack_len, BOOL_T));
+#else
+ long stack_len = (STACKITEM *) thread->base -
+ (STACKITEM *) (thread->sp);
+
+ /* Registers are already on the stack. No need to mark. */
+
+ scm_mark_locations ((STACKITEM *) (size_t)thread->sp,
+ stack_len, BOOL_T);
+#endif
+ }
+
+ /* Mark all the of this thread's thread-local protects */
+ for (j = scm_num_thread_local_protects-1; j >= 0; j--)
+ {
+ scm_gc_mark (((SCM*)(thread->data))[j], BOOL_F);
+ }
+ }
+}
+
+#ifdef __STDC__
+void
+launch_thread (void *p)
+#else
+void
+launch_thread (p)
+ void *p;
+#endif
+{
+ SCM thunk = scm_coop_create_info.thunk;
+ SCM error = scm_coop_create_info.error;
+
+ /* dynwinds must be set to BOOL_F for each new thread
+ (it is a thread-local variable) */
+ dynwinds = BOOL_F;
+
+ coop_mutex_unlock(&scm_coop_create_mutex);
+
+ scm_with_dynamic_root (thunk, error);
+
+ scm_thread_count--;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_with_new_thread (SCM thunk, SCM error_thunk)
+#else
+SCM
+gscm_threads_with_new_thread (thunk, error_thunk)
+ SCM thunk;
+ SCM error_thunk;
+#endif
+{
+ int rc;
+ SCM t = gscm_alloc (&scm_thread_type, sizeof(coop_t *));
+
+ coop_t **pt = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);
+
+ int status;
+
+ /* Rather than allocate space to hold fn and arg, a mutex is used
+ to serialize thread creation. */
+ coop_mutex_lock(&scm_coop_create_mutex);
+
+ /* this data is passed to the newly created thread */
+ scm_coop_create_info.thunk = thunk;
+ scm_coop_create_info.error = error_thunk;
+
+ *pt = coop_create(launch_thread, &scm_coop_create_info);
+ scm_thread_count++;
+
+ {
+ SCM * prots;
+
+ prots = (SCM *)malloc (sizeof (SCM) * scm_num_thread_local_protects);
+
+ (*pt)->data = prots;
+
+ /* Copy root thread specific data over */
+ memcpy(prots, (SCM*)coop_global_curr->data,
+ sizeof (SCM) * scm_num_thread_local_protects);
+
+ prots[SCM_THREAD_T] = t;
+ prots[SCM_THREAD_THUNK] = thunk;
+ prots[SCM_THREAD_ERROR] = error_thunk;
+ }
+
+ /* we're now ready for the thread to begin */
+ coop_yield();
+
+ return t;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_join_thread (SCM t)
+#else
+SCM
+gscm_threads_join_thread (t)
+ SCM t;
+#endif
+{
+ coop_t **thread = (coop_t **) gscm_unwrap_obj (&scm_thread_type, &t);
+
+ coop_join(*thread);
+
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_make_mutex ()
+#else
+SCM
+gscm_threads_make_mutex ()
+#endif
+{
+ SCM t = gscm_alloc (&scm_mutex_type, sizeof(coop_m));
+
+ coop_m *m = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &t);
+
+ coop_mutex_init(m);
+
+ return t;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_lock_mutex (SCM m)
+#else
+SCM
+gscm_threads_lock_mutex (m)
+ SCM m;
+#endif
+{
+ coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);
+
+ coop_mutex_lock(mutex);
+
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_unlock_mutex (SCM m)
+#else
+SCM
+gscm_threads_unlock_mutex (m)
+ SCM m;
+#endif
+{
+ coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);
+
+ coop_mutex_unlock(mutex);
+
+ /* Yield early */
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+ coop_yield();
+
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_make_condition_variable ()
+#else
+SCM
+gscm_threads_make_condition_variable ()
+#endif
+{
+ SCM t = gscm_alloc (&scm_mutex_type, sizeof(coop_c));
+
+ coop_c *c = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &t);
+
+ coop_condition_variable_init(c);
+
+ return t;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_condition_variable_wait (SCM c, SCM m)
+#else
+SCM
+gscm_threads_condition_variable_wait (c, m)
+ SCM c;
+ SCM m;
+#endif
+{
+ coop_c *cv = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &c);
+ coop_m *mutex = (coop_m *) gscm_unwrap_obj (&scm_mutex_type, &m);
+
+ coop_mutex_unlock(mutex);
+ coop_condition_variable_wait(cv);
+
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_condition_variable_signal (SCM c)
+#else
+SCM
+gscm_threads_condition_variable_signal (c)
+ SCM c;
+#endif
+{
+ coop_c *cv = (coop_c *) gscm_unwrap_obj (&scm_condition_variable_type, &c);
+
+ coop_condition_variable_signal(cv);
+
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+gscm_threads_yield ()
+#else
+SCM
+gscm_threads_yield ()
+#endif
+{
+ /* Yield early */
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+ coop_yield();
+
+ return SCM_BOOL_T;
+}
diff --git a/libguile/coop-threads.h b/libguile/coop-threads.h
new file mode 100644
index 000000000..0d9678eb4
--- /dev/null
+++ b/libguile/coop-threads.h
@@ -0,0 +1,140 @@
+/* classes: h_files */
+
+#ifndef COOP_THREADSH
+#define COOP_THREADSH
+
+/* Copyright (C) 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* This file is only included by coop-threads.c while coop-defs.h is
+ included by threads.h, which, in turn, is included by
+ libguile.h. */
+
+/* The coop_t struct is declared in coop-defs.h. */
+
+#include "libguile/__scm.h"
+
+#include <time.h>
+
+#include "coop-defs.h"
+#include "../qt/qt.h"
+
+/* This code is based on a sample thread libraru by David Keppel.
+ Portions of this file fall under the following copyright: */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* A queue is a circular list of threads. The queue head is a
+ designated list element. If this is a uniprocessor-only
+ implementation we can store the `main' thread in this, but in a
+ multiprocessor there are several `heavy' threads but only one run
+ queue. A fancier implementation might have private run queues,
+ which would lead to a simpler (trivial) implementation */
+
+typedef struct coop_q_t {
+ coop_t t;
+ coop_t *tail;
+} coop_q_t;
+
+/* A Mutex variable is made up of a owner thread, and a queue of threads
+ waiting on the mutex */
+
+typedef struct coop_m {
+ coop_t *owner; /* Mutex owner */
+ coop_q_t waiting; /* Queue of waiting threads */
+} coop_m;
+
+/* A Condition variable is made up of a list of threads waiting on the
+ condition. */
+
+typedef struct coop_c {
+ coop_q_t waiting; /* Queue of waiting threads */
+} coop_c;
+
+/* Each thread starts by calling a user-supplied function of this
+ type. */
+
+typedef void (coop_userf_t)(void *p0);
+
+/* Call this before any other primitives. */
+extern void coop_init();
+
+/* When one or more threads are created by the main thread,
+ the system goes multithread when this is called. It is done
+ (no more runable threads) when this returns. */
+
+extern void coop_start (void);
+
+/* Create a thread and make it runable. When the thread starts
+ running it will call `f' with arguments `p0' and `p1'. */
+
+extern coop_t *coop_create (coop_userf_t *f, void *p0);
+
+/* The current thread stops running but stays runable.
+ It is an error to call `coop_yield' before `coop_start'
+ is called or after `coop_start' returns. */
+
+extern void coop_yield (void);
+
+/* Like `coop_yield' but the thread is discarded. Any intermediate
+ state is lost. The thread can also terminate by simply
+ returning. */
+
+extern void coop_abort (void);
+
+extern coop_q_t coop_global_runq; /* A queue of runable threads. */
+extern coop_q_t coop_global_sleepq;
+extern coop_q_t coop_global_allq; /* A queue of all threads. */
+extern coop_t *coop_global_curr; /* Currently-executing thread. */
+
+#endif /* COOP_THREADSH */
diff --git a/libguile/coop-threads.h.cygnus b/libguile/coop-threads.h.cygnus
new file mode 100644
index 000000000..bf72e824a
--- /dev/null
+++ b/libguile/coop-threads.h.cygnus
@@ -0,0 +1,223 @@
+/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#ifndef GSCM_COOP_THREADS_H
+#define GSCM_COOP_THREADS_H
+
+#include <qt.h>
+#include <time.h>
+
+/* This code is based on a sample thread libraru by David Keppel.
+ Portions of this file fall under the following copyright: */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* The notion of a thread is merged with the notion of a queue.
+ Thread stuff: thread status (sp) and stuff to use during
+ (re)initialization. Queue stuff: next thread in the queue
+ (next). */
+
+typedef struct coop_t {
+ qt_t *sp; /* QuickThreads handle. */
+ void *sto; /* `malloc'-allocated stack. */
+
+ struct coop_t *next; /* Next thread in the queue. */
+
+ struct coop_t *all_next;
+ struct coop_t *all_prev;
+
+ void *data; /* Thread local data */
+
+ void *base; /* Base of stack */
+ void *top; /* Top of stack */
+
+ void *joining; /* A queue of threads waiting to join this
+ thread */
+
+ time_t wakeup_time; /* Time to stop sleeping */
+
+} coop_t;
+
+/* A queue is a circular list of threads. The queue head is a
+ designated list element. If this is a uniprocessor-only
+ implementation we can store the `main' thread in this, but in a
+ multiprocessor there are several `heavy' threads but only one run
+ queue. A fancier implementation might have private run queues,
+ which would lead to a simpler (trivial) implementation */
+
+typedef struct coop_q_t {
+ coop_t t;
+ coop_t *tail;
+} coop_q_t;
+
+/* A Mutex variable is made up of a owner thread, and a queue of threads
+ waiting on the mutex */
+
+typedef struct coop_m {
+ coop_t *owner; /* Mutex owner */
+ coop_q_t waiting; /* Queue of waiting threads */
+} coop_m;
+
+/* A Condition variable is made up of a list of threads waiting on the
+ condition. */
+
+typedef struct coop_c {
+ coop_q_t waiting; /* Queue of waiting threads */
+} coop_c;
+
+/* Each thread starts by calling a user-supplied function of this
+ type. */
+
+typedef void (coop_userf_t)(void *p0);
+
+/* Call this before any other primitives. */
+extern void coop_init();
+
+/* When one or more threads are created by the main thread,
+ the system goes multithread when this is called. It is done
+ (no more runable threads) when this returns. */
+
+extern void coop_start (void);
+
+/* Create a thread and make it runable. When the thread starts
+ running it will call `f' with arguments `p0' and `p1'. */
+
+extern coop_t *coop_create (coop_userf_t *f, void *p0);
+
+/* The current thread stops running but stays runable.
+ It is an error to call `coop_yield' before `coop_start'
+ is called or after `coop_start' returns. */
+
+extern void coop_yield (void);
+
+/* Like `coop_yield' but the thread is discarded. Any intermediate
+ state is lost. The thread can also terminate by simply
+ returning. */
+
+extern void coop_abort (void);
+
+extern coop_q_t coop_global_allq; /* A queue of all threads. */
+extern coop_t *coop_global_curr; /* Currently-executing thread. */
+
+
+
+extern size_t scm_switch_counter;
+extern size_t scm_thread_count;
+
+
+
+/* Cooperative threads don't need to have these defined */
+
+#define SCM_THREAD_CRITICAL_SECTION_START
+#define SCM_THREAD_CRITICAL_SECTION_END
+#define SCM_THREAD_INITIALIZE_STORAGE gscm_threads_init_coop_threads()
+
+
+
+#define SCM_NO_CRITICAL_SECTION_OWNER 0
+#define SCM_THREAD_SWITCH_COUNT 10
+
+
+
+#define SCM_DEFER_INTS \
+{ \
+ scm_ints_disabled = 1; \
+}
+
+#define SCM_ALLOW_INTS \
+{ \
+ scm_ints_disabled = 0; \
+ SCM_CHECK_INTS; \
+ scm_switch_counter--; \
+ if (scm_switch_counter == 0) \
+ { \
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT; \
+ if (scm_thread_count > 1) \
+ coop_yield(); \
+ } \
+}
+
+#define SCM_REDEFER_INTS \
+{ \
+ ++scm_ints_disabled; \
+}
+
+#define SCM_REALLOW_INTS \
+{ \
+ --scm_ints_disabled; \
+ if (!scm_ints_disabled) \
+ { \
+ SCM_CHECK_INTS; \
+ } \
+ scm_switch_counter--; \
+ if (scm_switch_counter == 0) \
+ { \
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT; \
+ if (scm_thread_count > 1) \
+ coop_yield(); \
+ } \
+}
+
+
+
+/* This structure is used when creating new threads. */
+
+struct scm_coop_create_info_type
+{
+ SCM thunk;
+ SCM error;
+};
+
+extern struct scm_coop_create_info_type scm_coop_create_info;
+
+#endif
diff --git a/libguile/coop.c b/libguile/coop.c
new file mode 100644
index 000000000..56f7175d2
--- /dev/null
+++ b/libguile/coop.c
@@ -0,0 +1,588 @@
+/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* $Id: coop.c,v 1.1 1997-04-15 01:34:30 jimb Exp $ */
+
+/* Cooperative thread library, based on QuickThreads */
+
+#include <qt.h>
+
+#define COOP_STKSIZE (0x10000)
+
+/* `alignment' must be a power of 2. */
+#define COOP_STKALIGN(sp, alignment) \
+((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))
+
+
+
+/* Queue access functions. */
+
+#ifdef __STDC__
+static void
+coop_qinit (coop_q_t *q)
+#else
+static void
+coop_qinit (q)
+ coop_q_t *q;
+#endif
+{
+ q->t.next = q->tail = &q->t;
+
+ q->t.all_prev = NULL;
+ q->t.all_next = NULL;
+}
+
+
+#ifdef __STDC__
+static coop_t *
+coop_qget (coop_q_t *q)
+#else
+static coop_t *
+coop_qget (q)
+ coop_q_t *q;
+#endif
+{
+ coop_t *t;
+
+ t = q->t.next;
+ q->t.next = t->next;
+ if (t->next == &q->t) {
+ if (t == &q->t) { /* If it was already empty .. */
+ return (NULL); /* .. say so. */
+ }
+ q->tail = &q->t; /* Else now it is empty. */
+ }
+ return (t);
+}
+
+
+#ifdef __STDC__
+static void
+coop_qput (coop_q_t *q, coop_t *t)
+#else
+static void
+coop_qput (q, t)
+ coop_q_t *q;
+ coop_t *t;
+#endif
+{
+ q->tail->next = t;
+ t->next = &q->t;
+ q->tail = t;
+}
+
+#ifdef __STDC__
+static void
+coop_all_qput (coop_q_t *q, coop_t *t)
+#else
+static void
+coop_all_qput (q, t)
+ coop_q_t *q;
+ coop_t *t;
+#endif
+{
+ if (q->t.all_next)
+ q->t.all_next->all_prev = t;
+ t->all_prev = NULL;
+ t->all_next = q->t.all_next;
+ q->t.all_next = t;
+}
+
+#ifdef __STDC__
+static void
+coop_all_qremove (coop_q_t *q, coop_t *t)
+#else
+static void
+coop_all_qremove (q, t)
+ coop_q_t *q;
+ coop_t *t;
+#endif
+{
+ if (t->all_prev)
+ t->all_prev->all_next = t->all_next;
+ else
+ q->t.all_next = t->all_next;
+ if (t->all_next)
+ t->all_next->all_prev = t->all_prev;
+}
+
+
+ /* Thread routines. */
+
+coop_q_t coop_global_runq; /* A queue of runable threads. */
+coop_q_t coop_global_sleepq; /* A queue of sleeping threads. */
+static coop_q_t tmp_queue; /* A temp working queue */
+coop_q_t coop_global_allq; /* A queue of all threads. */
+static coop_t coop_global_main; /* Thread for the process. */
+coop_t *coop_global_curr; /* Currently-executing thread. */
+
+static void *coop_starthelp (qt_t *old, void *ignore0, void *ignore1);
+static void coop_only (void *pu, void *pt, qt_userf_t *f);
+static void *coop_aborthelp (qt_t *sp, void *old, void *null);
+static void *coop_yieldhelp (qt_t *sp, void *old, void *blockq);
+
+
+#ifdef __STDC__
+void
+coop_init()
+#else
+void
+coop_init()
+#endif
+{
+ coop_qinit (&coop_global_runq);
+ coop_qinit (&coop_global_sleepq);
+ coop_qinit (&tmp_queue);
+ coop_qinit (&coop_global_allq);
+ coop_global_curr = &coop_global_main;
+}
+
+
+/* Return the next runnable thread. If no threads are currently runnable,
+ and there are sleeping threads - wait until one wakes up. Otherwise,
+ return NULL. */
+
+#ifdef __STDC__
+coop_t *
+coop_next_runnable_thread()
+#else
+coop_t *
+coop_next_runnable_thread()
+#endif
+{
+ int sleepers;
+ coop_t *t;
+ time_t now;
+
+ do {
+ sleepers = 0;
+ now = time(NULL);
+
+ /* Check the sleeping queue */
+ while ((t = coop_qget(&coop_global_sleepq)) != NULL)
+ {
+ sleepers++;
+ if (t->wakeup_time <= now)
+ coop_qput(&coop_global_runq, t);
+ else
+ coop_qput(&tmp_queue, t);
+ }
+ while ((t = coop_qget(&tmp_queue)) != NULL)
+ coop_qput(&coop_global_sleepq, t);
+
+ t = coop_qget (&coop_global_runq);
+
+ } while ((t == NULL) && (sleepers > 0));
+
+ return t;
+}
+
+
+#ifdef __STDC__
+void
+coop_start()
+#else
+void
+coop_start()
+#endif
+{
+ coop_t *next;
+
+ while ((next = coop_qget (&coop_global_runq)) != NULL) {
+ coop_global_curr = next;
+ QT_BLOCK (coop_starthelp, 0, 0, next->sp);
+ }
+}
+
+
+#ifdef __STDC__
+static void *
+coop_starthelp (qt_t *old, void *ignore0, void *ignore1)
+#else
+static void *
+coop_starthelp (old, ignore0, ignore1)
+ qt_t *old;
+ void *ignore0;
+ void *ignore1;
+#endif
+{
+ coop_global_main.sp = old;
+ coop_global_main.joining = NULL;
+ coop_qput (&coop_global_runq, &coop_global_main);
+ return NULL; /* not used, but keeps compiler happy */
+}
+
+#ifdef __STDC__
+void
+coop_mutex_init (coop_m *m)
+#else
+void
+coop_mutex_init (m)
+ coop_m *m;
+#endif
+{
+ m->owner = NULL;
+ coop_qinit(&(m->waiting));
+}
+
+#ifdef __STDC__
+void
+coop_mutex_lock (coop_m *m)
+#else
+void
+coop_mutex_lock ()
+ coop_m *m;
+#endif
+{
+ if (m->owner == NULL)
+ {
+ m->owner = coop_global_curr;
+ }
+ else
+ {
+ coop_t *old, *newthread;
+
+ /* Record the current top-of-stack before going to sleep */
+ coop_global_curr->top = &old;
+
+ newthread = coop_next_runnable_thread();
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, &(m->waiting), newthread->sp);
+ }
+}
+
+
+#ifdef __STDC__
+void
+coop_mutex_unlock (coop_m *m)
+#else
+void
+coop_mutex_unlock (m)
+ coop_m *m;
+#endif
+{
+ coop_t *old, *newthread;
+
+ newthread = coop_qget (&(m->waiting));
+ if (newthread != NULL)
+ {
+ /* Record the current top-of-stack before going to sleep */
+ coop_global_curr->top = &old;
+
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ m->owner = coop_global_curr;
+ QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
+ }
+ else
+ {
+ m->owner = NULL;
+ }
+}
+
+
+#ifdef __STDC__
+void
+coop_condition_variable_init (coop_c *c)
+#else
+void
+coop_condition_variable_init (c)
+ coop_c *c;
+#endif
+{
+ coop_qinit(&(c->waiting));
+}
+
+#ifdef __STDC__
+void
+coop_condition_variable_wait (coop_c *c)
+#else
+void
+coop_condition_variable_wait (c)
+ coop_c *c;
+#endif
+{
+ coop_t *old, *newthread;
+
+ newthread = coop_next_runnable_thread();
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, &(c->waiting), newthread->sp);
+}
+
+#ifdef __STDC__
+void
+coop_condition_variable_signal (coop_c *c)
+#else
+void
+coop_condition_variable_signal (c)
+ coop_c *c;
+#endif
+{
+ coop_t *newthread;
+
+ while ((newthread = coop_qget (&(c->waiting))) != NULL)
+ {
+ coop_qput (&coop_global_runq, newthread);
+ }
+}
+
+
+#ifdef __STDC__
+coop_t *
+coop_create (coop_userf_t *f, void *pu)
+#else
+coop_t *
+coop_create (f, pu)
+ coop_userf_t *f;
+ void *pu;
+#endif
+{
+ coop_t *t;
+ void *sto;
+
+ t = malloc (sizeof(coop_t));
+
+ t->data = NULL;
+ t->sto = malloc (COOP_STKSIZE);
+ sto = COOP_STKALIGN (t->sto, QT_STKALIGN);
+ t->sp = QT_SP (sto, COOP_STKSIZE - QT_STKALIGN);
+ t->base = t->sp;
+ t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, coop_only);
+ t->joining = NULL;
+ coop_qput (&coop_global_runq, t);
+ coop_all_qput (&coop_global_allq, t);
+
+ return t;
+}
+
+
+#ifdef __STDC__
+static void
+coop_only (void *pu, void *pt, qt_userf_t *f)
+#else
+static void
+coop_only (pu. pt, f)
+ void *pu,
+ void *pt,
+ qt_userf_t *f;
+#endif
+{
+ coop_global_curr = (coop_t *)pt;
+ (*(coop_userf_t *)f)(pu);
+ coop_abort();
+ /* NOTREACHED */
+}
+
+
+#ifdef __STDC__
+void
+coop_abort ()
+#else
+void
+coop_abort ()
+#endif
+{
+ coop_t *old, *newthread;
+
+ /* Wake up any threads that are waiting to join this one */
+ if (coop_global_curr->joining)
+ {
+ while ((newthread = coop_qget ((coop_q_t *)(coop_global_curr->joining)))
+ != NULL)
+ {
+ coop_qput (&coop_global_runq, newthread);
+ }
+ free(coop_global_curr->joining);
+ }
+
+ newthread = coop_next_runnable_thread();
+ coop_all_qremove(&coop_global_allq, coop_global_curr);
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_ABORT (coop_aborthelp, old, (void *)NULL, newthread->sp);
+}
+
+
+#ifdef __STDC__
+static void *
+coop_aborthelp (qt_t *sp, void *old, void *null)
+#else
+static void *
+coop_aborthelp (sp, old, null)
+ qt_t *sp;
+ void *old;
+ void *null;
+#endif
+{
+ coop_t *oldthread = (coop_t *) old;
+
+ free (oldthread->sto);
+
+ /* "old" is freed in scm_threads_thread_die().
+ Marking old->base NULL indicates that this thread is dead */
+
+ oldthread->base = NULL;
+
+ return NULL;
+}
+
+
+#ifdef __STDC__
+void
+coop_join(coop_t *t)
+#else
+void
+coop_join()
+ coop_t *t;
+#endif
+{
+ coop_t *old, *newthread;
+
+ /* Check if t is already finished */
+ if (t->base == NULL)
+ return;
+
+ /* Create a join list if necessary */
+ if (t->joining == NULL)
+ {
+ t->joining = malloc(sizeof(coop_q_t));
+ coop_qinit((coop_q_t *) t->joining);
+ }
+
+ newthread = coop_next_runnable_thread();
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, (coop_q_t *) t->joining, newthread->sp);
+}
+
+#ifdef __STDC__
+void
+coop_yield()
+#else
+void
+coop_yield()
+#endif
+{
+ coop_t *old = NULL;
+ coop_t *newthread;
+
+ newthread = coop_next_runnable_thread();
+
+ /* There may be no other runnable threads. Return if this is the
+ case. */
+ if (newthread == NULL)
+ return;
+
+ old = coop_global_curr;
+
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
+}
+
+
+#ifdef __STDC__
+static void *
+coop_yieldhelp (qt_t *sp, void *old, void *blockq)
+#else
+static void *
+coop_yieldhelp (sp, old, blockq)
+ qt_t *sp;
+ void *old;
+ void *blockq;
+#endif
+{
+ ((coop_t *)old)->sp = sp;
+ coop_qput ((coop_q_t *)blockq, (coop_t *)old);
+ return NULL;
+}
+
+/* Replacement for the system's sleep() function. Does the right thing
+ for the process - but not for the system (it busy-waits) */
+
+#ifdef __STDC__
+static void *
+coop_sleephelp (qt_t *sp, void *old, void *blockq)
+#else
+static void *
+coop_sleephelp (sp, old, bolckq)
+ qt_t *sp;
+ void *old;
+ void *blockq;
+#endif
+{
+ ((coop_t *)old)->sp = sp;
+ /* old is already on the sleep queue - so there's no need to
+ do anything extra here */
+ return NULL;
+}
+
+#ifdef __STDC__
+unsigned
+sleep (unsigned s)
+#else
+unsigned
+sleep (s)
+ unsigned s;
+#endif
+{
+ coop_t *newthread, *old;
+ time_t now = time(NULL);
+ coop_global_curr->wakeup_time = now + s;
+
+ /* Put the current thread on the sleep queue */
+ coop_qput (&coop_global_sleepq, coop_global_curr);
+
+ newthread = coop_next_runnable_thread();
+
+ /* If newthread is the same as the sleeping thread, do nothing */
+ if (newthread == coop_global_curr)
+ return s;
+
+ old = coop_global_curr;
+
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_sleephelp, old, NULL, newthread->sp);
+
+ return s;
+}
diff --git a/libguile/cpp_cnvt.awk b/libguile/cpp_cnvt.awk
new file mode 100644
index 000000000..a01ba52a8
--- /dev/null
+++ b/libguile/cpp_cnvt.awk
@@ -0,0 +1,7 @@
+# Converts a list of symbols into C expressions which define the symbols
+# in Guile.
+{
+print "#ifdef " $0;
+print "scm_sysintern (\""$0"\", SCM_MAKINUM ("$0"));";
+print "#endif"
+}
diff --git a/libguile/cpp_err_symbols.in b/libguile/cpp_err_symbols.in
new file mode 100644
index 000000000..67b897ca9
--- /dev/null
+++ b/libguile/cpp_err_symbols.in
@@ -0,0 +1,122 @@
+E2BIG
+EACCES
+EADDRINUSE
+EADDRNOTAVAIL
+EADV
+EAFNOSUPPORT
+EAGAIN
+EALREADY
+EBADE
+EBADF
+EBADFD
+EBADMSG
+EBADR
+EBADRQC
+EBADSLT
+EBFONT
+EBUSY
+ECHILD
+ECHRNG
+ECOMM
+ECONNABORTED
+ECONNREFUSED
+ECONNRESET
+EDEADLK
+EDEADLOCK
+EDESTADDRREQ
+EDOM
+EDOTDOT
+EDQUOT
+EEXIST
+EFAULT
+EFBIG
+EHOSTDOWN
+EHOSTUNREACH
+EIDRM
+EILSEQ
+EINPROGRESS
+EINTR
+EINVAL
+EIO
+EISCONN
+EISDIR
+EISNAM
+EL2HLT
+EL2NSYNC
+EL3HLT
+EL3RST
+ELIBACC
+ELIBBAD
+ELIBEXEC
+ELIBMAX
+ELIBSCN
+ELNRNG
+ELOOP
+EMFILE
+EMLINK
+EMSGSIZE
+EMULTIHOP
+ENAMETOOLONG
+ENAVAIL
+ENETDOWN
+ENETRESET
+ENETUNREACH
+ENFILE
+ENOANO
+ENOBUFS
+ENOCSI
+ENODATA
+ENODEV
+ENOENT
+ENOEXEC
+ENOLCK
+ENOLINK
+ENOMEM
+ENOMSG
+ENONET
+ENOPKG
+ENOPROTOOPT
+ENOSPC
+ENOSR
+ENOSTR
+ENOSYS
+ENOTBLK
+ENOTCONN
+ENOTDIR
+ENOTEMPTY
+ENOTNAM
+ENOTSOCK
+ENOTTY
+ENOTUNIQ
+ENXIO
+EOPNOTSUPP
+EOVERFLOW
+EPERM
+EPFNOSUPPORT
+EPIPE
+EPROTO
+EPROTONOSUPPORT
+EPROTOTYPE
+ERANGE
+EREMCHG
+EREMOTE
+EREMOTEIO
+ERESTART
+EROFS
+ESHUTDOWN
+ESOCKTNOSUPPORT
+ESPIPE
+ESRCH
+ESRMNT
+ESTALE
+ESTRPIPE
+ETIME
+ETIMEDOUT
+ETOOMANYREFS
+ETXTBSY
+EUCLEAN
+EUNATCH
+EUSERS
+EWOULDBLOCK
+EXDEV
+EXFULL
diff --git a/libguile/cpp_errno.c b/libguile/cpp_errno.c
new file mode 100644
index 000000000..8ee25bad9
--- /dev/null
+++ b/libguile/cpp_errno.c
@@ -0,0 +1,3 @@
+/* this file is processed by gcc with special options to extract
+ a list of errno codes. */
+#include <errno.h>
diff --git a/libguile/cpp_sig_symbols.in b/libguile/cpp_sig_symbols.in
new file mode 100644
index 000000000..a533ea1b0
--- /dev/null
+++ b/libguile/cpp_sig_symbols.in
@@ -0,0 +1,34 @@
+SIGABRT
+SIGALRM
+SIGBUS
+SIGCHLD
+SIGCLD
+SIGCONT
+SIGFPE
+SIGHUP
+SIGILL
+SIGINT
+SIGIO
+SIGIOT
+SIGKILL
+SIGPIPE
+SIGPOLL
+SIGPROF
+SIGPWR
+SIGQUIT
+SIGSEGV
+SIGSTKFLT
+SIGSTOP
+SIGTERM
+SIGTRAP
+SIGTSTP
+SIGTTIN
+SIGTTOU
+SIGUNUSED
+SIGURG
+SIGUSR1
+SIGUSR2
+SIGVTALRM
+SIGWINCH
+SIGXCPU
+SIGXFSZ
diff --git a/libguile/cpp_signal.c b/libguile/cpp_signal.c
new file mode 100644
index 000000000..eb4ed9667
--- /dev/null
+++ b/libguile/cpp_signal.c
@@ -0,0 +1,3 @@
+/* this file is processed by gcc with special options to extract
+ a list of signal numbers. */
+#include <signal.h>
diff --git a/libguile/debug.c b/libguile/debug.c
new file mode 100644
index 000000000..9fbc950a3
--- /dev/null
+++ b/libguile/debug.c
@@ -0,0 +1,427 @@
+/* Debugging extensions for Guile
+ * Copyright (C) 1995, 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+#include "eval.h"
+#include "throw.h"
+#include "genio.h"
+#include "smob.h"
+#include "procprop.h"
+#include "srcprop.h"
+#include "alist.h"
+#include "continuations.h"
+#include "strports.h"
+#include "read.h"
+#include "feature.h"
+
+#include "debug.h"
+
+
+/* {Run time control of the debugging evaluator}
+ */
+
+SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options);
+
+SCM
+scm_debug_options (setting)
+ SCM setting;
+{
+ SCM ans;
+ SCM_DEFER_INTS;
+ ans = scm_options (setting,
+ scm_debug_opts,
+ SCM_N_DEBUG_OPTIONS,
+ s_debug_options);
+#ifndef SCM_RECKLESS
+ if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
+ {
+ scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options);
+ scm_out_of_range (s_debug_options, setting);
+ }
+#endif
+ SCM_RESET_DEBUG_MODE;
+ scm_debug_eframe_size = 2 * SCM_N_FRAMES;
+ SCM_ALLOW_INTS
+ return ans;
+}
+
+SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps);
+
+SCM
+scm_evaluator_traps (setting)
+ SCM setting;
+{
+ SCM ans;
+ SCM_DEFER_INTS;
+ ans = scm_options (setting,
+ scm_evaluator_trap_table,
+ SCM_N_EVALUATOR_TRAPS,
+ s_evaluator_traps);
+ SCM_RESET_DEBUG_MODE;
+ SCM_ALLOW_INTS
+ return ans;
+}
+
+SCM_PROC (s_single_step, "single-step", 2, 0, 0, scm_single_step);
+
+SCM
+scm_single_step (cont, val)
+ SCM cont;
+ SCM val;
+{
+ SCM_DEFER_INTS;
+ SCM_ENTER_FRAME_P = SCM_EXIT_FRAME_P = 1;
+ SCM_RESET_DEBUG_MODE;
+ SCM_ALLOW_INTS;
+ scm_call_continuation (cont, val);
+ return SCM_BOOL_F; /* never returns */
+}
+
+
+static SCM scm_i_source, scm_i_more;
+static SCM scm_i_proc, scm_i_args, scm_i_eval_args;
+static SCM scm_i_procname;
+
+/* {Memoized Source}
+ */
+
+long scm_tc16_memoized;
+
+
+static int prinmemoized SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
+
+static int
+prinmemoized (obj, port, pstate)
+ SCM obj;
+ SCM port;
+ scm_print_state *pstate;
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_gen_puts (scm_regular_string, "#<memoized ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (scm_unmemoize (obj), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns memoizedsmob =
+{scm_markcdr, scm_free0, prinmemoized, 0};
+
+SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p);
+
+SCM
+scm_memoized_p (obj)
+ SCM obj;
+{
+ return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM
+scm_make_memoized (exp, env)
+ SCM exp;
+ SCM env;
+{
+ /* *fixme* Check that env is a valid environment. */
+ register SCM z, ans;
+ SCM_DEFER_INTS;
+ SCM_NEWCELL (z);
+ SCM_SETCAR (z, exp);
+ SCM_SETCDR (z, env);
+ SCM_NEWCELL (ans);
+ SCM_SETCAR (ans, scm_tc16_memoized);
+ SCM_SETCDR (ans, z);
+ SCM_ALLOW_INTS;
+ return ans;
+}
+
+SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize);
+
+SCM
+scm_unmemoize (m)
+ SCM m;
+{
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
+ return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
+}
+
+SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment);
+
+SCM
+scm_memoized_environment (m)
+ SCM m;
+{
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
+ return SCM_MEMOIZED_ENV (m);
+}
+
+SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name);
+
+SCM
+scm_procedure_name (proc)
+ SCM proc;
+{
+ SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T,
+ proc,
+ SCM_ARG1,
+ s_procedure_name);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ case scm_tc7_cclo:
+ {
+ SCM name = scm_procedure_property (proc, scm_i_name);
+#if 0
+ /* Procedure property scm_i_procname not implemented yet... */
+ SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_i_procname);
+ if (SCM_FALSEP (name))
+ name = scm_procedure_property (proc, scm_i_name);
+#endif
+ return name;
+ }
+ case scm_tcs_subrs:
+ return SCM_SNAME (proc);
+ default:
+ return SCM_BOOL_F;
+ }
+}
+
+SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source);
+
+SCM
+scm_procedure_source (proc)
+ SCM proc;
+{
+ SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ {
+ SCM src;
+ src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_i_copy);
+ if (src != SCM_BOOL_F)
+ return scm_cons2 (scm_i_lambda, SCM_CAR (SCM_CODE (proc)), src);
+ src = SCM_CODE (proc);
+ return scm_cons (scm_i_lambda,
+ scm_unmemocopy (src,
+ SCM_EXTEND_ENV (SCM_CAR (src),
+ SCM_EOL,
+ SCM_ENV (proc))));
+ }
+ case scm_tc7_contin:
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ /* It would indeed be a nice thing if we supplied source even for
+ built in procedures! */
+ return scm_procedure_property (proc, scm_i_source);
+ default:
+ scm_wta (proc, (char *) SCM_ARG1, s_procedure_source);
+ return 0;
+ }
+}
+
+SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment);
+
+SCM
+scm_procedure_environment (proc)
+ SCM proc;
+{
+ SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ return SCM_ENV (proc);
+ case scm_tc7_contin:
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ return SCM_EOL;
+ default:
+ scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment);
+ return 0;
+ }
+}
+
+
+
+/* Eval in a local environment. We would like to have the ability to
+ * evaluate in a specified local environment, but due to the
+ * memoization this isn't normally possible. We solve it by copying
+ * the code before evaluating. One solution would be to have eval.c
+ * generate yet another evaluator. They are not very big actually.
+ */
+SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval);
+
+SCM
+scm_local_eval (exp, env)
+ SCM exp;
+ SCM env;
+{
+ if (SCM_UNBNDP (env))
+ {
+ SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval);
+ return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp));
+ }
+ return scm_eval_3 (exp, 1, env);
+}
+
+static char s_start_stack[] = "start-stack";
+SCM
+scm_m_start_stack (exp, env)
+ SCM exp;
+ SCM env;
+{
+ SCM answer;
+ scm_debug_frame vframe;
+ scm_debug_info vframe_vect_body;
+ exp = SCM_CDR (exp);
+ SCM_ASSERT (SCM_NIMP (exp)
+ && SCM_ECONSP (exp)
+ && SCM_NIMP (SCM_CDR (exp))
+ && SCM_ECONSP (SCM_CDR (exp))
+ && SCM_NULLP (SCM_CDDR (exp)),
+ exp,
+ SCM_WNA,
+ s_start_stack);
+ vframe.prev = scm_last_debug_frame;
+ vframe.status = SCM_VOIDFRAME;
+ vframe.vect = &vframe_vect_body;
+ vframe.vect[0].id = scm_eval_car (exp, env);
+ scm_last_debug_frame = &vframe;
+ answer = scm_eval_car (SCM_CDR (exp), env);
+ scm_last_debug_frame = vframe.prev;
+ return answer;
+}
+
+/* {Debug Objects}
+ *
+ * The debugging evaluator throws these on frame traps.
+ */
+
+long scm_tc16_debugobj;
+
+static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
+
+static int
+prindebugobj (obj, port, pstate)
+ SCM obj;
+ SCM port;
+ scm_print_state *pstate;
+{
+ scm_gen_puts (scm_regular_string, "#<debug-object ", port);
+ scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns debugobjsmob =
+{scm_mark0, scm_free0, prindebugobj, 0};
+
+SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p);
+
+SCM
+scm_debug_object_p (obj)
+ SCM obj;
+{
+ return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+
+SCM
+scm_make_debugobj (frame)
+ scm_debug_frame *frame;
+{
+ register SCM z;
+ SCM_DEFER_INTS;
+ SCM_NEWCELL (z);
+ SCM_SETCAR (z, scm_tc16_debugobj);
+ SCM_SET_DEBUGOBJ_FRAME (z, (SCM) frame);
+ SCM_ALLOW_INTS;
+ return z;
+}
+
+
+
+/* Undocumented debugging procedure */
+#ifdef GUILE_DEBUG
+SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang);
+
+SCM
+scm_debug_hang (obj)
+ SCM obj;
+{
+ int go = 0;
+ while (!go) ;
+ return SCM_UNSPECIFIED;
+}
+#endif
+
+
+
+void
+scm_init_debug ()
+{
+ scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
+ scm_init_opts (scm_evaluator_traps,
+ scm_evaluator_trap_table,
+ SCM_N_EVALUATOR_TRAPS);
+
+ scm_tc16_memoized = scm_newsmob (&memoizedsmob);
+ scm_tc16_debugobj = scm_newsmob (&debugobjsmob);
+
+ scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED));
+ scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED));
+ scm_i_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED));
+ scm_i_proc = SCM_CAR (scm_sysintern ("proc", SCM_UNDEFINED));
+ scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED));
+ scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED));
+
+ scm_make_synt (s_start_stack, scm_makacro, scm_m_start_stack);
+
+ scm_add_feature ("debug-extensions");
+
+#include "debug.x"
+}
diff --git a/libguile/debug.h b/libguile/debug.h
new file mode 100644
index 000000000..0f796a687
--- /dev/null
+++ b/libguile/debug.h
@@ -0,0 +1,204 @@
+/* classes: h_files */
+
+#ifndef DEBUGH
+#define DEBUGH
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+#include "libguile/options.h"
+
+
+/*
+ * Here comes some definitions for the debugging machinery.
+ * It might seem strange to represent debug flags as ints,
+ * but consider that any particular piece of code is normally
+ * only interested in one flag at a time. This is then
+ * the most efficient representation.
+ */
+
+/* {Options}
+ */
+
+/* scm_debug_opts and scm_evaluator_trap_table are defined in eval.c.
+ */
+
+extern scm_option scm_debug_opts[];
+
+#define SCM_CHEAPTRAPS_P scm_debug_opts[0].val
+#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
+#define SCM_TRACE_P scm_debug_opts[2].val
+#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
+#define SCM_BACKWARDS_P scm_debug_opts[4].val
+#define SCM_BACKTRACE_INDENT scm_debug_opts[5].val
+#define SCM_N_FRAMES scm_debug_opts[6].val
+#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[7].val
+#define SCM_BACKTRACE_DEPTH scm_debug_opts[8].val
+#define SCM_BACKTRACE_P scm_debug_opts[9].val
+#define SCM_DEVAL_P scm_debug_opts[10].val
+#define SCM_STACK_LIMIT scm_debug_opts[11].val
+#define SCM_N_DEBUG_OPTIONS 12
+
+extern scm_option scm_evaluator_trap_table[];
+
+#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[0].val
+#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[1].val
+#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[2].val
+#define SCM_N_EVALUATOR_TRAPS 3
+
+extern SCM (*scm_ceval_ptr) SCM_P ((SCM exp, SCM env));
+
+extern int scm_debug_mode;
+extern int scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
+
+#define CHECK_ENTRY scm_check_entry_p
+#define CHECK_APPLY scm_check_apply_p
+#define CHECK_EXIT scm_check_exit_p
+
+#define SCM_RESET_DEBUG_MODE \
+{\
+ CHECK_ENTRY = SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P;\
+ CHECK_APPLY = SCM_APPLY_FRAME_P || SCM_TRACE_P;\
+ CHECK_EXIT = SCM_EXIT_FRAME_P || SCM_TRACE_P;\
+ scm_debug_mode = SCM_DEVAL_P || CHECK_ENTRY || CHECK_APPLY || CHECK_EXIT;\
+ scm_ceval_ptr = scm_debug_mode ? scm_deval : scm_ceval;\
+}
+
+
+/* {Evaluator}
+ */
+
+typedef union scm_debug_info
+{
+ struct { SCM exp, env; } e;
+ struct { SCM proc, args; } a;
+ SCM id;
+} scm_debug_info;
+
+extern int scm_debug_eframe_size;
+
+typedef struct scm_debug_frame
+{
+ struct scm_debug_frame *prev;
+ long status;
+ scm_debug_info *vect;
+ scm_debug_info *info;
+} scm_debug_frame;
+
+#ifndef USE_THREADS
+extern scm_debug_frame *scm_last_debug_frame;
+#endif
+
+#define SCM_EVALFRAME (0L << 10)
+#define SCM_APPLYFRAME (1L << 10)
+#define SCM_VOIDFRAME (2L << 10)
+#define SCM_TAILREC (1L << 9)
+#define SCM_TRACED_FRAME (1L << 8)
+#define SCM_ARGS_READY (1L << 7)
+#define SCM_DOVERFLOW (1L << 6)
+#define SCM_MAX_FRAME_SIZE 63 /* also used as a mask for the size field */
+
+#define SCM_FRAMETYPE (3L << 10)
+
+#define SCM_EVALFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_EVALFRAME)
+#define SCM_APPLYFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_APPLYFRAME)
+#define SCM_VOIDFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_VOIDFRAME)
+#define SCM_OVERFLOWP(x) (((x).status & SCM_DOVERFLOW) != 0)
+#define SCM_ARGS_READY_P(x) (((x).status & SCM_ARGS_READY) != 0)
+#define SCM_TRACED_FRAME_P(x) (((x).status & SCM_TRACED_FRAME) != 0)
+#define SCM_TAILRECP(x) (((x).status & SCM_TAILREC) != 0)
+#define SCM_SET_OVERFLOW(x) ((x).status |= SCM_DOVERFLOW)
+#define SCM_SET_ARGSREADY(x) ((x).status |= SCM_ARGS_READY)
+#define SCM_CLEAR_ARGSREADY(x) ((x).status &= ~SCM_ARGS_READY)
+#define SCM_SET_TRACED_FRAME(x) ((x).status |= SCM_TRACED_FRAME)
+#define SCM_CLEAR_TRACED_FRAME(x) ((x).status &= ~SCM_TRACED_FRAME)
+#define SCM_SET_TAILREC(x) ((x).status |= SCM_TAILREC)
+
+#define SCM_DEBUGGINGP scm_debug_mode
+#define SCM_DSIDEVAL(x, env) if NIMP(x) scm_deval((x), (env))
+
+/* {Debug Objects}
+ */
+
+extern long scm_tc16_debugobj;
+
+#define SCM_DEBUGOBJP(x) (scm_tc16_debugobj == SCM_TYP16 (x))
+#define SCM_DEBUGOBJ_FRAME(x) SCM_CDR (x)
+#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SETCDR (x, f)
+
+/* {Memoized Source}
+ */
+
+extern long scm_tc16_memoized;
+
+#define SCM_MEMOIZEDP(x) (scm_tc16_memoized == SCM_TYP16 (x))
+#define SCM_MEMOIZED_EXP(x) SCM_CAR (SCM_CDR (x))
+#define SCM_MEMOIZED_ENV(x) SCM_CDR (SCM_CDR (x))
+
+
+
+extern SCM * scm_lookup_cstr SCM_P ((char *str, int len, SCM env));
+extern SCM * scm_lookup_soft SCM_P ((SCM var, SCM genv));
+extern SCM scm_evstr SCM_P ((char *str));
+extern SCM scm_eval_string SCM_P ((SCM str));
+extern int scm_ready_p SCM_P ((void));
+extern void debug_print SCM_P ((SCM obj));
+extern SCM scm_debug_object_p SCM_P ((SCM obj));
+extern SCM scm_local_eval SCM_P ((SCM exp, SCM env));
+extern SCM scm_procedure_environment SCM_P ((SCM proc));
+extern SCM scm_procedure_source SCM_P ((SCM proc));
+extern SCM scm_procedure_name SCM_P ((SCM proc));
+extern SCM scm_memoized_environment SCM_P ((SCM m));
+extern SCM scm_make_memoized SCM_P ((SCM exp, SCM env));
+extern SCM scm_memoized_p SCM_P ((SCM obj));
+extern SCM scm_single_step SCM_P ((SCM cont, SCM val));
+extern SCM scm_evaluator_traps SCM_P ((SCM setting));
+extern SCM scm_debug_options SCM_P ((SCM setting));
+extern SCM scm_unmemoize SCM_P ((SCM memoized));
+extern SCM scm_make_debugobj SCM_P ((scm_debug_frame* debug));
+extern void scm_init_debug SCM_P ((void));
+
+#endif /* DEBUGH */
diff --git a/libguile/dynl-dl.c b/libguile/dynl-dl.c
new file mode 100644
index 000000000..f72821bc6
--- /dev/null
+++ b/libguile/dynl-dl.c
@@ -0,0 +1,103 @@
+/* dynl-dl.c - dynamic linking for dlopen/dlsym
+ *
+ * Copyright (C) 1990-1997 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "dynl.c" dynamically link&load object files.
+ Author: Aubrey Jaffer
+ Modified for libguile by Marius Vollmer */
+
+#include <dlfcn.h>
+
+#ifdef RTLD_LAZY /* Solaris 2. */
+# define DLOPEN_MODE RTLD_LAZY
+#else
+# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
+#endif
+
+static void *
+sysdep_dynl_link (fname, subr)
+ char *fname;
+ char *subr;
+{
+ void *handle = dlopen (fname, DLOPEN_MODE);
+ if (NULL == handle)
+ scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
+ return handle;
+}
+
+static void
+sysdep_dynl_unlink (handle, subr)
+ void *handle;
+ char *subr;
+{
+ int status;
+
+ SCM_DEFER_INTS;
+ status = dlclose (handle);
+ SCM_ALLOW_INTS;
+ if(status)
+ scm_misc_error (subr, (char *)dlerror (), SCM_EOL);
+}
+
+static void *
+sysdep_dynl_func (symb, handle, subr)
+ char *symb;
+ void *handle;
+ char *subr;
+{
+ void *fptr;
+ char *err;
+
+ SCM_DEFER_INTS;
+ fptr = dlsym (handle, symb);
+ err = (char *)dlerror ();
+ SCM_ALLOW_INTS;
+
+ if (!fptr)
+ scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL);
+ return fptr;
+}
+
+static void
+sysdep_dynl_init ()
+{
+}
diff --git a/libguile/dynl-dld.c b/libguile/dynl-dld.c
new file mode 100644
index 000000000..64fda4d3f
--- /dev/null
+++ b/libguile/dynl-dld.c
@@ -0,0 +1,128 @@
+/* dynl-dld.c - dynamic linking with dld
+ *
+ * Copyright (C) 1990-1997 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "dynl.c" dynamically link&load object files.
+ Author: Aubrey Jaffer
+ Modified for libguile by Marius Vollmer */
+
+#include "dld.h"
+
+static void listundef SCM_P ((void));
+
+static void
+listundefs ()
+{
+ int i;
+ char **undefs = dld_list_undefined_sym();
+ puts(" undefs:");
+ for(i = dld_undefined_sym_count;i--;) {
+ putc('"', stdout);
+ fputs(undefs[i], stdout);
+ puts("\"");
+ }
+ free(undefs);
+}
+
+static void *
+sysdep_dynl_link (fname, subr)
+ char *fname;
+ char *subr;
+{
+ int status;
+
+ status = dld_link (fname);
+ if (status)
+ scm_misc_error (subr, dld_strerror (status), SCM_EOL);
+ return fname;
+}
+
+static void
+sysdep_dynl_unlink (handle, subr)
+ void *handle;
+ char *subr;
+{
+ int status;
+
+ SCM_DEFER_INTS;
+ status = dld_unlink_by_file ((char *)fname, 1);
+ SCM_ALLOW_INTS;
+ if (status)
+ scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL);
+}
+
+static void *
+sysdep_dynl_func (symb, handle, subr)
+ char *symb;
+ void *handle;
+ char *subr;
+{
+ void *func;
+
+ SCM_DEFER_INTS;
+ func = (void *) dld_get_func (func);
+ if (func == 0)
+ scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL);
+ if (!dld_function_executable_p (func)) {
+ listundefs ();
+ scm_misc_error (subr, "unresolved symbols remain", SCM_EOL);
+ }
+ SCM_ALLOW_INTS;
+ return func;
+}
+
+static void
+sysdep_dynl_init ()
+{
+#ifndef RTL
+ if (!execpath)
+ execpath = dld_find_executable (SCM_CHARS (SCM_CAR (progargs)));
+ if (dld_init (SCM_CHARS (SCM_CAR (progargs)))) {
+ dld_perror("DLD");
+ return;
+ }
+#endif
+
+#ifdef DLD_DYNCM /* XXX - what's this? */
+ add_feature("dld:dyncm");
+#endif
+}
diff --git a/libguile/dynl-shl.c b/libguile/dynl-shl.c
new file mode 100644
index 000000000..834d2726d
--- /dev/null
+++ b/libguile/dynl-shl.c
@@ -0,0 +1,98 @@
+/* dynl-shl.c - dynamic linking with shl_load (HP-UX)
+ *
+ * Copyright (C) 1990-1997 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "dynl.c" dynamically link&load object files.
+ Author: Aubrey Jaffer
+ Modified for libguile by Marius Vollmer */
+
+#include "dl.h"
+
+static void *
+sysdep_dynl_link (fname, subr)
+ char *fname;
+ char *subr;
+{
+ shl_t shl;
+
+ shl = shl_load (fname, BIND_DEFERRED , 0L);
+ if (NULL==shl)
+ scm_misc_error (subr, "dynamic linking failed", SCM_EOL);
+ return shl;
+}
+
+static void
+sysdep_dynl_unlink (handle, subr)
+ void *handle;
+ char *subr;
+{
+ int status;
+
+ SCM_DEFER_INTS;
+ status = shl_unload ((shl_t) handle);
+ SCM_ALLOW_INTS;
+ if (status)
+ scm_misc_error (subr, "dynamic unlinking failed", SCM_EOL);
+}
+
+static void *
+sysdep_dynl_func (symb, handle, subr)
+ char *symb;
+ void *handle;
+ char *subr;
+{
+ void (*func)() = NULL;
+ int status;
+
+ SCM_DEFER_INTS;
+ status = shl_findsym ((shl_t) handle, symb, TYPE_PROCEDURE, &func);
+ SCM_ALLOW_INTS;
+ if (status)
+ scm_misc_error (s_dynamic_call, "undefined function",
+ scm_cons (scm_makfrom0str (symb), SCM_EOL));
+ return func;
+}
+
+static void
+sysdep_dynl_init ()
+{
+}
diff --git a/libguile/dynl-vms.c b/libguile/dynl-vms.c
new file mode 100644
index 000000000..322839cbc
--- /dev/null
+++ b/libguile/dynl-vms.c
@@ -0,0 +1,106 @@
+/* dynl-vms.c - dynamic linking for VMS, not yet ported
+ *
+ * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "dynl.c" dynamically link&load object files.
+ Author: Aubrey Jaffer
+ (Not yet) modified for libguile by Marius Vollmer */
+
+/* We should try to implement dynamic-link/dynamic-call for VMS,
+ too. */
+
+#include "_scm.h"
+
+/* This permits dynamic linking. For example, the procedure of 0 arguments
+ from a file could be the initialization procedure.
+ (vms:dynamic-link-call "MYDISK:[MYDIR].EXE" "foo" "INIT_FOO")
+ The first argument specifies the directory where the file specified
+ by the second argument resides. The current directory would be
+ "SYS$DISK:[].EXE".
+ The second argument cannot contain any punctuation.
+ The third argument probably needs to be uppercased to mimic the VMS linker.
+ */
+
+# include <descrip.h>
+# include <ssdef.h>
+# include <rmsdef.h>
+
+struct dsc$descriptor *descriptorize(x, buff)
+ struct dsc$descriptor *x;
+ SCM buff;
+{(*x).dsc$w_length = LENGTH(buff);
+ (*x).dsc$a_pointer = CHARS(buff);
+ (*x).dsc$b_class = DSC$K_CLASS_S;
+ (*x).dsc$b_dtype = DSC$K_DTYPE_T;
+ return(x);}
+
+static char s_dynl[] = "vms:dynamic-link-call";
+SCM dynl(dir, symbol, fname)
+ SCM 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);
+ descriptorize(&fnamed, fname);
+ descriptorize(&symbold, symbol);
+ DEFER_INTS;
+ retval = lib$find_image_symbol(&fnamed, &symbold, &fcn,
+ IMP(dir) ? 0 : descriptorize(&dird, dir));
+ if (SS$_NORMAL != retval) {
+ /* wta(MAKINUM(retval), "vms error", s_dynl); */
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ ALLOW_INTS;
+/* *loc_loadpath = dir; */
+ (*fcn)();
+/* *loc_loadpath = oloadpath; */
+ return BOOL_T;
+}
+
+void init_dynl()
+{
+ make_subr(s_dynl, tc7_subr_3, dynl);
+}
diff --git a/libguile/dynl.c b/libguile/dynl.c
new file mode 100644
index 000000000..9bca8c446
--- /dev/null
+++ b/libguile/dynl.c
@@ -0,0 +1,441 @@
+/* dynl.c - dynamic linking
+ *
+ * Copyright (C) 1990-1997 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "dynl.c" dynamically link&load object files.
+ Author: Aubrey Jaffer
+ Modified for libguile by Marius Vollmer */
+
+/* XXX - This is only here to drag in a definition of __eprintf. This
+ is needed for proper operation of dynamic linking. The real
+ solution would probably be a shared libgcc. */
+
+#undef NDEBUG
+#include <assert.h>
+
+static void
+maybe_drag_in_eprintf ()
+{
+ assert (!maybe_drag_in_eprintf);
+}
+
+#include <stdio.h>
+
+#include "_scm.h"
+#include "dynl.h"
+#include "genio.h"
+#include "smob.h"
+
+/* Converting a list of SCM strings into a argv-style array. You must
+ have ints disabled for the whole lifetime of the created argv (from
+ before MAKE_ARGV_FROM_STRINGLIST until after
+ MUST_FREE_ARGV). Atleast this is was the documentation for
+ MAKARGVFROMSTRS says, it isn't really used that way.
+
+ This code probably belongs into strings.c */
+
+static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp,
+ char *subr, int argn));
+
+static char **
+scm_make_argv_from_stringlist (args, argcp, subr, argn)
+ SCM args;
+ int *argcp;
+ char *subr;
+ int argn;
+{
+ char **argv;
+ int argc, i;
+
+ argc = scm_ilength(args);
+ argv = (char **) scm_must_malloc ((1L+argc)*sizeof(char *), subr);
+ for(i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) {
+ size_t len;
+ char *dst, *src;
+ SCM str = SCM_CAR (args);
+
+ SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, argn, subr);
+ len = 1 + SCM_ROLENGTH (str);
+ dst = (char *) scm_must_malloc ((long)len, subr);
+ src = SCM_ROCHARS (str);
+ while (len--)
+ dst[len] = src[len];
+ argv[i] = dst;
+ }
+
+ if (argcp)
+ *argcp = argc;
+ argv[argc] = 0;
+ return argv;
+}
+
+static void scm_must_free_argv SCM_P ((char **argv));
+
+static void
+scm_must_free_argv(argv)
+ char **argv;
+{
+ char **av = argv;
+ while(!(*av))
+ free(*(av++));
+ free(argv);
+}
+
+/* Coerce an arbitrary readonly-string into a zero-terminated string.
+ */
+
+static SCM scm_coerce_rostring SCM_P ((SCM rostr, char *subr, int argn));
+
+static SCM
+scm_coerce_rostring (rostr, subr, argn)
+ SCM rostr;
+ char *subr;
+ int argn;
+{
+ SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr);
+ if (SCM_SUBSTRP (rostr))
+ rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0);
+ return rostr;
+}
+
+/* Module registry
+ */
+
+/* We can't use SCM objects here. One should be able to call
+ SCM_REGISTER_MODULE from a C++ constructor for a static
+ object. This happens before main and thus before libguile is
+ initialized. */
+
+struct moddata {
+ struct moddata *link;
+ char *module_name;
+ void *init_func;
+};
+
+static struct moddata *registered_mods = NULL;
+
+void
+scm_register_module_xxx (module_name, init_func)
+ char *module_name;
+ void *init_func;
+{
+ struct moddata *md;
+
+ /* XXX - should we (and can we) DEFER_INTS here? */
+
+ for (md = registered_mods; md; md = md->link)
+ if (!strcmp (md->module_name, module_name)) {
+ md->init_func = init_func;
+ return;
+ }
+
+ md = (struct moddata *)malloc (sizeof (struct moddata));
+ if (md == NULL) {
+ fprintf (stderr,
+ "guile: can't register module (%s): not enough memory",
+ module_name);
+ return;
+ }
+
+ md->module_name = module_name;
+ md->init_func = init_func;
+ md->link = registered_mods;
+ registered_mods = md;
+}
+
+SCM_PROC (s_registered_modules, "c-registered-modules", 0, 0, 0, scm_registered_modules);
+
+SCM
+scm_registered_modules ()
+{
+ SCM res;
+ struct moddata *md;
+
+ res = SCM_EOL;
+ for (md = registered_mods; md; md = md->link)
+ res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
+ scm_ulong2num ((unsigned long) md->init_func)),
+ res);
+ return res;
+}
+
+SCM_PROC (s_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, scm_clear_registered_modules);
+
+SCM
+scm_clear_registered_modules ()
+{
+ struct moddata *md1, *md2;
+
+ SCM_DEFER_INTS;
+
+ for (md1 = registered_mods; md1; md1 = md2) {
+ md2 = md1->link;
+ free (md1);
+ }
+ registered_mods = NULL;
+
+ SCM_ALLOW_INTS;
+ return SCM_UNSPECIFIED;
+}
+
+/* Dispatch to the system dependent files
+ *
+ * They define these static functions:
+ */
+
+static void sysdep_dynl_init SCM_P ((void));
+static void *sysdep_dynl_link SCM_P ((char *filename, char *subr));
+static void sysdep_dynl_unlink SCM_P ((void *handle, char *subr));
+static void *sysdep_dynl_func SCM_P ((char *symbol, void *handle, char *subr));
+
+#ifdef HAVE_LIBDL
+#include "dynl-dl.c"
+#else
+#ifdef HAVE_SHL_LOAD
+#include "dynl-shl.c"
+#else
+#ifdef HAVE_DLD
+#include "dynl-dld.c"
+#else
+
+/* no dynamic linking available, throw errors. */
+
+static void
+sysdep_dynl_init ()
+{
+}
+
+static void
+no_dynl_error (subr)
+ char *subr;
+{
+ scm_misc_error (subr, "dynamic linking not available", SCM_EOL);
+}
+
+static void *
+sysdep_dynl_link (filename, subr)
+ char *filename;
+ char *subr;
+{
+ no_dynl_error (subr);
+ return NULL;
+}
+
+static void
+sysdep_dynl_unlink (handle, subr)
+ void *handle;
+ char *subr;
+{
+ no_dynl_error (subr);
+}
+
+static void *
+sysdep_dynl_func (symbol, handle, subr)
+ char *symbol;
+ void *handle;
+ char *subr;
+{
+ no_dynl_error (subr);
+ return NULL;
+}
+
+#endif
+#endif
+#endif
+
+int scm_tc16_dynamic_obj;
+
+struct dynl_obj {
+ SCM filename;
+ void *handle;
+};
+
+static SCM mark_dynl_obj SCM_P ((SCM ptr));
+static SCM
+mark_dynl_obj (ptr)
+ SCM ptr;
+{
+ struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (ptr);
+ SCM_SETGC8MARK (ptr);
+ return d->filename;
+}
+
+static int print_dynl_obj SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+static int
+print_dynl_obj (exp, port, pstate)
+ SCM exp;
+ SCM port;
+ scm_print_state *pstate;
+{
+ struct dynl_obj *d = (struct dynl_obj *)SCM_CDR (exp);
+ scm_gen_puts (scm_regular_string, "#<dynamic-object ", port);
+ scm_iprin1 (d->filename, port, pstate);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns dynl_obj_smob = {
+ mark_dynl_obj,
+ scm_free0,
+ print_dynl_obj
+};
+
+SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
+
+SCM
+scm_dynamic_link (fname)
+ SCM fname;
+{
+ SCM z;
+ struct dynl_obj *d;
+
+ fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
+ d = (struct dynl_obj *)scm_must_malloc (sizeof (struct dynl_obj),
+ s_dynamic_link);
+ d->filename = fname;
+
+ SCM_DEFER_INTS;
+ d->handle = sysdep_dynl_link (SCM_CHARS (fname), s_dynamic_link);
+ SCM_NEWCELL (z);
+ SCM_SETCHARS (z, d);
+ SCM_SETCAR (z, scm_tc16_dynamic_obj);
+ SCM_ALLOW_INTS;
+
+ return z;
+}
+
+static struct dynl_obj *get_dynl_obj SCM_P ((SCM obj, char *subr, int argn));
+static struct dynl_obj *
+get_dynl_obj (dobj, subr, argn)
+ SCM dobj;
+ char *subr;
+ int argn;
+{
+ struct dynl_obj *d;
+ SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
+ dobj, argn, subr);
+ d = (struct dynl_obj *)SCM_CDR (dobj);
+ SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
+ return d;
+}
+
+SCM_PROC (s_dynamic_object_p, "dynamic-object?", 1, 0, 0, scm_dynamic_object_p);
+
+SCM
+scm_dynamic_object_p (SCM obj)
+{
+ return (SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj)?
+ SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
+
+SCM
+scm_dynamic_unlink (dobj)
+ SCM dobj;
+{
+ struct dynl_obj *d = get_dynl_obj (dobj, s_dynamic_unlink, SCM_ARG1);
+ sysdep_dynl_unlink (d->handle, s_dynamic_unlink);
+ d->handle = NULL;
+ return SCM_BOOL_T;
+}
+
+SCM_PROC (s_dynamic_func, "dynamic-func", 2, 0, 0, scm_dynamic_func);
+
+SCM
+scm_dynamic_func (SCM symb, SCM dobj)
+{
+ struct dynl_obj *d;
+ void (*func) ();
+
+ symb = scm_coerce_rostring (symb, s_dynamic_func, SCM_ARG1);
+ d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
+
+ func = sysdep_dynl_func (SCM_CHARS (symb), d->handle, s_dynamic_func);
+ return scm_ulong2num ((unsigned long)func);
+}
+
+SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
+
+SCM
+scm_dynamic_call (SCM func, SCM dobj)
+{
+ void (*fptr)();
+
+ if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
+ func = scm_dynamic_func (func, dobj);
+ fptr = (void (*)()) scm_num2ulong (func, (char *)SCM_ARG1, s_dynamic_call);
+ fptr ();
+ return SCM_BOOL_T;
+}
+
+SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
+
+SCM
+scm_dynamic_args_call (func, dobj, args)
+ SCM func, dobj, args;
+{
+ int (*fptr) (int argc, char **argv);
+ int result, argc;
+ char **argv;
+
+ if (SCM_NIMP (func) && SCM_ROSTRINGP (func))
+ func = scm_dynamic_func (func, dobj);
+
+ fptr = (int (*)(int, char **)) scm_num2ulong (func, (char *)SCM_ARG1,
+ s_dynamic_args_call);
+ argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
+ SCM_ARG3);
+
+ result = (*fptr) (argc, argv);
+
+ scm_must_free_argv (argv);
+ return SCM_MAKINUM(0L+result);
+}
+
+void
+scm_init_dynamic_linking ()
+{
+ scm_tc16_dynamic_obj = scm_newsmob (&dynl_obj_smob);
+ sysdep_dynl_init ();
+#include "dynl.x"
+}
diff --git a/libguile/dynl.h b/libguile/dynl.h
new file mode 100644
index 000000000..c61805752
--- /dev/null
+++ b/libguile/dynl.h
@@ -0,0 +1,63 @@
+/* Copyright (C) 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#ifndef LIBGUILE_DYNL_H
+#define LIBGUILE_DYNL_H
+
+#include "libguile/__scm.h"
+
+
+
+void scm_register_module_xxx SCM_P ((char *module_name, void *init_func));
+SCM scm_registered_modules SCM_P (());
+SCM scm_clear_registered_modules SCM_P (());
+
+SCM scm_dynamic_link SCM_P ((SCM fname));
+SCM scm_dynamic_unlink SCM_P ((SCM dobj));
+SCM scm_dynamic_object_p SCM_P ((SCM obj));
+SCM scm_dynamic_func SCM_P ((SCM symb, SCM dobj));
+SCM scm_dynamic_call SCM_P ((SCM symb, SCM dobj));
+SCM scm_dynamic_args_call SCM_P ((SCM symb, SCM dobj, SCM args));
+
+void scm_init_dynamic_linking SCM_P ((void));
+
+#endif /* LIBGUILE_DYNL_H */
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index b80a00c76..4a9424b0f 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -42,7 +42,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "eval.h"
+#include "alist.h"
+#include "dynwind.h"
/* {Dynamic wind}
@@ -51,16 +54,12 @@
SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind);
-#ifdef __STDC__
-SCM
-scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3)
-#else
+
SCM
scm_dynamic_wind (thunk1, thunk2, thunk3)
SCM thunk1;
SCM thunk2;
SCM thunk3;
-#endif
{
SCM ans;
scm_apply (thunk1, SCM_EOL, SCM_EOL);
@@ -71,15 +70,11 @@ scm_dynamic_wind (thunk1, thunk2, thunk3)
return ans;
}
-#ifdef __STDC__
-void
-scm_dowinds (SCM to, long delta)
-#else
+
void
scm_dowinds (to, delta)
SCM to;
long delta;
-#endif
{
tail:
if (scm_dynwinds == to);
@@ -135,13 +130,9 @@ scm_dowinds (to, delta)
}
-#ifdef __STDC__
-void
-scm_init_dynwind (void)
-#else
+
void
scm_init_dynwind ()
-#endif
{
#include "dynwind.x"
}
diff --git a/libguile/dynwind.h b/libguile/dynwind.h
index 42f1515d2..7352751c0 100644
--- a/libguile/dynwind.h
+++ b/libguile/dynwind.h
@@ -43,24 +43,12 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3);
-extern void scm_dowinds (SCM to, long delta);
-extern void scm_init_dynwind (void);
-
-#else /* STDC */
-extern SCM scm_dynamic_wind ();
-extern void scm_dowinds ();
-extern void scm_init_dynwind ();
-
-#endif /* STDC */
-
-
-
-
+extern SCM scm_dynamic_wind SCM_P ((SCM thunk1, SCM thunk2, SCM thunk3));
+extern void scm_dowinds SCM_P ((SCM to, long delta));
+extern void scm_init_dynwind SCM_P ((void));
#endif /* DYNWINDH */
diff --git a/libguile/eq.c b/libguile/eq.c
index ed6dc4e12..5bc88fe75 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -41,18 +41,20 @@
#include <stdio.h>
#include "_scm.h"
+#include "ramap.h"
+#include "stackchk.h"
+#include "strorder.h"
+#include "smob.h"
+#include "unif.h"
+#include "eq.h"
SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p);
-#ifdef __STDC__
-SCM
-scm_eq_p (SCM x, SCM y)
-#else
+
SCM
scm_eq_p (x, y)
SCM x;
SCM y;
-#endif
{
return ((x==y)
? SCM_BOOL_T
@@ -61,15 +63,11 @@ scm_eq_p (x, y)
SCM_PROC1 (s_eqv_p, "eqv?", scm_tc7_rpsubr, scm_eqv_p);
-#ifdef __STDC__
-SCM
-scm_eqv_p (SCM x, SCM y)
-#else
+
SCM
scm_eqv_p (x, y)
SCM x;
SCM y;
-#endif
{
if (x==y) return SCM_BOOL_T;
if SCM_IMP(x) return SCM_BOOL_F;
@@ -91,15 +89,11 @@ scm_eqv_p (x, y)
SCM_PROC1 (s_equal_p, "equal?", scm_tc7_rpsubr, scm_equal_p);
-#ifdef __STDC__
-SCM
-scm_equal_p (SCM x, SCM y)
-#else
+
SCM
scm_equal_p (x, y)
SCM x;
SCM y;
-#endif
{
SCM_CHECK_STACK;
tailrecurse: SCM_ASYNC_TICK;
@@ -149,13 +143,9 @@ scm_equal_p (x, y)
-#ifdef __STDC__
-void
-scm_init_eq (void)
-#else
+
void
scm_init_eq ()
-#endif
{
#include "eq.x"
}
diff --git a/libguile/eq.h b/libguile/eq.h
index db164ec0d..c9deb5007 100644
--- a/libguile/eq.h
+++ b/libguile/eq.h
@@ -43,21 +43,13 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_eq_p (SCM x, SCM y);
-extern SCM scm_eqv_p (SCM x, SCM y);
-extern SCM scm_equal_p (SCM x, SCM y);
-extern void scm_init_eq (void);
-
-#else /* STDC */
-extern SCM scm_eq_p ();
-extern SCM scm_eqv_p ();
-extern SCM scm_equal_p ();
-extern void scm_init_eq ();
-#endif /* STDC */
+extern SCM scm_eq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_eqv_p SCM_P ((SCM x, SCM y));
+extern SCM scm_equal_p SCM_P ((SCM x, SCM y));
+extern void scm_init_eq SCM_P ((void));
#endif /* EQH */
diff --git a/libguile/error.c b/libguile/error.c
index c16612513..910ad5c19 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -42,164 +42,252 @@
#include <stdio.h>
#include "_scm.h"
+#include "pairs.h"
+#include "genio.h"
+#include "throw.h"
+#include "error.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
/* {Errors and Exceptional Conditions}
*/
-SCM system_error_sym;
-/* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
- * when the interpreter is not running at all.
- */
-int scm_ints_disabled = 1;
+extern int errno;
+void (*scm_error_callback) () = 0;
-extern int errno;
-#ifdef __STDC__
-static void
-err_head (char *str)
-#else
-static void
-err_head (str)
- char *str;
-#endif
+/* All errors should pass through here. */
+void
+scm_error (key, subr, message, args, rest)
+ SCM key;
+ char *subr;
+ char *message;
+ SCM args;
+ SCM rest;
{
- int oerrno = errno;
- if (SCM_NIMP (scm_cur_outp))
- scm_fflush (scm_cur_outp);
- scm_gen_putc ('\n', scm_cur_errp);
-#if 0
- if (SCM_BOOL_F != *scm_loc_loadpath)
- {
- scm_iprin1 (*scm_loc_loadpath, scm_cur_errp, 1);
- scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp);
- scm_intprint ((long) scm_linum, 10, scm_cur_errp);
- scm_gen_puts (scm_regular_string, ": ", scm_cur_errp);
- }
-#endif
- scm_fflush (scm_cur_errp);
- errno = oerrno;
- if (scm_cur_errp == scm_def_errp)
- {
- if (errno > 0)
- perror (str);
- fflush (stderr);
- return;
- }
+ SCM arg_list;
+ if (scm_error_callback)
+ (*scm_error_callback) (key, subr, message, args, rest);
+
+ arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
+ message ? scm_makfrom0str (message) : SCM_BOOL_F,
+ args,
+ rest,
+ SCM_UNDEFINED);
+ scm_ithrow (key, arg_list, 1);
+
+ /* No return, but just in case: */
+
+ write (2, "unhandled system error", sizeof ("unhandled system error") - 1);
+ exit (1);
}
+/* Scheme interface to scm_error. */
+SCM_PROC(s_error_scm, "scm-error", 5, 0, 0, scm_error_scm);
+SCM
+scm_error_scm (key, subr, message, args, rest)
+ SCM key;
+ SCM subr;
+ SCM message;
+ SCM args;
+ SCM rest;
+{
+ SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_error_scm);
+ SCM_ASSERT (SCM_FALSEP (subr) || (SCM_NIMP (subr) && SCM_ROSTRINGP (subr)),
+ subr, SCM_ARG2, s_error_scm);
+ SCM_ASSERT (SCM_FALSEP (message)
+ || (SCM_NIMP (message) && SCM_ROSTRINGP (message)),
+ message, SCM_ARG3, s_error_scm);
-SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno);
-#ifdef __STDC__
-SCM
-scm_errno (SCM arg)
-#else
-SCM
-scm_errno (arg)
- SCM arg;
-#endif
+ scm_error (key,
+ (SCM_FALSEP (subr)) ? NULL : SCM_ROCHARS (subr),
+ (SCM_FALSEP (message)) ? NULL : SCM_ROCHARS (message),
+ args,
+ rest);
+ /* not reached. */
+}
+
+SCM_SYMBOL (scm_system_error_key, "system-error");
+void
+scm_syserror (subr)
+ char *subr;
{
- int old = errno;
- if (!SCM_UNBNDP (arg))
- {
- if (SCM_FALSEP (arg))
- errno = 0;
- else
- errno = SCM_INUM (arg);
- }
- return SCM_MAKINUM (old);
+ scm_error (scm_system_error_key,
+ subr,
+ "%s",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ SCM_UNDEFINED),
+ scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
+}
+
+void
+scm_syserror_msg (subr, message, args, eno)
+ char *subr;
+ char *message;
+ SCM args;
+ int eno;
+{
+ scm_error (scm_system_error_key,
+ subr,
+ message,
+ args,
+ scm_listify (SCM_MAKINUM (eno), SCM_UNDEFINED));
}
-SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror);
-#ifdef __STDC__
-SCM
-scm_perror (SCM arg)
+void
+scm_sysmissing (subr)
+ char *subr;
+{
+#ifdef ENOSYS
+ scm_error (scm_system_error_key,
+ subr,
+ "%s",
+ scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
+ scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
#else
-SCM
-scm_perror (arg)
- SCM arg;
+ scm_error (scm_system_error_key,
+ subr,
+ "Missing function",
+ SCM_BOOL_F,
+ scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED));
#endif
+}
+
+SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow");
+void
+scm_num_overflow (subr)
+ char *subr;
{
- SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror);
- err_head (SCM_CHARS (arg));
- return SCM_UNSPECIFIED;
+ scm_error (scm_num_overflow_key,
+ subr,
+ "Numerical overflow",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
}
+SCM_SYMBOL (scm_out_of_range_key, "out-of-range");
+void
+scm_out_of_range (subr, bad_value)
+ char *subr;
+ SCM bad_value;
+{
+ scm_error (scm_out_of_range_key,
+ subr,
+ "Argument out of range: %S",
+ scm_listify (bad_value, SCM_UNDEFINED),
+ SCM_BOOL_F);
+}
-#ifdef __STDC__
-void
-scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr)
-#else
-void
-scm_everr (exp, env, arg, pos, s_subr)
- SCM exp;
- SCM env;
- SCM arg;
- char *pos;
- char *s_subr;
-#endif
+SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args");
+void
+scm_wrong_num_args (proc)
+ SCM proc;
{
- SCM desc;
- SCM args;
-
- if ((~0x1fL) & (long) pos)
- desc = scm_makfrom0str (pos);
- else
- desc = SCM_MAKINUM ((long)pos);
-
- {
- SCM sym;
- if (!s_subr || !*s_subr)
- sym = SCM_BOOL_F;
- else
- sym = SCM_CAR (scm_intern0 (s_subr));
- args = scm_listify (desc, sym, arg, SCM_UNDEFINED);
- }
-
- /* (throw (quote %%system-error) <desc> <proc-name> arg)
- *
- * <desc> is a string or an integer (see %%system-errors).
- * <proc-name> is a symbol or #f in some annoying cases (e.g. cddr).
- */
-
- scm_ithrow (system_error_sym, args, 1);
-
- /* No return, but just in case: */
+ scm_error (scm_args_number_key,
+ NULL,
+ "Wrong number of arguments to %s",
+ scm_listify (proc, SCM_UNDEFINED),
+ SCM_BOOL_F);
+}
- write (2, "unhandled system error", sizeof ("unhandled system error"));
- exit (1);
+SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg");
+void
+scm_wrong_type_arg (subr, pos, bad_value)
+ char *subr;
+ int pos;
+ SCM bad_value;
+{
+ scm_error (scm_arg_type_key,
+ subr,
+ (pos == 0) ? "Wrong type argument: %S"
+ : "Wrong type argument in position %s: %S",
+ (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
+ : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
+ SCM_BOOL_F);
}
-#ifdef __STDC__
-SCM
-scm_wta (SCM arg, char *pos, char *s_subr)
-#else
+SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
+void
+scm_memory_error (subr)
+ char *subr;
+{
+ scm_error (scm_memory_alloc_key,
+ subr,
+ "Memory allocation error",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+}
+
+SCM_SYMBOL (scm_misc_error_key, "misc-error");
+void
+scm_misc_error (subr, message, args)
+ char *subr;
+ char *message;
+ SCM args;
+{
+ scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
+}
+
+/* implements the SCM_ASSERT interface. */
SCM
scm_wta (arg, pos, s_subr)
SCM arg;
char *pos;
char *s_subr;
-#endif
{
- scm_everr (SCM_UNDEFINED, SCM_EOL, arg, pos, s_subr);
+ if (!s_subr || !*s_subr)
+ s_subr = NULL;
+ if ((~0x1fL) & (long) pos)
+ {
+ /* error string supplied. */
+ scm_misc_error (s_subr, pos, SCM_BOOL_F);
+ }
+ else
+ {
+ /* numerical error code. */
+ int error = (long) pos;
+
+ switch (error)
+ {
+ case SCM_ARGn:
+ scm_wrong_type_arg (s_subr, 0, arg);
+ case SCM_ARG1:
+ scm_wrong_type_arg (s_subr, 1, arg);
+ case SCM_ARG2:
+ scm_wrong_type_arg (s_subr, 2, arg);
+ case SCM_ARG3:
+ scm_wrong_type_arg (s_subr, 3, arg);
+ case SCM_ARG4:
+ scm_wrong_type_arg (s_subr, 4, arg);
+ case SCM_ARG5:
+ scm_wrong_type_arg (s_subr, 5, arg);
+ case SCM_WNA:
+ scm_wrong_num_args (arg);
+ case SCM_OUTOFRANGE:
+ scm_out_of_range (s_subr, arg);
+ case SCM_NALLOC:
+ scm_memory_error (s_subr);
+ default:
+ /* this shouldn't happen. */
+ scm_misc_error (s_subr, "Unknown error", SCM_BOOL_F);
+ }
+ }
return SCM_UNSPECIFIED;
}
+/* obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
+ was equivalent to scm_wta (arg, pos, s_subr) */
-
-#ifdef __STDC__
-void
-scm_init_error (void)
-#else
void
scm_init_error ()
-#endif
{
- system_error_sym = SCM_CAR (scm_intern0 ("%%system-error"));
- scm_permanent_object (system_error_sym);
+#include "cpp_err_symbols.c"
#include "error.x"
}
diff --git a/libguile/error.h b/libguile/error.h
index c635c5d13..7327f27d6 100644
--- a/libguile/error.h
+++ b/libguile/error.h
@@ -2,7 +2,7 @@
#ifndef ERRORH
#define ERRORH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -43,37 +43,41 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
-#include "pairs.h"
+#include "libguile/__scm.h"
-
extern int scm_ints_disabled;
-extern SCM system_error_sym;
+/* GCC can be told that a function doesn't return; this helps it do
+ better error checking (for uninitialized variable use, for
+ example), and some optimization. */
+#ifdef __GNUC__
+#define SCM_NORETURN __attribute__ ((noreturn))
+#else
+#define SCM_NORETURN
+#endif
-#ifdef __STDC__
-extern int scm_handle_it (int i);
-extern void scm_warn (char *str1, char *str2);
-extern SCM scm_errno (SCM arg);
-extern SCM scm_perror (SCM arg);
-extern void scm_def_err_response (void);
-extern void scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr);
-extern SCM scm_wta (SCM arg, char *pos, char *s_subr);
-extern void scm_init_error (void);
-
-#else /* STDC */
-extern int scm_handle_it ();
-extern void scm_warn ();
-extern SCM scm_errno ();
-extern SCM scm_perror ();
-extern void scm_def_err_response ();
-extern void scm_everr ();
-extern SCM scm_wta ();
-extern void scm_init_error ();
-
-#endif /* STDC */
+extern void scm_error SCM_P ((SCM key, char *subr, char *message,
+ SCM args, SCM rest)) SCM_NORETURN;
+extern void (*scm_error_callback) SCM_P ((SCM key, char *subr,
+ char *message, SCM args, SCM rest));
+extern SCM scm_error_scm SCM_P ((SCM key, SCM subr, SCM message,
+ SCM args, SCM rest)) SCM_NORETURN;
+extern void scm_syserror SCM_P ((char *subr)) SCM_NORETURN;
+extern void scm_syserror_msg SCM_P ((char *subr, char *message, SCM args,
+ int eno)) SCM_NORETURN;
+extern void scm_sysmissing SCM_P ((char *subr)) SCM_NORETURN;
+extern void scm_num_overflow SCM_P ((char *subr)) SCM_NORETURN;
+extern void scm_out_of_range SCM_P ((char *subr, SCM bad_value)) SCM_NORETURN;
+extern void scm_wrong_num_args SCM_P ((SCM proc)) SCM_NORETURN;
+extern void scm_wrong_type_arg SCM_P ((char *subr, int pos, SCM bad_value))
+ SCM_NORETURN;
+extern void scm_memory_error SCM_P ((char *subr)) SCM_NORETURN;
+extern void scm_misc_error SCM_P ((char *subr, char *message, SCM args))
+ SCM_NORETURN;
+extern SCM scm_wta SCM_P ((SCM arg, char *pos, char *s_subr));
+extern void scm_init_error SCM_P ((void));
#endif /* ERRORH */
diff --git a/libguile/eval.c b/libguile/eval.c
index 7b2f3600e..b8c8e1b1f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -40,36 +40,116 @@
*/
-/* This file is read twice in order to produce a second debugging
- * version of scm_ceval called scm_deval. scm_deval is produced when
- * we define the preprocessor macro DEVAL.
+/* This file is read twice in order to produce debugging versions of
+ * scm_ceval and scm_apply. These functions, scm_deval and
+ * scm_dapply, are produced when we define the preprocessor macro
+ * DEVAL. The file is divided into sections which are treated
+ * differently with respect to DEVAL. The heads of these sections are
+ * marked with the string "SECTION:".
+ */
+
+
+/* SECTION: This code is compiled once.
*/
#ifndef DEVAL
+/* AIX requires this to be the first thing in the file. The #pragma
+ directive is indented so pre-ANSI compilers will ignore it, rather
+ than choke on it. */
+#ifndef __GNUC__
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# else
+# ifdef _AIX
+ #pragma alloca
+# else
+# ifndef alloca /* predefined by HP cc +Olibcalls */
+char *alloca ();
+# endif
+# endif
+# endif
+#endif
+
#include <stdio.h>
#include "_scm.h"
+#include "debug.h"
+#include "append.h"
+#include "alist.h"
+#include "sequences.h"
+#include "eq.h"
+#include "continuations.h"
+#include "throw.h"
+#include "smob.h"
+#include "markers.h"
+#include "procprop.h"
+#include "hashtab.h"
+#include "hash.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif /* DEBUG_EXTENSIONS */
+
+#include "srcprop.h"
+#include "stackchk.h"
+
+#include "eval.h"
+/* The evaluator contains a plethora of EVAL symbols.
+ * This is an attempt at explanation.
+ *
+ * The following macros should be used in code which is read twice
+ * (where the choice of evaluator is hard soldered):
+ *
+ * SCM_CEVAL is the symbol used within one evaluator to call itself.
+ * Originally, it is defined to scm_ceval, but is redefined to
+ * scm_deval during the second pass.
+ *
+ * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
+ * only side effects of expressions matter. All immediates are
+ * ignored.
+ *
+ * EVALIM is used when it is known that the expression is an
+ * immediate. (This macro never calls an evaluator.)
+ *
+ * EVALCAR evaluates the car of an expression.
+ *
+ * EVALCELLCAR is like EVALCAR, but is used when it is known that the
+ * car is a lisp cell.
+ *
+ * The following macros should be used in code which is read once
+ * (where the choice of evaluator is dynamic):
+ *
+ * XEVAL takes care of immediates without calling an evaluator. It
+ * then calls scm_ceval *or* scm_deval, depending on the debugging
+ * mode.
+ *
+ * XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
+ * depending on the debugging mode.
+ *
+ * The main motivation for keeping this plethora is efficiency
+ * together with maintainability (=> locality of code).
+ */
+
#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
? *scm_lookupcar(x, env) \
: SCM_CEVAL(SCM_CAR(x), env))
#ifdef MEMOIZE_LOCALS
-#define EVALIMP(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
+#define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
#else
-#define EVALIMP(x, env) x
+#define EVALIM(x, env) x
#endif
#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
? (SCM_IMP(SCM_CAR(x)) \
- ? EVALIMP(SCM_CAR(x), env) \
+ ? EVALIM(SCM_CAR(x), env) \
: SCM_GLOC_VAL(SCM_CAR(x))) \
: EVALCELLCAR(x, env))
#ifdef DEBUG_EXTENSIONS
#define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \
? (SCM_IMP(SCM_CAR(x)) \
- ? EVALIMP(SCM_CAR(x), env) \
+ ? EVALIM(SCM_CAR(x), env) \
: SCM_GLOC_VAL(SCM_CAR(x))) \
: (SCM_SYMBOLP(SCM_CAR(x)) \
? *scm_lookupcar(x, env) \
@@ -78,18 +158,14 @@
#define XEVALCAR(x, env) EVALCAR(x, env)
#endif
-#define EXTEND_SCM_ENV SCM_EXTEND_SCM_ENV
+#define EXTEND_ENV SCM_EXTEND_ENV
#ifdef MEMOIZE_LOCALS
-#ifdef __STDC__
-SCM *
-scm_ilookup (SCM iloc, SCM env)
-#else
+
SCM *
scm_ilookup (iloc, env)
SCM iloc;
SCM env;
-#endif
{
register int ir = SCM_IFRAME (iloc);
register SCM er = env;
@@ -99,20 +175,16 @@ scm_ilookup (iloc, env)
for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
er = SCM_CDR (er);
if (SCM_ICDRP (iloc))
- return &SCM_CDR (er);
- return &SCM_CAR (SCM_CDR (er));
+ return SCM_CDRLOC (er);
+ return SCM_CARLOC (SCM_CDR (er));
}
#endif
-#ifdef __STDC__
-SCM *
-scm_lookupcar (SCM vloc, SCM genv)
-#else
+
SCM *
scm_lookupcar (vloc, genv)
SCM vloc;
SCM genv;
-#endif
{
SCM env = genv;
register SCM *al, fl, var = SCM_CAR (vloc);
@@ -123,20 +195,20 @@ scm_lookupcar (vloc, genv)
{
if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env)))
break;
- al = &SCM_CAR (env);
+ al = SCM_CARLOC (env);
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
{
if (SCM_NCONSP (fl))
if (fl == var)
{
#ifdef MEMOIZE_LOCALS
- SCM_CAR (vloc) = iloc + SCM_ICDR;
+ SCM_SETCAR (vloc, iloc + SCM_ICDR);
#endif
- return &SCM_CDR (*al);
+ return SCM_CDRLOC (*al);
}
else
break;
- al = &SCM_CDR (*al);
+ al = SCM_CDRLOC (*al);
if (SCM_CAR (fl) == var)
{
#ifdef MEMOIZE_LOCALS
@@ -147,9 +219,9 @@ scm_lookupcar (vloc, genv)
goto errout;
}
#endif
- SCM_CAR (vloc) = iloc;
+ SCM_SETCAR (vloc, iloc);
#endif
- return &SCM_CAR (*al);
+ return SCM_CARLOC (*al);
}
#ifdef MEMOIZE_LOCALS
iloc += SCM_IDINC;
@@ -179,40 +251,40 @@ scm_lookupcar (vloc, genv)
{
var = SCM_CAR (var);
errout:
- scm_everr (vloc, genv, var,
- (SCM_NULLP (env)
- ? "unbound variable: "
- : "damaged environment"),
- "");
+ /* scm_everr (vloc, genv,...) */
+ scm_misc_error (NULL,
+ SCM_NULLP (env)
+ ? "Unbound variable: %S"
+ : "Damaged environment: %S",
+ scm_listify (var, SCM_UNDEFINED));
}
#endif
- SCM_CAR (vloc) = var + 1;
+ SCM_SETCAR (vloc, var + 1);
/* Except wait...what if the var is not a vcell,
* but syntax or something....
*/
- return &SCM_CDR (var);
+ return SCM_CDRLOC (var);
}
#define unmemocar scm_unmemocar
-#ifdef __STDC__
-SCM
-scm_unmemocar (SCM form, SCM env)
-#else
+
SCM
scm_unmemocar (form, env)
SCM form;
SCM env;
-#endif
{
+#ifdef DEBUG_EXTENSIONS
register int ir;
+#endif
SCM c;
if (SCM_IMP (form))
return form;
c = SCM_CAR (form);
if (1 == (c & 7))
- SCM_CAR (form) = SCM_CAR (c - 1);
+ SCM_SETCAR (form, SCM_CAR (c - 1));
#ifdef MEMOIZE_LOCALS
+#ifdef DEBUG_EXTENSIONS
else if (SCM_ILOCP (c))
{
for (ir = SCM_IFRAME (c); ir != 0; --ir)
@@ -220,23 +292,20 @@ scm_unmemocar (form, env)
env = SCM_CAR (SCM_CAR (env));
for (ir = SCM_IDIST (c); ir != 0; --ir)
env = SCM_CDR (env);
- SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env);
+ SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
}
#endif
+#endif
return form;
}
-#ifdef __STDC__
-SCM
-scm_eval_car (SCM pair, SCM env)
-#else
+
SCM
scm_eval_car (pair, env)
SCM pair;
SCM env;
-#endif
{
- return EVALCAR (pair, env);
+ return XEVALCAR (pair, env);
}
@@ -256,70 +325,60 @@ static char s_formals[] = "bad formals";
SCM scm_i_dot, scm_i_quote, scm_i_quasiquote, scm_i_lambda, scm_i_let,
scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply;
-SCM scm_i_name;
-#ifdef DEBUG_EXTENSIONS
-static SCM enter_frame_sym, exit_frame_sym;
-#endif
+SCM scm_i_define, scm_i_and, scm_i_begin, scm_i_case, scm_i_cond,
+ scm_i_do, scm_i_if, scm_i_let, scm_i_letrec, scm_i_letstar,
+ scm_i_or, scm_i_set, scm_i_atapply, scm_i_atcall_cc;
static char s_quasiquote[] = "quasiquote";
static char s_delay[] = "delay";
+static char s_undefine[] = "undefine";
+#ifdef DEBUG_EXTENSIONS
+SCM scm_i_enter_frame, scm_i_apply_frame, scm_i_exit_frame;
+SCM scm_i_trace;
+#endif
#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
-#ifdef __STDC__
-static void
-bodycheck (SCM xorig, SCM *bodyloc, char *what)
-#else
+
+static void bodycheck SCM_P ((SCM xorig, SCM *bodyloc, char *what));
+
static void
bodycheck (xorig, bodyloc, what)
SCM xorig;
SCM *bodyloc;
char *what;
-#endif
{
ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression);
}
-#ifdef __STDC__
-SCM
-scm_m_quote (SCM xorig, SCM env)
-#else
+
SCM
scm_m_quote (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "quote");
return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
}
-#ifdef __STDC__
-SCM
-scm_m_begin (SCM xorig, SCM env)
-#else
+
SCM
scm_m_begin (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, s_expression, "begin");
return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}
-#ifdef __STDC__
-SCM
-scm_m_if (SCM xorig, SCM env)
-#else
+
SCM
scm_m_if (xorig, env)
SCM xorig;
SCM env;
-#endif
{
int len = scm_ilength (SCM_CDR (xorig));
ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if");
@@ -327,55 +386,35 @@ scm_m_if (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_set (SCM xorig, SCM env)
-#else
+
SCM
scm_m_set (xorig, env)
SCM xorig;
SCM env;
-#endif
{
- SCM x;
- int len;
-
- x = SCM_CDR (xorig);
- len = scm_ilength (x);
- ASSYNT ((len > 0) && !(len & 1), xorig, s_expression, "set!");
-
- {
- SCM y;
- y = x;
- while (len)
- {
- ASSYNT (SCM_NIMP (SCM_CAR (y)) && SCM_SYMBOLP (SCM_CAR (y)),
- xorig, s_variable, "set!");
- y = SCM_CDR (SCM_CDR (x));
- len -= 2;
- }
- }
+ SCM x = SCM_CDR (xorig);
+ ASSYNT (2 == scm_ilength (x), xorig, s_expression, "set!");
+ ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)),
+ xorig, s_variable, "set!");
return scm_cons (SCM_IM_SET, x);
}
#if 0
-#ifdef __STDC__
-SCM
-scm_m_vref (SCM xorig, SCM env)
-#else
+
SCM
scm_m_vref (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig);
ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref);
if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
{
- scm_everr (SCM_UNDEFINED, env, SCM_CAR(SCM_CDR(x)), s_variable,
- "global variable reference");
+ /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
+ scm_misc_error (NULL,
+ "Bad variable: %S",
+ scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED));
}
ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
xorig, s_variable, s_vref);
@@ -384,15 +423,11 @@ scm_m_vref (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_vset (SCM xorig, SCM env)
-#else
+
SCM
scm_m_vset (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig);
ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset);
@@ -404,15 +439,11 @@ scm_m_vset (xorig, env)
#endif
-#ifdef __STDC__
-SCM
-scm_m_and (SCM xorig, SCM env)
-#else
+
SCM
scm_m_and (xorig, env)
SCM xorig;
SCM env;
-#endif
{
int len = scm_ilength (SCM_CDR (xorig));
ASSYNT (len >= 0, xorig, s_test, "and");
@@ -423,15 +454,11 @@ scm_m_and (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_or (SCM xorig, SCM env)
-#else
+
SCM
scm_m_or (xorig, env)
SCM xorig;
SCM env;
-#endif
{
int len = scm_ilength (SCM_CDR (xorig));
ASSYNT (len >= 0, xorig, s_test, "or");
@@ -442,15 +469,11 @@ scm_m_or (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_case (SCM xorig, SCM env)
-#else
+
SCM
scm_m_case (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM proc, x = SCM_CDR (xorig);
ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case");
@@ -465,15 +488,11 @@ scm_m_case (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_cond (SCM xorig, SCM env)
-#else
+
SCM
scm_m_cond (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM arg1, x = SCM_CDR (xorig);
int len = scm_ilength (x);
@@ -486,7 +505,7 @@ scm_m_cond (xorig, env)
if (scm_i_else == SCM_CAR (arg1))
{
ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond");
- SCM_CAR (arg1) = SCM_BOOL_T;
+ SCM_SETCAR (arg1, SCM_BOOL_T);
}
if (len >= 2 && scm_i_arrow == SCM_CAR (SCM_CDR (arg1)))
ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
@@ -497,15 +516,11 @@ scm_m_cond (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_lambda (SCM xorig, SCM env)
-#else
+
SCM
scm_m_lambda (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM proc, x = SCM_CDR (xorig);
if (scm_ilength (x) < 2)
@@ -536,38 +551,33 @@ scm_m_lambda (xorig, env)
(proc)
badforms:scm_wta (xorig, s_formals, "lambda");
memlambda:
- bodycheck (xorig, &SCM_CDR (x), "lambda");
+ bodycheck (xorig, SCM_CDRLOC (x), "lambda");
return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig));
}
-#ifdef __STDC__
-SCM
-scm_m_letstar (SCM xorig, SCM env)
-#else
+
SCM
scm_m_letstar (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
int len = scm_ilength (x);
ASSYNT (len >= 2, xorig, s_body, "let*");
proc = SCM_CAR (x);
ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*");
- while SCM_NIMP
- (proc)
+ while SCM_NIMP (proc)
{
arg1 = SCM_CAR (proc);
ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*");
ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let*");
*varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- varloc = &SCM_CDR (SCM_CDR (*varloc));
+ varloc = SCM_CDRLOC (SCM_CDR (*varloc));
proc = SCM_CDR (proc);
}
x = scm_cons (vars, SCM_CDR (x));
- bodycheck (xorig, &SCM_CDR (x), "let*");
+ bodycheck (xorig, SCM_CDRLOC (x), "let*");
return scm_cons (SCM_IM_LETSTAR, x);
}
@@ -586,15 +596,11 @@ scm_m_letstar (xorig, env)
*/
-#ifdef __STDC__
-SCM
-scm_m_do (SCM xorig, SCM env)
-#else
+
SCM
scm_m_do (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig), arg1, proc;
SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
@@ -614,44 +620,33 @@ scm_m_do (xorig, env)
vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
arg1 = SCM_CDR (arg1);
*initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
arg1 = SCM_CDR (arg1);
*steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */
- steploc = &SCM_CDR (*steploc);
+ steploc = SCM_CDRLOC (*steploc);
proc = SCM_CDR (proc);
}
x = SCM_CDR (x);
ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do");
x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
x = scm_cons2 (vars, inits, x);
- bodycheck (xorig, &SCM_CAR (SCM_CDR (SCM_CDR (x))), "do");
+ bodycheck (xorig, SCM_CARLOC (SCM_CDR (SCM_CDR (x))), "do");
return scm_cons (SCM_IM_DO, x);
}
-/* evalcar is small version of inline EVALCAR when we don't care about speed */
-#ifdef __STDC__
-static SCM
-evalcar (SCM x, SCM env)
-#else
-static SCM
-evalcar (x, env)
- SCM x;
- SCM env;
-#endif
-{
- return XEVALCAR (x, env);
-}
+/* evalcar is small version of inline EVALCAR when we don't care about
+ * speed
+ */
+#define evalcar scm_eval_car
+
+
+static SCM iqq SCM_P ((SCM form, SCM env, int depth));
-#ifdef __STDC__
-static SCM
-iqq (SCM form, SCM env, int depth)
-#else
static SCM
iqq (form, env, depth)
SCM form;
SCM env;
int depth;
-#endif
{
SCM tmp;
int edepth = depth;
@@ -679,7 +674,6 @@ iqq (form, env, depth)
--depth;
label:
form = SCM_CDR (form);
- /* !!! might need a check here to be sure that form isn't a struct. */
SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
form, SCM_ARG1, s_quasiquote);
if (0 == depth)
@@ -697,30 +691,22 @@ iqq (form, env, depth)
/* Here are acros which return values rather than code. */
-#ifdef __STDC__
-SCM
-scm_m_quasiquote (SCM xorig, SCM env)
-#else
+
SCM
scm_m_quasiquote (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig);
ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote);
return iqq (SCM_CAR (x), env, 1);
}
-#ifdef __STDC__
-SCM
-scm_m_delay (SCM xorig, SCM env)
-#else
+
SCM
scm_m_delay (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay);
xorig = SCM_CDR (xorig);
@@ -728,14 +714,12 @@ scm_m_delay (xorig, env)
env));
}
-#ifdef __STDC__
-static SCM
-env_top_level (SCM env)
-#else
+
+static SCM env_top_level SCM_P ((SCM env));
+
static SCM
env_top_level (env)
SCM env;
-#endif
{
while (SCM_NIMP(env))
{
@@ -746,15 +730,11 @@ env_top_level (env)
return SCM_BOOL_F;
}
-#ifdef __STDC__
-SCM
-scm_m_define (SCM x, SCM env)
-#else
+
SCM
scm_m_define (x, env)
SCM x;
SCM env;
-#endif
{
SCM proc, arg1 = x;
x = SCM_CDR (x);
@@ -772,6 +752,10 @@ scm_m_define (x, env)
if (SCM_TOP_LEVEL (env))
{
x = evalcar (x, env);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
+ scm_set_procedure_property_x (x, scm_i_name, proc);
+#endif
arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T);
#if 0
#ifndef RECKLESS
@@ -783,11 +767,7 @@ scm_m_define (x, env)
if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
scm_warn ("redefining ", SCM_CHARS (proc));
#endif
-#ifdef DEBUG_EXTENSIONS
- if (RECORD_PROCNAMES && SCM_NIMP (x) && SCM_CLOSUREP (x))
- scm_set_procedure_property_x (x, scm_i_name, proc);
-#endif
- SCM_CDR (arg1) = x;
+ SCM_SETCDR (arg1, x);
#ifdef SICP
return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL);
#else
@@ -796,17 +776,45 @@ scm_m_define (x, env)
}
return scm_cons2 (SCM_IM_DEFINE, proc, x);
}
-/* end of acros */
-#ifdef __STDC__
-SCM
-scm_m_letrec (SCM xorig, SCM env)
+SCM
+scm_m_undefine (x, env)
+ SCM x, env;
+{
+ SCM arg1 = x;
+ x = SCM_CDR (x);
+ ASSYNT (SCM_TOP_LEVEL (env), arg1, "bad placement ", s_undefine);
+ ASSYNT (SCM_NIMP (x) && SCM_CONSP (x) && SCM_CDR (x) == SCM_EOL,
+ arg1, s_expression, s_undefine);
+ x = SCM_CAR (x);
+ ASSYNT (SCM_NIMP (x) && SCM_SYMBOLP (x), arg1, s_variable, s_undefine);
+ arg1 = scm_sym2vcell (x, env_top_level (env), SCM_BOOL_F);
+ ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)),
+ x, "variable already unbound ", s_undefine);
+#if 0
+#ifndef RECKLESS
+ if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == x))
+ scm_warn ("undefining built-in ", SCM_CHARS (x));
+ else
+#endif
+ if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
+ scm_warn ("redefining ", SCM_CHARS (x));
+#endif
+ SCM_SETCDR (arg1, SCM_UNDEFINED);
+#ifdef SICP
+ return SCM_CAR (arg1);
#else
+ return SCM_UNSPECIFIED;
+#endif
+}
+
+/* end of acros */
+
+
SCM
scm_m_letrec (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
char *what = SCM_CHARS (SCM_CAR (xorig));
@@ -826,24 +834,20 @@ scm_m_letrec (xorig, env)
ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), s_variable);
vars = scm_cons (SCM_CAR (arg1), vars);
*initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
}
while SCM_NIMP
(proc = SCM_CDR (proc));
cdrx = scm_cons2 (vars, inits, SCM_CDR (x));
- bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what);
+ bodycheck (xorig, SCM_CDRLOC (SCM_CDR (cdrx)), what);
return scm_cons (SCM_IM_LETREC, cdrx);
}
-#ifdef __STDC__
-SCM
-scm_m_let (SCM xorig, SCM env)
-#else
+
SCM
scm_m_let (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
SCM x = cdrx, proc, arg1, name; /* structure traversers */
@@ -872,9 +876,9 @@ scm_m_let (xorig, env)
ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let");
ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let");
*varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
- varloc = &SCM_CDR (*varloc);
+ varloc = SCM_CDRLOC (*varloc);
*initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
proc = SCM_CDR (proc);
}
return
@@ -885,46 +889,238 @@ scm_m_let (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_apply (SCM xorig, SCM env)
-#else
+
SCM
scm_m_apply (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, s_expression, "@apply");
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
}
-#define s_atcall_cc (SCM_ISYMSCM_CHARS(SCM_IM_CONT)+1)
+#define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)
+
-#ifdef __STDC__
-SCM
-scm_m_cont (SCM xorig, SCM env)
-#else
SCM
scm_m_cont (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation");
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}
+/* scm_unmemocopy takes a memoized expression together with its
+ * environment and rewrites it to its original form. Thus, it is the
+ * inversion of the rewrite rules above. The procedure is not
+ * optimized for speed. It's used in scm_iprin1 when printing the
+ * code of a closure, in scm_procedure_source, in display_frame when
+ * generating the source for a stackframe in a backtrace, and in
+ * display_expression.
+ */
+
+static SCM unmemocopy SCM_P ((SCM x, SCM env));
+
+static SCM
+unmemocopy (x, env)
+ SCM x;
+ SCM env;
+{
+ SCM ls, z;
+#ifdef DEBUG_EXTENSIONS
+ SCM p;
+#endif
+ if (SCM_NCELLP (x) || SCM_NECONSP (x))
+ return x;
+#ifdef DEBUG_EXTENSIONS
+ p = scm_whash_lookup (scm_source_whash, x);
+#endif
+ switch (SCM_TYP7 (x))
+ {
+ case (127 & SCM_IM_AND):
+ ls = z = scm_cons (scm_i_and, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_BEGIN):
+ ls = z = scm_cons (scm_i_begin, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_CASE):
+ ls = z = scm_cons (scm_i_case, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_COND):
+ ls = z = scm_cons (scm_i_cond, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_DO):
+ ls = scm_cons (scm_i_do, SCM_UNSPECIFIED);
+ goto transform;
+ case (127 & SCM_IM_IF):
+ ls = z = scm_cons (scm_i_if, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_LET):
+ ls = scm_cons (scm_i_let, SCM_UNSPECIFIED);
+ goto transform;
+ case (127 & SCM_IM_LETREC):
+ {
+ SCM f, v, e, s;
+ ls = scm_cons (scm_i_letrec, SCM_UNSPECIFIED);
+ transform:
+ x = SCM_CDR (x);
+ f = v = SCM_CAR (x);
+ x = SCM_CDR (x);
+ z = EXTEND_ENV (f, SCM_EOL, env);
+ e = scm_reverse (unmemocopy (SCM_CAR (x),
+ SCM_CAR (ls) == scm_i_letrec ? z : env));
+ env = z;
+ s = SCM_CAR (ls) == scm_i_do
+ ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
+ : f;
+ z = SCM_EOL;
+ do
+ {
+ z = scm_acons (SCM_CAR (v),
+ scm_cons (SCM_CAR (e),
+ SCM_CAR (s) == SCM_CAR (v)
+ ? SCM_EOL
+ : scm_cons (SCM_CAR (s), SCM_EOL)),
+ z);
+ v = SCM_CDR (v);
+ e = SCM_CDR (e);
+ s = SCM_CDR (s);
+ }
+ while SCM_NIMP (v);
+ z = scm_cons (z, SCM_UNSPECIFIED);
+ SCM_SETCDR (ls, z);
+ if (SCM_CAR (ls) == scm_i_do)
+ {
+ x = SCM_CDR (x);
+ SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
+ x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1);
+ }
+ break;
+ }
+ case (127 & SCM_IM_LETSTAR):
+ {
+ SCM b, y;
+ x = SCM_CDR (x);
+ b = SCM_CAR (x);
+ y = SCM_EOL;
+ if SCM_IMP (b)
+ {
+ env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ goto letstar;
+ }
+ y = z = scm_acons (SCM_CAR (b),
+ unmemocar (
+ scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ SCM_UNSPECIFIED);
+ env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDR (SCM_CDR (b));
+ if (SCM_IMP (b))
+ {
+ SCM_SETCDR (y, SCM_EOL);
+ ls = scm_cons (scm_i_let, z = scm_cons (y, SCM_UNSPECIFIED));
+ break;
+ }
+ do
+ {
+ SCM_SETCDR (z, scm_acons (SCM_CAR (b),
+ unmemocar (
+ scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
+ env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDR (SCM_CDR (b));
+ }
+ while SCM_NIMP (b);
+ SCM_SETCDR (z, SCM_EOL);
+ letstar:
+ ls = scm_cons (scm_i_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
+ break;
+ }
+ case (127 & SCM_IM_OR):
+ ls = z = scm_cons (scm_i_or, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_LAMBDA):
+ x = SCM_CDR (x);
+ ls = scm_cons (scm_i_lambda,
+ z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
+ env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ break;
+ case (127 & SCM_IM_QUOTE):
+ ls = z = scm_cons (scm_i_quote, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_SET):
+ ls = z = scm_cons (scm_i_set, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_DEFINE):
+ {
+ SCM n;
+ x = SCM_CDR (x);
+ ls = scm_cons (scm_i_define,
+ z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
+ if (SCM_NNULLP (env))
+ SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
+ break;
+ }
+ case (127 & SCM_MAKISYM (0)):
+ z = SCM_CAR (x);
+ if (!SCM_ISYMP (z))
+ goto unmemo;
+ switch SCM_ISYMNUM (z)
+ {
+ case (SCM_ISYMNUM (SCM_IM_APPLY)):
+ ls = z = scm_cons (scm_i_atapply, SCM_UNSPECIFIED);
+ goto loop;
+ case (SCM_ISYMNUM (SCM_IM_CONT)):
+ ls = z = scm_cons (scm_i_atcall_cc, SCM_UNSPECIFIED);
+ goto loop;
+ default:
+ /* appease the Sun compiler god: */ ;
+ }
+ unmemo:
+ default:
+ ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env);
+ }
+loop:
+ while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
+ {
+ SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env));
+ z = SCM_CDR (z);
+ }
+ SCM_SETCDR (z, x);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_NFALSEP (p))
+ scm_whash_insert (scm_source_whash, ls, p);
+#endif
+ return ls;
+}
+
+
+SCM
+scm_unmemocopy (x, env)
+ SCM x;
+ SCM env;
+{
+ if (SCM_NNULLP (env))
+ /* Make a copy of the lowest frame to protect it from
+ modifications by SCM_IM_DEFINE */
+ return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
+ else
+ return unmemocopy (x, env);
+}
+
#ifndef RECKLESS
-#ifdef __STDC__
-int
-scm_badargsp (SCM formals, SCM args)
-#else
+
int
scm_badargsp (formals, args)
SCM formals;
SCM args;
-#endif
{
while SCM_NIMP
(formals)
@@ -944,69 +1140,224 @@ scm_badargsp (formals, args)
long scm_tc16_macro;
+
+SCM
+scm_eval_args (l, env)
+ SCM l;
+ SCM env;
+{
+ SCM res = SCM_EOL, *lloc = &res;
+ while (SCM_NIMP (l))
+ {
+ *lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
+ lloc = SCM_CDRLOC (*lloc);
+ l = SCM_CDR (l);
+ }
+ return res;
+}
+
+
+/* The SCM_CEVAL and SCM_APPLY functions use this function instead of
+ calling setjmp directly, to make sure that local variables don't
+ have their values clobbered by a longjmp.
+
+ According to Harbison & Steele, "Automatic variables local to the
+ function containing setjmp are guaranteed to have their correct
+ value in ANSI C only if they have a volatile-qualified type or if
+ their values were not changed between the original call to setjmp
+ and the corresponding longjmp call."
+
+ SCM_CEVAL and SCM_APPLY are too complex for me to see how to meet
+ the second condition, and making x and env volatile would be a
+ speed problem, so we'll just trivially meet the first, by having no
+ "automatic variables local to the function containing setjmp." */
+
+/* Actually, this entire approach is bogus, because setjmp ends up
+ capturing the stack frame of the wrapper function, which then
+ returns, rendering the jump buffer invalid. Duh. Gotta find a
+ better way... -JimB */
+#define safe_setjmp(x) setjmp (x)
+static int
+unsafe_setjmp (jmp_buf env)
+{
+ /* I think ANSI requires us to write the function this way, instead
+ of just saying "return setjmp (env)". Maybe I'm being silly.
+ See Harbison & Steele, third edition, p. 353. */
+ int val;
+ val = setjmp (env);
+ return val;
+}
+
+
#endif /* !DEVAL */
-#ifdef DEVAL
-#undef SCM_EVAL_ARGS
-#define SCM_EVAL_ARGS scm_deval_args
+
+/* SECTION: This code is specific for the debugging support. One
+ * branch is read when DEVAL isn't defined, the other when DEVAL is
+ * defined.
+ */
+
+#ifndef DEVAL
+
+#define SCM_APPLY scm_apply
+#define PREP_APPLY(proc, args)
+#define ENTER_APPLY
+#define RETURN(x) return x;
+#ifdef STACK_CHECKING
+#ifndef NO_CEVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
+#endif
+
+#else /* !DEVAL */
+
#undef SCM_CEVAL
#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
#undef SCM_APPLY
#define SCM_APPLY scm_dapply
+#undef PREP_APPLY
+#define PREP_APPLY(p, l) \
+{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
+#undef ENTER_APPLY
+#define ENTER_APPLY \
+{\
+ SCM_SET_ARGSREADY (debug);\
+ if (CHECK_APPLY)\
+ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
+ {\
+ SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
+ SCM_SET_TRACED_FRAME (debug); \
+ SCM_APPLY_FRAME_P = 0; \
+ SCM_TRACE_P = 0; \
+ SCM_RESET_DEBUG_MODE; \
+ if (SCM_CHEAPTRAPS_P)\
+ {\
+ tmp = scm_make_debugobj (&debug);\
+ scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ }\
+ else\
+ {\
+ scm_make_cont (&tmp);\
+ if (!safe_setjmp (SCM_JMPBUF (tmp)))\
+ scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ }\
+ }\
+}
#undef RETURN
#define RETURN(e) {proc = (e); goto exit;}
-#else
-#define SCM_EVAL_ARGS scm_eval_args
-#define RETURN(x) return x;
+#ifdef STACK_CHECKING
+#ifndef EVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
#endif
-SCM
-SCM_EVAL_ARGS (l, env)
- SCM l, env;
+/* scm_ceval_ptr points to the currently selected evaluator.
+ * *fixme*: Although efficiency is important here, this state variable
+ * should probably not be a global. It should be related to the
+ * current repl.
+ */
+
+
+SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env));
+
+/* scm_last_debug_frame contains a pointer to the last debugging
+ * information stack frame. It is accessed very often from the
+ * debugging evaluator, so it should probably not be indirectly
+ * addressed. Better to save and restore it from the current root at
+ * any stack swaps.
+ */
+
+#ifndef USE_THREADS
+scm_debug_frame *scm_last_debug_frame;
+#endif
+
+/* scm_debug_eframe_size is the number of slots available for pseudo
+ * stack frames at each real stack frame.
+ */
+
+int scm_debug_eframe_size;
+
+int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
+
+scm_option scm_debug_opts[] = {
+ { SCM_OPTION_BOOLEAN, "cheap", 1,
+ "*Flyweight representation of the stack at traps." },
+ { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
+ { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
+ { SCM_OPTION_BOOLEAN, "procnames", 1,
+ "Record procedure names at definition." },
+ { SCM_OPTION_BOOLEAN, "backwards", 0,
+ "Display backtrace in anti-chronological order." },
+ { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
+ { SCM_OPTION_INTEGER, "frames", 3,
+ "Maximum number of tail-recursive frames in backtrace." },
+ { SCM_OPTION_INTEGER, "maxdepth", 1000,
+ "Maximal number of stored backtrace frames." },
+ { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
+ { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
+ { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
+ { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (0 = no check)." }
+};
+
+scm_option scm_evaluator_trap_table[] = {
+ { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
+ { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
+ { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
+};
+
+SCM
+scm_deval_args (l, env, lloc)
+ SCM l, env, *lloc;
{
- SCM res = SCM_EOL, *lloc = &res;
+ SCM *res = lloc;
while (SCM_NIMP (l))
{
*lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
- lloc = &SCM_CDR (*lloc);
+ lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
- return res;
+ return *res;
}
-#if 0
-#ifdef __STDC__
-SCM
-scm_ceval (SCM x, SCM env)
+#endif /* !DEVAL */
+
+
+/* SECTION: Some local definitions for the evaluator.
+ */
+
+#ifndef DEVAL
+#ifdef SCM_FLOATS
+#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
#else
+#define CHECK_EQVISH(A,B) ((A) == (B))
+#endif
+#endif /* DEVAL */
+
+#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
+
+/* SECTION: This is the evaluator. Like any real monster, it has
+ * three heads. This code is compiled twice.
+ */
+
+#if 0
+
SCM
scm_ceval (x, env)
SCM x;
SCM env;
-#endif
{}
#endif
#if 0
-#ifdef __STDC__
-SCM
-scm_deval (SCM x, SCM env)
-#else
+
SCM
scm_deval (x, env)
SCM x;
SCM env;
-#endif
{}
#endif
-#ifdef SCM_FLOATS
-#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
-#else
-#define CHECK_EQVISH(A,B) ((A) == (B))
-#endif
-
-SCM
+SCM
SCM_CEVAL (x, env)
SCM x;
SCM env;
@@ -1016,14 +1367,80 @@ SCM_CEVAL (x, env)
SCM *lloc;
SCM arg1;
} t;
- SCM proc;
- SCM arg2;
-
- SCM_CHECK_STACK;
-
- loop:
+ SCM proc, arg2;
+#ifdef DEVAL
+ scm_debug_frame debug;
+ scm_debug_info *debug_info_end;
+ debug.prev = scm_last_debug_frame;
+ debug.status = scm_debug_eframe_size;
+ debug.vect = (scm_debug_info *) alloca (scm_debug_eframe_size
+ * sizeof (debug.vect[0]));
+ debug.info = debug.vect;
+ debug_info_end = debug.vect + scm_debug_eframe_size;
+ scm_last_debug_frame = &debug;
+#endif
+#ifdef EVAL_STACK_CHECKING
+ if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)
+ && scm_stack_checking_enabled_p)
+ {
+#ifdef DEVAL
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+#endif
+ scm_report_stack_overflow ();
+ }
+#endif
+#ifdef DEVAL
+ goto start;
+#endif
+loopnoap:
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+loop:
+#ifdef DEVAL
+ SCM_CLEAR_ARGSREADY (debug);
+ if (SCM_OVERFLOWP (debug))
+ --debug.info;
+ else if (++debug.info >= debug_info_end)
+ {
+ SCM_SET_OVERFLOW (debug);
+ debug.info -= 2;
+ }
+start:
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+ if (CHECK_ENTRY)
+ if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
+ {
+ SCM tail = SCM_TAILRECP (debug) ? SCM_BOOL_T : SCM_BOOL_F;
+ SCM_SET_TAILREC (debug);
+ SCM_ENTER_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ if (SCM_CHEAPTRAPS_P)
+ t.arg1 = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&t.arg1);
+ if (safe_setjmp (SCM_JMPBUF (t.arg1)))
+ {
+ x = SCM_THROW_VALUE (t.arg1);
+ if (SCM_IMP (x))
+ {
+ RETURN (x);
+ }
+ else
+ /* This gives the possibility for the debugger to
+ modify the source expression before evaluation. */
+ goto dispatch;
+ }
+ }
+ scm_ithrow (scm_i_enter_frame,
+ scm_cons2 (t.arg1, tail,
+ scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
+ 0);
+ }
+dispatch:
+#endif
SCM_ASYNC_TICK;
-
switch (SCM_TYP7 (x))
{
case scm_tcs_symbols:
@@ -1042,10 +1459,12 @@ SCM_CEVAL (x, env)
}
else
x = t.arg1;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
case (127 & SCM_IM_BEGIN):
-
+ cdrxnoap:
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
cdrxbegin:
x = SCM_CDR (x);
@@ -1061,13 +1480,13 @@ SCM_CEVAL (x, env)
if (SCM_NCELLP (SCM_CAR (x)))
{
x = SCM_CAR (x);
- RETURN (SCM_IMP (x) ? EVALIMP (x, env) : SCM_GLOC_VAL (x));
+ RETURN (SCM_IMP (x) ? EVALIM (x, env) : SCM_GLOC_VAL (x))
}
if (SCM_SYMBOLP (SCM_CAR (x)))
{
retval:
- RETURN (*scm_lookupcar (x, env));
+ RETURN (*scm_lookupcar (x, env))
}
x = SCM_CAR (x);
@@ -1083,6 +1502,7 @@ SCM_CEVAL (x, env)
if (scm_i_else == SCM_CAR (proc))
{
x = SCM_CDR (proc);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
proc = SCM_CAR (proc);
@@ -1091,12 +1511,13 @@ SCM_CEVAL (x, env)
if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
{
x = SCM_CDR (SCM_CAR (x));
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
proc = SCM_CDR (proc);
}
}
- RETURN (SCM_UNSPECIFIED);
+ RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_COND):
@@ -1107,19 +1528,24 @@ SCM_CEVAL (x, env)
if (SCM_NFALSEP (t.arg1))
{
x = SCM_CDR (proc);
- if (SCM_NULLP (x))
+ if SCM_NULLP (x)
{
- RETURN (t.arg1);
+ RETURN (t.arg1)
}
if (scm_i_arrow != SCM_CAR (x))
- goto begin;
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
proc = SCM_CDR (x);
proc = EVALCAR (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
+ ENTER_APPLY;
goto evap1;
}
}
- RETURN (SCM_UNSPECIFIED);
+ RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_DO):
@@ -1131,7 +1557,7 @@ SCM_CEVAL (x, env)
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
proc = SCM_CDR (proc);
}
- env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env);
+ env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
x = SCM_CDR (SCM_CDR (x));
while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
{
@@ -1142,13 +1568,12 @@ SCM_CEVAL (x, env)
}
for (t.arg1 = SCM_EOL, proc = SCM_CDR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc))
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
+ env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
}
x = SCM_CDR (proc);
if (SCM_NULLP (x))
- {
- RETURN (SCM_UNSPECIFIED);
- }
+ RETURN (SCM_UNSPECIFIED);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
@@ -1160,6 +1585,7 @@ SCM_CEVAL (x, env)
{
RETURN (SCM_UNSPECIFIED);
}
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
@@ -1172,14 +1598,14 @@ SCM_CEVAL (x, env)
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env);
+ env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
x = SCM_CDR (x);
- goto cdrxbegin;
+ goto cdrxnoap;
case (127 & SCM_IM_LETREC):
x = SCM_CDR (x);
- env = EXTEND_SCM_ENV (SCM_CAR (x), scm_undefineds, env);
+ env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
x = SCM_CDR (x);
proc = SCM_CAR (x);
t.arg1 = SCM_EOL;
@@ -1188,8 +1614,8 @@ SCM_CEVAL (x, env)
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- SCM_CDR (SCM_CAR (env)) = t.arg1;
- goto cdrxbegin;
+ SCM_SETCDR (SCM_CAR (env), t.arg1);
+ goto cdrxnoap;
case (127 & SCM_IM_LETSTAR):
@@ -1197,17 +1623,17 @@ SCM_CEVAL (x, env)
proc = SCM_CAR (x);
if (SCM_IMP (proc))
{
- env = EXTEND_SCM_ENV (SCM_EOL, SCM_EOL, env);
- goto cdrxbegin;
+ env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ goto cdrxnoap;
}
do
{
t.arg1 = SCM_CAR (proc);
proc = SCM_CDR (proc);
- env = EXTEND_SCM_ENV (t.arg1, EVALCAR (proc, env), env);
+ env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- goto cdrxbegin;
+ goto cdrxnoap;
case (127 & SCM_IM_OR):
x = SCM_CDR (x);
@@ -1221,6 +1647,7 @@ SCM_CEVAL (x, env)
}
x = t.arg1;
}
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
@@ -1233,16 +1660,15 @@ SCM_CEVAL (x, env)
case (127 & SCM_IM_SET):
- set_some_more:
x = SCM_CDR (x);
proc = SCM_CAR (x);
- switch (7 & (int)proc)
+ switch (7 & (int) proc)
{
case 0:
t.lloc = scm_lookupcar (x, env);
break;
case 1:
- t.lloc = &SCM_GLOC_VAL (proc);
+ t.lloc = SCM_GLOC_VAL_LOC (proc);
break;
#ifdef MEMOIZE_LOCALS
case 4:
@@ -1252,8 +1678,6 @@ SCM_CEVAL (x, env)
}
x = SCM_CDR (x);
*t.lloc = EVALCAR (x, env);
- if (!SCM_NULLP (SCM_CDR(x)))
- goto set_some_more;
#ifdef SICP
RETURN (*t.lloc);
#else
@@ -1266,15 +1690,18 @@ SCM_CEVAL (x, env)
proc = SCM_CAR (x);
x = SCM_CDR (x);
x = evalcar (x, env);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
+ scm_set_procedure_property_x (x, scm_i_name, proc);
+#endif
env = SCM_CAR (env);
SCM_DEFER_INTS;
- SCM_CAR (env) = scm_cons (proc, SCM_CAR (env));
- SCM_CDR (env) = scm_cons (x, SCM_CDR (env));
+ SCM_SETCAR (env, scm_cons (proc, SCM_CAR (env)));
+ SCM_SETCDR (env, scm_cons (x, SCM_CDR (env)));
SCM_ALLOW_INTS;
RETURN (SCM_UNSPECIFIED);
-
/* new syntactic forms go here. */
case (127 & SCM_MAKISYM (0)):
proc = SCM_CAR (x);
@@ -1291,7 +1718,7 @@ SCM_CEVAL (x, env)
case (SCM_ISYMNUM (IM_VSET)):
SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env);
SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable;
- RETURN (SCM_UNSPECIFIED);
+ RETURN (SCM_UNSPECIFIED)
#endif
case (SCM_ISYMNUM (SCM_IM_APPLY)):
@@ -1300,13 +1727,17 @@ SCM_CEVAL (x, env)
SCM_ASRTGO (SCM_NIMP (proc), badfun);
if (SCM_CLOSUREP (proc))
{
+ PREP_APPLY (proc, SCM_EOL);
t.arg1 = SCM_CDR (SCM_CDR (x));
t.arg1 = EVALCAR (t.arg1, env);
+#ifdef DEVAL
+ debug.info->a.args = t.arg1;
+#endif
#ifndef RECKLESS
if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
goto wrongnumargs;
#endif
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc));
x = SCM_CODE (proc);
goto cdrxbegin;
}
@@ -1315,15 +1746,17 @@ SCM_CEVAL (x, env)
case (SCM_ISYMNUM (SCM_IM_CONT)):
scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
+ if (safe_setjmp (SCM_JMPBUF (t.arg1)))
{
SCM val;
val = SCM_THROW_VALUE (t.arg1);
- RETURN (val);;
+ RETURN (val);
}
proc = SCM_CDR (x);
proc = evalcar (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
+ ENTER_APPLY;
goto evap1;
default:
@@ -1333,8 +1766,10 @@ SCM_CEVAL (x, env)
default:
proc = x;
badfun:
- scm_everr (x, env, proc, "Wrong type to apply: ", "");
-
+ /* scm_everr (x, env,...) */
+ scm_misc_error (NULL,
+ "Wrong type to apply: %S",
+ scm_listify (proc, SCM_UNDEFINED));
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_bvect:
@@ -1401,14 +1836,37 @@ SCM_CEVAL (x, env)
case 2:
if (scm_ilength (t.arg1) <= 0)
t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
+#ifdef DEVAL
+ if (!SCM_CLOSUREP (SCM_CDR (proc)))
+ {
+#if 0 /* Top-level defines doesn't very often occur in backtraces */
+ if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL (env))
+ /* Prevent memoizing result of define macro */
+ {
+ debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
+ scm_set_source_properties_x (debug.info->e.exp,
+ scm_source_properties (x));
+ }
+#endif
+ SCM_DEFER_INTS;
+ SCM_SETCAR (x, SCM_CAR (t.arg1));
+ SCM_SETCDR (x, SCM_CDR (t.arg1));
+ SCM_ALLOW_INTS;
+ goto dispatch;
+ }
+ /* Prevent memoizing of debug info expression. */
+ debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
+ scm_set_source_properties_x (debug.info->e.exp,
+ scm_source_properties (x));
+#endif
SCM_DEFER_INTS;
- SCM_CAR (x) = SCM_CAR (t.arg1);
- SCM_CDR (x) = SCM_CDR (t.arg1);
+ SCM_SETCAR (x, SCM_CAR (t.arg1));
+ SCM_SETCDR (x, SCM_CDR (t.arg1));
SCM_ALLOW_INTS;
- goto loop;
+ goto loopnoap;
case 1:
if (SCM_NIMP (x = t.arg1))
- goto loop;
+ goto loopnoap;
case 0:
RETURN (t.arg1);
}
@@ -1443,8 +1901,10 @@ SCM_CEVAL (x, env)
}
- evapply:
- if (SCM_NULLP (SCM_CDR (x)))
+evapply:
+ PREP_APPLY (proc, SCM_EOL);
+ if (SCM_NULLP (SCM_CDR (x))) {
+ ENTER_APPLY;
switch (SCM_TYP7 (proc))
{ /* no arguments given */
case scm_tc7_subr_0:
@@ -1457,13 +1917,19 @@ SCM_CEVAL (x, env)
RETURN (SCM_BOOL_T);
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+#ifdef CCLO
case scm_tc7_cclo:
t.arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+#endif
goto evap1;
+#endif
case scm_tcs_closures:
x = SCM_CODE (proc);
- env = EXTEND_SCM_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
goto cdrxbegin;
case scm_tc7_contin:
case scm_tc7_subr_1:
@@ -1475,12 +1941,13 @@ SCM_CEVAL (x, env)
umwrongnumargs:
unmemocar (x, env);
wrongnumargs:
- scm_everr (x, env, proc, (char *) SCM_WNA, "");
+ /* scm_everr (x, env,...) */
+ scm_wrong_num_args (proc);
default:
/* handle macros here */
goto badfun;
}
-
+ }
/* must handle macros by here */
x = SCM_CDR (x);
@@ -1489,12 +1956,16 @@ SCM_CEVAL (x, env)
goto wrongnumargs;
#endif
t.arg1 = EVALCAR (x, env);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+#endif
x = SCM_CDR (x);
if (SCM_NULLP (x))
{
+ ENTER_APPLY;
evap1:
switch (SCM_TYP7 (proc))
- { /* have one argument in t.arg1 */
+ { /* have one argument in t.arg1 */
case scm_tc7_subr_2o:
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
case scm_tc7_subr_1:
@@ -1541,21 +2012,27 @@ SCM_CEVAL (x, env)
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#else
RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
#endif
+#ifdef CCLO
case scm_tc7_cclo:
arg2 = t.arg1;
t.arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
goto evap2;
+#endif
case scm_tcs_closures:
x = SCM_CODE (proc);
#ifdef DEVAL
- env = EXTEND_SCM_ENV (SCM_CAR (x), dbg_info.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_SCM_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto cdrxbegin;
case scm_tc7_contin:
@@ -1575,165 +2052,216 @@ SCM_CEVAL (x, env)
#endif
{ /* have two or more arguments */
arg2 = EVALCAR (x, env);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+#endif
x = SCM_CDR (x);
if (SCM_NULLP (x)) {
+ ENTER_APPLY;
#ifdef CCLO
evap2:
#endif
+ switch (SCM_TYP7 (proc))
+ { /* have two arguments */
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
+ case scm_tc7_lsubr:
#ifdef DEVAL
- dbg_info.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+#else
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
#endif
- switch SCM_TYP7
- (proc)
- { /* have two arguments */
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
- case scm_tc7_lsubr:
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
+#ifdef CCLO
+ cclon:
+ case scm_tc7_cclo:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
+ scm_cons (debug.info->a.args, SCM_EOL)));
#else
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
+ scm_cons2 (t.arg1, arg2,
+ scm_cons (scm_eval_args (x, env), SCM_EOL))));
#endif
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
-#ifdef CCLO
- cclon: case scm_tc7_cclo:
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
- scm_cons2 (t.arg1, arg2, scm_cons (SCM_EVAL_ARGS (x, env), SCM_EOL))));
- /* case scm_tc7_cclo:
- x = scm_cons(arg2, scm_eval_args(x, env));
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = SCM_CCLO_SUBR(proc);
- goto evap3; */
-#endif
- case scm_tc7_subr_0:
- case scm_tc7_cxr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_1:
- case scm_tc7_subr_3:
- case scm_tc7_contin:
- goto wrongnumargs;
- default:
- goto badfun;
- case scm_tcs_closures:
+ /* case scm_tc7_cclo:
+ x = scm_cons(arg2, scm_eval_args(x, env));
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = SCM_CCLO_SUBR(proc);
+ goto evap3; */
+#endif
+ case scm_tc7_subr_0:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_3:
+ case scm_tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ case scm_tcs_closures:
#ifdef DEVAL
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), dbg_info.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
- x = SCM_CODE (proc);
- goto cdrxbegin;
- }
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
+ }
}
#ifdef DEVAL
- dbg_info.args = scm_cons2 (t.arg1, arg2, scm_deval_args (x, env));
+ debug.info->a.args = scm_cons2 (t.arg1, arg2,
+ scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
#endif
- switch SCM_TYP7
- (proc)
- { /* have 3 or more arguments */
+ ENTER_APPLY;
+ switch (SCM_TYP7 (proc))
+ { /* have 3 or more arguments */
#ifdef DEVAL
- case scm_tc7_subr_3:
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (dbg_info.args)))));
- case scm_tc7_asubr:
- /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
- while SCM_NIMP(x) {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- RETURN (t.arg1) */
- case scm_tc7_rpsubr:
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (dbg_info.args)), SCM_EOL)));
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (dbg_info.args))));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ case scm_tc7_subr_3:
+ SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (debug.info->a.args)))));
+ case scm_tc7_asubr:
+#ifdef BUILTIN_RPASUBR
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
+ arg2 = SCM_CDR (SCM_CDR (debug.info->a.args));
+ do {
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
+ arg2 = SCM_CDR (arg2);
+ } while (SCM_NIMP (arg2));
+ RETURN (t.arg1)
+#endif /* BUILTIN_RPASUBR */
+ case scm_tc7_rpsubr:
+#ifdef BUILTIN_RPASUBR
+ if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
+ RETURN (SCM_BOOL_F)
+ t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args));
+ do {
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
+ RETURN (SCM_BOOL_F)
+ arg2 = SCM_CAR (t.arg1);
+ t.arg1 = SCM_CDR (t.arg1);
+ } while (SCM_NIMP (t.arg1));
+ RETURN (SCM_BOOL_T)
+#else /* BUILTIN_RPASUBR */
+ RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (debug.info->a.args)), SCM_EOL)))
+#endif /* BUILTIN_RPASUBR */
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (debug.info->a.args))))
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#ifdef CCLO
- case scm_tc7_cclo:
- goto cclon;
+ case scm_tc7_cclo:
+ goto cclon;
#endif
- case scm_tcs_closures:
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)),
- dbg_info.args,
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto cdrxbegin;
-#else
- case scm_tc7_subr_3:
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
- case scm_tc7_asubr:
- /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
- while SCM_NIMP(x) {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- RETURN (t.arg1) */
- case scm_tc7_rpsubr:
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env))));
+ case scm_tcs_closures:
+ SCM_SET_ARGSREADY (debug);
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ debug.info->a.args,
+ SCM_ENV (proc));
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
+#else /* DEVAL */
+ case scm_tc7_subr_3:
+ SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
+ case scm_tc7_asubr:
+#ifdef BUILTIN_RPASUBR
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
+ do {
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
+ x = SCM_CDR(x);
+ } while (SCM_NIMP (x));
+ RETURN (t.arg1)
+#endif /* BUILTIN_RPASUBR */
+ case scm_tc7_rpsubr:
+#ifdef BUILTIN_RPASUBR
+ if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
+ RETURN (SCM_BOOL_F)
+ do {
+ t.arg1 = EVALCAR (x, env);
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
+ RETURN (SCM_BOOL_F)
+ arg2 = t.arg1;
+ x = SCM_CDR (x);
+ } while (SCM_NIMP (x));
+ RETURN (SCM_BOOL_T)
+#else /* BUILTIN_RPASUBR */
+ RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
+#endif /* BUILTIN_RPASUBR */
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env))));
#ifdef CCLO
- case scm_tc7_cclo:
- goto cclon;
+ case scm_tc7_cclo:
+ goto cclon;
#endif
- case scm_tcs_closures:
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)),
- scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto cdrxbegin;
+ case scm_tcs_closures:
+#ifdef DEVAL
+ SCM_SET_ARGSREADY (debug);
+#endif
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
+ SCM_ENV (proc));
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
#endif /* DEVAL */
- case scm_tc7_subr_2:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_subr_0:
- case scm_tc7_cxr:
- case scm_tc7_subr_1:
- case scm_tc7_contin:
- goto wrongnumargs;
- default:
- goto badfun;
- }
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_subr_0:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1:
+ case scm_tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
}
#ifdef DEVAL
- exit:
- if (CHECK_SCM_EXIT)
- {
- /* if (SINGLE_STEP) ... but this is always fulfilled. */
- SINGLE_STEP = 0;
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
- {
- proc = SCM_THROW_VALUE(t.arg1);
- goto ret;
- }
- scm_ithrow (exit_frame_sym, proc, 0);
- }
- ret:
- last_debug_info_frame = dbg_info.prev;
+exit:
+ if (CHECK_EXIT)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_EXIT_FRAME_P = 0;
+ SCM_TRACE_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ SCM_CLEAR_TRACED_FRAME (debug);
+ if (SCM_CHEAPTRAPS_P)
+ t.arg1 = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&t.arg1);
+ if (safe_setjmp (SCM_JMPBUF (t.arg1)))
+ {
+ proc = SCM_THROW_VALUE (t.arg1);
+ goto ret;
+ }
+ }
+ scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
+ }
+ret:
+ scm_last_debug_frame = debug.prev;
return proc;
#endif
}
+
+/* SECTION: This code is compiled once.
+ */
+
#ifndef DEVAL
SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
-#ifdef __STDC__
-SCM
-scm_procedure_documentation (SCM proc)
-#else
+
SCM
scm_procedure_documentation (proc)
SCM proc;
-#endif
{
SCM code;
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
@@ -1760,111 +2288,162 @@ scm_procedure_documentation (proc)
}
}
-/* This code is for scm_apply. it is destructive on multiple args.
- * This will only screw you if you do (scm_apply scm_apply '( ... ))
- */
+/* This code processes the arguments to apply:
+
+ (apply PROC ARG1 ... ARGS)
+
+ Given a list (ARG1 ... ARGS), this function conses the ARG1
+ ... arguments onto the front of ARGS, and returns the resulting
+ list. Note that ARGS is a list; thus, the argument to this
+ function is a list whose last element is a list.
+
+ Apply calls this function, and applies PROC to the elements of the
+ result. apply:nconc2last takes care of building the list of
+ arguments, given (ARG1 ... ARGS).
+
+ Rather than do new consing, apply:nconc2last destroys its argument.
+ On that topic, this code came into my care with the following
+ beautifully cryptic comment on that topic: "This will only screw
+ you if you do (scm_apply scm_apply '( ... ))" If you know what
+ they're referring to, send me a patch to this comment. */
+
SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);
-#ifdef __STDC__
-SCM
-scm_nconc2last (SCM lst)
-#else
+
SCM
scm_nconc2last (lst)
SCM lst;
-#endif
{
SCM *lloc;
- if (SCM_EOL == lst)
- return lst;
- SCM_ASSERT (SCM_NIMP (lst) && SCM_CONSP (lst), lst, SCM_ARG1, s_nconc2last);
+ SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last);
lloc = &lst;
while (SCM_NNULLP (SCM_CDR (*lloc)))
- {
- lloc = &SCM_CDR (*lloc);
- SCM_ASSERT (SCM_NIMP (*lloc) && SCM_CONSP (*lloc), lst, SCM_ARG1, s_nconc2last);
- }
+ lloc = SCM_CDRLOC (*lloc);
+ SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last);
*lloc = SCM_CAR (*lloc);
return lst;
}
#endif /* !DEVAL */
+
+/* SECTION: When DEVAL is defined this code yields scm_dapply.
+ * It is compiled twice.
+ */
+
#if 0
-#ifdef __STDC__
-SCM
-scm_apply (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_apply (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{}
#endif
#if 0
-#ifdef __STDC__
-SCM
-scm_dapply (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_dapply (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{}
#endif
+/* Apply a function to a list of arguments.
+
+ This function is exported to the Scheme level as taking two
+ required arguments and a tail argument, as if it were:
+ (lambda (proc arg1 . args) ...)
+ Thus, if you just have a list of arguments to pass to a procedure,
+ pass the list as ARG1, and '() for ARGS. If you have some fixed
+ args, pass the first as ARG1, then cons any remaining fixed args
+ onto the front of your argument list, and pass that as ARGS. */
-#ifdef __STDC__
-SCM
-SCM_APPLY (SCM proc, SCM arg1, SCM args)
-#else
SCM
SCM_APPLY (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
- debug_info dbg_info;
- dbg_info.prev = last_debug_info_frame;
- dbg_info.exp = SCM_UNDEFINED;
- dbg_info.proc = proc;
- dbg_info.args = SCM_UNDEFINED;
- last_debug_info_frame = &dbg_info;
-#else
- if (DEBUGGINGP)
+ scm_debug_frame debug;
+ scm_debug_info debug_vect_body;
+ debug.prev = scm_last_debug_frame;
+ debug.status = SCM_APPLYFRAME;
+ debug.vect = &debug_vect_body;
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = SCM_EOL;
+ scm_last_debug_frame = &debug;
+#else
+ if (SCM_DEBUGGINGP)
return scm_dapply (proc, arg1, args);
#endif
#endif
SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+ /* If ARGS is the empty list, then we're calling apply with only two
+ arguments --- ARG1 is the list of arguments for PROC. Whatever
+ the case, futz with things so that ARG1 is the first argument to
+ give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
+ rest.
+
+ Setting the debug apply frame args this way is pretty messy.
+ Perhaps we should store arg1 and args directly in the frame as
+ received, and let scm_frame_arguments unpack them, because that's
+ a relatively rare operation. This works for now; if the Guile
+ developer archives are still around, see Mikael's post of
+ 11-Apr-97. */
if (SCM_NULLP (args))
{
if (SCM_NULLP (arg1))
- arg1 = SCM_UNDEFINED;
+ {
+ arg1 = SCM_UNDEFINED;
+#ifdef DEVAL
+ debug.vect[0].a.args = SCM_EOL;
+#endif
+ }
else
{
+#ifdef DEVAL
+ debug.vect[0].a.args = arg1;
+#endif
args = SCM_CDR (arg1);
arg1 = SCM_CAR (arg1);
}
}
else
{
- /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
+ /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
args = scm_nconc2last (args);
- }
-#ifdef CCLO
- tail:
+#ifdef DEVAL
+ debug.vect[0].a.args = scm_cons (arg1, args);
#endif
+ }
#ifdef DEVAL
- dbg_info.args = scm_cons (arg1, args);
+ if (SCM_ENTER_FRAME_P)
+ {
+ SCM tmp;
+ SCM_ENTER_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ if (SCM_CHEAPTRAPS_P)
+ tmp = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&tmp);
+ if (safe_setjmp (SCM_JMPBUF (tmp)))
+ goto entap;
+ }
+ scm_ithrow (scm_i_enter_frame, scm_cons (tmp, SCM_EOL), 0);
+ }
+entap:
+ ENTER_APPLY;
+#endif
+#ifdef CCLO
+tail:
#endif
switch (SCM_TYP7 (proc))
{
@@ -1887,13 +2466,15 @@ SCM_APPLY (proc, arg1, args)
#ifdef SCM_FLOATS
if (SCM_SUBRF (proc))
{
- if SCM_INUMP
- (arg1)
- RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0))
+ if (SCM_INUMP (arg1))
+ {
+ RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0));
+ }
SCM_ASRTGO (SCM_NIMP (arg1), floerr);
- if SCM_REALP
- (arg1)
- RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0))
+ if (SCM_REALP (arg1))
+ {
+ RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0));
+ }
#ifdef SCM_BIGDIG
if SCM_BIGP
(arg1)
@@ -1918,7 +2499,7 @@ SCM_APPLY (proc, arg1, args)
RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args))
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args))
#else
RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)))
#endif
@@ -1949,7 +2530,7 @@ SCM_APPLY (proc, arg1, args)
RETURN (SCM_BOOL_T);
case scm_tcs_closures:
#ifdef DEVAL
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args);
+ arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
@@ -1957,7 +2538,7 @@ SCM_APPLY (proc, arg1, args)
if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
goto wrongnumargs;
#endif
- args = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc));
+ args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc));
proc = SCM_CODE (proc);
while (SCM_NNULLP (proc = SCM_CDR (proc)))
arg1 = EVALCAR (proc, args);
@@ -1968,54 +2549,65 @@ SCM_APPLY (proc, arg1, args)
#ifdef CCLO
case scm_tc7_cclo:
#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : dbg_info.args);
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#endif
goto tail;
#endif
wrongnumargs:
- scm_wta (proc, (char *) SCM_WNA, "apply");
+ scm_wrong_num_args (proc);
default:
badproc:
scm_wta (proc, (char *) SCM_ARG1, "apply");
RETURN (arg1);
}
#ifdef DEVAL
- exit:
- if (CHECK_SCM_EXIT)
- {
- /* if (SINGLE_STEP) ... but this is always fulfilled. */
- SINGLE_STEP = 0;
- scm_make_cont (&arg1);
- if (setjmp (SCM_JMPBUF (arg1)))
- {
- proc = SCM_THROW_VALUE(arg1);
- goto ret;
- }
- scm_ithrow (exit_frame_sym, proc, 0);
- }
- ret:
- last_debug_info_frame = dbg_info.prev;
+exit:
+ if (CHECK_EXIT)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_EXIT_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ SCM_CLEAR_TRACED_FRAME (debug);
+ if (SCM_CHEAPTRAPS_P)
+ arg1 = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&arg1);
+ if (safe_setjmp (SCM_JMPBUF (arg1)))
+ {
+ proc = SCM_THROW_VALUE (arg1);
+ goto ret;
+ }
+ }
+ scm_ithrow (scm_i_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
+ }
+ret:
+ scm_last_debug_frame = debug.prev;
return proc;
#endif
}
+
+/* SECTION: The rest of this file is only read once.
+ */
+
#ifndef DEVAL
SCM_PROC(s_map, "map", 2, 0, 1, scm_map);
-#ifdef __STDC__
-SCM
-scm_map (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_map (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{
long i;
SCM res = SCM_EOL;
@@ -2031,7 +2623,7 @@ scm_map (proc, arg1, args)
{
SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map);
*pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL);
- pres = &SCM_CDR (*pres);
+ pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
}
return res;
@@ -2053,22 +2645,18 @@ scm_map (proc, arg1, args)
ve[i] = SCM_CDR (ve[i]);
}
*pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
- pres = &SCM_CDR (*pres);
+ pres = SCM_CDRLOC (*pres);
}
}
SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each);
-#ifdef __STDC__
-SCM
-scm_for_each (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_for_each (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{
SCM *ve = &args; /* Keep args from being optimized away. */
long i;
@@ -2106,125 +2694,105 @@ scm_for_each (proc, arg1, args)
}
-#ifdef __STDC__
-SCM
-scm_closure (SCM code, SCM env)
-#else
+
SCM
scm_closure (code, env)
SCM code;
SCM env;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
SCM_SETCODE (z, code);
- SCM_ENV (z) = env;
+ SCM_SETENV (z, env);
return z;
}
long scm_tc16_promise;
-#ifdef __STDC__
-SCM
-scm_makprom (SCM code)
-#else
+
SCM
scm_makprom (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_promise;
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_promise);
return z;
}
-#ifdef __STDC__
-static int
-prinprom (SCM exp, SCM port, int writing)
-#else
+
+static int prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinprom (exp, port, writing)
+prinprom (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
+ int writingp = SCM_WRITINGP (pstate);
scm_gen_puts (scm_regular_string, "#<promise ", port);
- scm_iprin1 (SCM_CDR (exp), port, writing);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_CDR (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port);
return !0;
}
SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro);
-#ifdef __STDC__
-SCM
-scm_makacro (SCM code)
-#else
+
SCM
scm_makacro (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro;
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro);
return z;
}
SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro);
-#ifdef __STDC__
-SCM
-scm_makmacro (SCM code)
-#else
+
SCM
scm_makmacro (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro | (1L << 16);
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro | (1L << 16));
return z;
}
SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro);
-#ifdef __STDC__
-SCM
-scm_makmmacro (SCM code)
-#else
+
SCM
scm_makmmacro (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro | (2L << 16);
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro | (2L << 16));
return z;
}
-#ifdef __STDC__
-static int
-prinmacro (SCM exp, SCM port, int writing)
-#else
+
+static int prinmacro SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinmacro (exp, port, writing)
+prinmacro (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
+ int writingp = SCM_WRITINGP (pstate);
if (SCM_CAR (exp) & (3L << 16))
scm_gen_puts (scm_regular_string, "#<macro", port);
else
@@ -2232,20 +2800,18 @@ prinmacro (exp, port, writing)
if (SCM_CAR (exp) & (2L << 16))
scm_gen_putc ('!', port);
scm_gen_putc (' ', port);
- scm_iprin1 (SCM_CDR (exp), port, writing);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_CDR (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port);
return !0;
}
SCM_PROC(s_force, "force", 1, 0, 0, scm_force);
-#ifdef __STDC__
-SCM
-scm_force (SCM x)
-#else
+
SCM
scm_force (x)
SCM x;
-#endif
{
SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force);
if (!((1L << 16) & SCM_CAR (x)))
@@ -2254,8 +2820,8 @@ scm_force (x)
if (!((1L << 16) & SCM_CAR (x)))
{
SCM_DEFER_INTS;
- SCM_CDR (x) = ans;
- SCM_CAR (x) |= (1L << 16);
+ SCM_SETCDR (x, ans);
+ SCM_SETOR_CAR (x, (1L << 16));
SCM_ALLOW_INTS;
}
}
@@ -2263,14 +2829,10 @@ scm_force (x)
}
SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p);
-#ifdef __STDC__
-SCM
-scm_promise_p (SCM x)
-#else
+
SCM
scm_promise_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise))
? SCM_BOOL_T
@@ -2278,14 +2840,10 @@ scm_promise_p (x)
}
SCM_PROC(s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree);
-#ifdef __STDC__
-SCM
-scm_copy_tree (SCM obj)
-#else
+
SCM
scm_copy_tree (obj)
SCM obj;
-#endif
{
SCM ans, tl;
if SCM_IMP
@@ -2303,37 +2861,33 @@ scm_copy_tree (obj)
/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
ans = tl = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED);
while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj))
- tl = (SCM_CDR (tl) = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED));
- SCM_CDR (tl) = obj;
+ {
+ SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
+ SCM_UNSPECIFIED));
+ tl = SCM_CDR (tl);
+ }
+ SCM_SETCDR (tl, obj);
return ans;
}
-#ifdef __STDC__
-SCM
-scm_eval_3 (SCM obj, int copyp, SCM env)
-#else
+
SCM
scm_eval_3 (obj, copyp, env)
SCM obj;
int copyp;
SCM env;
-#endif
{
if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
else if (copyp)
obj = scm_copy_tree (obj);
- return EVAL (obj, env);
+ return XEVAL (obj, env);
}
-#ifdef __STDC__
-SCM
-scm_top_level_env (SCM thunk)
-#else
+
SCM
scm_top_level_env (thunk)
SCM thunk;
-#endif
{
if (SCM_IMP(thunk))
return SCM_EOL;
@@ -2342,83 +2896,66 @@ scm_top_level_env (thunk)
}
SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2);
-#ifdef __STDC__
-SCM
-scm_eval2 (SCM obj, SCM env_thunk)
-#else
+
SCM
scm_eval2 (obj, env_thunk)
SCM obj;
SCM env_thunk;
-#endif
{
return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk));
}
SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval);
-#ifdef __STDC__
-SCM
-scm_eval (SCM obj)
-#else
+
SCM
scm_eval (obj)
SCM obj;
-#endif
{
return
- scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_thunk_var)));
+ scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var)));
}
-SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
-#ifdef __STDC__
-SCM
-scm_eval_x (SCM obj)
-#else
+/* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
+
SCM
scm_eval_x (obj)
SCM obj;
-#endif
{
return
scm_eval_3(obj,
0,
- scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var)));
+ scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)));
}
SCM_PROC (s_macro_eval_x, "macro-eval!", 2, 0, 0, scm_macro_eval_x);
-#ifdef __STDC__
-SCM
-scm_macro_eval_x (SCM exp, SCM env)
-#else
+
SCM
scm_macro_eval_x (exp, env)
SCM exp;
SCM env;
-#endif
{
return scm_eval_3 (exp, 0, env);
}
-#ifdef __STDC__
-SCM
-scm_definedp (SCM x, SCM env)
-#else
+
+SCM_PROC (s_definedp, "defined?", 1, 0, 0, scm_definedp);
+
SCM
-scm_definedp (x, env)
- SCM x;
- SCM env;
-#endif
+scm_definedp (sym)
+ SCM sym;
{
- SCM proc = SCM_CAR (x = SCM_CDR (x));
- if (SCM_ISYMP (proc))
+ SCM vcell;
+
+ if (SCM_ISYMP (sym))
return SCM_BOOL_T;
- else if(SCM_IMP(proc) || !SCM_SYMBOLP(proc))
- return SCM_BOOL_F;
- else
- {
- SCM vcell = scm_sym2vcell(proc, env_top_level(env), SCM_BOOL_F);
- return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ? SCM_BOOL_F : SCM_BOOL_T;
- }
+
+ SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG1, s_definedp);
+
+ vcell = scm_sym2vcell(sym,
+ SCM_CDR (scm_top_level_lookup_closure_var),
+ SCM_BOOL_F);
+ return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ?
+ SCM_BOOL_F : SCM_BOOL_T;
}
static scm_smobfuns promsmob =
@@ -2427,16 +2964,12 @@ static scm_smobfuns promsmob =
static scm_smobfuns macrosmob =
{scm_markcdr, scm_free0, prinmacro};
-#ifdef __STDC__
-SCM
-scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ())
-#else
+
SCM
scm_make_synt (name, macroizer, fcn)
char *name;
SCM (*macroizer) ();
SCM (*fcn) ();
-#endif
{
SCM symcell = scm_sysintern (name, SCM_UNDEFINED);
long tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
@@ -2445,31 +2978,25 @@ scm_make_synt (name, macroizer, fcn)
tmp = 0;
SCM_NEWCELL (z);
SCM_SUBRF (z) = fcn;
- SCM_CAR (z) = tmp + scm_tc7_subr_2;
- SCM_CDR (symcell) = macroizer (z);
+ SCM_SETCAR (z, tmp + scm_tc7_subr_2);
+ SCM_SETCDR (symcell, macroizer (z));
return SCM_CAR (symcell);
}
+
+/* At this point, scm_deval and scm_dapply are generated.
+ */
+
#ifdef DEBUG_EXTENSIONS
-# ifndef DEVAL
-# define DEVAL
-# include "eval.c"
-# endif
+# define DEVAL
+# include "eval.c"
#endif
-#ifdef __STDC__
-void
-scm_init_eval (void)
-#else
+
void
scm_init_eval ()
-#endif
{
-#ifdef DEBUG_EXTENSIONS
- enter_frame_sym = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
- exit_frame_sym = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
-#endif
scm_tc16_promise = scm_newsmob (&promsmob);
scm_tc16_macro = scm_newsmob (&macrosmob);
scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
@@ -2482,32 +3009,40 @@ scm_init_eval ()
/* acros */
scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote);
- scm_make_synt ("define", scm_makmmacro, scm_m_define);
+ scm_make_synt (s_undefine, scm_makacro, scm_m_undefine);
scm_make_synt (s_delay, scm_makacro, scm_m_delay);
/* end of acros */
- scm_top_level_lookup_thunk_var =
- scm_sysintern("*top-level-lookup-thunk*", SCM_BOOL_F);
-
- scm_make_synt ("and", scm_makmmacro, scm_m_and);
- scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
- scm_make_synt ("case", scm_makmmacro, scm_m_case);
- scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
- scm_make_synt ("do", scm_makmmacro, scm_m_do);
- scm_make_synt ("if", scm_makmmacro, scm_m_if);
+ scm_top_level_lookup_closure_var =
+ scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F);
+ scm_can_use_top_level_lookup_closure_var = 1;
+
+ scm_i_and = scm_make_synt ("and", scm_makmmacro, scm_m_and);
+ scm_i_begin = scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
+ scm_i_case = scm_make_synt ("case", scm_makmmacro, scm_m_case);
+ scm_i_cond = scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
+ scm_i_define = scm_make_synt ("define", scm_makmmacro, scm_m_define);
+ scm_i_do = scm_make_synt ("do", scm_makmmacro, scm_m_do);
+ scm_i_if = scm_make_synt ("if", scm_makmmacro, scm_m_if);
scm_i_lambda = scm_make_synt ("lambda", scm_makmmacro, scm_m_lambda);
scm_i_let = scm_make_synt ("let", scm_makmmacro, scm_m_let);
- scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
- scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
- scm_make_synt ("or", scm_makmmacro, scm_m_or);
+ scm_i_letrec = scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
+ scm_i_letstar = scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
+ scm_i_or = scm_make_synt ("or", scm_makmmacro, scm_m_or);
scm_i_quote = scm_make_synt ("quote", scm_makmmacro, scm_m_quote);
- scm_make_synt ("set!", scm_makmmacro, scm_m_set);
- scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
- scm_make_synt ("@call-with-current-continuation", scm_makmmacro, scm_m_cont);
- scm_make_synt ("defined?", scm_makmmacro, scm_definedp);
- scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
- scm_permanent_object (scm_i_name);
+ scm_i_set = scm_make_synt ("set!", scm_makmmacro, scm_m_set);
+ scm_i_atapply = scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
+ scm_i_atcall_cc = scm_make_synt ("@call-with-current-continuation",
+ scm_makmmacro, scm_m_cont);
+
+#ifdef DEBUG_EXTENSIONS
+ scm_i_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
+ scm_i_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED));
+ scm_i_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
+ scm_i_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED));
+#endif
+
#include "eval.x"
}
-#endif /* !DEVAL */
+#endif /* !DEVAL */
diff --git a/libguile/eval.h b/libguile/eval.h
index fb8c0c9ec..f83eb1560 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -66,22 +66,24 @@
-/* Evaluator */
+/* {Evaluator}
+ *
+ * For an explanation of symbols containing "EVAL", see beginning of eval.c.
+ */
#ifdef DEBUG_EXTENSIONS
-#define EVAL(x, env) (SCM_IMP(x) \
+#define XEVAL(x, env) (SCM_IMP(x) \
? (x) \
: (*scm_ceval_ptr) ((x), (env)))
#else
-#define EVAL(x, env) (SCM_IMP(x)?(x):scm_ceval((x), (env)))
+#define XEVAL(x, env) (SCM_IMP(x)?(x):scm_ceval((x), (env)))
#endif /* DEBUG_EXTENSIONS */
#define SCM_CEVAL scm_ceval
-#define SCM_APPLY scm_apply
#define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env))
-#define SCM_EXTEND_SCM_ENV scm_acons
+#define SCM_EXTEND_ENV scm_acons
extern SCM scm_i_dot;
@@ -94,8 +96,6 @@ extern SCM scm_i_else;
extern SCM scm_i_unquote;
extern SCM scm_i_uq_splicing;
extern SCM scm_i_apply;
-extern SCM scm_top_level_lookup_thunk_var;
-extern SCM scm_i_name;
/* A resolved global variable reference in the CAR position
@@ -105,114 +105,66 @@ extern SCM scm_i_name;
#define SCM_GLOC_SYM(x) (SCM_CAR((x)-1L))
#define SCM_GLOC_VAL(x) (SCM_CDR((x)-1L))
+#define SCM_GLOC_VAL_LOC(x) (SCM_CDRLOC((x)-1L))
-#ifdef __STDC__
-extern SCM * scm_ilookup (SCM iloc, SCM env);
-extern SCM * scm_lookupcar (SCM vloc, SCM genv);
-extern SCM scm_unmemocar (SCM form, SCM env);
-extern SCM scm_eval_car (SCM pair, SCM env);
-extern SCM scm_m_quote (SCM xorig, SCM env);
-extern SCM scm_m_begin (SCM xorig, SCM env);
-extern SCM scm_m_if (SCM xorig, SCM env);
-extern SCM scm_m_set (SCM xorig, SCM env);
-extern SCM scm_m_vref (SCM xorig, SCM env);
-extern SCM scm_m_vset (SCM xorig, SCM env);
-extern SCM scm_m_and (SCM xorig, SCM env);
-extern SCM scm_m_or (SCM xorig, SCM env);
-extern SCM scm_m_case (SCM xorig, SCM env);
-extern SCM scm_m_cond (SCM xorig, SCM env);
-extern SCM scm_m_lambda (SCM xorig, SCM env);
-extern SCM scm_m_letstar (SCM xorig, SCM env);
-extern SCM scm_m_do (SCM xorig, SCM env);
-extern SCM scm_m_quasiquote (SCM xorig, SCM env);
-extern SCM scm_m_delay (SCM xorig, SCM env);
-extern SCM scm_m_define (SCM x, SCM env);
-extern SCM scm_m_letrec (SCM xorig, SCM env);
-extern SCM scm_m_let (SCM xorig, SCM env);
-extern SCM scm_m_apply (SCM xorig, SCM env);
-extern SCM scm_m_cont (SCM xorig, SCM env);
-extern int scm_badargsp (SCM formals, SCM args);
-extern SCM scm_ceval (SCM x, SCM env);
-extern SCM scm_deval (SCM x, SCM env);
-extern SCM scm_procedure_documentation (SCM proc);
-extern SCM scm_nconc2last (SCM lst);
-extern SCM scm_apply (SCM proc, SCM arg1, SCM args);
-extern SCM scm_dapply (SCM proc, SCM arg1, SCM args);
-extern SCM SCM_APPLY (SCM proc, SCM arg1, SCM args);
-extern SCM scm_map (SCM proc, SCM arg1, SCM args);
-extern SCM scm_for_each (SCM proc, SCM arg1, SCM args);
-extern SCM scm_closure (SCM code, SCM env);
-extern SCM scm_makprom (SCM code);
-extern SCM scm_makacro (SCM code);
-extern SCM scm_makmacro (SCM code);
-extern SCM scm_makmmacro (SCM code);
-extern SCM scm_force (SCM x);
-extern SCM scm_promise_p (SCM x);
-extern SCM scm_copy_tree (SCM obj);
-extern SCM scm_eval_3 (SCM obj, int copyp, SCM env);
-extern SCM scm_top_level_env (SCM thunk);
-extern SCM scm_eval2 (SCM obj, SCM env_thunk);
-extern SCM scm_eval (SCM obj);
-extern SCM scm_eval_x (SCM obj);
-extern SCM scm_macro_eval_x (SCM exp, SCM env);
-extern SCM scm_definedp (SCM x, SCM env);
-extern SCM scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ());
-extern void scm_init_eval (void);
-
-#else /* STDC */
-extern SCM * scm_ilookup ();
-extern SCM * scm_lookupcar ();
-extern SCM scm_unmemocar ();
-extern SCM scm_eval_car ();
-extern SCM scm_m_quote ();
-extern SCM scm_m_begin ();
-extern SCM scm_m_if ();
-extern SCM scm_m_set ();
-extern SCM scm_m_vref ();
-extern SCM scm_m_vset ();
-extern SCM scm_m_and ();
-extern SCM scm_m_or ();
-extern SCM scm_m_case ();
-extern SCM scm_m_cond ();
-extern SCM scm_m_lambda ();
-extern SCM scm_m_letstar ();
-extern SCM scm_m_do ();
-extern SCM scm_m_quasiquote ();
-extern SCM scm_m_delay ();
-extern SCM scm_m_define ();
-extern SCM scm_m_letrec ();
-extern SCM scm_m_let ();
-extern SCM scm_m_apply ();
-extern SCM scm_m_cont ();
-extern int scm_badargsp ();
-extern SCM scm_ceval ();
-extern SCM scm_deval ();
-extern SCM scm_procedure_documentation ();
-extern SCM scm_nconc2last ();
-extern SCM scm_apply ();
-extern SCM scm_dapply ();
-extern SCM SCM_APPLY ();
-extern SCM scm_map ();
-extern SCM scm_for_each ();
-extern SCM scm_closure ();
-extern SCM scm_makprom ();
-extern SCM scm_makacro ();
-extern SCM scm_makmacro ();
-extern SCM scm_makmmacro ();
-extern SCM scm_force ();
-extern SCM scm_promise_p ();
-extern SCM scm_copy_tree ();
-extern SCM scm_eval_3 ();
-extern SCM scm_top_level_env ();
-extern SCM scm_eval2 ();
-extern SCM scm_eval ();
-extern SCM scm_eval_x ();
-extern SCM scm_macro_eval_x ();
-extern SCM scm_definedp ();
-extern SCM scm_make_synt ();
-extern void scm_init_eval ();
-
-#endif /* STDC */
+
+extern SCM * scm_ilookup SCM_P ((SCM iloc, SCM env));
+extern SCM * scm_lookupcar SCM_P ((SCM vloc, SCM genv));
+extern SCM scm_unmemocar SCM_P ((SCM form, SCM env));
+extern SCM scm_unmemocopy SCM_P ((SCM form, SCM env));
+extern SCM scm_eval_car SCM_P ((SCM pair, SCM env));
+extern SCM scm_eval_args SCM_P ((SCM i, SCM env));
+extern SCM scm_deval_args SCM_P ((SCM l, SCM env, SCM *lloc));
+extern SCM scm_m_quote SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_begin SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_if SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_set SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_vref SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_vset SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_and SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_or SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_case SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_cond SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_lambda SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_letstar SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_do SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_quasiquote SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_delay SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_define SCM_P ((SCM x, SCM env));
+extern SCM scm_m_letrec SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_let SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_apply SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_cont SCM_P ((SCM xorig, SCM env));
+extern SCM scm_m_undefine SCM_P ((SCM x, SCM env));
+extern int scm_badargsp SCM_P ((SCM formals, SCM args));
+extern SCM scm_ceval SCM_P ((SCM x, SCM env));
+extern SCM scm_deval SCM_P ((SCM x, SCM env));
+extern SCM scm_procedure_documentation SCM_P ((SCM proc));
+extern SCM scm_nconc2last SCM_P ((SCM lst));
+extern SCM scm_apply SCM_P ((SCM proc, SCM arg1, SCM args));
+extern SCM scm_dapply SCM_P ((SCM proc, SCM arg1, SCM args));
+extern SCM SCM_APPLY SCM_P ((SCM proc, SCM arg1, SCM args));
+extern SCM scm_map SCM_P ((SCM proc, SCM arg1, SCM args));
+extern SCM scm_for_each SCM_P ((SCM proc, SCM arg1, SCM args));
+extern SCM scm_closure SCM_P ((SCM code, SCM env));
+extern SCM scm_makprom SCM_P ((SCM code));
+extern SCM scm_makacro SCM_P ((SCM code));
+extern SCM scm_makmacro SCM_P ((SCM code));
+extern SCM scm_makmmacro SCM_P ((SCM code));
+extern SCM scm_force SCM_P ((SCM x));
+extern SCM scm_promise_p SCM_P ((SCM x));
+extern SCM scm_copy_tree SCM_P ((SCM obj));
+extern SCM scm_eval_3 SCM_P ((SCM obj, int copyp, SCM env));
+extern SCM scm_top_level_env SCM_P ((SCM thunk));
+extern SCM scm_eval2 SCM_P ((SCM obj, SCM env_thunk));
+extern SCM scm_eval SCM_P ((SCM obj));
+extern SCM scm_eval_x SCM_P ((SCM obj));
+extern SCM scm_macro_eval_x SCM_P ((SCM exp, SCM env));
+extern SCM scm_definedp SCM_P ((SCM sym));
+extern SCM scm_make_synt SCM_P ((char *name,
+ SCM (*macroizer) (SCM),
+ SCM (*fcn) ()));
+extern void scm_init_eval SCM_P ((void));
#endif /* EVALH */
diff --git a/libguile/extchrs.c b/libguile/extchrs.c
index 44d9a14a1..6b063da8a 100644
--- a/libguile/extchrs.c
+++ b/libguile/extchrs.c
@@ -44,17 +44,13 @@
-#ifdef FAKE_EXT_SCM_CHARS
+#ifdef SCM_FAKE_EXT_CHARS
+
-#ifdef __STDC__
-int
-xmblen (const char * str, size_t size)
-#else
int
xmblen (str, size)
const char * str;
size_t size;
-#endif
{
if (!str)
return 0;
@@ -69,15 +65,11 @@ xmblen (str, size)
return 1;
}
-#ifdef __STDC__
-int
-xwctomb (char * _str, int c)
-#else
+
int
xwctomb (_str, c)
char * _str;
int c;
-#endif
{
unsigned char * str;
str = (unsigned char *)_str;
@@ -104,16 +96,12 @@ xwctomb (_str, c)
return 4;
}
-#ifdef __STDC__
-int
-xmbtowc (xwchar_t * result, const unsigned char * _str, size_t size)
-#else
+
int
-xmbtowc (result, str, size)
+xmbtowc (result, _str, size)
xwchar_t * result;
const unsigned char * _str;
size_t size;
-#endif
{
const unsigned char * str;
str = (const unsigned char *)_str;
@@ -142,5 +130,5 @@ xmbtowc (result, str, size)
return 4;
}
-#endif /* FAKE_EXT_SCM_CHARS */
+#endif /* SCM_FAKE_EXT_CHARS */
diff --git a/libguile/extchrs.h b/libguile/extchrs.h
index 8d17c4681..3f1f02276 100644
--- a/libguile/extchrs.h
+++ b/libguile/extchrs.h
@@ -46,9 +46,11 @@
#include <stdlib.h>
-#define FAKE_EXT_SCM_CHARS 1
+#include "libguile/__scm.h"
-#if !defined(FAKE_EXT_SCM_CHARS)
+#define SCM_FAKE_EXT_CHARS 1
+
+#if !defined(SCM_FAKE_EXT_CHARS)
#define xmblen mblen
#define xwctomb wctomb
@@ -63,21 +65,10 @@ typedef unsigned short xwchar_t;
#endif
-
-#ifdef __STDC__
-extern int xmblen (const char * str, size_t size);
-extern int xwctomb (char * _str, int c);
-extern int xmbtowc (xwchar_t * result, const unsigned char * _str, size_t size);
-
-#else /* STDC */
-extern int xmblen ();
-extern int xwctomb ();
-extern int xmbtowc ();
-
-#endif /* STDC */
-
-
+extern int xmblen SCM_P ((const char * str, size_t size));
+extern int xwctomb SCM_P ((char * _str, int c));
+extern int xmbtowc SCM_P ((xwchar_t * result, const unsigned char * _str, size_t size));
#endif /* EXTCHRSH */
diff --git a/libguile/feature.c b/libguile/feature.c
index b4622b7e9..9aaee678c 100644
--- a/libguile/feature.c
+++ b/libguile/feature.c
@@ -43,73 +43,57 @@
#include <stdio.h>
#include "_scm.h"
+#include "feature.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
-SCM *scm_loc_features;
+static SCM *scm_loc_features;
-#ifdef __STDC__
-void
-scm_add_feature(char* str)
-#else
void
scm_add_feature(str)
char* str;
-#endif
-{
- *scm_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))), *scm_loc_features);
-}
-
-
-
-/* {Help finding slib}
- */
-
-
-SCM_PROC(s_compiled_library_path, "compiled-library-path", 0, 0, 0, scm_compiled_library_path);
-#ifdef __STDC__
-SCM
-scm_compiled_library_path (void)
-#else
-SCM
-scm_compiled_library_path ()
-#endif
{
-#ifndef LIBRARY_PATH
- return SCM_BOOL_F;
-#else
- return scm_makfrom0str (LIBRARY_PATH);
-#endif
+ *scm_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))),
+ *scm_loc_features);
}
-
SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments);
-#ifdef __STDC__
-SCM
-scm_program_arguments (void)
-#else
+
SCM
scm_program_arguments ()
-#endif
{
return scm_progargs;
}
+/* Set the value returned by program-arguments, given ARGC and ARGV.
+ If FIRST is non-zero, make it the first element; we do this in
+ situations where other code (like getopt) has parsed out a few
+ arguments, but we still want the script name to be the first
+ element. */
+void
+scm_set_program_arguments (argc, argv, first)
+ int argc;
+ char **argv;
+ char *first;
+{
+ scm_progargs = scm_makfromstrs (argc, argv);
+ if (first)
+ scm_progargs = scm_cons (scm_makfrom0str (first), scm_progargs);
+}
-#ifdef __STDC__
-void
-scm_init_feature(void)
-#else
void
scm_init_feature()
-#endif
{
- scm_loc_features = &SCM_CDR(scm_sysintern("*features*", SCM_EOL));
+ scm_loc_features = SCM_CDRLOC (scm_sysintern ("*features*", SCM_EOL));
#ifdef RECKLESS
scm_add_feature("reckless");
#endif
@@ -128,8 +112,10 @@ scm_init_feature()
#ifndef CHEAP_CONTINUATIONS
scm_add_feature ("full-continuation");
#endif
-
-
- scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_SCM_CODE_LIMIT));
+#ifdef USE_THREADS
+ scm_add_feature ("threads");
+#endif
+
+ scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT));
#include "feature.x"
}
diff --git a/libguile/feature.h b/libguile/feature.h
index c1f7b1cb8..712aff8a0 100644
--- a/libguile/feature.h
+++ b/libguile/feature.h
@@ -44,26 +44,12 @@
*/
-#include "__scm.h"
-
-
-
-extern SCM *scm_loc_features;
-
-
-#ifdef __STDC__
-extern void scm_add_feature(char* str);
-extern SCM scm_compiled_library_path (void);
-extern SCM scm_program_arguments (void);
-extern void scm_init_feature(void);
-
-#else /* STDC */
-extern void scm_add_feature();
-extern SCM scm_compiled_library_path ();
-extern SCM scm_program_arguments ();
-extern void scm_init_feature();
-
-#endif /* STDC */
+#include "libguile/__scm.h"
+extern void scm_add_feature SCM_P((char* str));
+extern SCM scm_program_arguments SCM_P((void));
+extern void scm_set_program_arguments SCM_P ((int argc, char **argv,
+ char *first));
+extern void scm_init_feature SCM_P((void));
#endif /* FEATUREH */
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 5ca9b309c..723632072 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -39,8 +39,14 @@
* If you do not wish that, delete this exception notice.
*/
+#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "smob.h"
+#include "feature.h"
+#include "fports.h"
+#include "filesys.h"
#ifdef TIME_WITH_SYS_TIME
# include <sys/time.h>
@@ -57,10 +63,19 @@
#include <unistd.h>
#endif
+#ifdef LIBC_H_WITH_UNISTD_H
+#include <libc.h>
+#endif
+
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
#endif
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
@@ -101,105 +116,70 @@
# endif
#endif
+/* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
+#if defined (S_IFSOCK) && ! defined (S_ISSOCK)
+#define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
+#endif
-#ifdef O_CREAT
-SCM_CONST_LONG (scm_O_CREAT, "O_CREAT", O_CREAT);
-#endif
-
-#ifdef O_EXCL
-SCM_CONST_LONG (scm_O_EXCL, "O_EXCL", O_EXCL);
-#endif
-
-#ifdef O_NOCTTY
-SCM_CONST_LONG (scm_O_NOCTTY, "O_NOCTTY", O_NOCTTY);
-#endif
-
-#ifdef O_TRUNC
-SCM_CONST_LONG (scm_O_TRUNC, "O_TRUNC", O_TRUNC);
-#endif
-
-#ifdef O_APPEND
-SCM_CONST_LONG (scm_O_APPEND, "O_APPEND", O_APPEND);
-#endif
-
-#ifdef O_NONBLOCK
-SCM_CONST_LONG (scm_O_NONBLOCK, "O_NONBLOCK", O_NONBLOCK);
-#endif
-
-#ifdef O_NDELAY
-SCM_CONST_LONG (scm_O_NDELAY, "O_NDELAY", O_NDELAY);
-#endif
-
-#ifdef O_SYNC
-SCM_CONST_LONG (scm_O_SYNC, "O_SYNC", O_SYNC);
-#endif
-
-
/* {Permissions}
*/
-SCM_PROC (s_sys_chown, "%chown", 3, 0, 0, scm_sys_chown);
-#ifdef __STDC__
-SCM
-scm_sys_chown (SCM path, SCM owner, SCM group)
-#else
+SCM_PROC (s_chown, "chown", 3, 0, 0, scm_chown);
+
SCM
-scm_sys_chown (path, owner, group)
+scm_chown (path, owner, group)
SCM path;
SCM owner;
SCM group;
-#endif
{
int val;
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_chown);
+
+ SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_chown);
if (SCM_SUBSTRP (path))
path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
- SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_sys_chown);
- SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_sys_chown);
- SCM_SYSCALL (val = chown (SCM_ROCHARS (path), SCM_INUM (owner), SCM_INUM (group)));
- return val ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_chown);
+ SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_chown);
+ SCM_SYSCALL (val = chown (SCM_ROCHARS (path),
+ SCM_INUM (owner), SCM_INUM (group)));
+ if (val != 0)
+ scm_syserror (s_chown);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_chmod, "%chmod", 2, 0, 0, scm_sys_chmod);
-#ifdef __STDC__
-SCM
-scm_sys_chmod (SCM port_or_path, SCM mode)
-#else
+SCM_PROC (s_chmod, "chmod", 2, 0, 0, scm_chmod);
+
SCM
-scm_sys_chmod (port_or_path, mode)
+scm_chmod (port_or_path, mode)
SCM port_or_path;
SCM mode;
-#endif
{
int rv;
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_chmod);
- SCM_ASSERT (SCM_NIMP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod);
+ SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_chmod);
+ SCM_ASSERT (SCM_NIMP (port_or_path), port_or_path, SCM_ARG1, s_chmod);
if (SCM_STRINGP (port_or_path))
SCM_SYSCALL (rv = chmod (SCM_CHARS (port_or_path), SCM_INUM (mode)));
else
{
- SCM_ASSERT (SCM_OPFPORTP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod);
+ SCM_ASSERT (SCM_OPFPORTP (port_or_path), port_or_path, SCM_ARG1, s_chmod);
rv = fileno ((FILE *)SCM_STREAM (port_or_path));
if (rv != -1)
SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode)));
}
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (rv != 0)
+ scm_syserror (s_chmod);
+ return SCM_UNSPECIFIED;
}
SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask);
-#ifdef __STDC__
-SCM
-scm_umask (SCM mode)
-#else
+
SCM
scm_umask (mode)
SCM mode;
-#endif
{
mode_t mask;
if (SCM_UNBNDP (mode))
@@ -216,325 +196,90 @@ scm_umask (mode)
}
-/* {File Descriptors}
- */
-long scm_tc16_fd;
-
-#ifdef __STDC__
-static int
-scm_fd_print (SCM sexp, SCM port, int writing)
-#else
-static int
-scm_fd_print (sexp, port, writing)
- SCM sexp;
- SCM port;
- int writing;
-#endif
-{
- scm_gen_puts (scm_regular_string, "#<fd ", port);
- scm_intprint (SCM_CDR (sexp), 10, port);
- scm_gen_puts (scm_regular_string, ">", port);
- return 1;
-}
-
-#ifdef __STDC__
-static scm_sizet
-scm_fd_free (SCM p)
-#else
-static scm_sizet
-scm_fd_free (p)
- SCM p;
-#endif
-{
- SCM flags;
-
- flags = SCM_FD_FLAGS (p);
- if ((scm_close_fd_on_gc & flags) && (scm_fd_is_open & flags))
- {
- SCM_SYSCALL( close (SCM_FD (p)) );
- }
- return 0;
-}
-static scm_smobfuns fd_smob = {scm_mark0, scm_fd_free, scm_fd_print, 0};
+SCM_PROC (s_open, "open", 2, 1, 0, scm_open);
-#ifdef __STDC__
SCM
-scm_intern_fd (int fd, int flags)
-#else
-SCM
-scm_intern_fd (fd, flags)
- int fd;
- int flags;
-#endif
-{
- SCM it;
- SCM_NEWCELL (it);
- SCM_REDEFER_INTS;
- SCM_SETCAR (it, (scm_tc16_fd | (flags << 16)));
- SCM_SETCDR (it, (SCM)fd);
- SCM_REALLOW_INTS;
- return it;
-}
-
-
-
-SCM_PROC (s_sys_open, "%open", 3, 0, 0, scm_sys_open);
-#ifdef __STDC__
-SCM
-scm_sys_open (SCM path, SCM flags, SCM mode)
-#else
-SCM
-scm_sys_open (path, flags, mode)
+scm_open (path, flags, mode)
SCM path;
SCM flags;
SCM mode;
-#endif
-{
- int fd;
- SCM sfd;
-
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_open);
- SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG2, s_sys_open);
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_sys_open);
-
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
-
- SCM_DEFER_INTS;
- SCM_SYSCALL ( fd = open (SCM_ROCHARS (path), SCM_INUM (flags), SCM_INUM (mode)) );
- if (fd == -1)
- sfd = SCM_MAKINUM (errno);
- else
- sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
- SCM_ALLOW_INTS;
-
- return scm_return_first (sfd, path);
-}
-
-
-SCM_PROC (s_sys_create, "%create", 2, 0, 0, scm_sys_create);
-#ifdef __STDC__
-SCM
-scm_sys_create (SCM path, SCM mode)
-#else
-SCM
-scm_sys_create (path, mode)
- SCM path;
- SCM mode;
-#endif
{
int fd;
- SCM sfd;
+ SCM newpt;
+ FILE *f;
+ char *port_mode;
+ int iflags;
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_create);
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_create);
+ SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_open);
+ iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open);
if (SCM_SUBSTRP (path))
path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
SCM_DEFER_INTS;
- SCM_SYSCALL ( fd = creat (SCM_ROCHARS (path), SCM_INUM (mode)) );
- if (fd == -1)
- sfd = SCM_MAKINUM (errno);
- else
- sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
- SCM_ALLOW_INTS;
-
- return scm_return_first (sfd, path);
-}
-
-
-SCM_PROC (s_sys_close, "%close", 1, 0, 0, scm_sys_close);
-#ifdef __STDC__
-SCM
-scm_sys_close (SCM sfd)
-#else
-SCM
-scm_sys_close (sfd)
- SCM sfd;
-#endif
-{
- int fd;
- int got;
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_close);
- fd = SCM_FD (sfd);
-
- SCM_DEFER_INTS;
- got = close (fd);
- SCM_SETCAR (sfd, scm_tc16_fd);
- SCM_ALLOW_INTS;
- return (got == -1 ? SCM_MAKINUM (errno) : SCM_BOOL_T);
-}
-
-
-SCM_PROC (s_sys_write_fd, "%write-fd", 2, 0, 0, scm_sys_write_fd);
-#ifdef __STDC__
-SCM
-scm_sys_write_fd (SCM sfd, SCM buf)
-#else
-SCM
-scm_sys_write_fd (sfd, buf)
- SCM sfd;
- SCM buf;
-#endif
-{
- SCM answer;
- int fd;
- size_t written;
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_write_fd);
- SCM_ASSERT (SCM_NIMP (buf) && SCM_ROSTRINGP (buf), buf, SCM_ARG2, s_sys_write_fd);
- fd = SCM_FD (sfd);
- SCM_DEFER_INTS;
- written = write (fd, SCM_ROCHARS (buf), SCM_ROLENGTH (buf));
- if (written == -1)
- answer = scm_cons (SCM_MAKINUM (errno), SCM_EOL);
- else
- answer = scm_long2num (written);
- SCM_ALLOW_INTS;
- return scm_return_first (answer, buf);
-}
-
-
-SCM_PROC (s_sys_read_fd, "%read-fd", 2, 2, 0, scm_sys_read_fd);
-#ifdef __STDC__
-SCM
-scm_sys_read_fd (SCM sfd, SCM buf, SCM offset, SCM length)
-#else
-SCM
-scm_sys_read_fd (sfd, buf, offset, length)
- SCM sfd;
- SCM buf;
- SCM offset;
- SCM length;
-#endif
-{
- SCM answer;
- int fd;
- char * bytes;
- int off;
- int len;
- size_t got;
-
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_read_fd);
- fd = SCM_FD (sfd);
-
- SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_sys_read_fd);
- bytes = SCM_CHARS (buf);
-
- if (SCM_UNBNDP (offset))
- off = 0;
- else
- {
- SCM_ASSERT (SCM_INUMP (offset), offset, SCM_ARG3, s_sys_read_fd);
- off = SCM_INUM (offset);
- }
-
- if (SCM_UNBNDP (length))
- len = SCM_LENGTH (buf);
+ if (SCM_UNBNDP (mode))
+ SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags));
else
{
- SCM_ASSERT (SCM_INUMP (length), length, SCM_ARG3, s_sys_read_fd);
- len = SCM_INUM (length);
+ SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_open);
+ SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, SCM_INUM (mode)));
}
-
- SCM_DEFER_INTS;
- got = read (fd, bytes + off, len);
- if (got == -1)
- answer = scm_cons (SCM_MAKINUM (errno), SCM_EOL);
- else
- answer = scm_long2num (got);
- SCM_ALLOW_INTS;
- return scm_return_first (answer, buf);
-}
-
-SCM_PROC (s_sys_lseek, "%lseek", 2, 1, 0, scm_sys_lseek);
-#ifdef __STDC__
-SCM
-scm_sys_lseek (SCM sfd, SCM offset, SCM whence)
-#else
-SCM
-scm_sys_lseek (sfd, offset, whence)
- SCM sfd;
- SCM offset;
- SCM whence;
-#endif
-{
- SCM answer;
- int fd;
- long off;
- int wh;
- long got;
-
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_lseek);
- fd = SCM_FD (sfd);
-
- off = scm_num2long (offset, (char *)SCM_ARG2, s_sys_lseek);
- if (SCM_UNBNDP (whence))
- wh = SEEK_SET;
- else
+ if (fd == -1)
+ scm_syserror (s_open);
+ SCM_NEWCELL (newpt);
+ if (iflags & O_RDWR)
+ port_mode = "r+";
+ else {
+ if (iflags & O_WRONLY)
+ port_mode = "w";
+ else
+ port_mode = "r";
+ }
+ f = fdopen (fd, port_mode);
+ if (!f)
{
- SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_sys_lseek);
- wh = SCM_INUM (whence);
+ SCM_SYSCALL (close (fd));
+ scm_syserror (s_open);
}
-
- SCM_DEFER_INTS;
- SCM_SYSCALL (got = lseek (fd, off, wh));
- if (got == -1)
- answer = SCM_MAKINUM (errno);
- else
- answer = scm_long2num (got);
+ {
+ struct scm_port_table * pt;
+
+ pt = scm_add_to_port_table (newpt);
+ SCM_SETPTAB_ENTRY (newpt, pt);
+ SCM_SETCAR (newpt, scm_tc16_fport | scm_mode_bits (port_mode));
+ /* if (SCM_BUF0 & SCM_CAR (newpt))
+ scm_setbuf0 (newpt); */
+ SCM_SETSTREAM (newpt, (SCM)f);
+ SCM_PTAB_ENTRY (newpt)->file_name = path;
+ }
SCM_ALLOW_INTS;
- return answer;
-}
-
-
-SCM_PROC (s_sys_dup, "%dup", 1, 1, 0, scm_sys_dup);
-#ifdef __STDC__
-SCM
-scm_sys_dup (SCM oldfd, SCM newfd)
-#else
-SCM
-scm_sys_dup (oldfd, newfd)
- SCM oldfd;
- SCM newfd;
-#endif
-{
- SCM answer;
- int fd;
- int nfd;
- int (*fn)();
- SCM_ASSERT (SCM_NIMP (oldfd) && SCM_FD_P (oldfd), oldfd, SCM_ARG1, s_sys_dup);
- SCM_ASSERT (SCM_UNBNDP (newfd) || SCM_INUMP (newfd), newfd, SCM_ARG2, s_sys_dup);
- fd = SCM_FD (oldfd);
- nfd = (SCM_INUMP (newfd) ? SCM_INUM (newfd) : -1);
-
- SCM_DEFER_INTS;
- fn = ((nfd == -1) ? (int (*)())dup : (int (*)())dup2);
- nfd = fn (fd, nfd);
- answer = (nfd == -1
- ? scm_cons (SCM_MAKINUM (errno), SCM_EOL)
- : SCM_MAKINUM (nfd));
- SCM_ALLOW_INTS;
- return answer;
+ return newpt;
}
-
/* {Files}
*/
-#ifdef __STDC__
-static SCM
-scm_stat2scm (struct stat *stat_temp)
-#else
+
+SCM_SYMBOL (scm_sym_regular, "regular");
+SCM_SYMBOL (scm_sym_directory, "directory");
+SCM_SYMBOL (scm_sym_symlink, "symlink");
+SCM_SYMBOL (scm_sym_block_special, "block-special");
+SCM_SYMBOL (scm_sym_char_special, "char-special");
+SCM_SYMBOL (scm_sym_fifo, "fifo");
+SCM_SYMBOL (scm_sym_sock, "socket");
+SCM_SYMBOL (scm_sym_unknown, "unknown");
+
+static SCM scm_stat2scm SCM_P ((struct stat *stat_temp));
+
static SCM
scm_stat2scm (stat_temp)
struct stat *stat_temp;
-#endif
{
- SCM ans = scm_make_vector (SCM_MAKINUM (13), SCM_UNSPECIFIED, SCM_BOOL_F);
+ SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED, SCM_BOOL_F);
SCM *ve = SCM_VELTS (ans);
+
ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev);
ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino);
ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode);
@@ -560,47 +305,101 @@ scm_stat2scm (stat_temp)
#else
ve[12] = SCM_BOOL_F;
#endif
+ {
+ int mode = stat_temp->st_mode;
+
+ if (S_ISREG (mode))
+ ve[13] = scm_sym_regular;
+ else if (S_ISDIR (mode))
+ ve[13] = scm_sym_directory;
+ else if (S_ISLNK (mode))
+ ve[13] = scm_sym_symlink;
+ else if (S_ISBLK (mode))
+ ve[13] = scm_sym_block_special;
+ else if (S_ISCHR (mode))
+ ve[13] = scm_sym_char_special;
+ else if (S_ISFIFO (mode))
+ ve[13] = scm_sym_fifo;
+ else if (S_ISSOCK (mode))
+ ve[13] = scm_sym_sock;
+ else
+ ve[13] = scm_sym_unknown;
+
+ ve[14] = SCM_MAKINUM ((~S_IFMT) & mode);
+
+ /* the layout of the bits in ve[14] is intended to be portable.
+ If there are systems that don't follow the usual convention,
+ the following could be used:
+
+ tmp = 0;
+ if (S_ISUID & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IRGRP & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_ISVTX & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IRUSR & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IWUSR & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IXUSR & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IWGRP & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IXGRP & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IROTH & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IWOTH & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IXOTH & mode) tmp += 1;
+
+ ve[14] = SCM_MAKINUM (tmp);
+
+ */
+ }
return ans;
}
-SCM_PROC (s_sys_stat, "%stat", 1, 0, 0, scm_sys_stat);
-#ifdef __STDC__
-SCM
-scm_sys_stat (SCM fd_or_path)
-#else
+SCM_PROC (s_stat, "stat", 1, 0, 0, scm_stat);
+
SCM
-scm_sys_stat (fd_or_path)
- SCM fd_or_path;
-#endif
+scm_stat (file)
+ SCM file;
{
- int rv;
+ int rv = 1;
struct stat stat_temp;
- if (SCM_INUMP (fd_or_path))
- {
- SCM_ASSERT (SCM_OPFPORTP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat);
- rv = SCM_INUM (fd_or_path);
- SCM_SYSCALL (rv = fstat (rv, &stat_temp));
- }
- else if (SCM_NIMP (fd_or_path) && SCM_FD_P (fd_or_path))
- {
- rv = SCM_FD (fd_or_path);
- SCM_SYSCALL (rv = fstat (rv, &stat_temp));
- }
+ if (SCM_INUMP (file))
+ SCM_SYSCALL (rv = fstat (SCM_INUM (file), &stat_temp));
else
{
- SCM_ASSERT (SCM_NIMP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat);
- SCM_ASSERT (SCM_ROSTRINGP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat);
- if (SCM_ROSTRINGP (fd_or_path))
+ SCM_ASSERT (SCM_NIMP (file), file, SCM_ARG1, s_stat);
+ if (SCM_FPORTP (file))
+ SCM_SYSCALL (rv = fstat (fileno ((FILE *) SCM_STREAM (file)),
+ &stat_temp));
+ else
{
- if (SCM_SUBSTRP (fd_or_path))
- fd_or_path = scm_makfromstr (SCM_ROCHARS (fd_or_path), SCM_ROLENGTH (fd_or_path), 0);
- SCM_SYSCALL (rv = stat (SCM_CHARS (fd_or_path), &stat_temp));
+ SCM_ASSERT (SCM_ROSTRINGP (file), file, SCM_ARG1, s_stat);
+ if (SCM_SUBSTRP (file))
+ file = scm_makfromstr (SCM_ROCHARS (file),
+ SCM_ROLENGTH (file),
+ 0);
+ SCM_SYSCALL (rv = stat (SCM_CHARS (file), &stat_temp));
}
+ }
+ if (rv != 0)
+ {
+ int en = errno;
+ scm_syserror_msg (s_stat, "%s: %S",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ file,
+ SCM_UNDEFINED),
+ en);
}
- return rv ? SCM_MAKINUM (errno) : scm_stat2scm (&stat_temp);
+ return scm_stat2scm (&stat_temp);
}
@@ -608,79 +407,88 @@ scm_sys_stat (fd_or_path)
/* {Modifying Directories}
*/
-SCM_PROC (s_sys_link, "%link", 2, 0, 0, scm_sys_link);
-#ifdef __STDC__
-SCM
-scm_sys_link (SCM oldpath, SCM newpath)
-#else
+SCM_PROC (s_link, "link", 2, 0, 0, scm_link);
+
SCM
-scm_sys_link (oldpath, newpath)
+scm_link (oldpath, newpath)
SCM oldpath;
SCM newpath;
-#endif
{
int val;
- SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_sys_link);
+
+ SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_link);
if (SCM_SUBSTRP (oldpath))
oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0);
- SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, s_sys_link);
+ SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, s_link);
if (SCM_SUBSTRP (newpath))
newpath = scm_makfromstr (SCM_ROCHARS (newpath), SCM_ROLENGTH (newpath), 0);
SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
- return val ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (val != 0)
+ scm_syserror (s_link);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_rename, "%rename-file", 2, 0, 0, scm_sys_rename);
-#ifdef __STDC__
-SCM
-scm_sys_rename (SCM oldname, SCM newname)
-#else
+SCM_PROC (s_rename, "rename-file", 2, 0, 0, scm_rename);
+
SCM
-scm_sys_rename (oldname, newname)
+scm_rename (oldname, newname)
SCM oldname;
SCM newname;
-#endif
{
int rv;
- SCM_ASSERT (SCM_NIMP (oldname) && SCM_STRINGP (oldname), oldname, SCM_ARG1, s_sys_rename);
- SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_sys_rename);
+ SCM_ASSERT (SCM_NIMP (oldname) && SCM_STRINGP (oldname), oldname, SCM_ARG1, s_rename);
+ SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_rename);
#ifdef HAVE_RENAME
SCM_SYSCALL (rv = rename (SCM_CHARS (oldname), SCM_CHARS (newname)));
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (rv != 0)
+ scm_syserror (s_rename);
+ return SCM_UNSPECIFIED;
#else
SCM_DEFER_INTS;
SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname)));
- if (!rv)
+ if (rv == 0)
{
SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));;
- if (rv)
+ if (rv != 0)
/* unlink failed. remove new name */
SCM_SYSCALL (unlink (SCM_CHARS (newname)));
}
SCM_ALLOW_INTS;
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (rv != 0)
+ scm_syserror (s_rename);
+ return SCM_UNSPECIFIED;
#endif
}
+SCM_PROC(s_delete_file, "delete-file", 1, 0, 0, scm_delete_file);
-SCM_PROC (s_sys_mkdir, "%mkdir", 1, 1, 0, scm_sys_mkdir);
-#ifdef __STDC__
SCM
-scm_sys_mkdir (SCM path, SCM mode)
-#else
+scm_delete_file (str)
+ SCM str;
+{
+ int ans;
+ SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_delete_file);
+ SCM_SYSCALL (ans = unlink (SCM_CHARS (str)));
+ if (ans != 0)
+ scm_syserror (s_delete_file);
+ return SCM_UNSPECIFIED;
+}
+
+
+SCM_PROC (s_mkdir, "mkdir", 1, 1, 0, scm_mkdir);
+
SCM
-scm_sys_mkdir (path, mode)
+scm_mkdir (path, mode)
SCM path;
SCM mode;
-#endif
{
#ifdef HAVE_MKDIR
int rv;
mode_t mask;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_mkdir);
+ SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_mkdir);
if (SCM_UNBNDP (mode))
{
mask = umask (0);
@@ -689,33 +497,38 @@ scm_sys_mkdir (path, mode)
}
else
{
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_mkdir);
+ SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_mkdir);
SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), SCM_INUM (mode)));
}
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (rv != 0)
+ scm_syserror (s_mkdir);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_mkdir);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_rmdir, "%rmdir", 1, 0, 0, scm_sys_rmdir);
-#ifdef __STDC__
-SCM
-scm_sys_rmdir (SCM path)
-#else
+SCM_PROC (s_rmdir, "rmdir", 1, 0, 0, scm_rmdir);
+
SCM
-scm_sys_rmdir (path)
+scm_rmdir (path)
SCM path;
-#endif
{
#ifdef HAVE_RMDIR
int val;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_rmdir);
+
+ SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_rmdir);
SCM_SYSCALL (val = rmdir (SCM_CHARS (path)));
- return val ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (val != 0)
+ scm_syserror (s_rmdir);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_rmdir);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
@@ -725,66 +538,52 @@ scm_sys_rmdir (path)
long scm_tc16_dir;
-SCM_PROC (s_sys_opendir, "%opendir", 1, 0, 0, scm_sys_opendir);
-#ifdef __STDC__
-SCM
-scm_sys_opendir (SCM dirname)
-#else
+SCM_PROC (s_opendir, "opendir", 1, 0, 0, scm_opendir);
+
SCM
-scm_sys_opendir (dirname)
+scm_opendir (dirname)
SCM dirname;
-#endif
{
DIR *ds;
SCM dir;
- SCM_ASSERT (SCM_NIMP (dirname) && SCM_STRINGP (dirname), dirname, SCM_ARG1, s_sys_opendir);
+ SCM_ASSERT (SCM_NIMP (dirname) && SCM_STRINGP (dirname), dirname, SCM_ARG1, s_opendir);
SCM_NEWCELL (dir);
SCM_DEFER_INTS;
SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname)));
- if (!ds)
- {
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
- }
- SCM_CAR (dir) = scm_tc16_dir | SCM_OPN;
+ if (ds == NULL)
+ scm_syserror (s_opendir);
+ SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN);
SCM_SETCDR (dir, ds);
SCM_ALLOW_INTS;
return dir;
}
-SCM_PROC (s_sys_readdir, "%readdir", 1, 0, 0, scm_sys_readdir);
-#ifdef __STDC__
-SCM
-scm_sys_readdir (SCM port)
-#else
+SCM_PROC (s_readdir, "readdir", 1, 0, 0, scm_readdir);
+
SCM
-scm_sys_readdir (port)
+scm_readdir (port)
SCM port;
-#endif
{
struct dirent *rdent;
SCM_DEFER_INTS;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_sys_readdir);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_readdir);
errno = 0;
SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
SCM_ALLOW_INTS;
- return (rdent
- ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
- : (errno ? SCM_MAKINUM (errno) : SCM_EOF_VAL));
+ if (errno != 0)
+ scm_syserror (s_readdir);
+ return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
+ : SCM_EOF_VAL);
}
SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir);
-#ifdef __STDC__
-SCM
-scm_rewinddir (SCM port)
-#else
+
SCM
scm_rewinddir (port)
SCM port;
-#endif
{
SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_rewinddir);
rewinddir ((DIR *) SCM_CDR (port));
@@ -793,60 +592,50 @@ scm_rewinddir (port)
-SCM_PROC (s_sys_closedir, "%closedir", 1, 0, 0, scm_sys_closedir);
-#ifdef __STDC__
-SCM
-scm_sys_closedir (SCM port)
-#else
+SCM_PROC (s_closedir, "closedir", 1, 0, 0, scm_closedir);
+
SCM
-scm_sys_closedir (port)
+scm_closedir (port)
SCM port;
-#endif
{
int sts;
- SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_sys_closedir);
+
+ SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_closedir);
SCM_DEFER_INTS;
if (SCM_CLOSEDP (port))
{
SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
+ return SCM_UNSPECIFIED;
}
SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
- if (sts)
- {
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
- }
- SCM_CAR (port) = scm_tc16_dir;
+ if (sts != 0)
+ scm_syserror (s_closedir);
+ SCM_SETCAR (port, scm_tc16_dir);
SCM_ALLOW_INTS;
- return SCM_BOOL_T;
+ return SCM_UNSPECIFIED;
}
-#ifdef __STDC__
-static int
-scm_dir_print (SCM sexp, SCM port, int writing)
-#else
+
+static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
+
static int
-scm_dir_print (sexp, port, writing)
+scm_dir_print (sexp, port, pstate)
SCM sexp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_prinport (sexp, port, "directory");
return 1;
}
-#ifdef __STDC__
-static scm_sizet
-scm_dir_free (SCM p)
-#else
+
+static scm_sizet scm_dir_free SCM_P ((SCM p));
+
static scm_sizet
scm_dir_free (p)
SCM p;
-#endif
{
if (SCM_OPENP (p))
closedir ((DIR *) SCM_CDR (p));
@@ -860,32 +649,27 @@ static scm_smobfuns dir_smob = {scm_mark0, scm_dir_free, scm_dir_print, 0};
*/
-SCM_PROC (s_sys_chdir, "%chdir", 1, 0, 0, scm_sys_chdir);
-#ifdef __STDC__
-SCM
-scm_sys_chdir (SCM str)
-#else
+SCM_PROC (s_chdir, "chdir", 1, 0, 0, scm_chdir);
+
SCM
-scm_sys_chdir (str)
+scm_chdir (str)
SCM str;
-#endif
{
int ans;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_chdir);
+
+ SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_chdir);
SCM_SYSCALL (ans = chdir (SCM_CHARS (str)));
- return ans ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (ans != 0)
+ scm_syserror (s_chdir);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_getcwd, "%getcwd", 0, 0, 0, scm_sys_getcwd);
-#ifdef __STDC__
-SCM
-scm_sys_getcwd (void)
-#else
+SCM_PROC (s_getcwd, "getcwd", 0, 0, 0, scm_getcwd);
+
SCM
-scm_sys_getcwd ()
-#endif
+scm_getcwd ()
{
#ifdef HAVE_GETCWD
char *rv;
@@ -895,36 +679,35 @@ scm_sys_getcwd ()
SCM result;
SCM_DEFER_INTS;
- wd = scm_must_malloc (size, s_sys_getcwd);
+ wd = scm_must_malloc (size, s_getcwd);
while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
{
scm_must_free (wd);
size *= 2;
- wd = scm_must_malloc (size, s_sys_getcwd);
+ wd = scm_must_malloc (size, s_getcwd);
}
- if (rv != 0)
- result = scm_makfromstr (wd, strlen (wd), 0);
- else
- result = SCM_MAKINUM (errno);
+ if (rv == 0)
+ scm_syserror (s_getcwd);
+ result = scm_makfromstr (wd, strlen (wd), 0);
scm_must_free (wd);
SCM_ALLOW_INTS;
return result;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_getcwd);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-#ifdef __STDC__
-static void
-fill_select_type (SELECT_TYPE * set, SCM list)
-#else
+
+static void fill_select_type SCM_P ((SELECT_TYPE * set, SCM list));
+
static void
fill_select_type (set, list)
SELECT_TYPE * set;
SCM list;
-#endif
{
while (list != SCM_EOL)
{
@@ -934,21 +717,17 @@ fill_select_type (set, list)
FD_SET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set);
else if (SCM_INUMP (SCM_CAR (list)))
FD_SET (SCM_INUM (SCM_CAR (list)), set);
- else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list)))
- FD_SET (SCM_FD (SCM_CAR (list)), set);
list = SCM_CDR (list);
}
}
-#ifdef __STDC__
-static SCM
-retrieve_select_type (SELECT_TYPE * set, SCM list)
-#else
+
+static SCM retrieve_select_type SCM_P ((SELECT_TYPE * set, SCM list));
+
static SCM
retrieve_select_type (set, list)
SELECT_TYPE * set;
SCM list;
-#endif
{
SCM answer;
answer = SCM_EOL;
@@ -966,30 +745,24 @@ retrieve_select_type (set, list)
if (FD_ISSET (SCM_INUM (SCM_CAR (list)), set))
answer = scm_cons (SCM_CAR (list), answer);
}
- else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list)))
- {
- if (FD_ISSET (SCM_FD (SCM_CAR (list)), set))
- answer = scm_cons (SCM_CAR (list), answer);
- }
list = SCM_CDR (list);
}
return answer;
}
-SCM_PROC (s_sys_select, "%select", 3, 2, 0, scm_sys_select);
-#ifdef __STDC__
-SCM
-scm_sys_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs)
-#else
+/* {Checking for events}
+ */
+
+SCM_PROC (s_select, "select", 3, 2, 0, scm_select);
+
SCM
-scm_sys_select (reads, writes, excepts, secs, msecs)
+scm_select (reads, writes, excepts, secs, msecs)
SCM reads;
SCM writes;
SCM excepts;
SCM secs;
SCM msecs;
-#endif
{
#ifdef HAVE_SELECT
struct timeval timeout;
@@ -999,9 +772,9 @@ scm_sys_select (reads, writes, excepts, secs, msecs)
SELECT_TYPE except_set;
int sreturn;
- SCM_ASSERT (-1 < scm_ilength (reads), reads, SCM_ARG1, s_sys_select);
- SCM_ASSERT (-1 < scm_ilength (writes), reads, SCM_ARG1, s_sys_select);
- SCM_ASSERT (-1 < scm_ilength (excepts), reads, SCM_ARG1, s_sys_select);
+ SCM_ASSERT (-1 < scm_ilength (reads), reads, SCM_ARG1, s_select);
+ SCM_ASSERT (-1 < scm_ilength (writes), reads, SCM_ARG1, s_select);
+ SCM_ASSERT (-1 < scm_ilength (excepts), reads, SCM_ARG1, s_select);
FD_ZERO (&read_set);
FD_ZERO (&write_set);
@@ -1015,11 +788,11 @@ scm_sys_select (reads, writes, excepts, secs, msecs)
time_p = 0;
else
{
- SCM_ASSERT (SCM_INUMP (secs), secs, SCM_ARG4, s_sys_select);
+ SCM_ASSERT (SCM_INUMP (secs), secs, SCM_ARG4, s_select);
if (SCM_UNBNDP (msecs))
msecs = SCM_INUM0;
else
- SCM_ASSERT (SCM_INUMP (msecs), msecs, SCM_ARG5, s_sys_select);
+ SCM_ASSERT (SCM_INUMP (msecs), msecs, SCM_ARG5, s_select);
timeout.tv_sec = SCM_INUM (secs);
timeout.tv_usec = 1000 * SCM_INUM (msecs);
@@ -1029,250 +802,359 @@ scm_sys_select (reads, writes, excepts, secs, msecs)
SCM_DEFER_INTS;
sreturn = select (SELECT_SET_SIZE,
&read_set, &write_set, &except_set, time_p);
- SCM_ALLOW_INTS;
if (sreturn < 0)
- return SCM_MAKINUM (errno);
- else
- return scm_listify (retrieve_select_type (&read_set, reads),
- retrieve_select_type (&write_set, writes),
- retrieve_select_type (&except_set, excepts),
- SCM_UNDEFINED);
+ scm_syserror (s_select);
+ SCM_ALLOW_INTS;
+ return scm_listify (retrieve_select_type (&read_set, reads),
+ retrieve_select_type (&write_set, writes),
+ retrieve_select_type (&except_set, excepts),
+ SCM_UNDEFINED);
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_select);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
+/* Check if FILE has characters waiting to be read. */
+
+#ifdef __IBMC__
+# define MSDOS
+#endif
+#ifdef MSDOS
+# ifndef GO32
+# include <io.h>
+# include <conio.h>
+
+int
+scm_input_waiting_p (f, caller)
+ FILE *f;
+ char *caller;
+{
+ if (feof (f))
+ return 1;
+ if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin))))
+ return kbhit ();
+ return -1;
+}
+
+# endif
+#else
+# ifdef _DCC
+# include <ioctl.h>
+# else
+# ifndef AMIGA
+# ifndef vms
+# ifdef MWC
+# include <sys/io.h>
+# else
+# ifndef THINK_C
+# ifndef ARM_ULIB
+# include <sys/ioctl.h>
+# endif
+# endif
+# endif
+# endif
+# endif
+# endif
+
+int
+scm_input_waiting_p (f, caller)
+ FILE *f;
+ char *caller;
+{
+ /* Can we return an end-of-file character? */
+ if (feof (f))
+ return 1;
+
+ /* Do we have characters in the stdio buffer? */
+# ifdef FILE_CNT_FIELD
+ if (f->FILE_CNT_FIELD > 0)
+ return 1;
+# else
+# ifdef FILE_CNT_GPTR
+ if (f->_gptr != f->_egptr)
+ return 1;
+# else
+# ifdef FILE_CNT_READPTR
+ if (f->_IO_read_end != f->_IO_read_ptr)
+ return 1;
+# else
+ Configure.in could not guess the name of the correct field in a FILE *.
+ This function needs to be ported to your system.
+ It should return zero iff no characters are waiting to be read.;
+# endif
+# endif
+# endif
+
+ /* Is the file prepared to deliver input? */
+# ifdef HAVE_SELECT
+ {
+ struct timeval timeout;
+ SELECT_TYPE read_set;
+ SELECT_TYPE write_set;
+ SELECT_TYPE except_set;
+ int fno = fileno ((FILE *)f);
+
+ FD_ZERO (&read_set);
+ FD_ZERO (&write_set);
+ FD_ZERO (&except_set);
+
+ FD_SET (fno, &read_set);
+
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 0;
+
+ SCM_DEFER_INTS;
+ if (select (SELECT_SET_SIZE,
+ &read_set, &write_set, &except_set, &timeout)
+ < 0)
+ scm_syserror (caller);
+ SCM_ALLOW_INTS;
+ return FD_ISSET (fno, &read_set);
+ }
+# else
+# ifdef FIONREAD
+ {
+ long remir;
+ ioctl(fileno(f), FIONREAD, &remir);
+ return remir;
+ }
+# else
+ scm_misc_error ("char-ready?", "Not fully implemented");
+# endif
+# endif
+}
+#endif
+
+
+
+SCM_PROC (s_fcntl, "fcntl", 3, 0, 0, scm_fcntl);
+
+SCM
+scm_fcntl (port, cmd, value)
+ SCM port;
+ SCM cmd;
+ SCM value;
+{
+ int rv;
+
+ SCM_ASSERT (SCM_OPFPORTP (port), port, SCM_ARG1, s_fcntl);
+ SCM_ASSERT (SCM_INUMP (cmd), cmd, SCM_ARG2, s_fcntl);
+ SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG3, s_fcntl);
+
+ rv = fileno ((FILE *)SCM_STREAM (port));
+ if (rv != -1)
+ SCM_SYSCALL (rv = fcntl (rv, SCM_INUM (cmd), SCM_INUM (value)));
+ if (rv == -1)
+ scm_syserror (s_fcntl);
+ return SCM_MAKINUM (rv);
+}
/* {Symbolic Links}
*/
-SCM_PROC (s_sys_symlink, "%symlink", 2, 0, 0, scm_sys_symlink);
-#ifdef __STDC__
-SCM
-scm_sys_symlink(SCM oldpath, SCM newpath)
-#else
+SCM_PROC (s_symlink, "symlink", 2, 0, 0, scm_symlink);
+
SCM
-scm_sys_symlink(oldpath, newpath)
+scm_symlink(oldpath, newpath)
SCM oldpath;
SCM newpath;
-#endif
{
#ifdef HAVE_SYMLINK
int val;
- SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_sys_symlink);
- SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_sys_symlink);
- SCM_SYSCALL(val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath)));
- return val ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+
+ SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_symlink);
+ SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_symlink);
+ SCM_SYSCALL (val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath)));
+ if (val != 0)
+ scm_syserror (s_symlink);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_symlink);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_readlink, "%readlink", 1, 0, 0, scm_sys_readlink);
-#ifdef __STDC__
-SCM
-scm_sys_readlink(SCM path)
-#else
+SCM_PROC (s_readlink, "readlink", 1, 0, 0, scm_readlink);
+
SCM
-scm_sys_readlink(path)
+scm_readlink(path)
SCM path;
-#endif
{
#ifdef HAVE_READLINK
scm_sizet rv;
scm_sizet size = 100;
char *buf;
SCM result;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, (char *) SCM_ARG1, s_sys_readlink);
+ SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, (char *) SCM_ARG1, s_readlink);
SCM_DEFER_INTS;
- buf = scm_must_malloc (size, s_sys_readlink);
+ buf = scm_must_malloc (size, s_readlink);
while ((rv = readlink (SCM_CHARS (path), buf, (scm_sizet) size)) == size)
{
scm_must_free (buf);
size *= 2;
- buf = scm_must_malloc (size, s_sys_readlink);
+ buf = scm_must_malloc (size, s_readlink);
}
- if (rv != -1)
- result = scm_makfromstr (buf, rv, 0);
- else
- result = SCM_MAKINUM (errno);
+ if (rv == -1)
+ scm_syserror (s_readlink);
+ result = scm_makfromstr (buf, rv, 0);
scm_must_free (buf);
SCM_ALLOW_INTS;
return result;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_readlink);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_lstat, "%lstat", 1, 0, 0, scm_sys_lstat);
-#ifdef __STDC__
-SCM
-scm_sys_lstat(SCM str)
-#else
+SCM_PROC (s_lstat, "lstat", 1, 0, 0, scm_lstat);
+
SCM
-scm_sys_lstat(str)
+scm_lstat(str)
SCM str;
-#endif
{
-#ifdef HAVE_LSTATE
- int i;
+#ifdef HAVE_LSTAT
+ int rv;
struct stat stat_temp;
- SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat);
- SCM_SYSCALL(i = lstat(SCM_CHARS(str), &stat_temp));
- return i ? SCM_MAKINUM (errno) : scm_stat2scm(&stat_temp);
+
+ SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_lstat);
+ SCM_SYSCALL(rv = lstat(SCM_CHARS(str), &stat_temp));
+ if (rv != 0)
+ {
+ int en = errno;
+
+ scm_syserror_msg (s_lstat, "%s: %S",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ str,
+ SCM_UNDEFINED),
+ en);
+ }
+ return scm_stat2scm(&stat_temp);
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_lstat);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_copy_file, "%copy-file", 2, 0, 0, scm_sys_copy_file);
-#ifdef __STDC__
-SCM
-scm_sys_copy_file (SCM oldfile, SCM newfile)
-#else
+SCM_PROC (s_copy_file, "copy-file", 2, 0, 0, scm_copy_file);
+
SCM
-scm_sys_copy_file (oldfile, newfile)
+scm_copy_file (oldfile, newfile)
SCM oldfile;
SCM newfile;
-#endif
{
int oldfd, newfd;
int n;
char buf[BUFSIZ]; /* this space could be shared. */
struct stat oldstat;
- SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_sys_copy_file);
+ SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_copy_file);
if (SCM_SUBSTRP (oldfile))
oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
- SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_sys_copy_file);
+ SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_copy_file);
if (SCM_SUBSTRP (newfile))
newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
- return SCM_BOOL_F;
+ scm_syserror (s_copy_file);
SCM_DEFER_INTS;
oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
if (oldfd == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
- /* should probably use the POSIX flags instead of 07777. */
+ scm_syserror (s_copy_file);
+
+ /* use POSIX flags instead of 07777?. */
newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
oldstat.st_mode & 07777);
if (newfd == -1)
- {
- close (oldfd);
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_copy_file);
+
while ((n = read (oldfd, buf, sizeof buf)) > 0)
if (write (newfd, buf, n) != n)
{
close (oldfd);
close (newfd);
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ scm_syserror (s_copy_file);
}
close (oldfd);
if (close (newfd) == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_copy_file);
SCM_ALLOW_INTS;
- return SCM_BOOL_T;
+ return SCM_UNSPECIFIED;
}
-#ifdef __STDC__
-void
-scm_init_filesys (void)
-#else
+
void
scm_init_filesys ()
-#endif
{
- /* File type/permission bits. */
-#ifdef S_IRUSR
- scm_sysintern ("S_IRUSR", SCM_MAKINUM (S_IRUSR));
-#endif
-#ifdef S_IWUSR
- scm_sysintern ("S_IWUSR", SCM_MAKINUM (S_IWUSR));
-#endif
-#ifdef S_IXUSR
- scm_sysintern ("S_IXUSR", SCM_MAKINUM (S_IXUSR));
-#endif
-#ifdef S_IRWXU
- scm_sysintern ("S_IRWXU", SCM_MAKINUM (S_IRWXU));
-#endif
+ scm_add_feature ("i/o-extensions");
-#ifdef S_IRGRP
- scm_sysintern ("S_IRGRP", SCM_MAKINUM (S_IRGRP));
-#endif
-#ifdef S_IWGRP
- scm_sysintern ("S_IWGRP", SCM_MAKINUM (S_IWGRP));
-#endif
-#ifdef S_IXGRP
- scm_sysintern ("S_IXGRP", SCM_MAKINUM (S_IXGRP));
-#endif
-#ifdef S_IRWXG
- scm_sysintern ("S_IRWXG", SCM_MAKINUM (S_IRWXG));
-#endif
-
-#ifdef S_IROTH
- scm_sysintern ("S_IROTH", SCM_MAKINUM (S_IROTH));
-#endif
-#ifdef S_IWOTH
- scm_sysintern ("S_IWOTH", SCM_MAKINUM (S_IWOTH));
-#endif
-#ifdef S_IXOTH
- scm_sysintern ("S_IXOTH", SCM_MAKINUM (S_IXOTH));
-#endif
-#ifdef S_IRWXO
- scm_sysintern ("S_IRWXO", SCM_MAKINUM (S_IRWXO));
-#endif
-
-#ifdef S_ISUID
- scm_sysintern ("S_ISUID", SCM_MAKINUM (S_ISUID));
-#endif
-#ifdef S_ISGID
- scm_sysintern ("S_ISGID", SCM_MAKINUM (S_ISGID));
-#endif
-#ifdef S_ISVTX
- scm_sysintern ("S_ISVTX", SCM_MAKINUM (S_ISVTX));
-#endif
-
-#ifdef S_IFMT
- scm_sysintern ("S_IFMT", SCM_MAKINUM (S_IFMT));
-#endif
-#ifdef S_IFDIR
- scm_sysintern ("S_IFDIR", SCM_MAKINUM (S_IFDIR));
-#endif
-#ifdef S_IFCHR
- scm_sysintern ("S_IFCHR", SCM_MAKINUM (S_IFCHR));
-#endif
-#ifdef S_IFBLK
- scm_sysintern ("S_IFBLK", SCM_MAKINUM (S_IFBLK));
-#endif
-#ifdef S_IFREG
- scm_sysintern ("S_IFREG", SCM_MAKINUM (S_IFREG));
-#endif
-#ifdef S_IFLNK
- scm_sysintern ("S_IFLNK", SCM_MAKINUM (S_IFLNK));
-#endif
-#ifdef S_IFSOCK
- scm_sysintern ("S_IFSOCK", SCM_MAKINUM (S_IFSOCK));
-#endif
-#ifdef S_IFIFO
- scm_sysintern ("S_IFIFO", SCM_MAKINUM (S_IFIFO));
-#endif
+ scm_tc16_dir = scm_newsmob (&dir_smob);
+#ifdef O_RDONLY
+scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
+#endif
+#ifdef O_WRONLY
+scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY));
+#endif
+#ifdef O_RDWR
+scm_sysintern ("O_RDWR", scm_long2num (O_RDWR));
+#endif
+#ifdef O_CREAT
+scm_sysintern ("O_CREAT", scm_long2num (O_CREAT));
+#endif
+#ifdef O_EXCL
+scm_sysintern ("O_EXCL", scm_long2num (O_EXCL));
+#endif
+#ifdef O_NOCTTY
+scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY));
+#endif
+#ifdef O_TRUNC
+scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC));
+#endif
+#ifdef O_APPEND
+scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
+#endif
+#ifdef O_NONBLO
+scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
+#endif
+#ifdef O_NDELAY
+scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY));
+#endif
+#ifdef O_SYNC
+scm_sysintern ("O_SYNC", scm_long2num (O_SYNC));
+#endif
- scm_tc16_fd = scm_newsmob (&fd_smob);
- scm_tc16_dir = scm_newsmob (&dir_smob);
+#ifdef F_DUPFD
+scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD));
+#endif
+#ifdef F_GETFD
+scm_sysintern ("F_GETFD", scm_long2num (F_GETFD));
+#endif
+#ifdef F_SETFD
+scm_sysintern ("F_SETFD", scm_long2num (F_SETFD));
+#endif
+#ifdef F_GETFL
+scm_sysintern ("F_GETFL", scm_long2num (F_GETFL));
+#endif
+#ifdef F_SETFL
+scm_sysintern ("F_SETFL", scm_long2num (F_SETFL));
+#endif
+#ifdef F_GETOWN
+scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN));
+#endif
+#ifdef F_SETOWN
+scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN));
+#endif
+#ifdef FD_CLOEXEC
+scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC));
+#endif
#include "filesys.x"
}
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 9949d383b..aae4db349 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -2,7 +2,7 @@
#ifndef FILESYSH
#define FILESYSH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -45,91 +45,38 @@
#include <stdio.h>
-#include "_scm.h"
+#include "libguile/__scm.h"
-extern long scm_tc16_fd;
-
-#define SCM_FD_P(x) (SCM_TYP16(x)==(scm_tc16_fd))
-#define SCM_FD_FLAGS(x) (SCM_CAR(x) >> 16)
-#define SCM_FD(x) ((int)SCM_CDR (x))
-
-enum scm_fd_flags
-{
- scm_fd_is_open = 1,
- scm_close_fd_on_gc = 2
-};
-
-
-
-
extern long scm_tc16_dir;
#define SCM_DIRP(x) (SCM_TYP16(x)==(scm_tc16_dir))
#define SCM_OPDIRP(x) (SCM_CAR(x)==(scm_tc16_dir | SCM_OPN))
-
-
-#ifdef __STDC__
-extern SCM scm_sys_chown (SCM path, SCM owner, SCM group);
-extern SCM scm_sys_chmod (SCM port_or_path, SCM mode);
-extern SCM scm_umask (SCM mode);
-extern SCM scm_intern_fd (int fd, int flags);
-extern SCM scm_sys_open (SCM path, SCM flags, SCM mode);
-extern SCM scm_sys_create (SCM path, SCM mode);
-extern SCM scm_sys_close (SCM sfd);
-extern SCM scm_sys_write_fd (SCM sfd, SCM buf);
-extern SCM scm_sys_read_fd (SCM sfd, SCM buf, SCM offset, SCM length);
-extern SCM scm_sys_lseek (SCM sfd, SCM offset, SCM whence);
-extern SCM scm_sys_dup (SCM oldfd, SCM newfd);
-extern SCM scm_sys_stat (SCM fd_or_path);
-extern SCM scm_sys_link (SCM oldpath, SCM newpath);
-extern SCM scm_sys_rename (SCM oldname, SCM newname);
-extern SCM scm_sys_mkdir (SCM path, SCM mode);
-extern SCM scm_sys_rmdir (SCM path);
-extern SCM scm_sys_opendir (SCM dirname);
-extern SCM scm_sys_readdir (SCM port);
-extern SCM scm_rewinddir (SCM port);
-extern SCM scm_sys_closedir (SCM port);
-extern SCM scm_sys_chdir (SCM str);
-extern SCM scm_sys_getcwd (void);
-extern SCM scm_sys_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs);
-extern SCM scm_sys_symlink(SCM oldpath, SCM newpath);
-extern SCM scm_sys_readlink(SCM path);
-extern SCM scm_sys_lstat(SCM str);
-extern SCM scm_sys_copy_file (SCM oldfile, SCM newfile);
-extern void scm_init_filesys (void);
-
-#else /* STDC */
-extern SCM scm_sys_chown ();
-extern SCM scm_sys_chmod ();
-extern SCM scm_umask ();
-extern SCM scm_intern_fd ();
-extern SCM scm_sys_open ();
-extern SCM scm_sys_create ();
-extern SCM scm_sys_close ();
-extern SCM scm_sys_write_fd ();
-extern SCM scm_sys_read_fd ();
-extern SCM scm_sys_lseek ();
-extern SCM scm_sys_dup ();
-extern SCM scm_sys_stat ();
-extern SCM scm_sys_link ();
-extern SCM scm_sys_rename ();
-extern SCM scm_sys_mkdir ();
-extern SCM scm_sys_rmdir ();
-extern SCM scm_sys_opendir ();
-extern SCM scm_sys_readdir ();
-extern SCM scm_rewinddir ();
-extern SCM scm_sys_closedir ();
-extern SCM scm_sys_chdir ();
-extern SCM scm_sys_getcwd ();
-extern SCM scm_sys_select ();
-extern SCM scm_sys_symlink();
-extern SCM scm_sys_readlink();
-extern SCM scm_sys_lstat();
-extern SCM scm_sys_copy_file ();
-extern void scm_init_filesys ();
-#endif /* STDC */
+extern SCM scm_chown SCM_P ((SCM path, SCM owner, SCM group));
+extern SCM scm_chmod SCM_P ((SCM port_or_path, SCM mode));
+extern SCM scm_umask SCM_P ((SCM mode));
+extern SCM scm_open SCM_P ((SCM path, SCM flags, SCM mode));
+extern SCM scm_stat SCM_P ((SCM fd_or_path));
+extern SCM scm_link SCM_P ((SCM oldpath, SCM newpath));
+extern SCM scm_rename SCM_P ((SCM oldname, SCM newname));
+extern SCM scm_delete_file SCM_P ((SCM str));
+extern SCM scm_mkdir SCM_P ((SCM path, SCM mode));
+extern SCM scm_rmdir SCM_P ((SCM path));
+extern SCM scm_opendir SCM_P ((SCM dirname));
+extern SCM scm_readdir SCM_P ((SCM port));
+extern SCM scm_rewinddir SCM_P ((SCM port));
+extern SCM scm_closedir SCM_P ((SCM port));
+extern SCM scm_chdir SCM_P ((SCM str));
+extern SCM scm_getcwd SCM_P ((void));
+extern SCM scm_select SCM_P ((SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs));
+extern int scm_input_waiting_p SCM_P ((FILE *file, char *caller));
+extern SCM scm_fcntl SCM_P ((SCM port, SCM cmd, SCM value));
+extern SCM scm_symlink SCM_P ((SCM oldpath, SCM newpath));
+extern SCM scm_readlink SCM_P ((SCM path));
+extern SCM scm_lstat SCM_P ((SCM str));
+extern SCM scm_copy_file SCM_P ((SCM oldfile, SCM newfile));
+extern void scm_init_filesys SCM_P ((void));
#endif /* FILESYSH */
diff --git a/libguile/fports.c b/libguile/fports.c
index 234c21d26..005d5b94e 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -42,22 +42,23 @@
#include <stdio.h>
#include "_scm.h"
+#include "markers.h"
+
+#include "fports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
-char *ttyname ();
-char *tmpnam ();
scm_sizet fwrite ();
#endif
-#ifdef HAVE_STRING_H
-#include "string.h"
-#endif
#ifdef __IBMC__
#include <io.h>
#include <direct.h>
-#define ttyname(x) "CON:"
#else
#ifndef MSDOS
#ifndef ultrix
@@ -87,24 +88,18 @@ scm_sizet fwrite ();
*/
/* should be called with SCM_DEFER_INTS active */
-#ifdef __STDC__
-SCM
-scm_setbuf0 (SCM port)
-#else
+
SCM
scm_setbuf0 (port)
SCM port;
-#endif
{
#ifndef NOSETBUF
#ifndef MSDOS
-#ifdef FIONREAD
#ifndef ultrix
SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0););
#endif
#endif
#endif
-#endif
return SCM_UNSPECIFIED;
}
@@ -113,14 +108,10 @@ scm_setbuf0 (port)
*
* See PORT FLAGS in scm.h
*/
-#ifdef __STDC__
-long
-scm_mode_bits (char *modes)
-#else
+
long
scm_mode_bits (modes)
char *modes;
-#endif
{
return (SCM_OPN
| (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0)
@@ -139,81 +130,102 @@ scm_mode_bits (modes)
*
* Return the new port.
*/
+SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
-#ifdef __STDC__
SCM
-scm_mkfile (char * name, char * modes)
-#else
-SCM
-scm_mkfile (name, modes)
- char * name;
- char * modes;
-#endif
+scm_open_file (filename, modes)
+ SCM filename;
+ SCM modes;
{
- register SCM port;
+ SCM port;
FILE *f;
+ char *file;
+ char *mode;
+
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
+ SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
+ if (SCM_SUBSTRP (filename))
+ filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
+ if (SCM_SUBSTRP (modes))
+ modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
+
+ file = SCM_ROCHARS (filename);
+ mode = SCM_ROCHARS (modes);
+
SCM_NEWCELL (port);
SCM_DEFER_INTS;
- SCM_SYSCALL (f = fopen (name, modes));
+ SCM_SYSCALL (f = fopen (file, mode));
if (!f)
{
- SCM_ALLOW_INTS;
- port = SCM_BOOL_F;
+ int en = errno;
+
+ scm_syserror_msg (s_open_file, "%s: %S",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ filename,
+ SCM_UNDEFINED),
+ en);
}
else
{
struct scm_port_table * pt;
+
pt = scm_add_to_port_table (port);
SCM_SETPTAB_ENTRY (port, pt);
- if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (modes)))
+ SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode));
+ SCM_SETSTREAM (port, (SCM) f);
+ if (SCM_BUF0 & SCM_CAR (port))
scm_setbuf0 (port);
- SCM_SETSTREAM (port, (SCM)f);
- SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
- SCM_ALLOW_INTS;
+ SCM_PTAB_ENTRY (port)->file_name = filename;
}
+ SCM_ALLOW_INTS;
return port;
}
-SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
-#ifdef __STDC__
-SCM
-scm_open_file (SCM filename, SCM modes)
-#else
+
+/* Build a Scheme port from an open stdio port, FILE.
+ MODE indicates whether FILE is open for reading or writing; it uses
+ the same notation as open-file's second argument.
+ If NAME is non-zero, use it as the port's filename.
+
+ scm_stdio_to_port sets the revealed count for FILE's file
+ descriptor to 1, so that FILE won't be closed when the port object
+ is GC'd. */
SCM
-scm_open_file (filename, modes)
- SCM filename;
- SCM modes;
-#endif
+scm_stdio_to_port (file, mode, name)
+ FILE *file;
+ char *mode;
+ char *name;
{
+ long mode_bits = scm_mode_bits (mode);
SCM port;
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
- if (SCM_SUBSTRP (filename))
- filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
- if (SCM_SUBSTRP (modes))
- modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
- port = scm_mkfile (SCM_ROCHARS (filename), SCM_ROCHARS (modes));
- /* Force the compiler to keep filename and modes alive:
- */
- if (port == SCM_BOOL_F)
- scm_cons (filename, modes);
+ struct scm_port_table * pt;
+
+ SCM_NEWCELL (port);
+ SCM_DEFER_INTS;
+ {
+ pt = scm_add_to_port_table (port);
+ SCM_SETPTAB_ENTRY (port, pt);
+ SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
+ SCM_SETSTREAM (port, (SCM) file);
+ if (SCM_BUF0 & SCM_CAR (port))
+ scm_setbuf0 (port);
+ SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
+ }
+ SCM_ALLOW_INTS;
+ scm_set_port_revealed_x (port, SCM_MAKINUM (1));
return port;
}
+
/* Return the mode flags from an open port.
* Some modes such as "append" are only used when opening
- * a file and are not returned here.
- */
+ * a file and are not returned here. */
SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode);
-#ifdef __STDC__
-SCM
-scm_port_mode (SCM port)
-#else
+
SCM
scm_port_mode (port)
SCM port;
-#endif
{
char modes[3];
modes[0] = '\0';
@@ -232,16 +244,14 @@ scm_port_mode (port)
}
-#ifdef __STDC__
-static int
-prinfport (SCM exp, SCM port, int writing)
-#else
+
+static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinfport (exp, port, writing)
+prinfport (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
SCM name;
char * c;
@@ -257,20 +267,18 @@ prinfport (exp, port, writing)
else
c = "file";
}
-
+
scm_prinport (exp, port, c);
return !0;
}
-#ifdef __STDC__
-static int
-scm_fgetc (FILE * s)
-#else
+
+static int scm_fgetc SCM_P ((FILE * s));
+
static int
scm_fgetc (s)
FILE * s;
-#endif
{
if (feof (s))
return EOF;
@@ -279,16 +287,14 @@ scm_fgetc (s)
}
#ifdef vms
-#ifdef __STDC__
-static scm_sizet
-pwrite (char *ptr, scm_sizet size, nitems, FILE *port)
-#else
+
+static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
+
static scm_sizet
pwrite (ptr, size, nitems, port)
char *ptr;
scm_sizet size, nitems;
FILE *port;
-#endif
{
scm_sizet len = size * nitems;
scm_sizet i = 0;
@@ -306,6 +312,9 @@ pwrite (ptr, size, nitems, port)
/* This otherwise pointless code helps some poor
* crippled C compilers cope with life.
*/
+
+static int local_fclose SCM_P ((FILE *fp));
+
static int
local_fclose (fp)
FILE * fp;
@@ -313,6 +322,8 @@ local_fclose (fp)
return fclose (fp);
}
+static int local_fflush SCM_P ((FILE *fp));
+
static int
local_fflush (fp)
FILE * fp;
@@ -320,6 +331,8 @@ local_fflush (fp)
return fflush (fp);
}
+static int local_fputc SCM_P ((int c, FILE *fp));
+
static int
local_fputc (c, fp)
int c;
@@ -328,6 +341,8 @@ local_fputc (c, fp)
return fputc (c, fp);
}
+static int local_fputs SCM_P ((char *s, FILE *fp));
+
static int
local_fputs (s, fp)
char * s;
@@ -336,6 +351,8 @@ local_fputs (s, fp)
return fputs (s, fp);
}
+static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp));
+
static scm_sizet
local_ffwrite (ptr, size, nitems, fp)
void * ptr;
@@ -350,15 +367,15 @@ local_ffwrite (ptr, size, nitems, fp)
scm_ptobfuns scm_fptob =
{
scm_mark0,
- local_fclose,
+ (int (*) SCM_P ((SCM))) local_fclose,
prinfport,
0,
- local_fputc,
- local_fputs,
- local_ffwrite,
- local_fflush,
- scm_fgetc,
- local_fclose
+ (int (*) SCM_P ((int, SCM))) local_fputc,
+ (int (*) SCM_P ((char *, SCM))) local_fputs,
+ (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
+ (int (*) SCM_P ((SCM))) local_fflush,
+ (int (*) SCM_P ((SCM))) scm_fgetc,
+ (int (*) SCM_P ((SCM))) local_fclose
};
/* {Pipe ports}
@@ -366,26 +383,19 @@ scm_ptobfuns scm_fptob =
scm_ptobfuns scm_pipob =
{
scm_mark0,
- 0, /* replaced by pclose in scm_init_ioext() */
- 0, /* replaced by prinpipe in scm_init_ioext() */
+ (int (*) SCM_P ((SCM))) pclose,
+ scm_prinport,
0,
- local_fputc,
- local_fputs,
- local_ffwrite,
- local_fflush,
- scm_fgetc,
- 0
-}; /* replaced by pclose in scm_init_ioext() */
-
+ (int (*) SCM_P ((int, SCM))) local_fputc,
+ (int (*) SCM_P ((char *, SCM))) local_fputs,
+ (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
+ (int (*) SCM_P ((SCM))) local_fflush,
+ (int (*) SCM_P ((SCM))) scm_fgetc,
+ (int (*) SCM_P ((SCM))) pclose
+};
-#ifdef __STDC__
-void
-scm_init_fports (void)
-#else
void
scm_init_fports ()
-#endif
{
#include "fports.x"
}
-
diff --git a/libguile/fports.h b/libguile/fports.h
index a0ca6fe3b..5f92367ab 100644
--- a/libguile/fports.h
+++ b/libguile/fports.h
@@ -2,7 +2,7 @@
#ifndef FPORTSH
#define FPORTSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,7 +44,9 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+
+#include "libguile/ports.h"
@@ -52,27 +54,12 @@ extern scm_ptobfuns scm_fptob;
extern scm_ptobfuns scm_pipob;
-#ifdef __STDC__
-extern SCM scm_setbuf0 (SCM port);
-extern long scm_mode_bits (char *modes);
-extern SCM scm_mkfile (char * name, char * modes);
-extern SCM scm_open_file (SCM filename, SCM modes);
-extern SCM scm_port_mode (SCM port);
-extern void scm_init_fports (void);
-
-#else /* STDC */
-extern SCM scm_setbuf0 ();
-extern long scm_mode_bits ();
-extern SCM scm_mkfile ();
-extern SCM scm_open_file ();
-extern SCM scm_port_mode ();
-extern void scm_init_fports ();
-
-#endif /* STDC */
-
-
-
-
+extern SCM scm_setbuf0 SCM_P ((SCM port));
+extern long scm_mode_bits SCM_P ((char *modes));
+extern SCM scm_open_file SCM_P ((SCM filename, SCM modes));
+extern SCM scm_stdio_to_port SCM_P ((FILE *file, char *name, char *modes));
+extern SCM scm_port_mode SCM_P ((SCM port));
+extern void scm_init_fports SCM_P ((void));
#endif /* FPORTSH */
diff --git a/libguile/fsu-pthreads.h b/libguile/fsu-pthreads.h
new file mode 100644
index 000000000..58122e5a5
--- /dev/null
+++ b/libguile/fsu-pthreads.h
@@ -0,0 +1,166 @@
+/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#ifndef SCM_FSU_PTHREADS_H
+#define SCM_FSU_PTHREADS_H
+
+#define PTHREAD_KERNEL
+#include <pthread.h>
+
+/* Identify where the stack pointer can be found in a jmpbuf.
+ */
+
+#if defined(__sparc_setjmp_h)
+# define THREAD_SP machdep_data.machdep_state[2]
+#endif
+
+#if defined(linux)
+# define THREAD_SP machdep_data.machdep_state[0].__sp
+#endif
+
+#if defined(sgi)
+# define THREAD_SP machdep_data.machdep_state[JB_SP]
+#endif
+
+/* ...define THREAD_SP for your architecture here...
+ */
+
+#if !defined(THREAD_SP)
+--> where is your stack pointer?
+#endif
+
+
+
+#define PTHREAD_MAX_PRIORITY 64
+
+
+
+/* Boost the priority of this thread so that it is the only
+ one running. PTHREAD_MAX_PRIORITY is reserved for this
+ purpose */
+
+#define SCM_THREAD_CRITICAL_SECTION_START \
+ struct sched_param param; \
+ int previous_prio; \
+ int policy; \
+ pthread_getschedparam(pthread_self(), &policy, &param); \
+ previous_prio = param.prio; \
+ param.prio = PTHREAD_MAX_PRIORITY; \
+ pthread_setschedparam(pthread_self(), policy, &param)
+
+#define SCM_THREAD_CRITICAL_SECTION_END \
+ param.prio = previous_prio; \
+ pthread_setschedparam(pthread_self(), policy, &param)
+
+#define SCM_THREAD_INITIALIZE_STORAGE \
+ scm_threads_init_mit_pthreads ()
+
+
+
+#define SCM_NO_CRITICAL_SECTION_OWNER 0
+
+#define SCM_DEFER_INTS \
+{ \
+ SCM_IASSERT(scm_critical_section_owner != pthread_self()); \
+ pthread_mutex_lock(&scm_critical_section_mutex); \
+ scm_critical_section_owner = pthread_self(); \
+ scm_ints_disabled = 1; \
+}
+
+#define SCM_ALLOW_INTS \
+{ \
+ SCM_IASSERT(scm_critical_section_owner == pthread_self()); \
+ scm_ints_disabled = 0; \
+ scm_critical_section_owner = SCM_NO_CRITICAL_SECTION_OWNER; \
+ pthread_mutex_unlock(&scm_critical_section_mutex); \
+ SCM_CHECK_INTS; \
+}
+
+#define SCM_REDEFER_INTS \
+{ \
+ if ((scm_critical_section_owner != pthread_self()) || \
+ (scm_critical_section_owner == SCM_NO_CRITICAL_SECTION_OWNER)) \
+ { \
+ pthread_mutex_lock(&scm_critical_section_mutex); \
+ scm_critical_section_owner = pthread_self(); \
+ } \
+ ++scm_ints_disabled; \
+}
+
+#define SCM_REALLOW_INTS \
+{ \
+ SCM_IASSERT(scm_critical_section_owner == pthread_self()); \
+ --scm_ints_disabled; \
+ if (!scm_ints_disabled) \
+ { \
+ scm_critical_section_owner = SCM_NO_CRITICAL_SECTION_OWNER; \
+ pthread_mutex_unlock(&scm_critical_section_mutex); \
+ SCM_CHECK_INTS; \
+ } \
+}
+
+*fixme*
+#define scm_root ((scm_root_state *) pthread_self()->prots)
+#define scm_set_root(new_root) (pthread_self()->prots = (new_root))
+
+
+
+void scm_threads_init_mit_pthreads ();
+
+typedef struct QUEUE {
+ struct QUEUE *flink, *blink;
+} queue;
+
+extern pthread_mutex_t scm_critical_section_mutex;
+extern pthread_t scm_critical_section_owner;
+
+/* Key to thread specific data */
+extern pthread_key_t info_key;
+
+struct scm_pthread_create_info_type
+{
+ SCM thunk;
+ SCM error;
+ SCM *prots;
+} scm_pthread_create_info;
+
+#endif
diff --git a/libguile/gc.c b/libguile/gc.c
index 26e718158..9d434f33e 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -41,13 +41,31 @@
#include <stdio.h>
#include "_scm.h"
+#include "stime.h"
+#include "stackchk.h"
+#include "struct.h"
+#include "genio.h"
+#include "weaks.h"
+#include "smob.h"
+#include "unif.h"
+#include "async.h"
+
+#include "gc.h"
#ifdef HAVE_MALLOC_H
-#include "malloc.h"
+#include <malloc.h>
#endif
#ifdef HAVE_UNISTD_H
-#include "unistd.h"
+#include <unistd.h>
+#endif
+
+#ifdef __STDC__
+#include <stdarg.h>
+#define var_start(x, y) va_start(x, y)
+#else
+#include <varargs.h>
+#define var_start(x, y) va_start(x)
#endif
@@ -77,6 +95,12 @@
*
* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
* trigger a GC.
+ *
+ * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
+ * reclaimed by a GC triggered by must_malloc. If less than this is
+ * reclaimed, the trigger threshold is raised. [I don't know what a
+ * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
+ * work around a oscillation that caused almost constant GC.]
*/
#define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell))
@@ -92,6 +116,7 @@
#endif
#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
#define SCM_INIT_MALLOC_LIMIT 100000
+#define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
bounds for allocated storage */
@@ -168,33 +193,133 @@ SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
struct scm_heap_seg_data
{
- SCM_CELLPTR bounds[2]; /* lower and upper */
- SCM *freelistp; /* the value of this may be shared */
- int ncells; /* per object in this segment */
+ /* lower and upper bounds of the segment */
+ SCM_CELLPTR bounds[2];
+
+ /* address of the head-of-freelist pointer for this segment's cells.
+ All segments usually point to the same one, scm_freelist. */
+ SCM *freelistp;
+
+ /* number of SCM words per object in this segment */
+ int ncells;
+
+ /* If SEG_DATA->valid is non-zero, the conservative marking
+ functions will apply SEG_DATA->valid to the purported pointer and
+ SEG_DATA, and mark the object iff the function returns non-zero.
+ At the moment, I don't think anyone uses this. */
int (*valid) ();
};
+static void scm_mark_weak_vector_spines SCM_P ((void));
+static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *));
+static void alloc_some_heap SCM_P ((int, SCM *));
+
+
+
+/* Debugging functions. */
+
+#ifdef DEBUG_FREELIST
+
+/* Return the number of the heap segment containing CELL. */
+static int
+which_seg (SCM cell)
+{
+ int i;
-static void alloc_some_heap ();
-static void scm_mark_weak_vector_spines ();
+ for (i = 0; i < scm_n_heap_segs; i++)
+ if (SCM_PTR_LE (scm_heap_table[i].bounds[0], (SCM_CELLPTR) cell)
+ && SCM_PTR_GT (scm_heap_table[i].bounds[1], (SCM_CELLPTR) cell))
+ return i;
+ fprintf (stderr, "which_seg: can't find segment containing cell %lx\n",
+ cell);
+ abort ();
+}
+SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list);
+SCM
+scm_map_free_list ()
+{
+ int last_seg = -1, count = 0;
+ SCM f;
+
+ fprintf (stderr, "%d segments total\n", scm_n_heap_segs);
+ for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f))
+ {
+ int this_seg = which_seg (f);
+
+ if (this_seg != last_seg)
+ {
+ if (last_seg != -1)
+ fprintf (stderr, " %5d cells in segment %d\n", count, last_seg);
+ last_seg = this_seg;
+ count = 0;
+ }
+ count++;
+ }
+ if (last_seg != -1)
+ fprintf (stderr, " %5d cells in segment %d\n", count, last_seg);
+
+ fflush (stderr);
+
+ return SCM_UNSPECIFIED;
+}
+
+
+/* Number of calls to SCM_NEWCELL since startup. */
+static unsigned long scm_newcell_count;
+
+/* Search freelist for anything that isn't marked as a free cell.
+ Abort if we find something. */
+static void
+scm_check_freelist ()
+{
+ SCM f;
+ int i = 0;
+
+ for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++)
+ if (SCM_CAR (f) != (SCM) scm_tc_free_cell)
+ {
+ fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n",
+ scm_newcell_count, i);
+ fflush (stderr);
+ abort ();
+ }
+}
+
+static int scm_debug_check_freelist = 0;
+void
+scm_debug_newcell (SCM *into)
+{
+ scm_newcell_count++;
+ if (scm_debug_check_freelist)
+ scm_check_freelist ();
+
+ /* The rest of this is supposed to be identical to the SCM_NEWCELL
+ macro. */
+ if (SCM_IMP (scm_freelist))
+ *into = scm_gc_for_newcell ();
+ else
+ {
+ *into = scm_freelist;
+ scm_freelist = SCM_CDR (scm_freelist);
+ ++scm_cells_allocated;
+ }
+}
+
+#endif /* DEBUG_FREELIST */
+
/* {Scheme Interface to GC}
*/
SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats);
-#ifdef __STDC__
-SCM
-scm_gc_stats (void)
-#else
SCM
scm_gc_stats ()
-#endif
{
int i;
int n;
@@ -237,14 +362,9 @@ scm_gc_stats ()
}
-#ifdef __STDC__
-void
-scm_gc_start (char *what)
-#else
void
scm_gc_start (what)
char *what;
-#endif
{
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ());
scm_gc_cells_collected = 0;
@@ -252,13 +372,8 @@ scm_gc_start (what)
scm_gc_ports_collected = 0;
}
-#ifdef __STDC__
-void
-scm_gc_end (void)
-#else
void
scm_gc_end ()
-#endif
{
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt;
scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt;
@@ -276,13 +391,8 @@ scm_object_addr (obj)
SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc);
-#ifdef __STDC__
-SCM
-scm_gc (void)
-#else
SCM
scm_gc ()
-#endif
{
SCM_DEFER_INTS;
scm_igc ("call");
@@ -295,15 +405,10 @@ scm_gc ()
/* {C Interface For When GC is Triggered}
*/
-#ifdef __STDC__
-void
-scm_gc_for_alloc (int ncells, SCM * freelistp)
-#else
void
scm_gc_for_alloc (ncells, freelistp)
int ncells;
SCM * freelistp;
-#endif
{
SCM_REDEFER_INTS;
scm_igc ("cells");
@@ -315,13 +420,8 @@ scm_gc_for_alloc (ncells, freelistp)
}
-#ifdef __STDC__
-SCM
-scm_gc_for_newcell (void)
-#else
SCM
scm_gc_for_newcell ()
-#endif
{
SCM fl;
scm_gc_for_alloc (1, &scm_freelist);
@@ -330,17 +430,17 @@ scm_gc_for_newcell ()
return fl;
}
-#ifdef __STDC__
-void
-scm_igc (char *what)
-#else
void
scm_igc (what)
char *what;
-#endif
{
int j;
+#ifdef USE_THREADS
+ /* During the critical section, only the current thread may run. */
+ SCM_THREAD_CRITICAL_SECTION_START;
+#endif
+
scm_gc_start (what);
if (!scm_stack_base || scm_block_gc)
{
@@ -362,7 +462,7 @@ scm_igc (what)
while (type_list != SCM_EOL)
if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt])
{
- pos = &SCM_CDR (type_list);
+ pos = SCM_CDRLOC (type_list);
type_list = SCM_CDR (type_list);
}
else
@@ -388,6 +488,8 @@ scm_igc (what)
}
}
+#ifndef USE_THREADS
+
/* Protect from the C stack. This must be the first marking
* done because it provides information about what objects
* are "in-use" by the C code. "in-use" objects are those
@@ -400,8 +502,9 @@ scm_igc (what)
/* This assumes that all registers are saved into the jmp_buf */
setjmp (scm_save_regs_gc_mark);
scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
- ( (scm_sizet) sizeof scm_save_regs_gc_mark
- / sizeof (SCM_STACKITEM)));
+ ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 +
+ sizeof scm_save_regs_gc_mark)
+ / sizeof (SCM_STACKITEM)));
{
/* stack_len is long rather than scm_sizet in order to guarantee that
@@ -423,6 +526,12 @@ scm_igc (what)
#endif
}
+#else /* USE_THREADS */
+
+ /* Mark every thread's stack and registers */
+ scm_threads_mark_stacks();
+
+#endif /* USE_THREADS */
/* FIXME: insert a phase to un-protect string-data preserved
* in scm_vector_set_length_x.
@@ -432,20 +541,9 @@ scm_igc (what)
while (j--)
scm_gc_mark (scm_sys_protects[j]);
- scm_gc_mark (scm_rootcont);
- scm_gc_mark (scm_dynwinds);
- scm_gc_mark (scm_continuation_stack);
- scm_gc_mark (scm_continuation_stack_ptr);
- scm_gc_mark (scm_progargs);
- scm_gc_mark (scm_exitval);
- scm_gc_mark (scm_cur_inp);
- scm_gc_mark (scm_cur_outp);
- scm_gc_mark (scm_cur_errp);
- scm_gc_mark (scm_def_inp);
- scm_gc_mark (scm_def_outp);
- scm_gc_mark (scm_def_errp);
- scm_gc_mark (scm_top_level_lookup_thunk_var);
- scm_gc_mark (scm_system_transformer);
+#ifndef USE_THREADS
+ scm_gc_mark (scm_root->handle);
+#endif
scm_mark_weak_vector_spines ();
@@ -453,6 +551,10 @@ scm_igc (what)
--scm_gc_heap_lock;
scm_gc_end ();
+
+#ifdef USE_THREADS
+ SCM_THREAD_CRITICAL_SECTION_END;
+#endif
}
@@ -463,14 +565,9 @@ scm_igc (what)
/* Mark an object precisely.
*/
-#ifdef __STDC__
-void
-scm_gc_mark (SCM p)
-#else
void
scm_gc_mark (p)
SCM p;
-#endif
{
register long i;
register SCM ptr;
@@ -525,18 +622,31 @@ gc_mark_nimp:
SCM * vtable_data;
int len;
char * fields_desc;
- SCM * mem;
- int x;
+ register SCM * mem;
+ register int x;
vtable_data = (SCM *)vcell;
layout = vtable_data[scm_struct_i_layout];
len = SCM_LENGTH (layout);
fields_desc = SCM_CHARS (layout);
- mem = (SCM *)SCM_GCCDR (ptr); /* like struct_data but removes mark */
+ /* We're using SCM_GCCDR here like STRUCT_DATA, except
+ that it removes the mark */
+ mem = (SCM *)SCM_GCCDR (ptr);
- for (x = 0; x < len; x += 2)
- if (fields_desc[x] == 'p')
- scm_gc_mark (mem[x / 2]);
+ if (len)
+ {
+ for (x = 0; x < len - 2; x += 2, ++mem)
+ if (fields_desc[x] == 'p')
+ scm_gc_mark (*mem);
+ if (fields_desc[x] == 'p')
+ {
+ if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
+ for (x = *mem; x; --x)
+ scm_gc_mark (*++mem);
+ else
+ scm_gc_mark (*mem);
+ }
+ }
if (!SCM_CDR (vcell))
{
SCM_SETGCMARK (vcell);
@@ -580,7 +690,10 @@ gc_mark_nimp:
(ptr) break;
SCM_SETGC8MARK (ptr);
scm_mark_locations (SCM_VELTS (ptr),
- (scm_sizet) (SCM_LENGTH (ptr) + sizeof (regs) / sizeof (SCM_STACKITEM)));
+ (scm_sizet)
+ (SCM_LENGTH (ptr) +
+ (sizeof (SCM_STACKITEM) + -1 + sizeof (scm_contregs)) /
+ sizeof (SCM_STACKITEM)));
break;
case scm_tc7_bvect:
case scm_tc7_byvect:
@@ -720,7 +833,7 @@ gc_mark_nimp:
case scm_tc_free_cell:
/* printf("found free_cell %X ", ptr); fflush(stdout); */
SCM_SETGC8MARK (ptr);
- SCM_CDR (ptr) = SCM_EOL;
+ SCM_SETCDR (ptr, SCM_EOL);
break;
case scm_tcs_bignums:
case scm_tc16_flo:
@@ -743,15 +856,10 @@ gc_mark_nimp:
/* Mark a Region Conservatively
*/
-#ifdef __STDC__
-void
-scm_mark_locations (SCM_STACKITEM x[], scm_sizet n)
-#else
void
scm_mark_locations (x, n)
SCM_STACKITEM x[];
scm_sizet n;
-#endif
{
register long m = n;
register int i, j;
@@ -812,13 +920,75 @@ scm_mark_locations (x, n)
}
-#ifdef __STDC__
-void
-scm_mark_weak_vector_spines (void)
-#else
-void
+/* The following is a C predicate which determines if an SCM value can be
+ regarded as a pointer to a cell on the heap. The code is duplicated
+ from scm_mark_locations. */
+
+
+int
+scm_cellp (value)
+ SCM value;
+{
+ register int i, j;
+ register SCM_CELLPTR ptr;
+
+ if SCM_CELLP (*(SCM **) & value)
+ {
+ ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
+ i = 0;
+ j = scm_n_heap_segs - 1;
+ if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
+ && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
+ {
+ while (i <= j)
+ {
+ int seg_id;
+ seg_id = -1;
+ if ( (i == j)
+ || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
+ seg_id = i;
+ else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
+ seg_id = j;
+ else
+ {
+ int k;
+ k = (i + j) / 2;
+ if (k == i)
+ break;
+ if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
+ {
+ j = k;
+ ++i;
+ if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
+ continue;
+ else
+ break;
+ }
+ else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
+ {
+ i = k;
+ --j;
+ if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
+ continue;
+ else
+ break;
+ }
+ }
+ if ( !scm_heap_table[seg_id].valid
+ || scm_heap_table[seg_id].valid (ptr,
+ &scm_heap_table[seg_id]))
+ return 1;
+ break;
+ }
+
+ }
+ }
+ return 0;
+}
+
+
+static void
scm_mark_weak_vector_spines ()
-#endif
{
int i;
@@ -856,13 +1026,8 @@ scm_mark_weak_vector_spines ()
-#ifdef __STDC__
-void
-scm_gc_sweep (void)
-#else
void
scm_gc_sweep ()
-#endif
{
register SCM_CELLPTR ptr;
#ifdef SCM_POINTERS_MUNGED
@@ -882,16 +1047,26 @@ scm_gc_sweep ()
n = 0;
m = 0;
- i = 0;
- while (i < scm_n_heap_segs)
+ /* Reset all free list pointers. We'll reconstruct them completely
+ while scanning. */
+ for (i = 0; i < scm_n_heap_segs; i++)
+ *scm_heap_table[i].freelistp = SCM_EOL;
+
+ for (i = 0; i < scm_n_heap_segs; i++)
{
+ /* Unmarked cells go onto the front of the freelist this heap
+ segment points to. Rather than updating the real freelist
+ pointer as we go along, we accumulate the new head in
+ nfreelist. Then, if it turns out that the entire segment is
+ free, we free (i.e., malloc's free) the whole segment, and
+ simply don't assign nfreelist back into the real freelist. */
hp_freelist = scm_heap_table[i].freelistp;
- nfreelist = SCM_EOL;
+ nfreelist = *hp_freelist;
+
span = scm_heap_table[i].ncells;
ptr = CELL_UP (scm_heap_table[i].bounds[0]);
seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr;
- ++i;
for (j = seg_size + span; j -= span; ptr += span)
{
#ifdef SCM_POINTERS_MUNGED
@@ -903,7 +1078,7 @@ scm_gc_sweep ()
if (SCM_GCMARKP (scmptr))
{
if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1)
- SCM_CDR (SCM_CAR (scmptr) - 1) = (SCM)0;
+ SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0);
goto cmrkcontinue;
}
{
@@ -912,12 +1087,10 @@ scm_gc_sweep ()
if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
{
- SCM * mem;
- SCM amt;
- mem = (SCM *)SCM_CDR (scmptr);
- amt = mem[-2];
- free (mem - 2);
- m += amt * sizeof (SCM);
+ SCM *p = (SCM *) SCM_GCCDR (scmptr);
+ m += p[scm_struct_i_n_words] * sizeof (SCM);
+ /* I feel like I'm programming in BCPL here... */
+ free ((char *) p[scm_struct_i_ptr]);
}
}
break;
@@ -1017,7 +1190,7 @@ scm_gc_sweep ()
case scm_tc7_contin:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
- m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (regs);
+ m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs);
goto freechars;
case scm_tc7_ssymbol:
if SCM_GC8MARKP(scmptr)
@@ -1043,7 +1216,7 @@ scm_gc_sweep ()
SCM_SETSTREAM (scmptr, 0);
scm_remove_from_port_table (scmptr);
scm_gc_ports_collected++;
- SCM_CAR (scmptr) &= ~SCM_OPN;
+ SCM_SETAND_CAR (scmptr, ~SCM_OPN);
}
break;
case scm_tc7_smob:
@@ -1099,14 +1272,11 @@ scm_gc_sweep ()
if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
exit (2);
#endif
- SCM_CAR (scmptr) = (SCM) scm_tc_free_cell;
- SCM_CDR (scmptr) = nfreelist;
+ /* Stick the new cell on the front of nfreelist. */
+ SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
+ SCM_SETCDR (scmptr, nfreelist);
nfreelist = scmptr;
-#if 0
- if ((nfreelist < scm_heap_table[0].bounds[0]) ||
- (nfreelist >= scm_heap_table[0].bounds[1]))
- exit (1);
-#endif
+
continue;
c8mrkcontinue:
SCM_CLRGC8MARK (scmptr);
@@ -1118,17 +1288,24 @@ scm_gc_sweep ()
if (n == seg_size)
{
scm_heap_size -= seg_size;
- free ((char *) scm_heap_table[i - 1].bounds[0]);
- scm_heap_table[i - 1].bounds[0] = 0;
- for (j = i; j < scm_n_heap_segs; j++)
+ free ((char *) scm_heap_table[i].bounds[0]);
+ scm_heap_table[i].bounds[0] = 0;
+ for (j = i + 1; j < scm_n_heap_segs; j++)
scm_heap_table[j - 1] = scm_heap_table[j];
scm_n_heap_segs -= 1;
- i -= 1; /* need to scan segment just moved. */
+ i--; /* We need to scan the segment just moved. */
}
else
#endif /* ifdef GC_FREE_SEGMENTS */
+ /* Update the real freelist pointer to point to the head of
+ the list of free cells we've built for this segment. */
*hp_freelist = nfreelist;
+#ifdef DEBUG_FREELIST
+ scm_check_freelist ();
+ scm_map_free_list ();
+#endif
+
scm_gc_cells_collected += n;
n = 0;
}
@@ -1180,7 +1357,7 @@ scm_gc_sweep ()
*fixup = SCM_CDR (alist);
}
else
- fixup = &SCM_CDR (alist);
+ fixup = SCM_CDRLOC (alist);
alist = SCM_CDR (alist);
}
}
@@ -1215,15 +1392,10 @@ scm_gc_sweep ()
*
* The limit scm_mtrigger may be raised by this allocation.
*/
-#ifdef __STDC__
-char *
-scm_must_malloc (long len, char *what)
-#else
char *
scm_must_malloc (len, what)
long len;
char *what;
-#endif
{
char *ptr;
scm_sizet size = len;
@@ -1240,14 +1412,19 @@ scm_must_malloc (len, what)
return ptr;
}
}
+
scm_igc (what);
nm = scm_mallocated + size;
SCM_SYSCALL (ptr = (char *) malloc (size));
if (NULL != ptr)
{
scm_mallocated = nm;
- if (nm > scm_mtrigger)
- scm_mtrigger = nm + nm / 2;
+ if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
+ if (nm > scm_mtrigger)
+ scm_mtrigger = nm + nm / 2;
+ else
+ scm_mtrigger += scm_mtrigger / 2;
+ }
return ptr;
}
goto malerr;
@@ -1257,17 +1434,12 @@ scm_must_malloc (len, what)
/* scm_must_realloc
* is similar to scm_must_malloc.
*/
-#ifdef __STDC__
-char *
-scm_must_realloc (char *where, long olen, long len, char *what)
-#else
char *
scm_must_realloc (where, olen, len, what)
char *where;
long olen;
long len;
char *what;
-#endif
{
char *ptr;
scm_sizet size = len;
@@ -1290,24 +1462,20 @@ scm_must_realloc (where, olen, len, what)
if (NULL != ptr)
{
scm_mallocated = nm;
- if (nm > scm_mtrigger)
- scm_mtrigger = nm + nm / 2;
+ if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
+ if (nm > scm_mtrigger)
+ scm_mtrigger = nm + nm / 2;
+ else
+ scm_mtrigger += scm_mtrigger / 2;
+ }
return ptr;
}
goto ralerr;
}
-/* scm_must_free
- * is for releasing memory from scm_must_realloc and scm_must_malloc.
- */
-#ifdef __STDC__
-void
-scm_must_free (char *obj)
-#else
void
scm_must_free (obj)
char *obj;
-#endif
{
if (obj)
free (obj);
@@ -1359,17 +1527,12 @@ long scm_heap_size = 0;
*/
-#ifdef __STDC__
-static scm_sizet
-init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, int ncells, SCM *freelistp)
-#else
static scm_sizet
init_heap_seg (seg_org, size, ncells, freelistp)
SCM_CELLPTR seg_org;
scm_sizet size;
int ncells;
SCM *freelistp;
-#endif
{
register SCM_CELLPTR ptr;
#ifdef SCM_POINTERS_MUNGED
@@ -1429,8 +1592,8 @@ init_heap_seg (seg_org, size, ncells, freelistp)
#ifdef SCM_POINTERS_MUNGED
scmptr = PTR2SCM (ptr);
#endif
- SCM_CAR (scmptr) = (SCM) scm_tc_free_cell;
- SCM_CDR (scmptr) = PTR2SCM (ptr + ncells);
+ SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
+ SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells));
ptr += ncells;
}
@@ -1439,7 +1602,7 @@ init_heap_seg (seg_org, size, ncells, freelistp)
/* Patch up the last freelist pointer in the segment
* to join it to the input freelist.
*/
- SCM_CDR (PTR2SCM (ptr)) = *freelistp;
+ SCM_SETCDR (PTR2SCM (ptr), *freelistp);
*freelistp = PTR2SCM (CELL_UP (seg_org));
scm_heap_size += (ncells * n_new_objects);
@@ -1450,15 +1613,10 @@ init_heap_seg (seg_org, size, ncells, freelistp)
}
-#ifdef __STDC__
-static void
-alloc_some_heap (int ncells, SCM * freelistp)
-#else
static void
alloc_some_heap (ncells, freelistp)
int ncells;
SCM * freelistp;
-#endif
{
struct scm_heap_seg_data * tmptable;
SCM_CELLPTR ptr;
@@ -1524,14 +1682,9 @@ alloc_some_heap (ncells, freelistp)
SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name);
-#ifdef __STDC__
-SCM
-scm_unhash_name (SCM name)
-#else
SCM
scm_unhash_name (name)
SCM name;
-#endif
{
int x;
int bound;
@@ -1571,16 +1724,12 @@ scm_unhash_name (name)
*/
-#ifdef __STDC__
-void
-scm_remember (SCM * ptr)
-#else
void
scm_remember (ptr)
SCM * ptr;
-#endif
{}
+
#ifdef __STDC__
SCM
scm_return_first (SCM elt, ...)
@@ -1595,14 +1744,9 @@ scm_return_first (elt, va_alist)
}
-#ifdef __STDC__
-SCM
-scm_permanent_object (SCM obj)
-#else
SCM
scm_permanent_object (obj)
SCM obj;
-#endif
{
SCM_REDEFER_INTS;
scm_permobjs = scm_cons (obj, scm_permobjs);
@@ -1611,15 +1755,49 @@ scm_permanent_object (obj)
}
+/* Protect OBJ from the garbage collector. OBJ will not be freed,
+ even if all other references are dropped, until someone applies
+ scm_unprotect_object to it. This function returns OBJ.
+
+ Note that calls to scm_protect_object do not nest. You can call
+ scm_protect_object any number of times on a given object, and the
+ next call to scm_unprotect_object will unprotect it completely.
+
+ Basically, scm_protect_object and scm_unprotect_object just
+ maintain a list of references to things. Since the GC knows about
+ this list, all objects it mentions stay alive. scm_protect_object
+ adds its argument to the list; scm_unprotect_object remove its
+ argument from the list. */
+SCM
+scm_protect_object (obj)
+ SCM obj;
+{
+ /* This function really should use address hashing tables, but I
+ don't know how to use them yet. For now we just use a list. */
+ scm_protects = scm_cons (obj, scm_protects);
+
+ return obj;
+}
+
+
+/* Remove any protection for OBJ established by a prior call to
+ scm_protect_obj. This function returns OBJ.
+
+ See scm_protect_obj for more information. */
+SCM
+scm_unprotect_object (obj)
+ SCM obj;
+{
+ scm_protects = scm_delq_x (obj, scm_protects);
+
+ return obj;
+}
+
+
-#ifdef __STDC__
-int
-scm_init_storage (long init_heap_size)
-#else
int
scm_init_storage (init_heap_size)
long init_heap_size;
-#endif
{
scm_sizet j;
@@ -1659,15 +1837,18 @@ scm_init_storage (init_heap_size)
scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
- SCM_CDR (scm_undefineds) = scm_undefineds;
+ SCM_SETCDR (scm_undefineds, scm_undefineds);
scm_listofnull = scm_cons (SCM_EOL, SCM_EOL);
scm_nullstr = scm_makstr (0L, 0);
scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED, SCM_UNDEFINED);
scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
- scm_weak_symhash = scm_make_weak_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim));
+ scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim));
scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
+ scm_stand_in_procs = SCM_EOL;
scm_permobjs = SCM_EOL;
+ scm_protects = SCM_EOL;
+ scm_asyncs = SCM_EOL;
scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
#ifdef SCM_BIGDIG
@@ -1677,14 +1858,8 @@ scm_init_storage (init_heap_size)
}
-#ifdef __STDC__
-void
-scm_init_gc (void)
-#else
void
scm_init_gc ()
-#endif
{
#include "gc.x"
}
-
diff --git a/libguile/gc.h b/libguile/gc.h
index 8760811a9..0a1f20549 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#define SCM_FREEP(x) (SCM_CAR(x)==scm_tc_free_cell)
@@ -68,51 +68,34 @@ extern unsigned long scm_cells_allocated;
extern unsigned long scm_mallocated;
extern long scm_mtrigger;
-
-#ifdef __STDC__
-extern SCM scm_gc_stats (void);
-extern void scm_gc_start (char *what);
-extern void scm_gc_end (void);
-extern SCM scm_gc (void);
-extern void scm_gc_for_alloc (int ncells, SCM * freelistp);
-extern SCM scm_gc_for_newcell (void);
-extern void scm_igc (char *what);
-extern void scm_gc_mark (SCM p);
-extern void scm_mark_locations (SCM_STACKITEM x[], scm_sizet n);
-extern void scm_gc_sweep (void);
-extern char * scm_must_malloc (long len, char *what);
-extern char * scm_must_realloc (char *where, long olen, long len, char *what);
-extern void scm_must_free (char *obj);
-extern void scm_remember (SCM * ptr);
-extern SCM scm_return_first (SCM elt, ...);
-extern SCM scm_permanent_object (SCM obj);
-extern SCM scm_protect_object (SCM obj);
-extern SCM scm_unprotect_object (SCM obj);
-extern int scm_init_storage (long init_heap_size);
-extern void scm_init_gc (void);
+#ifdef DEBUG_FREELIST
+extern void scm_debug_newcell SCM_P ((SCM *into));
+#endif
-#else /* STDC */
-extern SCM scm_gc_stats ();
-extern void scm_gc_start ();
-extern void scm_gc_end ();
-extern SCM scm_gc ();
-extern void scm_gc_for_alloc ();
-extern SCM scm_gc_for_newcell ();
-extern void scm_igc ();
-extern void scm_gc_mark ();
-extern void scm_mark_locations ();
-extern void scm_gc_sweep ();
-extern char * scm_must_malloc ();
-extern char * scm_must_realloc ();
-extern void scm_must_free ();
-extern void scm_remember ();
-extern SCM scm_return_first ();
-extern SCM scm_permanent_object ();
-extern SCM scm_protect_object ();
-extern SCM scm_unprotect_object ();
-extern int scm_init_storage ();
-extern void scm_init_gc ();
+
-#endif /* STDC */
-#include "marksweep.h"
+extern SCM scm_object_addr SCM_P ((SCM obj));
+extern SCM scm_unhash_name SCM_P ((SCM name));
+extern SCM scm_gc_stats SCM_P ((void));
+extern void scm_gc_start SCM_P ((char *what));
+extern void scm_gc_end SCM_P ((void));
+extern SCM scm_gc SCM_P ((void));
+extern void scm_gc_for_alloc SCM_P ((int ncells, SCM * freelistp));
+extern SCM scm_gc_for_newcell SCM_P ((void));
+extern void scm_igc SCM_P ((char *what));
+extern void scm_gc_mark SCM_P ((SCM p));
+extern void scm_mark_locations SCM_P ((SCM_STACKITEM x[], scm_sizet n));
+extern int scm_cellp SCM_P ((SCM value));
+extern void scm_gc_sweep SCM_P ((void));
+extern char * scm_must_malloc SCM_P ((long len, char *what));
+extern char * scm_must_realloc SCM_P ((char *where, long olen, long len,
+ char *what));
+extern void scm_must_free SCM_P ((char *obj));
+extern void scm_remember SCM_P ((SCM * ptr));
+extern SCM scm_return_first SCM_P ((SCM elt, ...));
+extern SCM scm_permanent_object SCM_P ((SCM obj));
+extern SCM scm_protect_object SCM_P ((SCM obj));
+extern SCM scm_unprotect_object SCM_P ((SCM obj));
+extern int scm_init_storage SCM_P ((long init_heap_size));
+extern void scm_init_gc SCM_P ((void));
#endif /* GCH */
diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h
new file mode 100644
index 000000000..9ca931b40
--- /dev/null
+++ b/libguile/gdb_interface.h
@@ -0,0 +1,127 @@
+/* Simple interpreter interface for GDB, the GNU debugger.
+ Copyright (C) 1996 Mikael Djurfeldt.
+
+This file is part of GDB.
+
+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.
+
+The author can be reached at djurfeldt@nada.kth.se
+Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
+
+#ifndef GDB_INTERFACE_H
+#define GDB_INTERFACE_H
+
+/* This is the header file for GDB's interpreter interface. The
+ interpreter must supply definitions of all symbols declared in this
+ file.
+
+ Before including this file, you must #define GDB_TYPE to be the
+ data type used for communication with the interpreter. */
+
+/* The following macro can be used to anchor the symbols of the
+ interface in your main program. This is necessary if the interface
+ is defined in a library, such as Guile. */
+
+#define GDB_INTERFACE \
+void *gdb_interface[] = { \
+ &gdb_options, \
+ &gdb_language, \
+ &gdb_result, \
+ &gdb_output, \
+ &gdb_output_length, \
+ (void *) gdb_maybe_valid_type_p, \
+ (void *) gdb_read, \
+ (void *) gdb_eval, \
+ (void *) gdb_print, \
+ (void *) gdb_binding \
+}; \
+
+
+/* GDB_OPTIONS is a set of flags informing gdb what features are present
+ in the interface. Currently only one option is supported: */
+
+/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new
+ top level bindings on demand (through gdb_top_level_binding) */
+
+#define GDB_HAVE_BINDINGS 1
+
+extern unsigned short gdb_options;
+
+/* GDB_LANGUAGE holds the name of the preferred language mode for this
+ interpreter. For lisp interpreters, the suggested mode is "lisp/c". */
+
+extern char *gdb_language;
+
+/* GDB_RESULT is used for passing results from the interpreter to GDB */
+
+extern GDB_TYPE gdb_result;
+
+/* The interpreter passes strings to GDB in GDB_OUTPUT and
+ GDB_OUTPUT_LENGTH. GDB_OUTPUT should hold the pointer to the
+ string. GDB_OUTPUT_LENGTH should hold its length. The string
+ doesn't need to be terminated by '\0'. */
+
+extern char *gdb_output;
+
+extern int gdb_output_length;
+
+/* Return TRUE if the interpreter regards VALUE's type as valid. A
+ lazy implementation is allowed to pass TRUE always. FALSE should
+ only be returned when it is certain that VALUE is not valid.
+
+ In the "lisp/c" language mode, this is used to heuristically
+ discriminate lisp values from C values during printing. */
+
+extern int gdb_maybe_valid_type_p SCM_P ((GDB_TYPE value));
+
+/* Parse expression in string STR. Store result in GDB_RESULT, then
+ return 0 to indicate success. On error, return -1 to indicate
+ failure. An error string can be passed in GDB_OUTPUT and
+ GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero if
+ no message is passed. Please note that the resulting value should
+ be protected against garbage collection. */
+
+extern int gdb_read SCM_P ((char *str));
+
+/* Evaluate expression EXP. Store result in GDB_RESULT, then return 0
+ to indicate success. On error, return -1 to indicate failure. Any
+ output (both on success and failure) can be passed in GDB_OUTPUT
+ and GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero
+ if no output is passed. Please note that the resulting lisp object
+ should be protected against garbage collection. */
+
+extern int gdb_eval SCM_P ((GDB_TYPE exp));
+
+/* Print VALUE. Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH.
+ Return 0 to indicate success. On error, return -1 to indicate
+ failure. GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on
+ failure. Note that this function should be robust against strange
+ values. It could in fact be passed any kind of value. */
+
+extern int gdb_print SCM_P ((GDB_TYPE value));
+
+/* Bind NAME to VALUE in interpreter. (GDB has previously obtained
+ NAME by passing a string to gdb_read.) Return 0 to indicate
+ success or -1 to indicate failure. This feature is optional. GDB
+ will only call this function if the GDB_HAVE_BINDINGS flag is set
+ in gdb_options. Note that GDB may call this function many times
+ for the same name.
+
+ For scheme interpreters, this function should introduce top-level
+ bindings. */
+
+extern int gdb_binding SCM_P ((GDB_TYPE name, GDB_TYPE value));
+
+#endif /* GDB_INTERFACE_H */
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
new file mode 100644
index 000000000..4879723d7
--- /dev/null
+++ b/libguile/gdbint.c
@@ -0,0 +1,325 @@
+/* GDB interface for Guile
+ * Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+#include "tag.h"
+#include "strports.h"
+#include "read.h"
+#include "eval.h"
+#include "chars.h"
+
+#include "gdbint.h"
+
+/* {Support for debugging with gdb}
+ *
+ * TODO:
+ *
+ * 1. Redirect outputs
+ * 2. Catch errors
+ * 3. Prevent print from causing segmentation fault when given broken pairs
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+
+#define GDB_TYPE SCM
+
+#include "gdb_interface.h"
+
+
+
+/* Be carefull when this macro is true.
+ scm_gc_heap_lock is set during gc.
+ */
+#define SCM_GC_P (scm_gc_heap_lock)
+
+/* Macros that encapsulate blocks of code which can be called by the
+ * debugger.
+ */
+#define SCM_BEGIN_FOREIGN_BLOCK \
+{ \
+ old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
+ old_gc = scm_block_gc; scm_block_gc = 1; \
+ scm_print_carefully_p = 1; \
+} \
+
+
+#define SCM_END_FOREIGN_BLOCK \
+{ \
+ scm_print_carefully_p = 0; \
+ scm_block_gc = old_gc; \
+ scm_ints_disabled = old_ints; \
+} \
+
+
+#define RESET_STRING { gdb_output_length = 0; }
+
+#define SEND_STRING(str) \
+{ \
+ gdb_output = str; \
+ gdb_output_length = strlen (str); \
+} \
+
+
+/* {Gdb interface}
+ */
+
+unsigned short gdb_options = GDB_HAVE_BINDINGS;
+
+char *gdb_language = "lisp/c";
+
+SCM gdb_result;
+
+char *gdb_output;
+
+int gdb_output_length;
+
+int scm_print_carefully_p;
+
+static SCM gdb_input_port;
+static int port_mark_p, stream_mark_p, string_mark_p;
+
+static SCM tok_buf;
+static int tok_buf_mark_p;
+
+static SCM gdb_output_port;
+static int old_ints, old_gc;
+
+
+static void unmark_port SCM_P ((SCM port));
+
+static void
+unmark_port (port)
+ SCM port;
+{
+ SCM stream, string;
+ port_mark_p = SCM_GC8MARKP (port);
+ SCM_CLRGC8MARK (port);
+ stream = SCM_STREAM (port);
+ stream_mark_p = SCM_GCMARKP (stream);
+ SCM_CLRGCMARK (stream);
+ string = SCM_CDR (stream);
+ string_mark_p = SCM_GC8MARKP (string);
+ SCM_CLRGC8MARK (string);
+}
+
+
+static void remark_port SCM_P ((SCM port));
+
+static void
+remark_port (port)
+ SCM port;
+{
+ SCM stream = SCM_STREAM (port);
+ SCM string = SCM_CDR (stream);
+ if (string_mark_p) SCM_SETGC8MARK (string);
+ if (stream_mark_p) SCM_SETGCMARK (stream);
+ if (port_mark_p) SCM_SETGC8MARK (port);
+}
+
+
+int
+gdb_maybe_valid_type_p (value)
+ SCM value;
+{
+ if (SCM_IMP (value) || scm_cellp (value))
+ return scm_tag (value) != SCM_MAKINUM (-1);
+ return 0;
+}
+
+
+int
+gdb_read (str)
+ char *str;
+{
+ SCM ans;
+ int status = 0;
+ RESET_STRING;
+ /* Need to be restrictive about what to read? */
+ if (SCM_GC_P)
+ {
+ char *p;
+ for (p = str; *p != '\0'; ++p)
+ switch (*p)
+ {
+ case '(':
+ case '\'':
+ case '"':
+ SEND_STRING ("Can't read this kind of expressions during gc");
+ return -1;
+ case '#':
+ if (*++p == '\0')
+ goto premature;
+ if (*p == '\\')
+ {
+ if (*++p != '\0')
+ continue;
+ premature:
+ SEND_STRING ("Premature end of lisp expression");
+ return -1;
+ }
+ default:
+ continue;
+ }
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ unmark_port (gdb_input_port);
+ /* Replace string in input port and reset stream */
+ ans = SCM_CDR (SCM_STREAM (gdb_input_port));
+ SCM_SETCHARS (ans, str);
+ SCM_SETLENGTH (ans, strlen (str), scm_tc7_string);
+ SCM_SETCAR (SCM_STREAM (gdb_input_port), SCM_INUM0);
+ /* Read one object */
+ tok_buf_mark_p = SCM_GC8MARKP (tok_buf);
+ SCM_CLRGC8MARK (tok_buf);
+ ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
+ if (SCM_GC_P)
+ {
+ if (SCM_NIMP (ans))
+ {
+ SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
+ status = -1;
+ goto exit;
+ }
+ }
+ gdb_result = ans;
+ /* Protect answer from future GC */
+ if (SCM_NIMP (ans))
+ scm_permanent_object (ans);
+exit:
+ if (tok_buf_mark_p)
+ SCM_SETGC8MARK (tok_buf);
+ remark_port (gdb_input_port);
+ SCM_END_FOREIGN_BLOCK;
+ return status;
+}
+
+
+int
+gdb_eval (exp)
+ SCM exp;
+{
+ RESET_STRING;
+ if (SCM_IMP (exp))
+ {
+ gdb_result = exp;
+ return 0;
+ }
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't evaluate lisp expressions during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
+ gdb_result = scm_permanent_object (scm_ceval (exp, env));
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+
+int
+gdb_print (obj)
+ SCM obj;
+{
+ RESET_STRING;
+ SCM_BEGIN_FOREIGN_BLOCK;
+ /* Reset stream */
+ SCM_SETCAR (SCM_STREAM (gdb_output_port), SCM_INUM0);
+ scm_write (obj, gdb_output_port);
+ scm_display (SCM_MAKICHR (0), gdb_output_port);
+ SEND_STRING (SCM_CHARS (SCM_CDR (SCM_STREAM (gdb_output_port))));
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+
+int
+gdb_binding (name, value)
+ SCM name;
+ SCM value;
+{
+ RESET_STRING;
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't create new bindings during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM vcell = scm_sym2vcell (name,
+ SCM_CDR (scm_top_level_lookup_closure_var),
+ SCM_BOOL_T);
+ SCM_SETCDR (vcell, value);
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+void
+scm_init_gdbint ()
+{
+ static char *s = "scm_init_gdb_interface";
+ SCM port;
+
+ scm_print_carefully_p = 0;
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ s);
+ gdb_output_port = scm_permanent_object (port);
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
+ SCM_OPN | SCM_RDNG,
+ s);
+ gdb_input_port = scm_permanent_object (port);
+
+ tok_buf = scm_permanent_object (scm_makstr (30L, 0));
+}
diff --git a/libguile/gdbint.h b/libguile/gdbint.h
new file mode 100644
index 000000000..bf12524f6
--- /dev/null
+++ b/libguile/gdbint.h
@@ -0,0 +1,58 @@
+/* classes: h_files */
+
+#ifndef GDBINTH
+#define GDBINTH
+/* Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+extern int scm_print_carefully_p;
+
+extern void scm_init_gdbint SCM_P ((void));
+
+#endif /* GDBINTH */
diff --git a/libguile/genio.c b/libguile/genio.c
index 6bc082536..5ebd86e3f 100644
--- a/libguile/genio.c
+++ b/libguile/genio.c
@@ -42,34 +42,36 @@
#include "extchrs.h"
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "genio.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
-#ifdef __STDC__
-static void
-scm_putc (int c, SCM port)
-#else
+
+static void scm_putc SCM_P ((int c, SCM port));
+
static void
scm_putc (c, port)
int c;
SCM port;
-#endif
{
scm_sizet i = SCM_PTOBNUM (port);
SCM_SYSCALL ((scm_ptobs[i].fputc) (c, SCM_STREAM (port)));
}
-#ifdef __STDC__
-static void
-scm_puts (char *s, SCM port)
-#else
+
+static void scm_puts SCM_P ((char *s, SCM port));
+
static void
scm_puts (s, port)
char *s;
SCM port;
-#endif
{
scm_sizet i = SCM_PTOBNUM (port);
SCM_SYSCALL ((scm_ptobs[i].fputs) (s, SCM_STREAM (port)));
@@ -80,17 +82,15 @@ scm_puts (s, port)
}
-#ifdef __STDC__
-static int
-scm_lfwrite (char *ptr, scm_sizet size, scm_sizet nitems, SCM port)
-#else
+
+static int scm_lfwrite SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM port));
+
static int
scm_lfwrite (ptr, size, nitems, port)
char *ptr;
scm_sizet size;
scm_sizet nitems;
SCM port;
-#endif
{
int ret;
scm_sizet i = SCM_PTOBNUM (port);
@@ -105,15 +105,11 @@ scm_lfwrite (ptr, size, nitems, port)
-#ifdef __STDC__
-void
-scm_gen_putc (int c, SCM port)
-#else
+
void
scm_gen_putc (c, port)
int c;
SCM port;
-#endif
{
switch (SCM_PORT_REPRESENTATION (port))
{
@@ -162,18 +158,12 @@ scm_gen_putc (c, port)
-#ifdef __STDC__
-void
-scm_gen_puts (enum scm_string_representation_type rep,
- char *str_data,
- SCM port)
-#else
+
void
scm_gen_puts (rep, str_data, port)
enum scm_string_representation_type rep;
- unsigned char *str_data;
+ char *str_data;
SCM port;
-#endif
{
switch (rep)
{
@@ -228,7 +218,7 @@ scm_gen_puts (rep, str_data, port)
{
xwchar_t * wstr_data;
- wstr_data = (xwchar_t *)wstr_data;
+ wstr_data = (xwchar_t *) str_data;
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
@@ -279,17 +269,13 @@ scm_gen_puts (rep, str_data, port)
-#ifdef __STDC__
-void
-scm_gen_write (enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port)
-#else
+
void
scm_gen_write (rep, str_data, nitems, port)
enum scm_string_representation_type rep;
char *str_data;
scm_sizet nitems;
SCM port;
-#endif
{
/* is nitems bytes or characters in the mb_string case? */
@@ -345,7 +331,7 @@ scm_gen_write (rep, str_data, nitems, port)
{
xwchar_t * wstr_data;
- wstr_data = (xwchar_t *)wstr_data;
+ wstr_data = (xwchar_t *) str_data;
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
@@ -395,33 +381,27 @@ scm_gen_write (rep, str_data, nitems, port)
-#ifdef __STDC__
-static int
-scm_getc (SCM port)
-#else
+
+static int scm_getc SCM_P ((SCM port));
+
static int
scm_getc (port)
SCM port;
-#endif
{
- FILE *f;
+ SCM f;
int c;
scm_sizet i;
- f = (FILE *)SCM_STREAM (port);
+ f = SCM_STREAM (port);
i = SCM_PTOBNUM (port);
SCM_SYSCALL (c = (scm_ptobs[i].fgetc) (f));
return c;
}
-#ifdef __STDC__
-int
-scm_gen_getc (SCM port)
-#else
+
int
scm_gen_getc (port)
SCM port;
-#endif
{
int c;
@@ -458,7 +438,6 @@ scm_gen_getc (port)
{
int x;
unsigned char buf[256];
- int c;
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
"huge translation", "scm_gen_puts");
@@ -507,15 +486,11 @@ scm_gen_getc (port)
}
}
-#ifdef __STDC__
-void
-scm_gen_ungetc (int c, SCM port)
-#else
+
void
scm_gen_ungetc (c, port)
int c;
SCM port;
-#endif
{
/* SCM_ASSERT(!SCM_CRDYP(port), port, SCM_ARG2, "too many scm_gen_ungetc");*/
SCM_CUNGET (c, port);
diff --git a/libguile/genio.h b/libguile/genio.h
index 30275211b..78d17fac5 100644
--- a/libguile/genio.h
+++ b/libguile/genio.h
@@ -44,26 +44,16 @@
*/
-#include "__scm.h"
-#include "ports.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern void scm_gen_putc (int c, SCM port);
-extern void scm_gen_puts (enum scm_string_representation_type rep,
- char *str_data,
- SCM port);
-extern void scm_gen_write (enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port);
-extern int scm_gen_getc (SCM port);
-extern void scm_gen_ungetc (int c, SCM port);
-
-#else /* STDC */
-extern void scm_gen_putc ();
-extern void scm_gen_puts ();
-extern void scm_gen_write ();
-extern int scm_gen_getc ();
-extern void scm_gen_ungetc ();
-#endif /* STDC */
+extern void scm_gen_putc SCM_P ((int c, SCM port));
+extern void scm_gen_puts SCM_P ((enum scm_string_representation_type rep,
+ char *str_data,
+ SCM port));
+extern void scm_gen_write SCM_P ((enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port));
+extern int scm_gen_getc SCM_P ((SCM port));
+extern void scm_gen_ungetc SCM_P ((int c, SCM port));
#endif /* GENIOH */
diff --git a/libguile/gh.h b/libguile/gh.h
new file mode 100644
index 000000000..890b48883
--- /dev/null
+++ b/libguile/gh.h
@@ -0,0 +1,195 @@
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#ifndef __GH_H
+#define __GH_H
+
+#include <stdio.h>
+
+#include <libguile.h>
+
+/* gcc has extern inline functions that are basically as fast as macros */
+#ifdef __GNUC__
+# define INL inline
+# define EXTINL extern inline
+#else
+# define INL
+#define EXTINL
+#endif /* __GNUC__ */
+
+void gh_enter(int argc, char *argv[], void (*c_main_prog)());
+void gh_repl();
+SCM gh_catch(SCM tag, scm_catch_body_t body, void *body_data,
+ scm_catch_handler_t handler, void *handler_data);
+
+/* SCM gh_catch_with_saved_stack (SCM tag, scm_catch_body_t body, */
+/* void *body_data, scm_catch_handler_t handler, */
+/* void *handler_data); */
+SCM gh_standard_handler(void *data, SCM tag, SCM throw_args);
+#if 0
+SCM gh_repl_handler(void *data, SCM tag, SCM throw_args);
+void gh_enter_repl(int argc, char *argv[], void (*init_proc)());
+#endif /* 0 */
+
+SCM gh_eval_str(char *scheme_code);
+SCM gh_eval_str_with_catch(char *scheme_code, scm_catch_handler_t handler);
+SCM gh_eval_str_with_standard_handler(char *scheme_code);
+SCM gh_eval_str_with_stack_saving_handler(char *scheme_code);
+
+SCM gh_eval_file(char *fname);
+SCM gh_eval_file_with_catch(char *scheme_code, scm_catch_handler_t handler);
+SCM gh_eval_file_with_standard_handler(char *scheme_code);
+
+#define gh_defer_ints() SCM_DEFER_INTS
+#define gh_allow_ints() SCM_ALLOW_INTS
+
+SCM gh_new_procedure(char *proc_name, SCM (*fn)(),
+ int n_required_args, int n_optional_args, int varp);
+SCM gh_new_procedure0_0(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure0_1(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure0_2(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure1_0(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure1_1(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure1_2(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure2_0(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure2_1(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure2_2(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure3_0(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure4_0(char *proc_name, SCM (*fn)());
+SCM gh_new_procedure5_0(char *proc_name, SCM (*fn)());
+
+/* C to Scheme conversion */
+SCM gh_bool2scm(int x);
+SCM gh_int2scm(int x);
+SCM gh_ulong2scm(unsigned long x);
+SCM gh_long2scm(long x);
+SCM gh_double2scm(double x);
+SCM gh_char2scm(char c);
+SCM gh_str2scm(char *s, int len);
+SCM gh_str02scm(char *s);
+void gh_set_substr(char *src, SCM dst, int start, int len);
+SCM gh_symbol2scm(char *symbol_str);
+
+
+/* Scheme to C conversion */
+int gh_scm2bool(SCM obj);
+int gh_scm2int(SCM obj);
+unsigned long gh_scm2ulong(SCM obj);
+long gh_scm2long(SCM obj);
+char gh_scm2char(SCM obj);
+double gh_scm2double(SCM obj);
+char *gh_scm2newstr(SCM str, int *lenp);
+void gh_get_substr(SCM src, char *dst, int start, int len);
+char *gh_symbol2newstr(SCM sym, int *lenp);
+
+/* type predicates: tell you if an SCM object has a given type */
+int gh_boolean_p(SCM val);
+int gh_symbol_p(SCM val);
+int gh_char_p(SCM val);
+int gh_vector_p(SCM val);
+int gh_pair_p(SCM val);
+int gh_number_p(SCM val);
+int gh_string_p(SCM val);
+int gh_procedure_p(SCM val);
+int gh_list_p(SCM val);
+int gh_inexact_p(SCM val);
+int gh_exact_p(SCM val);
+
+/* more predicates */
+int gh_eq_p(SCM x, SCM y);
+int gh_eqv_p(SCM x, SCM y);
+int gh_equal_p(SCM x, SCM y);
+
+/* standard Scheme procedures available from C */
+
+SCM gh_define(char *name, SCM val);
+
+SCM gh_vector(SCM length, SCM val);
+SCM gh_vset(SCM vec, SCM pos, SCM val);
+SCM gh_vref(SCM vec, SCM pos);
+unsigned long gh_vector_length(SCM v);
+
+SCM gh_cons(SCM x, SCM y);
+#define gh_list scm_listify
+unsigned long gh_list_length(SCM l);
+
+SCM gh_car(SCM x);
+SCM gh_cdr(SCM x);
+
+SCM gh_caar(SCM x);
+SCM gh_cadr(SCM x);
+SCM gh_cdar(SCM x);
+SCM gh_cddr(SCM x);
+
+SCM gh_caaar(SCM x);
+SCM gh_caadr(SCM x);
+SCM gh_cadar(SCM x);
+SCM gh_caddr(SCM x);
+SCM gh_cdaar(SCM x);
+SCM gh_cdadr(SCM x);
+SCM gh_cddar(SCM x);
+SCM gh_cdddr(SCM x);
+
+/* Calling Scheme functions from C. */
+SCM gh_apply (SCM proc, SCM ls);
+SCM gh_call0 (SCM proc);
+SCM gh_call1 (SCM proc, SCM arg);
+SCM gh_call2 (SCM proc, SCM arg1, SCM arg2);
+SCM gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
+
+/* reading and writing Scheme objects. */
+void gh_display (SCM x);
+void gh_newline (void);
+
+/* void gh_gc_mark(SCM) : mark an SCM as in use. */
+/* void gh_defer_ints() : don't interrupt code section. */
+/* void gh_allow_ints() : see gh_defer_ints(). */
+/* void gh_new_cell(SCM, int tag) : initialize SCM to be of type 'tag' */
+/* int gh_type_p(SCM, tag) : test if SCM is of type 'tag' */
+/* SCM gh_intern(char*) : get symbol corresponding to c-string.*/
+/* void gh_set_ext_data(SCM, void*) : set extension data on SCM */
+/* void *gh_get_ext_data(SCM) : return extension data from SCM. */
+
+/* void gh_assert(int cond, char *msg, SCM obj); */
+
+
+#endif /* __GH_H */
diff --git a/libguile/gh_data.c b/libguile/gh_data.c
new file mode 100644
index 000000000..5992365c8
--- /dev/null
+++ b/libguile/gh_data.c
@@ -0,0 +1,286 @@
+/* Copyright (C) 1995,1996,1987 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* data initialization and C<->Scheme data conversion */
+
+#include <stdio.h>
+
+#include <gh.h>
+
+/* data conversion C->scheme */
+SCM
+gh_int2scmb (int x)
+{
+ return (x ? SCM_BOOL_T : SCM_BOOL_F);
+}
+SCM
+gh_int2scm (int x)
+{
+ return scm_long2num ((long) x);
+}
+SCM
+gh_ulong2scm (unsigned long x)
+{
+ return scm_ulong2num (x);
+}
+SCM
+gh_long2scm (long x)
+{
+ return scm_long2num (x);
+}
+SCM
+gh_double2scm (double x)
+{
+ return scm_makdbl (x, 0.0);
+}
+SCM
+gh_char2scm (char c)
+{
+ return SCM_MAKICHR (c);
+}
+SCM
+gh_str2scm (char *s, int len)
+{
+ return scm_makfromstr (s, len, 0);
+}
+SCM
+gh_str02scm (char *s)
+{
+ return scm_makfrom0str (s);
+}
+/* Copy LEN characters at SRC into the *existing* Scheme string DST,
+ starting at START. START is an index into DST; zero means the
+ beginning of the string.
+
+ If START + LEN is off the end of DST, signal an out-of-range
+ error. */
+void
+gh_set_substr (char *src, SCM dst, int start, int len)
+{
+ char *dst_ptr, dst_len, effective_length;
+
+ SCM_ASSERT (SCM_NIMP (dst) && SCM_STRINGP (dst), dst, SCM_ARG3,
+ "gh_set_substr");
+ scm_protect_object (dst);
+ dst_ptr = SCM_CHARS (dst);
+ dst_len = SCM_LENGTH (dst);
+ effective_length = (len < dst_len) ? len : dst_len;
+ memcpy (dst_ptr + start, src, effective_length);
+ /* FIXME: must signal an error if len > dst_len */
+ scm_unprotect_object (dst);
+}
+
+/* Return the symbol named SYMBOL_STR. */
+SCM
+gh_symbol2scm (char *symbol_str)
+{
+ return SCM_CAR (scm_intern (symbol_str, strlen (symbol_str)));
+}
+
+
+/* data conversion scheme->C */
+int
+gh_scm2bool (SCM obj)
+{
+ return ((obj) == SCM_BOOL_F) ? 0 : 1;
+}
+unsigned long
+gh_scm2ulong (SCM obj)
+{
+ return scm_num2ulong (obj, (char *) SCM_ARG1, "gh_scm2ulong");
+}
+long
+gh_scm2long (SCM obj)
+{
+ return scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2long");
+}
+int
+gh_scm2int (SCM obj)
+{
+ /* NOTE: possible loss of precision here */
+ return (int) scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2int");
+}
+double
+gh_scm2double (SCM obj)
+{
+ return scm_num2dbl (obj, "gh_scm2double");
+}
+char
+gh_scm2char (SCM obj)
+{
+ return SCM_ICHR (obj);
+}
+
+/* string conversions between C and Scheme */
+
+/* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
+ new copy of its contents, followed by a null byte. If lenp is
+ non-null, set *lenp to the string's length.
+
+ This function uses malloc to obtain storage for the copy; the
+ caller is responsible for freeing it.
+
+ Note that Scheme strings may contain arbitrary data, including null
+ characters. This means that null termination is not a reliable way
+ to determine the length of the returned value. However, the
+ function always copies the complete contents of STR, and sets
+ *LEN_P to the true length of the string (when LEN_P is non-null). */
+char *
+gh_scm2newstr (SCM str, int *lenp)
+{
+ char *ret_str;
+ int len;
+
+ SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG3,
+ "gh_scm2newstr");
+
+ /* protect str from GC while we copy off its data */
+ scm_protect_object (str);
+
+ len = SCM_LENGTH (str);
+
+ ret_str = (char *) malloc ((len + 1) * sizeof (char));
+ /* so we copy tmp_str to ret_str, which is what we will allocate */
+ memcpy (ret_str, SCM_CHARS (str), len);
+ /* now make sure we null-terminate it */
+ ret_str[len] = '\0';
+
+ scm_unprotect_object (str);
+
+ if (lenp != NULL)
+ {
+ *lenp = len;
+ }
+
+ return ret_str;
+}
+
+
+/* Copy LEN characters at START from the Scheme string SRC to memory
+ at DST. START is an index into SRC; zero means the beginning of
+ the string. DST has already been allocated by the caller.
+
+ If START + LEN is off the end of SRC, silently truncate the source
+ region to fit the string. If truncation occurs, the corresponding
+ area of DST is left unchanged. */
+void
+gh_get_substr (SCM src, char *dst, int start, int len)
+{
+ int src_len, effective_length;
+ SCM_ASSERT (SCM_NIMP (src) && SCM_STRINGP (src), src, SCM_ARG3,
+ "gh_get_substr");
+
+ scm_protect_object (src);
+ src_len = SCM_LENGTH (src);
+ effective_length = (len < src_len) ? len : src_len;
+ memcpy (dst + start, SCM_CHARS (src), effective_length * sizeof (char));
+ /* FIXME: must signal an error if len > src_len */
+ scm_unprotect_object (src);
+}
+
+
+/* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
+ pointer to a string with the symbol characters "identifier",
+ followed by a null byte. If lenp is non-null, set *lenp to the
+ string's length.
+
+ This function uses malloc to obtain storage for the copy; the
+ caller is responsible for freeing it. */
+char *
+gh_symbol2newstr (SCM sym, int *lenp)
+{
+ char *ret_str;
+ int len;
+
+ SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG3,
+ "gh_scm2newsymbol");
+
+ /* protect str from GC while we copy off its data */
+ scm_protect_object (sym);
+
+ len = SCM_LENGTH (sym);
+
+ ret_str = (char *) malloc ((len + 1) * sizeof (char));
+ /* so we copy tmp_str to ret_str, which is what we will allocate */
+ memcpy (ret_str, SCM_CHARS (sym), len);
+ /* now make sure we null-terminate it */
+ ret_str[len] = '\0';
+
+ scm_unprotect_object (sym);
+
+ if (lenp != NULL)
+ {
+ *lenp = len;
+ }
+
+ return ret_str;
+}
+
+
+/* create a new vector of the given length, all initialized to the
+ given value */
+SCM
+gh_vector (SCM length, SCM val)
+{
+ return scm_make_vector (length, val, SCM_UNDEFINED);
+}
+
+/* set the given element of the given vector to the given value */
+SCM
+gh_vset (SCM vec, SCM pos, SCM val)
+{
+ return scm_vector_set_x (vec, pos, val);
+}
+
+/* retrieve the given element of the given vector */
+SCM
+gh_vref (SCM vec, SCM pos)
+{
+ return scm_vector_ref (vec, pos);
+}
+
+/* returns the length of the given vector */
+unsigned long
+gh_vector_length (SCM v)
+{
+ return gh_scm2ulong (scm_vector_length (v));
+}
diff --git a/libguile/gh_eval.c b/libguile/gh_eval.c
new file mode 100644
index 000000000..bad70ed13
--- /dev/null
+++ b/libguile/gh_eval.c
@@ -0,0 +1,180 @@
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* routines to evaluate Scheme code */
+
+#include <stdio.h>
+
+#include <gh.h>
+
+typedef SCM (*gh_eval_t) (void *data, SCM jmpbuf);
+
+struct cwss_data
+ {
+ SCM tag;
+ scm_catch_body_t body;
+ void *data;
+ };
+
+/* Evaluate the string; toss the value. */
+#if 0
+void
+gh_eval_str (char *scheme_code)
+{
+ /* Create a port that reads characters from SCHEME_CODE. */
+ SCM port = scm_mkstrport (SCM_MAKINUM (0),
+ scm_makfrom0str (scheme_code),
+ SCM_OPN | SCM_RDNG,
+ "guile_main");
+ SCM form;
+
+ /* Read expressions from that port; ignore the values. */
+ while ((form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F)) != SCM_EOF_VAL)
+ scm_eval_x (form);
+
+ /* Dispose of the port when done. (Oh icky.) */
+ scm_close_port (port);
+}
+#endif /* 0 */
+
+SCM
+gh_eval_str (char *scheme_code)
+{
+ return scm_eval_0str (scheme_code);
+}
+
+/* evaluate the file by passing it to the lower level scm_primitive_load() */
+SCM
+gh_eval_file (char *fname)
+{
+ return scm_primitive_load (gh_str02scm (fname));
+}
+
+static SCM
+eval_str_wrapper (void *data, SCM jmpbuf)
+{
+/* gh_eval_t real_eval_proc = (gh_eval_t) (* ((gh_eval_t *) data)); */
+
+ char *scheme_code = (char *) data;
+ return gh_eval_str (scheme_code);
+}
+
+SCM
+gh_eval_str_with_catch (char *scheme_code, scm_catch_handler_t handler)
+{
+ /* FIXME: not there yet */
+ return gh_catch (SCM_BOOL_T, (scm_catch_body_t) eval_str_wrapper, scheme_code,
+ (scm_catch_handler_t) gh_standard_handler, scheme_code);
+}
+
+SCM
+gh_eval_str_with_standard_handler (char *scheme_code)
+{
+ return gh_eval_str_with_catch (scheme_code, gh_standard_handler);
+}
+
+
+SCM
+ss_handler (void *data, SCM tag, SCM throw_args)
+{
+ /* Save the stack */
+ SCM_SETCDR (scm_the_last_stack_var,
+ scm_make_stack (scm_cons (SCM_BOOL_T, SCM_EOL)));
+ /* Throw the error */
+ return scm_throw (tag, throw_args);
+}
+
+static SCM
+cwss_body (void *data, SCM jmpbuf)
+{
+ struct cwss_data *d = data;
+ return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
+}
+/* FIXME: should catch_with_saved_stack() be in the gh_ API? */
+static SCM
+catch_with_saved_stack (SCM tag,
+ scm_catch_body_t body,
+ void *body_data,
+ scm_catch_handler_t handler,
+ void *handler_data)
+{
+ struct cwss_data d;
+ d.tag = tag;
+ d.body = body;
+ d.data = body_data;
+ return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
+}
+
+SCM
+gh_eval_str_with_stack_saving_handler (char *scheme_code)
+{
+ return catch_with_saved_stack (SCM_BOOL_T,
+ (scm_catch_body_t) eval_str_wrapper,
+ scheme_code,
+ (scm_catch_handler_t)
+ gh_standard_handler,
+ scheme_code);
+}
+
+static SCM
+eval_file_wrapper (void *data, SCM jmpbuf)
+{
+/* gh_eval_t real_eval_proc = (gh_eval_t) (* ((gh_eval_t *) data)); */
+
+ char *scheme_code = (char *) data;
+ return gh_eval_file (scheme_code);
+}
+
+SCM
+gh_eval_file_with_catch (char *scheme_code, scm_catch_handler_t handler)
+{
+ /* FIXME: not there yet */
+ return gh_catch (SCM_BOOL_T, (scm_catch_body_t) eval_file_wrapper,
+ scheme_code, (scm_catch_handler_t) gh_standard_handler,
+ scheme_code);
+}
+
+SCM
+gh_eval_file_with_standard_handler (char *scheme_code)
+{
+ return gh_eval_file_with_catch (scheme_code, gh_standard_handler);
+}
diff --git a/libguile/gh_funcs.c b/libguile/gh_funcs.c
new file mode 100644
index 000000000..048ab209a
--- /dev/null
+++ b/libguile/gh_funcs.c
@@ -0,0 +1,169 @@
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+
+/* Defining Scheme functions implemented by C functions --- subrs. */
+
+#include <stdio.h>
+
+#include <gh.h>
+
+/* allows you to define new scheme primitives written in C */
+SCM
+gh_new_procedure (char *proc_name, SCM (*fn) (),
+ int n_required_args, int n_optional_args, int varp)
+{
+ return scm_make_gsubr (proc_name, n_required_args, n_optional_args,
+ varp, fn);
+}
+
+SCM
+gh_new_procedure0_0 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 0, 0, 0);
+}
+
+SCM
+gh_new_procedure0_1 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 0, 1, 0);
+}
+
+SCM
+gh_new_procedure0_2 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 0, 2, 0);
+}
+
+SCM
+gh_new_procedure1_0 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 1, 0, 0);
+}
+
+SCM
+gh_new_procedure1_1 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 1, 1, 0);
+}
+
+SCM
+gh_new_procedure1_2 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 1, 2, 0);
+}
+
+SCM
+gh_new_procedure2_0 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 2, 0, 0);
+}
+
+SCM
+gh_new_procedure2_1 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 2, 1, 0);
+}
+
+SCM
+gh_new_procedure2_2 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 2, 2, 0);
+}
+
+SCM
+gh_new_procedure3_0 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 3, 0, 0);
+}
+
+SCM
+gh_new_procedure4_0 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 4, 0, 0);
+}
+
+SCM
+gh_new_procedure5_0 (char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 5, 0, 0);
+}
+
+/* some (possibly most) Scheme functions available from C */
+SCM
+gh_define (char *name, SCM val)
+{
+ return scm_sysintern (name, val);
+}
+
+
+/* Calling Scheme functions from C. */
+
+SCM
+gh_apply (SCM proc, SCM args)
+{
+ return scm_apply (proc, args, SCM_EOL);
+}
+
+SCM
+gh_call0 (SCM proc)
+{
+ return scm_apply (proc, SCM_EOL, SCM_EOL);
+}
+
+SCM
+gh_call1 (SCM proc, SCM arg)
+{
+ return scm_apply (proc, arg, scm_listofnull);
+}
+
+SCM
+gh_call2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+}
+
+SCM
+gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
+{
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+}
diff --git a/libguile/gh_init.c b/libguile/gh_init.c
new file mode 100644
index 000000000..50517d441
--- /dev/null
+++ b/libguile/gh_init.c
@@ -0,0 +1,107 @@
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* Guile high level (gh_) interface, initialization-related stuff */
+
+#include <stdio.h>
+
+#include <gh.h>
+
+typedef void (*main_prog_t) (int argc, char **argv);
+typedef void (*repl_prog_t) (int argc, char **argv);
+
+/* This function takes care of all real GH initialization. Since it's
+ called by scm_boot_guile, it can safely work with heap objects, or
+ call functions that do so. */
+static void
+gh_launch_pad (void *closure, int argc, char **argv)
+{
+ main_prog_t c_main_prog = (main_prog_t) closure;
+
+ gh_eval_str ("(primitive-load-path \"ice-9/boot-9.scm\")");
+ c_main_prog (argc, argv);
+ exit (0);
+}
+
+
+/* starts up the Scheme interpreter, and stays in it. c_main_prog()
+ is the address of the user's main program, since gh_enter() never
+ returns. */
+void
+gh_enter (int argc, char *argv[], main_prog_t c_main_prog)
+{
+ scm_boot_guile (argc, argv, gh_launch_pad, c_main_prog);
+ /* never returns */
+}
+
+/* offer a REPL to the C programmer; for now I just invoke the ice-9
+ REPL that is written in Scheme */
+void
+gh_repl ()
+{
+/* gh_eval_str("(primitive-load-path \"ice-9/boot-9.scm\")"); */
+ gh_eval_str ("(top-repl)");
+}
+
+/* libguile programmers need exception handling mechanisms; here is
+ the recommended way of doing it with the gh_ interface */
+
+/* gh_catch() -- set up an exception handler for a particular type of
+ error (or any thrown error if tag is SCM_BOOL_T); see
+ ../libguile/throw.c for the comments explaining scm_internal_catch */
+SCM
+gh_catch (SCM tag, scm_catch_body_t body, void *body_data,
+ scm_catch_handler_t handler, void *handler_data)
+{
+ return scm_internal_catch (tag, body, body_data, handler, handler_data);
+}
+
+SCM
+gh_standard_handler (void *data, SCM tag, SCM throw_args)
+{
+ fprintf (stderr, "\nJust got an error; tag is\n ");
+ scm_display (tag, scm_current_output_port ());
+ scm_newline (scm_current_output_port ());
+ scm_newline (scm_current_output_port ());
+
+ return SCM_BOOL_F;
+}
diff --git a/libguile/gh_io.c b/libguile/gh_io.c
new file mode 100644
index 000000000..7488c189c
--- /dev/null
+++ b/libguile/gh_io.c
@@ -0,0 +1,57 @@
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include <stdio.h>
+
+#include <gh.h>
+
+void
+gh_display (SCM x)
+{
+ scm_display (x, scm_current_output_port ());
+}
+
+void
+gh_newline ()
+{
+ scm_newline (scm_current_output_port ());
+}
diff --git a/libguile/gh_list.c b/libguile/gh_list.c
new file mode 100644
index 000000000..b54c03d60
--- /dev/null
+++ b/libguile/gh_list.c
@@ -0,0 +1,142 @@
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* list manipulation */
+
+#include <stdio.h>
+
+#include <gh.h>
+
+/* returns the length of a list */
+unsigned long
+gh_list_length (SCM l)
+{
+ return gh_scm2ulong (scm_list_length (l));
+}
+
+/* list operations */
+
+/* analogous to the Scheme cons operator */
+SCM
+gh_cons (SCM x, SCM y)
+{
+ return scm_cons (x, y);
+}
+
+/* gh_list(SCM elt, ...) is implemented as a macro in gh.h. */
+
+/* analogous to the Scheme car operator */
+SCM
+gh_car (SCM x)
+{
+ return SCM_CAR (x);
+}
+
+/* analogous to the Scheme cdr operator */
+SCM
+gh_cdr (SCM x)
+{
+ return SCM_CDR (x);
+}
+
+/* now for the multiple car/cdr utility procedures */
+SCM
+gh_caar (SCM x)
+{
+ return SCM_CAAR (x);
+}
+SCM
+gh_cadr (SCM x)
+{
+ return SCM_CADR (x);
+}
+SCM
+gh_cdar (SCM x)
+{
+ return SCM_CDAR (x);
+}
+SCM
+gh_cddr (SCM x)
+{
+ return SCM_CDDR (x);
+}
+
+SCM
+gh_caaar (SCM x)
+{
+ return SCM_CAAAR (x);
+}
+SCM
+gh_caadr (SCM x)
+{
+ return SCM_CAADR (x);
+}
+SCM
+gh_cadar (SCM x)
+{
+ return SCM_CADAR (x);
+}
+SCM
+gh_caddr (SCM x)
+{
+ return SCM_CADDR (x);
+}
+SCM
+gh_cdaar (SCM x)
+{
+ return SCM_CDAAR (x);
+}
+SCM
+gh_cdadr (SCM x)
+{
+ return SCM_CDADR (x);
+}
+SCM
+gh_cddar (SCM x)
+{
+ return SCM_CDDAR (x);
+}
+SCM
+gh_cdddr (SCM x)
+{
+ return SCM_CDDDR (x);
+}
diff --git a/libguile/gh_predicates.c b/libguile/gh_predicates.c
new file mode 100644
index 000000000..e0183955c
--- /dev/null
+++ b/libguile/gh_predicates.c
@@ -0,0 +1,121 @@
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* type predicates and equality predicates */
+
+#include <stdio.h>
+
+#include <gh.h>
+
+/* type predicates: tell you if an SCM object has a given type */
+int
+gh_boolean_p (SCM val)
+{
+ return (scm_boolean_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_symbol_p (SCM val)
+{
+ return (scm_symbol_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_char_p (SCM val)
+{
+ return (scm_char_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_vector_p (SCM val)
+{
+ return (scm_vector_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_pair_p (SCM val)
+{
+ return (scm_pair_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_number_p (SCM val)
+{
+ return (scm_number_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_string_p (SCM val)
+{
+ return (scm_string_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_procedure_p (SCM val)
+{
+ return (scm_procedure_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_list_p (SCM val)
+{
+ return (scm_list_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_inexact_p (SCM val)
+{
+ return (scm_inexact_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_exact_p (SCM val)
+{
+ return (scm_exact_p (val) == SCM_BOOL_T) ? 1 : 0;
+}
+
+/* the three types of equality */
+int
+gh_eq_p (SCM x, SCM y)
+{
+ return (scm_eq_p (x, y) == SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_eqv_p (SCM x, SCM y)
+{
+ return (scm_eqv_p (x, y) != SCM_BOOL_T) ? 1 : 0;
+}
+int
+gh_equal_p (SCM x, SCM y)
+{
+ return (scm_equal_p (x, y) != SCM_BOOL_T) ? 1 : 0;
+}
diff --git a/libguile/gh_test_c.c b/libguile/gh_test_c.c
new file mode 100644
index 000000000..526b50e92
--- /dev/null
+++ b/libguile/gh_test_c.c
@@ -0,0 +1,221 @@
+/* Copyright (C) 1995,1996,1987 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include <stdio.h>
+#include <math.h>
+#include <assert.h>
+
+#include <gh.h>
+
+SCM c_factorial (SCM s_n);
+SCM c_sin (SCM s_x);
+SCM c_vector_test (SCM s_length);
+
+/* the gh_enter() routine, the standard entryp point for the gh_
+ interface, makes you use a separate main function */
+void
+main_prog (int argc, char *argv[])
+{
+ int done;
+ char input_str[1000];
+ SCM cf;
+ SCM result_dummy;
+
+ result_dummy = gh_eval_str ("(display \"hello guile\n\")");
+ gh_display (result_dummy);
+
+ printf ("\ntesting gh_define\n");
+ gh_define ("test_symbol", gh_double2scm (2.5));
+ gh_eval_str ("(display test_symbol) (newline)");
+
+ /* test playing with symbols */
+ {
+ SCM sym;
+ char *sym_string;
+ sym = gh_symbol2scm ("a-test-symbol");
+ sym_string = gh_symbol2newstr (sym, NULL);
+ printf ("the symbol was <%s>; after converting to Scheme and back to\n",
+ "a-test-symbol");
+ printf ("a C string it is now <%s>\n", sym_string);
+ free (sym_string);
+ }
+
+ /* here result dummy should be a string object */
+ result_dummy = gh_eval_str ("\"test_string\"");
+ assert (gh_string_p (result_dummy));
+ {
+ char *s;
+ s = gh_scm2newstr (result_dummy, NULL);
+ printf ("result of converting \"test_string\" from SCM to C is <%s>\n", s);
+ free (s); /* remember to free s!! */
+ }
+
+ gh_eval_str ("(define (square x) (* x x))");
+ gh_eval_str ("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))");
+
+ gh_eval_str ("(display (square 9)) (newline)");
+ gh_eval_str ("(display (fact 100)) (newline)");
+
+ gh_eval_str_with_standard_handler ("(display \"dude!\n\")");
+
+ /* in this next line I have a wilful typo: dosplay is not a defined
+ procedure, so it should throw an error */
+ gh_eval_str_with_standard_handler ("(dosplay \"dude!\n\")");
+
+ /* now define some new primitives in C */
+ cf = gh_new_procedure1_0 ("c_factorial", c_factorial);
+ gh_new_procedure1_0 ("c_sin", c_sin);
+ gh_new_procedure1_0 ("c_vector_test", c_vector_test);
+
+ /* now try some (eval ...) action from C */
+ {
+ SCM l = SCM_EOL;
+ l = gh_cons (gh_str02scm ("hello world"), l);
+ l = gh_cons (gh_symbol2scm ("display"), l);
+ printf ("expression is: ");
+ gh_display (l);
+ gh_newline ();
+ /* Don't have a function for evaluating sexps yet. */
+ }
+
+ printf ("testing the predicates for procedure? and vector?\n");
+ printf ("gh_procedure_p(c_factorial) is %d, gh_vector_p(c_factorial) is %d\n",
+ gh_procedure_p (cf), gh_vector_p (cf));
+
+ /* Test calling procedures. */
+ {
+ SCM list = gh_eval_str ("list");
+
+ printf ("testing gh_apply\n");
+ printf ("gh_apply (list, '(1 2)) => ");
+ gh_display (gh_apply (list, gh_cons (gh_int2scm (1),
+ gh_cons (gh_int2scm (2),
+ SCM_EOL))));
+ gh_newline ();
+
+ printf ("gh_call0 (list) => ");
+ gh_display (gh_call0 (list));
+ gh_newline ();
+
+ printf ("gh_call1 (list, 1) => ");
+ gh_display (gh_call1 (list, gh_int2scm (1)));
+ gh_newline ();
+
+ printf ("gh_call2 (list, 1, 2) => ");
+ gh_display (gh_call2 (list, gh_int2scm (1), gh_int2scm (2)));
+ gh_newline ();
+
+ printf ("gh_call3 (list, 1, 2, 3) => ");
+ gh_display (gh_call3 (list,
+ gh_int2scm (1), gh_int2scm (2), gh_int2scm (3)));
+ gh_newline ();
+ }
+
+ /* now sit in a scheme eval loop: I input the expressions, have
+ guile evaluate them, and then get another expression. */
+ done = 0;
+ while (!done)
+ {
+ printf ("\n%s> ", argv[0]);
+ if (gets (input_str) == NULL)
+ {
+ done = 1;
+ }
+ else
+ {
+/* gh_display(gh_eval_str_with_standard_handler(input_str)); */
+ gh_display (gh_eval_str_with_stack_saving_handler (input_str));
+ }
+ }
+}
+
+int
+main (int argc, char *argv[])
+{
+ gh_enter (argc, argv, main_prog);
+ return 0;
+}
+
+SCM
+c_factorial (SCM s_n)
+{
+ int i, n;
+ unsigned long result = 1;
+
+ n = gh_scm2ulong (s_n);
+
+ for (i = 1; i <= n; ++i)
+ {
+ result = result * i;
+ }
+ return gh_ulong2scm (result);
+}
+
+/* a sin routine in C, callable from scheme. it is named c_sin() to
+ distinguish it from the default scheme sin function */
+SCM
+c_sin (SCM s_x)
+{
+ double x = gh_scm2double (s_x);
+
+ return gh_double2scm (sin (x));
+}
+
+/* play around with vectors in guile: this routine creates a vector of
+ the given length, initializes it all to zero except element 2 which
+ is set to 1.9. */
+SCM
+c_vector_test (SCM s_length)
+{
+ SCM xvec;
+ unsigned long c_length;
+
+ c_length = gh_scm2ulong (s_length);
+ printf ("requested length for vector: %ld\n", c_length);
+
+ /* create a vector filled witth 0.0 entries */
+ xvec = gh_vector (c_length, gh_double2scm (0.0));
+ /* set the second element in it to some floating point value */
+ gh_vset (xvec, 2, gh_double2scm (1.9));
+
+ return xvec;
+}
diff --git a/libguile/gh_test_repl.c b/libguile/gh_test_repl.c
new file mode 100644
index 000000000..5ef7a44b7
--- /dev/null
+++ b/libguile/gh_test_repl.c
@@ -0,0 +1,156 @@
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+/* gh_test_repl -- a program that demonstrates starting Guile, adding
+ some privmitive procedures and entering a REPL form C */
+
+#include <stdio.h>
+#include <math.h>
+
+#include <gh.h>
+
+SCM c_factorial (SCM s_n);
+SCM c_sin (SCM s_x);
+SCM c_vector_test (SCM s_length);
+
+/* the gh_enter() routine, the standard entryp point for the gh_
+ interface, makes you use a separate main function */
+void
+main_prog (int argc, char *argv[])
+{
+ SCM cf;
+
+ gh_eval_str ("(display \"hello guile\n\")");
+
+ gh_eval_str ("(define (square x) (* x x))");
+ gh_eval_str ("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))");
+
+ gh_eval_str ("(display (square 9)) (newline)");
+ gh_eval_str ("(display (fact 100)) (newline)");
+
+ gh_eval_str ("(define s \"A string\")");
+ gh_eval_str ("(define p '(A . pair))");
+ gh_eval_str ("(display s)");
+ gh_eval_str ("(display p)");
+ gh_eval_str ("(display (string? s))");
+ gh_eval_str ("(display (pair? s))");
+
+ /* now define some new primitives in C */
+ cf = gh_new_procedure1_0 ("c_factorial", c_factorial);
+ gh_new_procedure1_0 ("c_sin", c_sin);
+ gh_new_procedure1_0 ("c_vector_test", c_vector_test);
+
+ /* now try some (eval ...) action from C */
+ {
+ SCM l = SCM_EOL;
+ l = gh_cons (gh_str02scm ("hello world"), l);
+ l = gh_cons (gh_symbol2scm ("'display"), l);
+ gh_display (l);
+ }
+
+ {
+ SCM a_string;
+ a_string = gh_str02scm ("A string");
+
+ printf ("testing the predicates for pair? and string?\n");
+ printf ("gh_pair_p(a_string) is %d, gh_string_p(a_string) is %d\n",
+ gh_pair_p (a_string), gh_string_p (a_string));
+ }
+
+ printf ("testing the predicates for procedure? and vector?\n");
+ printf ("gh_procedure_p(c_factorial) is %d, gh_vector_p(c_factorial) is %d\n",
+ gh_procedure_p (cf), gh_vector_p (cf));
+
+ gh_repl ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ gh_enter (argc, argv, main_prog);
+ return 0;
+}
+
+SCM
+c_factorial (SCM s_n)
+{
+ int i, n;
+ unsigned long result = 1;
+
+ n = gh_scm2ulong (s_n);
+
+ for (i = 1; i <= n; ++i)
+ {
+ result = result * i;
+ }
+ return gh_ulong2scm (result);
+}
+
+/* a sin routine in C, callable from scheme. it is named c_sin() to
+ distinguish it from the default scheme sin function */
+SCM
+c_sin (SCM s_x)
+{
+ double x = gh_scm2double (s_x);
+
+ return gh_double2scm (sin (x));
+}
+
+/* play around with vectors in guile: this routine creates a vector of
+ the given length, initializes it all to zero except element 2 which
+ is set to 1.9. */
+SCM
+c_vector_test (SCM s_length)
+{
+ SCM xvec;
+ unsigned long c_length;
+
+ c_length = gh_scm2ulong (s_length);
+ printf ("requested length for vector: %ld\n", c_length);
+
+ /* create a vector filled witth 0.0 entries */
+ xvec = gh_vector (c_length, gh_double2scm (0.0));
+ /* set the second element in it to some floating point value */
+ gh_vset (xvec, 2, gh_double2scm (1.9));
+
+ return xvec;
+}
diff --git a/libguile/gscm.c b/libguile/gscm.c
index 5eedc9755..daf172730 100644
--- a/libguile/gscm.c
+++ b/libguile/gscm.c
@@ -71,17 +71,15 @@ extern char *getenv ();
/* {Printing Objects to Strings}
*/
-#ifdef __STDC__
-static GSCM_status
-gscm_portprint_obj (SCM port, SCM obj)
-#else
+
+static GSCM_status gscm_portprint_obj SCM_P ((SCM port, SCM obj));
+
static GSCM_status
gscm_portprint_obj (port, obj)
SCM port;
SCM obj;
-#endif
{
- scm_iprin1 (obj, port, 1);
+ scm_prin1 (obj, port, 1);
return GSCM_OK;
}
@@ -94,14 +92,12 @@ struct seval_str_frame
char * str;
};
-#ifdef __STDC__
-static void
-_seval_str_fn (void * vframe)
-#else
+
+static void _seval_str_fn SCM_P ((void * vframe));
+
static void
_seval_str_fn (vframe)
void * vframe;
-#endif
{
struct seval_str_frame * frame;
frame = (struct seval_str_frame *)vframe;
@@ -110,15 +106,13 @@ _seval_str_fn (vframe)
-#ifdef __STDC__
-static GSCM_status
-gscm_strprint_obj (SCM * answer, SCM obj)
-#else
+
+static GSCM_status gscm_strprint_obj SCM_P ((SCM * answer, SCM obj));
+
static GSCM_status
gscm_strprint_obj (answer, obj)
SCM * answer;
SCM obj;
-#endif
{
SCM str;
SCM port;
@@ -133,15 +127,13 @@ gscm_strprint_obj (answer, obj)
return stat;
}
-#ifdef __STDC__
-static GSCM_status
-gscm_cstr (char ** answer, SCM obj)
-#else
+
+static GSCM_status gscm_cstr SCM_P ((char ** answer, SCM obj));
+
static GSCM_status
gscm_cstr (answer, obj)
char ** answer;
SCM obj;
-#endif
{
GSCM_status stat;
@@ -158,14 +150,12 @@ gscm_cstr (answer, obj)
/* {Invoking The Interpreter}
*/
-#ifdef __STDC__
-static SCM
-gscm_silent_repl (SCM env)
-#else
+
+static SCM gscm_silent_repl SCM_P ((SCM env));
+
static SCM
gscm_silent_repl (env)
SCM env;
-#endif
{
SCM source;
SCM answer;
@@ -182,17 +172,15 @@ typedef int setjmp_type;
typedef long setjmp_type;
#endif
-#ifdef __STDC__
-static GSCM_status
-_eval_port (SCM * answer, GSCM_top_level toplvl, SCM port, int printp)
-#else
+
+static GSCM_status _eval_port SCM_P ((SCM * answer, GSCM_top_level toplvl, SCM port, int printp));
+
static GSCM_status
_eval_port (answer, toplvl, port, printp)
SCM * answer;
GSCM_top_level toplvl;
SCM port;
int printp;
-#endif
{
SCM saved_inp;
GSCM_status status;
@@ -221,12 +209,12 @@ _eval_port (answer, toplvl, port, printp)
*/
SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i;
#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (scm_rootcont) = last_debug_info_frame = 0;
+ SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
#endif
saved_inp = scm_cur_inp;
i = setjmp (SCM_JMPBUF (scm_rootcont));
-#ifdef SCM_STACK_CHECK
- scm_check_stack_p = 1;
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
if (!i)
{
@@ -259,16 +247,14 @@ _eval_port (answer, toplvl, port, printp)
return status;
}
-#ifdef __STDC__
-static GSCM_status
-seval_str (SCM *answer, GSCM_top_level toplvl, char * str)
-#else
+
+static GSCM_status seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str));
+
static GSCM_status
seval_str (answer, toplvl, str)
SCM *answer;
GSCM_top_level toplvl;
char * str;
-#endif
{
SCM scheme_str;
SCM port;
@@ -281,16 +267,12 @@ seval_str (answer, toplvl, str)
}
-#ifdef __STDC__
-GSCM_status
-gscm_seval_str (SCM *answer, GSCM_top_level toplvl, char * str)
-#else
+
GSCM_status
gscm_seval_str (answer, toplvl, str)
SCM *answer;
GSCM_top_level toplvl;
char * str;
-#endif
{
SCM_STACKITEM i;
GSCM_status status;
@@ -300,15 +282,11 @@ gscm_seval_str (answer, toplvl, str)
return status;
}
-#ifdef __STDC__
-void
-format_load_command (char * buf, char *file_name)
-#else
+
void
format_load_command (buf, file_name)
char * buf;
char *file_name;
-#endif
{
char quoted_name[MAXPATHLEN + 1];
int source;
@@ -324,16 +302,12 @@ format_load_command (buf, file_name)
sprintf (buf, "(%%try-load \"%s\")", quoted_name);
}
-#ifdef __STDC__
-GSCM_status
-gscm_seval_file (SCM *answer, GSCM_top_level toplvl, char * file_name)
-#else
+
GSCM_status
gscm_seval_file (answer, toplvl, file_name)
SCM *answer;
GSCM_top_level toplvl;
char * file_name;
-#endif
{
char command[MAXPATHLEN * 3];
format_load_command (command, file_name);
@@ -341,16 +315,14 @@ gscm_seval_file (answer, toplvl, file_name)
}
-#ifdef __STDC__
-static GSCM_status
-eval_str (char ** answer, GSCM_top_level toplvl, char * str)
-#else
+
+static GSCM_status eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str));
+
static GSCM_status
eval_str (answer, toplvl, str)
char ** answer;
GSCM_top_level toplvl;
char * str;
-#endif
{
SCM sanswer;
SCM scheme_str;
@@ -371,16 +343,12 @@ eval_str (answer, toplvl, str)
}
-#ifdef __STDC__
-GSCM_status
-gscm_eval_str (char ** answer, GSCM_top_level toplvl, char * str)
-#else
+
GSCM_status
gscm_eval_str (answer, toplvl, str)
char ** answer;
GSCM_top_level toplvl;
char * str;
-#endif
{
SCM_STACKITEM i;
GSCM_status status;
@@ -391,16 +359,12 @@ gscm_eval_str (answer, toplvl, str)
}
-#ifdef __STDC__
-GSCM_status
-gscm_eval_file (char ** answer, GSCM_top_level toplvl, char * file_name)
-#else
+
GSCM_status
gscm_eval_file (answer, toplvl, file_name)
char ** answer;
GSCM_top_level toplvl;
char * file_name;
-#endif
{
char command[MAXPATHLEN * 3];
format_load_command (command, file_name);
@@ -430,14 +394,10 @@ static char * gscm_error_msgs[] =
AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file."
};
-#ifdef __STDC__
-char *
-gscm_error_msg (int n)
-#else
+
char *
gscm_error_msg (n)
int n;
-#endif
{
if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *))))
return "Unrecognized error.";
@@ -450,10 +410,7 @@ gscm_error_msg (n)
/* {Defining New Procedures}
*/
-#ifdef __STDC__
-SCM
-gscm_make_subr (SCM (*fn)(), int req, int opt, int varp, char * doc)
-#else
+
SCM
gscm_make_subr (fn, req, opt, varp, doc)
SCM (*fn)();
@@ -461,19 +418,14 @@ gscm_make_subr (fn, req, opt, varp, doc)
int opt;
int varp;
char * doc;
-#endif
{
return scm_make_gsubr ("*anonymous*", req, opt, varp, fn);
}
-#ifdef __STDC__
-int
-gscm_2_char (SCM c)
-#else
+
int
gscm_2_char (c)
SCM c;
-#endif
{
SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char");
return SCM_ICHR (c);
@@ -481,16 +433,12 @@ gscm_2_char (c)
-#ifdef __STDC__
-void
-gscm_2_str (char ** out, int * len_out, SCM * objp)
-#else
+
void
gscm_2_str (out, len_out, objp)
char ** out;
int * len_out;
SCM * objp;
-#endif
{
SCM_ASSERT (SCM_NIMP (*objp) && SCM_STRINGP (*objp), *objp, SCM_ARG3, "gscm_2_str");
if (out)
@@ -500,15 +448,11 @@ gscm_2_str (out, len_out, objp)
}
-#ifdef __STDC__
-void
-gscm_error (char * message, SCM args)
-#else
+
void
gscm_error (message, args)
char * message;
SCM args;
-#endif
{
SCM errsym;
SCM str;
@@ -519,10 +463,7 @@ gscm_error (message, args)
}
-#ifdef __STDC__
-GSCM_status
-gscm_run_scm (int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(), char * initfile, char * initcmd)
-#else
+
GSCM_status
gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
int argc;
@@ -533,7 +474,6 @@ gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
GSCM_status (*initfn)();
char * initfile;
char * initcmd;
-#endif
{
SCM_STACKITEM i;
GSCM_status status;
@@ -588,6 +528,7 @@ gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
scm_init_throw ();
scm_init_variable ();
scm_init_vectors ();
+ scm_init_version ();
scm_init_weaks ();
scm_init_vports ();
scm_init_eval ();
@@ -644,13 +585,9 @@ gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
-#ifdef __STDC__
-void
-scm_init_guile (void)
-#else
+
void
scm_init_guile ()
-#endif
{
#include "gscm.x"
}
diff --git a/libguile/gscm.h b/libguile/gscm.h
index c6ac44b5f..7e0554e5e 100644
--- a/libguile/gscm.h
+++ b/libguile/gscm.h
@@ -201,7 +201,7 @@
/* {I/O}
*/
-#define gscm_print_obj scm_iprin1
+#define gscm_print_obj scm_prin1
#define gscm_putc scm_putc
#define gscm_puts scm_puts
#define gscm_fwrite scm_fwrite
@@ -265,33 +265,17 @@ typedef int GSCM_status;
-#ifdef __STDC__
-extern GSCM_status gscm_seval_str (SCM *answer, GSCM_top_level toplvl, char * str);
-extern GSCM_status gscm_seval_file (SCM *answer, GSCM_top_level toplvl, char * file_name);
-extern GSCM_status gscm_eval_str (char ** answer, GSCM_top_level toplvl, char * str);
-extern GSCM_status gscm_eval_file (char ** answer, GSCM_top_level toplvl, char * file_name);
-extern GSCM_status gscm_run_scm (int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(), char * initfile, char * initcmd);
-extern char * gscm_error_msg (int n);
-extern SCM gscm_make_subr (SCM (*fn)(), int req, int opt, int varp, char * doc);
-extern int gscm_2_char (SCM c);
-extern void gscm_2_str (char ** out, int * len_out, SCM * objp);
-extern void gscm_error (char * message, SCM args);
-extern void scm_init_guile (void);
-
-#else /* STDC */
-extern GSCM_status gscm_seval_str ();
-extern void format_load_command ();
-extern GSCM_status gscm_seval_file ();
-extern GSCM_status gscm_eval_str ();
-extern GSCM_status gscm_eval_file ();
-extern char * gscm_error_msg ();
-extern SCM gscm_make_subr ();
-extern int gscm_2_char ();
-extern void gscm_2_str ();
-extern void gscm_error ();
-extern GSCM_status gscm_run_scm ();
-extern void scm_init_guile ();
-
-#endif /* STDC */
+extern GSCM_status gscm_seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str));
+extern GSCM_status gscm_seval_file SCM_P ((SCM *answer, GSCM_top_level toplvl, char * file_name));
+extern GSCM_status gscm_eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str));
+extern GSCM_status gscm_eval_file SCM_P ((char ** answer, GSCM_top_level toplvl, char * file_name));
+extern GSCM_status gscm_run_scm SCM_P ((int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(void), char * initfile, char * initcmd));
+extern char * gscm_error_msg SCM_P ((int n));
+extern SCM gscm_make_subr SCM_P ((SCM (*fn)(), int req, int opt, int varp, char * doc));
+extern int gscm_2_char SCM_P ((SCM c));
+extern void gscm_2_str SCM_P ((char ** out, int * len_out, SCM * objp));
+extern void gscm_error SCM_P ((char * message, SCM args));
+extern void scm_init_guile SCM_P ((void));
+
#endif /* GSCMH */
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 2f1cc75e9..b69a6c497 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -42,7 +42,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "procprop.h"
+#include "gsubr.h"
/*
* gsubr.c
@@ -63,11 +66,9 @@
#define GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1])
#define GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2])
+SCM scm_i_name;
static SCM f_gsubr_apply;
-#ifdef __STDC__
-SCM
-scm_make_gsubr(char *name, int req, int opt, int rst, SCM (*fcn)())
-#else
+
SCM
scm_make_gsubr(name, req, opt, rst, fcn)
char *name;
@@ -75,7 +76,6 @@ scm_make_gsubr(name, req, opt, rst, fcn)
int opt;
int rst;
SCM (*fcn)();
-#endif
{
switch GSUBR_MAKTYPE(req, opt, rst) {
case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn);
@@ -99,10 +99,14 @@ scm_make_gsubr(name, req, opt, rst, fcn)
tmp = 0;
SCM_NEWCELL(z);
SCM_SUBRF(z) = fcn;
- SCM_CAR(z) = tmp + scm_tc7_subr_0;
+ SCM_SETCAR (z, tmp + scm_tc7_subr_0);
GSUBR_PROC(cclo) = z;
GSUBR_TYPE(cclo) = SCM_MAKINUM(GSUBR_MAKTYPE(req, opt, rst));
- SCM_CDR(symcell) = cclo;
+ SCM_SETCDR (symcell, cclo);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_REC_PROCNAMES_P)
+ scm_set_procedure_property_x (cclo, scm_i_name, SCM_CAR (symcell));
+#endif
return cclo;
}
}
@@ -110,14 +114,10 @@ scm_make_gsubr(name, req, opt, rst, fcn)
SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply);
-#ifdef __STDC__
-SCM
-scm_gsubr_apply(SCM args)
-#else
+
SCM
scm_gsubr_apply(args)
SCM args;
-#endif
{
SCM self = SCM_CAR(args);
SCM (*fcn)() = SCM_SUBRF(GSUBR_PROC(self));
@@ -128,7 +128,7 @@ scm_gsubr_apply(args)
for (i = 0; i < GSUBR_REQ(typ); i++) {
#ifndef RECKLESS
if (SCM_IMP(args))
- scm_wta(SCM_UNDEFINED, (char *)SCM_WNA, SCM_CHARS(SCM_SNAME(GSUBR_PROC(self))));
+ scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self)));
#endif
v[i] = SCM_CAR(args);
args = SCM_CDR(args);
@@ -180,15 +180,13 @@ gsubr_21l(req1, req2, opt, rst)
#endif
-#ifdef __STDC__
-void
-scm_init_gsubr(void)
-#else
+
void
scm_init_gsubr()
-#endif
{
f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply);
+ scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
+ scm_permanent_object (scm_i_name);
#ifdef GSUBR_TEST
scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
#endif
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 4aed7ef0a..7eb34ce02 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -44,22 +44,12 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_make_gsubr(char *name, int req, int opt, int rst, SCM (*fcn)());
-extern SCM scm_gsubr_apply(SCM args);
-extern void scm_init_gsubr(void);
-
-#else /* STDC */
-extern SCM scm_make_gsubr();
-extern SCM scm_gsubr_apply();
-extern void scm_init_gsubr();
-
-#endif /* STDC */
-
-
+extern SCM scm_make_gsubr SCM_P ((char *name, int req, int opt, int rst, SCM (*fcn)()));
+extern SCM scm_gsubr_apply SCM_P ((SCM args));
+extern void scm_init_gsubr SCM_P ((void));
#endif /* GSUBRH */
diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in
new file mode 100644
index 000000000..e9254cdbc
--- /dev/null
+++ b/libguile/guile-snarf.in
@@ -0,0 +1,4 @@
+#!/bin/sh
+# Extract the initialization actions for builtin things.
+
+@CPP@ -DSCM_MAGIC_SNARFER $* | grep "^%%%" | sed -e "s/^%%%//"
diff --git a/libguile/hash.c b/libguile/hash.c
index 48f171a61..3ea9f866a 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -42,23 +42,21 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "hash.h"
#ifndef floor
extern double floor();
#endif
-#ifdef __STDC__
-unsigned long
-scm_hasher(SCM obj, unsigned long n, scm_sizet d)
-#else
+
unsigned long
scm_hasher(obj, n, d)
SCM obj;
unsigned long n;
scm_sizet d;
-#endif
{
switch (7 & (int) obj) {
case 2: case 6: /* SCM_INUMP(obj) */
@@ -138,30 +136,22 @@ scm_hasher(obj, n, d)
-#ifdef __STDC__
-unsigned int
-scm_ihashq (SCM obj, unsigned int n)
-#else
+
unsigned int
scm_ihashq (obj, n)
SCM obj;
unsigned int n;
-#endif
{
return (((unsigned int) obj) >> 1) % n;
}
SCM_PROC(s_hashq, "hashq", 2, 0, 0, scm_hashq);
-#ifdef __STDC__
-SCM
-scm_hashq(SCM obj, SCM n)
-#else
+
SCM
scm_hashq(obj, n)
SCM obj;
SCM n;
-#endif
{
SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashq);
return SCM_MAKINUM(scm_ihashq (obj, SCM_INUM (n)));
@@ -170,15 +160,11 @@ scm_hashq(obj, n)
-#ifdef __STDC__
-unsigned int
-scm_ihashv (SCM obj, unsigned int n)
-#else
+
unsigned int
scm_ihashv (obj, n)
SCM obj;
unsigned int n;
-#endif
{
if (SCM_ICHRP(obj))
return ((unsigned int)(scm_downcase(SCM_ICHR(obj)))) % n; /* downcase!?!! */
@@ -191,15 +177,11 @@ scm_ihashv (obj, n)
SCM_PROC(s_hashv, "hashv", 2, 0, 0, scm_hashv);
-#ifdef __STDC__
-SCM
-scm_hashv(SCM obj, SCM n)
-#else
+
SCM
scm_hashv(obj, n)
SCM obj;
SCM n;
-#endif
{
SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashv);
return SCM_MAKINUM(scm_ihashv (obj, SCM_INUM (n)));
@@ -208,29 +190,21 @@ scm_hashv(obj, n)
-#ifdef __STDC__
-unsigned int
-scm_ihash (SCM obj, unsigned int n)
-#else
+
unsigned int
scm_ihash (obj, n)
SCM obj;
unsigned int n;
-#endif
{
return (unsigned int)scm_hasher (obj, n, 10);
}
SCM_PROC(s_hash, "hash", 2, 0, 0, scm_hash);
-#ifdef __STDC__
-SCM
-scm_hash(SCM obj, SCM n)
-#else
+
SCM
scm_hash(obj, n)
SCM obj;
SCM n;
-#endif
{
SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hash);
return SCM_MAKINUM(scm_ihash(obj, SCM_INUM(n)));
@@ -239,13 +213,9 @@ scm_hash(obj, n)
-#ifdef __STDC__
-void
-scm_init_hash (void)
-#else
+
void
scm_init_hash ()
-#endif
{
#include "hash.x"
}
diff --git a/libguile/hash.h b/libguile/hash.h
index 8c53d3696..b9637d0c0 100644
--- a/libguile/hash.h
+++ b/libguile/hash.h
@@ -44,34 +44,17 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern unsigned long scm_hasher(SCM obj, unsigned long n, scm_sizet d);
-extern unsigned int scm_ihashq (SCM obj, unsigned int n);
-extern SCM scm_hashq(SCM obj, SCM n);
-extern unsigned int scm_ihashv (SCM obj, unsigned int n);
-extern SCM scm_hashv(SCM obj, SCM n);
-extern unsigned int scm_ihash (SCM obj, unsigned int n);
-extern SCM scm_hash(SCM obj, SCM n);
-extern void scm_init_hash (void);
-
-#else /* STDC */
-extern unsigned long scm_hasher();
-extern unsigned int scm_ihashq ();
-extern SCM scm_hashq();
-extern unsigned int scm_ihashv ();
-extern SCM scm_hashv();
-extern unsigned int scm_ihash ();
-extern SCM scm_hash();
-extern void scm_init_hash ();
-
-#endif /* STDC */
-
-
-
-
+extern unsigned long scm_hasher SCM_P ((SCM obj, unsigned long n, scm_sizet d));
+extern unsigned int scm_ihashq SCM_P ((SCM obj, unsigned int n));
+extern SCM scm_hashq SCM_P ((SCM obj, SCM n));
+extern unsigned int scm_ihashv SCM_P ((SCM obj, unsigned int n));
+extern SCM scm_hashv SCM_P ((SCM obj, SCM n));
+extern unsigned int scm_ihash SCM_P ((SCM obj, unsigned int n));
+extern SCM scm_hash SCM_P ((SCM obj, SCM n));
+extern void scm_init_hash SCM_P ((void));
#endif /* HASHH */
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index fd37e2574..a3cd76499 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -42,13 +42,14 @@
#include <stdio.h>
#include "_scm.h"
+#include "alist.h"
+#include "hash.h"
+#include "eval.h"
+#include "hashtab.h"
-#ifdef __STDC__
-SCM
-scm_hash_fn_get_handle (SCM table, SCM obj, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
-#else
+
SCM
scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure)
SCM table;
@@ -56,7 +57,6 @@ scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure)
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
-#endif
{
int k;
SCM h;
@@ -74,10 +74,7 @@ scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure)
}
-#ifdef __STDC__
-SCM
-scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
-#else
+
SCM
scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure)
SCM table;
@@ -86,7 +83,6 @@ scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure)
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
-#endif
{
int k;
SCM it;
@@ -118,10 +114,7 @@ scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure)
-#ifdef __STDC__
-SCM
-scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
-#else
+
SCM
scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure)
SCM table;
@@ -130,7 +123,6 @@ scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure)
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
-#endif
{
SCM it;
@@ -143,10 +135,7 @@ scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure)
-#ifdef __STDC__
-SCM
-scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
-#else
+
SCM
scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure)
SCM table;
@@ -155,7 +144,6 @@ scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure)
unsigned int (*hash_fn)();
SCM (*assoc_fn)();
void * closure;
-#endif
{
SCM it;
@@ -167,15 +155,7 @@ scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure)
-#ifdef __STDC__
-SCM
-scm_hash_fn_remove_x (SCM table,
- SCM obj,
- unsigned int (*hash_fn)(),
- SCM (*assoc_fn)(),
- SCM (*delete_fn)(),
- void * closure)
-#else
+
SCM
scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure)
SCM table;
@@ -184,7 +164,6 @@ scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure)
SCM (*assoc_fn)();
SCM (*delete_fn)();
void * closure;
-#endif
{
int k;
SCM h;
@@ -206,47 +185,35 @@ scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure)
SCM_PROC (s_hashq_get_handle, "hashq-get-handle", 2, 0, 0, scm_hashq_get_handle);
-#ifdef __STDC__
-SCM
-scm_hashq_get_handle (SCM table, SCM obj)
-#else
+
SCM
scm_hashq_get_handle (table, obj)
SCM table;
SCM obj;
-#endif
{
return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0);
}
SCM_PROC (s_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, scm_hashq_create_handle_x);
-#ifdef __STDC__
-SCM
-scm_hashq_create_handle_x (SCM table, SCM obj, SCM init)
-#else
+
SCM
scm_hashq_create_handle_x (table, obj, init)
SCM table;
SCM obj;
SCM init;
-#endif
{
return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0);
}
SCM_PROC (s_hashq_ref, "hashq-ref", 2, 1, 0, scm_hashq_ref);
-#ifdef __STDC__
-SCM
-scm_hashq_ref (SCM table, SCM obj, SCM dflt)
-#else
+
SCM
scm_hashq_ref (table, obj, dflt)
SCM table;
SCM obj;
SCM dflt;
-#endif
{
if (dflt == SCM_UNDEFINED)
dflt = SCM_BOOL_F;
@@ -256,16 +223,12 @@ scm_hashq_ref (table, obj, dflt)
SCM_PROC (s_hashq_set_x, "hashq-set!", 3, 0, 0, scm_hashq_set_x);
-#ifdef __STDC__
-SCM
-scm_hashq_set_x (SCM table, SCM obj, SCM val)
-#else
+
SCM
scm_hashq_set_x (table, obj, val)
SCM table;
SCM obj;
SCM val;
-#endif
{
return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0);
}
@@ -273,15 +236,11 @@ scm_hashq_set_x (table, obj, val)
SCM_PROC (s_hashq_remove_x, "hashq-remove!", 2, 0, 0, scm_hashq_remove_x);
-#ifdef __STDC__
-SCM
-scm_hashq_remove_x (SCM table, SCM obj)
-#else
+
SCM
scm_hashq_remove_x (table, obj)
SCM table;
SCM obj;
-#endif
{
return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0);
}
@@ -290,47 +249,35 @@ scm_hashq_remove_x (table, obj)
SCM_PROC (s_hashv_get_handle, "hashv-get-handle", 2, 0, 0, scm_hashv_get_handle);
-#ifdef __STDC__
-SCM
-scm_hashv_get_handle (SCM table, SCM obj)
-#else
+
SCM
scm_hashv_get_handle (table, obj)
SCM table;
SCM obj;
-#endif
{
return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0);
}
SCM_PROC (s_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, scm_hashv_create_handle_x);
-#ifdef __STDC__
-SCM
-scm_hashv_create_handle_x (SCM table, SCM obj, SCM init)
-#else
+
SCM
scm_hashv_create_handle_x (table, obj, init)
SCM table;
SCM obj;
SCM init;
-#endif
{
return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0);
}
SCM_PROC (s_hashv_ref, "hashv-ref", 2, 1, 0, scm_hashv_ref);
-#ifdef __STDC__
-SCM
-scm_hashv_ref (SCM table, SCM obj, SCM dflt)
-#else
+
SCM
scm_hashv_ref (table, obj, dflt)
SCM table;
SCM obj;
SCM dflt;
-#endif
{
if (dflt == SCM_UNDEFINED)
dflt = SCM_BOOL_F;
@@ -340,31 +287,23 @@ scm_hashv_ref (table, obj, dflt)
SCM_PROC (s_hashv_set_x, "hashv-set!", 3, 0, 0, scm_hashv_set_x);
-#ifdef __STDC__
-SCM
-scm_hashv_set_x (SCM table, SCM obj, SCM val)
-#else
+
SCM
scm_hashv_set_x (table, obj, val)
SCM table;
SCM obj;
SCM val;
-#endif
{
return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0);
}
SCM_PROC (s_hashv_remove_x, "hashv-remove!", 2, 0, 0, scm_hashv_remove_x);
-#ifdef __STDC__
-SCM
-scm_hashv_remove_x (SCM table, SCM obj)
-#else
+
SCM
scm_hashv_remove_x (table, obj)
SCM table;
SCM obj;
-#endif
{
return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0);
}
@@ -372,47 +311,35 @@ scm_hashv_remove_x (table, obj)
SCM_PROC (s_hash_get_handle, "hash-get-handle", 2, 0, 0, scm_hash_get_handle);
-#ifdef __STDC__
-SCM
-scm_hash_get_handle (SCM table, SCM obj)
-#else
+
SCM
scm_hash_get_handle (table, obj)
SCM table;
SCM obj;
-#endif
{
return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0);
}
SCM_PROC (s_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, scm_hash_create_handle_x);
-#ifdef __STDC__
-SCM
-scm_hash_create_handle_x (SCM table, SCM obj, SCM init)
-#else
+
SCM
scm_hash_create_handle_x (table, obj, init)
SCM table;
SCM obj;
SCM init;
-#endif
{
return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0);
}
SCM_PROC (s_hash_ref, "hash-ref", 2, 1, 0, scm_hash_ref);
-#ifdef __STDC__
-SCM
-scm_hash_ref (SCM table, SCM obj, SCM dflt)
-#else
+
SCM
scm_hash_ref (table, obj, dflt)
SCM table;
SCM obj;
SCM dflt;
-#endif
{
if (dflt == SCM_UNDEFINED)
dflt = SCM_BOOL_F;
@@ -422,16 +349,12 @@ scm_hash_ref (table, obj, dflt)
SCM_PROC (s_hash_set_x, "hash-set!", 3, 0, 0, scm_hash_set_x);
-#ifdef __STDC__
-SCM
-scm_hash_set_x (SCM table, SCM obj, SCM val)
-#else
+
SCM
scm_hash_set_x (table, obj, val)
SCM table;
SCM obj;
SCM val;
-#endif
{
return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0);
}
@@ -439,15 +362,11 @@ scm_hash_set_x (table, obj, val)
SCM_PROC (s_hash_remove_x, "hash-remove!", 2, 0, 0, scm_hash_remove_x);
-#ifdef __STDC__
-SCM
-scm_hash_remove_x (SCM table, SCM obj)
-#else
+
SCM
scm_hash_remove_x (table, obj)
SCM table;
SCM obj;
-#endif
{
return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0);
}
@@ -463,16 +382,14 @@ struct scm_ihashx_closure
};
-#ifdef __STDC__
-static unsigned int
-scm_ihashx (SCM obj, unsigned int n, struct scm_ihashx_closure * closure)
-#else
+
+static unsigned int scm_ihashx SCM_P ((SCM obj, unsigned int n, struct scm_ihashx_closure * closure));
+
static unsigned int
scm_ihashx (obj, n, closure)
SCM obj;
unsigned int n;
struct scm_ihashx_closure * closure;
-#endif
{
SCM answer;
SCM_ALLOW_INTS;
@@ -484,16 +401,14 @@ scm_ihashx (obj, n, closure)
}
-#ifdef __STDC__
-static SCM
-scm_sloppy_assx (SCM obj, SCM alist, struct scm_ihashx_closure * closure)
-#else
+
+static SCM scm_sloppy_assx SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
+
static SCM
scm_sloppy_assx (obj, alist, closure)
SCM obj;
SCM alist;
struct scm_ihashx_closure * closure;
-#endif
{
SCM answer;
SCM_ALLOW_INTS;
@@ -506,16 +421,14 @@ scm_sloppy_assx (obj, alist, closure)
-#ifdef __STDC__
-static SCM
-scm_delx_x (SCM obj, SCM alist, struct scm_ihashx_closure * closure)
-#else
+
+static SCM scm_delx_x SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
+
static SCM
scm_delx_x (obj, alist, closure)
SCM obj;
SCM alist;
struct scm_ihashx_closure * closure;
-#endif
{
SCM answer;
SCM_ALLOW_INTS;
@@ -529,17 +442,13 @@ scm_delx_x (obj, alist, closure)
SCM_PROC (s_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_hashx_get_handle);
-#ifdef __STDC__
-SCM
-scm_hashx_get_handle (SCM hash, SCM assoc, SCM table, SCM obj)
-#else
+
SCM
scm_hashx_get_handle (hash, assoc, table, obj)
SCM hash;
SCM assoc;
SCM table;
SCM obj;
-#endif
{
struct scm_ihashx_closure closure;
closure.hash = hash;
@@ -549,10 +458,7 @@ scm_hashx_get_handle (hash, assoc, table, obj)
SCM_PROC (s_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_hashx_create_handle_x);
-#ifdef __STDC__
-SCM
-scm_hashx_create_handle_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM init)
-#else
+
SCM
scm_hashx_create_handle_x (hash, assoc, table, obj, init)
SCM hash;
@@ -560,7 +466,6 @@ scm_hashx_create_handle_x (hash, assoc, table, obj, init)
SCM table;
SCM obj;
SCM init;
-#endif
{
struct scm_ihashx_closure closure;
closure.hash = hash;
@@ -571,10 +476,7 @@ scm_hashx_create_handle_x (hash, assoc, table, obj, init)
SCM_PROC (s_hashx_ref, "hashx-ref", 4, 1, 0, scm_hashx_ref);
-#ifdef __STDC__
-SCM
-scm_hashx_ref (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt)
-#else
+
SCM
scm_hashx_ref (hash, assoc, table, obj, dflt)
SCM hash;
@@ -582,7 +484,6 @@ scm_hashx_ref (hash, assoc, table, obj, dflt)
SCM table;
SCM obj;
SCM dflt;
-#endif
{
struct scm_ihashx_closure closure;
if (dflt == SCM_UNDEFINED)
@@ -596,10 +497,7 @@ scm_hashx_ref (hash, assoc, table, obj, dflt)
SCM_PROC (s_hashx_set_x, "hashx-set!", 5, 0, 0, scm_hashx_set_x);
-#ifdef __STDC__
-SCM
-scm_hashx_set_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM val)
-#else
+
SCM
scm_hashx_set_x (hash, assoc, table, obj, val)
SCM hash;
@@ -607,7 +505,6 @@ scm_hashx_set_x (hash, assoc, table, obj, val)
SCM table;
SCM obj;
SCM val;
-#endif
{
struct scm_ihashx_closure closure;
closure.hash = hash;
@@ -616,10 +513,7 @@ scm_hashx_set_x (hash, assoc, table, obj, val)
}
-#ifdef __STDC__
-SCM
-scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj)
-#else
+
SCM
scm_hashx_remove_x (hash, assoc, delete, table, obj)
SCM hash;
@@ -627,7 +521,6 @@ scm_hashx_remove_x (hash, assoc, delete, table, obj)
SCM delete;
SCM table;
SCM obj;
-#endif
{
struct scm_ihashx_closure closure;
closure.hash = hash;
@@ -638,13 +531,9 @@ scm_hashx_remove_x (hash, assoc, delete, table, obj)
-#ifdef __STDC__
-void
-scm_init_hashtab (void)
-#else
+
void
scm_init_hashtab ()
-#endif
{
#include "hashtab.x"
}
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 345303896..f53d25663 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -43,76 +43,42 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure);
-extern SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure);
-extern SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure);
-extern SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure);
-extern SCM scm_hash_fn_remove_x (SCM table,
- SCM obj,
- unsigned int (*hash_fn)(),
- SCM (*assoc_fn)(),
- SCM (*delete_fn)(),
- void * closure);
-extern SCM scm_hashq_get_handle (SCM table, SCM obj);
-extern SCM scm_hashq_create_handle_x (SCM table, SCM obj, SCM init);
-extern SCM scm_hashq_ref (SCM table, SCM obj, SCM dflt);
-extern SCM scm_hashq_set_x (SCM table, SCM obj, SCM val);
-extern SCM scm_hashq_remove_x (SCM table, SCM obj);
-extern SCM scm_hashv_get_handle (SCM table, SCM obj);
-extern SCM scm_hashv_create_handle_x (SCM table, SCM obj, SCM init);
-extern SCM scm_hashv_ref (SCM table, SCM obj, SCM dflt);
-extern SCM scm_hashv_set_x (SCM table, SCM obj, SCM val);
-extern SCM scm_hashv_remove_x (SCM table, SCM obj);
-extern SCM scm_hash_get_handle (SCM table, SCM obj);
-extern SCM scm_hash_create_handle_x (SCM table, SCM obj, SCM init);
-extern SCM scm_hash_ref (SCM table, SCM obj, SCM dflt);
-extern SCM scm_hash_set_x (SCM table, SCM obj, SCM val);
-extern SCM scm_hash_remove_x (SCM table, SCM obj);
-extern SCM scm_hashx_get_handle (SCM hash, SCM assoc, SCM table, SCM obj);
-extern SCM scm_hashx_create_handle_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM init);
-extern SCM scm_hashx_ref (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt);
-extern SCM scm_hashx_set_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM val);
-extern SCM scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj);
-extern void scm_init_hashtab (void);
-
-#else /* STDC */
-extern SCM scm_hash_fn_get_handle ();
-extern SCM scm_hash_fn_create_handle_x ();
-extern SCM scm_hash_fn_ref ();
-extern SCM scm_hash_fn_set_x ();
-extern SCM scm_hash_fn_remove_x ();
-extern SCM scm_hashq_get_handle ();
-extern SCM scm_hashq_create_handle_x ();
-extern SCM scm_hashq_ref ();
-extern SCM scm_hashq_set_x ();
-extern SCM scm_hashq_remove_x ();
-extern SCM scm_hashv_get_handle ();
-extern SCM scm_hashv_create_handle_x ();
-extern SCM scm_hashv_ref ();
-extern SCM scm_hashv_set_x ();
-extern SCM scm_hashv_remove_x ();
-extern SCM scm_hash_get_handle ();
-extern SCM scm_hash_create_handle_x ();
-extern SCM scm_hash_ref ();
-extern SCM scm_hash_set_x ();
-extern SCM scm_hash_remove_x ();
-extern SCM scm_hashx_get_handle ();
-extern SCM scm_hashx_create_handle_x ();
-extern SCM scm_hashx_ref ();
-extern SCM scm_hashx_set_x ();
-extern SCM scm_hashx_remove_x ();
-extern void scm_init_hashtab ();
-
-#endif /* STDC */
-
-
-
+#if 0
+typedef unsigned int scm_hash_fn_t SCM_P ((SCM obj, unsigned int d, void *closure));
+typedef SCM scm_assoc_fn_t SCM_P ((SCM key, SCM alist, void *closure));
+typedef SCM scm_delete_fn_t SCM_P ((SCM elt, SCM list));
+#endif
+extern SCM scm_hash_fn_get_handle SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
+extern SCM scm_hash_fn_create_handle_x SCM_P ((SCM table, SCM obj, SCM init, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
+extern SCM scm_hash_fn_ref SCM_P ((SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
+extern SCM scm_hash_fn_set_x SCM_P ((SCM table, SCM obj, SCM val, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
+extern SCM scm_hash_fn_remove_x SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure));
+extern SCM scm_hashq_get_handle SCM_P ((SCM table, SCM obj));
+extern SCM scm_hashq_create_handle_x SCM_P ((SCM table, SCM obj, SCM init));
+extern SCM scm_hashq_ref SCM_P ((SCM table, SCM obj, SCM dflt));
+extern SCM scm_hashq_set_x SCM_P ((SCM table, SCM obj, SCM val));
+extern SCM scm_hashq_remove_x SCM_P ((SCM table, SCM obj));
+extern SCM scm_hashv_get_handle SCM_P ((SCM table, SCM obj));
+extern SCM scm_hashv_create_handle_x SCM_P ((SCM table, SCM obj, SCM init));
+extern SCM scm_hashv_ref SCM_P ((SCM table, SCM obj, SCM dflt));
+extern SCM scm_hashv_set_x SCM_P ((SCM table, SCM obj, SCM val));
+extern SCM scm_hashv_remove_x SCM_P ((SCM table, SCM obj));
+extern SCM scm_hash_get_handle SCM_P ((SCM table, SCM obj));
+extern SCM scm_hash_create_handle_x SCM_P ((SCM table, SCM obj, SCM init));
+extern SCM scm_hash_ref SCM_P ((SCM table, SCM obj, SCM dflt));
+extern SCM scm_hash_set_x SCM_P ((SCM table, SCM obj, SCM val));
+extern SCM scm_hash_remove_x SCM_P ((SCM table, SCM obj));
+extern SCM scm_hashx_get_handle SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj));
+extern SCM scm_hashx_create_handle_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM init));
+extern SCM scm_hashx_ref SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt));
+extern SCM scm_hashx_set_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM val));
+extern SCM scm_hashx_remove_x SCM_P ((SCM hash, SCM assoc, SCM del, SCM table, SCM obj));
+extern void scm_init_hashtab SCM_P ((void));
#endif /* HASHTABH */
diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c
index f7ca832f7..1d02af5e5 100644
--- a/libguile/inet_aton.c
+++ b/libguile/inet_aton.c
@@ -41,7 +41,7 @@ static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93";
#include <netinet/in.h>
#include <arpa/inet.h>
-#ifdef 0
+#if 0
/*
* Ascii internet address interpretation routine.
diff --git a/libguile/init.c b/libguile/init.c
index 2f65c15f6..edb480a26 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -43,117 +43,136 @@
#include <stdio.h>
#include "_scm.h"
+/* Everybody has an init function. */
+#include "alist.h"
+#include "append.h"
+#include "arbiters.h"
+#include "async.h"
+#include "backtrace.h"
+#include "boolean.h"
+#include "chars.h"
+#include "continuations.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif
+#include "dynl.h"
+#include "dynwind.h"
+#include "eq.h"
+#include "error.h"
+#include "eval.h"
+#include "feature.h"
+#include "filesys.h"
+#include "fports.h"
+#include "gc.h"
+#include "gdbint.h"
+#include "gsubr.h"
+#include "hash.h"
+#include "hashtab.h"
+#include "ioext.h"
+#include "kw.h"
+#include "list.h"
+#include "load.h"
+#include "mallocs.h"
+#include "mbstrings.h"
+#include "net_db.h"
+#include "numbers.h"
+#include "objprop.h"
+#include "options.h"
+#include "pairs.h"
+#include "ports.h"
+#include "posix.h"
+#include "print.h"
+#include "procprop.h"
+#include "procs.h"
+#include "ramap.h"
+#include "read.h"
+#include "scmsigs.h"
+#include "sequences.h"
+#include "simpos.h"
+#include "smob.h"
+#include "socket.h"
+#include "srcprop.h"
+#include "stackchk.h"
+#include "stacks.h"
+#include "stime.h"
+#include "strings.h"
+#include "strop.h"
+#include "strorder.h"
+#include "strports.h"
+#include "struct.h"
+#include "symbols.h"
+#include "tag.h"
+#include "throw.h"
+#include "unif.h"
+#include "variable.h"
+#include "vectors.h"
+#include "version.h"
+#include "vports.h"
+#include "weaks.h"
+
+#include "init.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
-#ifdef __STDC__
-void
-scm_start_stack (void * base, FILE * in, FILE * out, FILE * err)
-#else
-void
-scm_start_stack (base, in, out, err)
+static void scm_start_stack SCM_P ((void *base));
+static void scm_restart_stack SCM_P ((void * base));
+
+static void
+scm_start_stack (base)
void * base;
- FILE * in;
- FILE * out;
- FILE * err;
-#endif
{
- struct scm_port_table * pt;
+ SCM root;
+ root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
+ scm_set_root (SCM_ROOT_STATE (root));
scm_stack_base = base;
- /* Create standar ports from stdio files, if requested to do so.
- */
-
- if (!in)
- {
- scm_def_inp = SCM_BOOL_F;
- }
- else
- {
- SCM_NEWCELL (scm_def_inp);
- pt = scm_add_to_port_table (scm_def_inp);
- SCM_CAR (scm_def_inp) = (scm_tc16_fport | SCM_OPN | SCM_RDNG);
- SCM_SETPTAB_ENTRY (scm_def_inp, pt);
- SCM_SETSTREAM (scm_def_inp, (SCM)in);
- if (isatty (fileno (in)))
- {
- scm_setbuf0 (scm_def_inp); /* turn off stdin buffering */
- SCM_CAR (scm_def_inp) |= SCM_BUF0;
- }
- scm_set_port_revealed_x (scm_def_inp, SCM_MAKINUM (1));
- }
-
- if (!out)
- {
- scm_def_outp = SCM_BOOL_F;
- }
- else
- {
- SCM_NEWCELL (scm_def_outp);
- pt = scm_add_to_port_table (scm_def_outp);
- SCM_CAR (scm_def_outp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG);
- SCM_SETPTAB_ENTRY (scm_def_outp, pt);
- SCM_SETSTREAM (scm_def_outp, (SCM)out);
- scm_set_port_revealed_x (scm_def_outp, SCM_MAKINUM (1));
- }
-
- if (!err)
- {
- scm_def_errp = SCM_BOOL_F;
- }
- else
- {
- SCM_NEWCELL (scm_def_errp);
- pt = scm_add_to_port_table (scm_def_errp);
- SCM_CAR (scm_def_errp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG);
- SCM_SETPTAB_ENTRY (scm_def_errp, pt);
- SCM_SETSTREAM (scm_def_errp, (SCM)err);
- scm_set_port_revealed_x (scm_def_errp, SCM_MAKINUM (1));
- }
-
- scm_cur_inp = scm_def_inp;
- scm_cur_outp = scm_def_outp;
- scm_cur_errp = scm_def_errp;
-
-
- scm_progargs = SCM_BOOL_F; /* vestigial */
scm_exitval = SCM_BOOL_F; /* vestigial */
- scm_top_level_lookup_thunk_var = SCM_BOOL_F;
+ scm_top_level_lookup_closure_var = SCM_BOOL_F;
scm_system_transformer = SCM_BOOL_F;
+ scm_the_last_stack_var = SCM_BOOL_F;
+
/* Create an object to hold the root continuation.
*/
SCM_NEWCELL (scm_rootcont);
- SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (regs), "continuation"));
- SCM_CAR (scm_rootcont) = scm_tc7_contin;
+ SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (scm_contregs),
+ "continuation"));
+ SCM_SETCAR (scm_rootcont, scm_tc7_contin);
+ SCM_SEQ (scm_rootcont) = 0;
/* The root continuation if further initialized by scm_restart_stack. */
/* Create the look-aside stack for variables that are shared between
* captured continuations.
*/
- scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED, SCM_UNDEFINED);
+ scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512),
+ SCM_UNDEFINED, SCM_UNDEFINED);
/* The continuation stack is further initialized by scm_restart_stack. */
- /* The remainder of stack initialization is factored out to another function so that
- * if this stack is ever exitted, it can be re-entered using scm_restart_stack.
- */
+ /* The remainder of stack initialization is factored out to another
+ * function so that if this stack is ever exitted, it can be
+ * re-entered using scm_restart_stack. */
scm_restart_stack (base);
}
-#ifdef __STDC__
-void
-scm_restart_stack (void * base)
-#else
-void
+static void
scm_restart_stack (base)
void * base;
-#endif
{
scm_dynwinds = SCM_EOL;
SCM_DYNENV (scm_rootcont) = SCM_EOL;
SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
+#ifdef DEBUG_EXTENSIONS
+ SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
+#endif
SCM_BASE (scm_rootcont) = base;
scm_continuation_stack_ptr = SCM_MAKINUM (0);
}
@@ -161,16 +180,14 @@ scm_restart_stack (base)
#if 0
static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
-#ifdef __STDC__
-static void
-fixconfig (char *s1, char *s2, int s)
-#else
+
+static void fixconfig SCM_P ((char *s1, char *s2, int s));
+
static void
fixconfig (s1, s2, s)
char *s1;
char *s2;
int s;
-#endif
{
fputs (s1, stderr);
fputs (s2, stderr);
@@ -181,6 +198,7 @@ fixconfig (s1, s2, s)
}
+static void check_config SCM_P ((void));
static void
check_config ()
@@ -218,67 +236,127 @@ check_config ()
+/* initializing standard and current I/O ports */
+
+/* Create standard ports from stdio stdin, stdout, and stderr. */
+static void
+scm_init_standard_ports ()
+{
+ /* I'm not sure why this should be unbuffered when coming from a
+ tty; isn't line buffering more common? */
+ scm_def_inp = scm_stdio_to_port (stdin,
+ (isatty (fileno (stdin)) ? "r0" : "r"),
+ "standard input");
+ scm_def_outp = scm_stdio_to_port (stdout, "w", "standard output");
+ scm_def_errp = scm_stdio_to_port (stderr, "w", "standard error");
+
+ scm_cur_inp = scm_def_inp;
+ scm_cur_outp = scm_def_outp;
+ scm_cur_errp = scm_def_errp;
+}
+
+
+
#ifdef _UNICOS
typedef int setjmp_type;
#else
typedef long setjmp_type;
#endif
-/* Fire up Scheme.
- *
- * argc and argv are made the return values of program-arguments.
- *
- * in, out, and err, if not NULL, become the standard ports.
- * If NULL is passed, your "scm_appinit" should set up the
- * standard ports.
- *
- * boot_cmd is a string containing a Scheme expression to evaluate
- * to get things rolling.
- *
- * result is returned a string containing a printed result of evaluating
- * the boot command.
- *
- * the return value is:
- * scm_boot_ok - evaluation concluded normally
- * scm_boot_error - evaluation concluded with a Scheme error
- * scm_boot_emem - allocation error mallocing *result
- * scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is prohibited.
- */
+/* All the data needed to invoke the main function. */
+struct main_func_closure
+{
+ /* the function to call */
+ void (*main_func) SCM_P ((void *closure, int argc, char **argv));
+ void *closure; /* dummy data to pass it */
+ int argc;
+ char **argv; /* the argument list it should receive */
+};
-#ifdef __STDC__
-int
-scm_boot_guile (char ** result, int argc, char ** argv, FILE * in, FILE * out, FILE * err, char * boot_cmd)
-#else
-int
-scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
- char ** result;
+
+static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
+ struct main_func_closure *closure));
+static SCM invoke_main_func SCM_P ((void *body_data, SCM jmpbuf));
+
+
+/* Fire up the Guile Scheme interpreter.
+
+ Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC
+ should do all the work of the program (initializing other packages,
+ reading user input, etc.) before returning. When MAIN_FUNC
+ returns, call exit (0); this function never returns. If you want
+ some other exit value, MAIN_FUNC may call exit itself.
+
+ scm_boot_guile arranges for program-arguments to return the strings
+ given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should
+ call scm_set_program_arguments with the final list, so Scheme code
+ will know which arguments have been processed.
+
+ scm_boot_guile establishes a catch-all catch handler which prints
+ an error message and exits the process. This means that Guile
+ exits in a coherent way when system errors occur and the user isn't
+ prepared to handle it. If the user doesn't like this behavior,
+ they can establish their own universal catcher to shadow this one.
+
+ Why must the caller do all the real work from MAIN_FUNC? The
+ garbage collector assumes that all local variables of type SCM will
+ be above scm_boot_guile's stack frame on the stack. If you try to
+ manipulate SCM values after this function returns, it's the luck of
+ the draw whether the GC will be able to find the objects you
+ allocate. So, scm_boot_guile function exits, rather than
+ returning, to discourage people from making that mistake. */
+
+
+void
+scm_boot_guile (argc, argv, main_func, closure)
int argc;
char ** argv;
- FILE * in;
- FILE * out;
- FILE * err;
- char * boot_cmd;
-#endif
+ void (*main_func) ();
+ void *closure;
+{
+ /* The garbage collector uses the address of this variable as one
+ end of the stack, and the address of one of its own local
+ variables as the other end. */
+ SCM_STACKITEM dummy;
+ struct main_func_closure c;
+
+ c.main_func = main_func;
+ c.closure = closure;
+ c.argc = argc;
+ c.argv = argv;
+
+ scm_boot_guile_1 (&dummy, &c);
+}
+
+
+/* Record here whether SCM_BOOT_GUILE_1 has already been called. This
+ variable is now here and not inside SCM_BOOT_GUILE_1 so that one
+ can tweak it. This is necessary for unexec to work. (Hey, "1-live"
+ is the name of a local radiostation...) */
+
+int scm_boot_guile_1_live = 0;
+
+static void
+scm_boot_guile_1 (base, closure)
+ SCM_STACKITEM *base;
+ struct main_func_closure *closure;
{
static int initialized = 0;
- static int live = 0;
- SCM_STACKITEM i;
+ /* static int live = 0; */
setjmp_type setjmp_val;
- int stat;
- if (live) /* This function is not re-entrant. */
- {
- return scm_boot_ereenter;
- }
+ /* This function is not re-entrant. */
+ if (scm_boot_guile_1_live)
+ abort ();
- live = 1;
+ scm_boot_guile_1_live = 1;
scm_ints_disabled = 1;
scm_block_gc = 1;
if (initialized)
{
- scm_restart_stack (&i);
+ scm_restart_stack (base);
}
else
{
@@ -286,47 +364,60 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
scm_smob_prehistory ();
scm_tables_prehistory ();
scm_init_storage (0);
- scm_start_stack (&i, in, out, err);
+ scm_init_root ();
+#ifdef USE_THREADS
+ scm_init_threads (base);
+#endif
+ scm_start_stack (base);
scm_init_gsubr ();
scm_init_feature ();
scm_init_alist ();
scm_init_append ();
scm_init_arbiters ();
scm_init_async ();
+ scm_init_backtrace ();
scm_init_boolean ();
scm_init_chars ();
scm_init_continuations ();
scm_init_dynwind ();
scm_init_eq ();
scm_init_error ();
- scm_init_fdsocket ();
scm_init_fports ();
- scm_init_files ();
scm_init_filesys ();
scm_init_gc ();
+ scm_init_gdbint ();
scm_init_hash ();
scm_init_hashtab ();
scm_init_ioext ();
scm_init_kw ();
scm_init_list ();
scm_init_mallocs ();
+ scm_init_net_db ();
scm_init_numbers ();
scm_init_objprop ();
+#if DEBUG_EXTENSIONS
+ /* Excluding this until it's really needed makes the binary
+ * smaller after linking. */
+ scm_init_options ();
+#endif
scm_init_pairs ();
scm_init_ports ();
scm_init_posix ();
scm_init_procs ();
scm_init_procprop ();
- scm_init_rgx ();
scm_init_scmsigs ();
scm_init_socket ();
+#ifdef DEBUG_EXTENSIONS
+ scm_init_srcprop ();
+#endif
scm_init_stackchk ();
+ scm_init_struct (); /* Requires struct */
+ scm_init_stacks ();
scm_init_strports ();
- scm_init_struct ();
scm_init_symbols ();
scm_init_tag ();
scm_init_load ();
- scm_init_print ();
+ scm_init_print (); /* Requires struct */
scm_init_read ();
scm_init_sequences ();
scm_init_stime ();
@@ -337,117 +428,62 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
scm_init_throw ();
scm_init_variable ();
scm_init_vectors ();
+ scm_init_version ();
scm_init_weaks ();
scm_init_vports ();
scm_init_eval ();
+#ifdef DEBUG_EXTENSIONS
+ scm_init_debug (); /* Requires macro smobs */
+#endif
scm_init_ramap ();
scm_init_unif ();
scm_init_simpos ();
- scm_appinit ();
- scm_progargs = scm_makfromstrs (argc, argv);
+ scm_init_load_path ();
+ scm_init_standard_ports ();
+ scm_init_dynamic_linking ();
initialized = 1;
}
scm_block_gc = 0; /* permit the gc to run */
/* ints still disabled */
- {
- SCM command;
-
- command = scm_makfrom0str (boot_cmd);
-
- setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
-
- if (!setjmp_val)
- {
- SCM last;
- scm_init_signals ();
-
- {
- SCM p;
- SCM form;
-
- p = scm_mkstrport (SCM_MAKINUM (0),
- command,
- SCM_OPN | SCM_RDNG,
- "boot_guile");
- while (1)
- {
- form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_EOF_VAL == form)
- break;
- last = scm_eval_x (form);
- }
-
- }
-
- scm_restore_signals ();
- /* This tick gives any pending
- * asyncs a chance to run. This must be done after
- * the call to scm_restore_signals.
- */
- SCM_ASYNC_TICK;
-
- scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
-
- {
- SCM str_answer;
-
- str_answer = scm_strprint_obj (last);
- *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
- if (!*result)
- stat = scm_boot_emem;
- else
- {
- memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
- (*result)[SCM_LENGTH (str_answer)] = 0;
- stat = scm_boot_ok;
- }
- }
- }
- else
- {
- /* This is reached if an unhandled throw terminated Scheme.
- * Such an occurence should be extremely unlikely -- it indicates
- * a programming error in the boot code.
- *
- * Details of the bogus exception are stored in scm_exitval even
- * though that isn't currently reflected in the return value.
- * !!!
- */
-
- scm_restore_signals ();
- /* This tick gives any pending
- * asyncs a chance to run. This must be done after
- * the call to scm_restore_signals.
- *
- * Note that an unhandled exception during signal handling
- * will put as back at the call to scm_restore_signals immediately
- * preceeding. A sufficiently bogus signal handler could
- * conceivably cause an infinite loop here.
- */
- SCM_ASYNC_TICK;
-
- scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
-
- {
- SCM str_answer;
-
- str_answer = scm_strprint_obj (scm_exitval);
- *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
- if (!*result)
- stat = scm_boot_emem;
- else
- {
- memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
- (*result)[SCM_LENGTH (str_answer)] = 0;
- stat = scm_boot_error;
- }
- }
- }
- }
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
- scm_block_gc = 1;
- live = 0;
- return stat;
+ setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
+ if (!setjmp_val)
+ {
+ scm_init_signals ();
+
+ scm_set_program_arguments (closure->argc, closure->argv, 0);
+ scm_internal_catch (SCM_BOOL_T, invoke_main_func, closure,
+ scm_handle_by_message, 0);
+ }
+
+ scm_restore_signals ();
+
+ /* This tick gives any pending
+ * asyncs a chance to run. This must be done after
+ * the call to scm_restore_signals.
+ */
+ SCM_ASYNC_TICK;
+
+ /* If the caller doesn't want this, they should return from
+ main_func themselves. */
+ exit (0);
+}
+
+
+static SCM
+invoke_main_func (body_data, jmpbuf)
+ void *body_data;
+ SCM jmpbuf;
+{
+ struct main_func_closure *closure = (struct main_func_closure *) body_data;
+
+ (*closure->main_func) (closure->closure, closure->argc, closure->argv);
+
+ /* never reached */
+ return SCM_UNDEFINED;
}
diff --git a/libguile/init.h b/libguile/init.h
index a20262104..97fb5e182 100644
--- a/libguile/init.h
+++ b/libguile/init.h
@@ -44,32 +44,13 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
-enum scm_boot_status
-{
- scm_boot_ok = 0,
- scm_boot_error,
- scm_boot_emem,
- scm_boot_ereenter
-};
-
-
-
-#ifdef __STDC__
-extern void scm_start_stack (void * base, FILE * in, FILE * out, FILE * err);
-extern void scm_restart_stack (void * base);
-
-#else /* STDC */
-extern void scm_start_stack ();
-extern void scm_restart_stack ();
-
-#endif /* STDC */
-
-
-
-
+extern void scm_boot_guile SCM_P ((int argc, char **argv,
+ void (*main_func) (void *closure,
+ int argc,
+ char **argv),
+ void *closure));
#endif /* INITH */
diff --git a/libguile/ioext.c b/libguile/ioext.c
index d51b9a09d..0fd45095e 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -42,90 +42,188 @@
#include <stdio.h>
-#include <unistd.h>
-#include "fd.h"
#include "_scm.h"
+#include "genio.h"
+#include "read.h"
+#include "fports.h"
+#include "unif.h"
+#include "chars.h"
+
+#include "ioext.h"
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
-SCM_PROC (s_sys_ftell, "%ftell", 1, 0, 0, scm_sys_ftell);
-#ifdef __STDC__
+SCM_PROC (s_read_delimited_x, "%read-delimited!", 3, 3, 0, scm_read_delimited_x);
+
SCM
-scm_sys_ftell (SCM port)
-#else
+scm_read_delimited_x (delims, buf, gobble, port, start, end)
+ SCM delims;
+ SCM buf;
+ SCM gobble;
+ SCM port;
+ SCM start;
+ SCM end;
+{
+ long j;
+ char *cbuf;
+ long cstart;
+ long cend;
+ int c;
+ char *cdelims;
+ int num_delims;
+
+ SCM_ASSERT (SCM_NIMP (delims) && SCM_ROSTRINGP (delims),
+ delims, SCM_ARG1, s_read_delimited_x);
+ cdelims = SCM_ROCHARS (delims);
+ num_delims = SCM_ROLENGTH (delims);
+ SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf),
+ buf, SCM_ARG2, s_read_delimited_x);
+ cbuf = SCM_CHARS (buf);
+ cend = SCM_LENGTH (buf);
+ if (SCM_UNBNDP (port))
+ port = scm_cur_inp;
+ else
+ {
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
+ port, SCM_ARG1, s_read_delimited_x);
+ }
+
+ if (SCM_UNBNDP (start))
+ cstart = 0;
+ else
+ {
+ cstart = scm_num2long (start,
+ (char *) SCM_ARG5, s_read_delimited_x);
+ if (cstart < 0 || cstart >= cend)
+ scm_out_of_range (s_read_delimited_x, start);
+
+ if (!SCM_UNBNDP (end))
+ {
+ long tend = scm_num2long (end, (char *) SCM_ARG6,
+ s_read_delimited_x);
+ if (tend <= cstart || tend > cend)
+ scm_out_of_range (s_read_delimited_x, end);
+ cend = tend;
+ }
+ }
+
+ for (j = cstart; j < cend; j++)
+ {
+ int k;
+
+ c = scm_gen_getc (port);
+ for (k = 0; k < num_delims; k++)
+ {
+ if (cdelims[k] == c)
+ {
+ if (SCM_FALSEP (gobble))
+ scm_gen_ungetc (c, port);
+
+ return scm_cons (SCM_MAKICHR (c),
+ scm_long2num (j - cstart));
+ }
+ }
+ if (c == EOF)
+ return scm_cons (SCM_EOF_VAL,
+ scm_long2num (j - cstart));
+
+ cbuf[j] = c;
+ }
+ return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart));
+}
+
+SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
+
SCM
-scm_sys_ftell (port)
+scm_write_line (obj, port)
+ SCM obj;
+ SCM port;
+{
+ scm_display (obj, port);
+ return scm_newline (port);
+}
+
+SCM_PROC (s_ftell, "ftell", 1, 0, 0, scm_ftell);
+
+SCM
+scm_ftell (port)
SCM port;
-#endif
{
long pos;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_ftell);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_ftell);
SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port)));
if (pos < 0)
- return SCM_BOOL_F;
+ scm_syserror (s_ftell);
if (pos > 0 && SCM_CRDYP (port))
pos--;
- return SCM_MAKINUM (pos);
+ return scm_long2num (pos);
}
-SCM_PROC (s_sys_fseek, "%fseek", 3, 0, 0, scm_sys_fseek);
-#ifdef __STDC__
-SCM
-scm_sys_fseek (SCM port, SCM offset, SCM whence)
-#else
+SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek);
+
SCM
-scm_sys_fseek (port, offset, whence)
+scm_fseek (port, offset, whence)
SCM port;
SCM offset;
SCM whence;
-#endif
{
int rv;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fseek);
- SCM_ASSERT (SCM_INUMP (offset), offset, SCM_ARG2, s_sys_fseek);
+ long loff;
+
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_fseek);
+ loff = scm_num2long (offset, (char *)SCM_ARG2, s_fseek);
SCM_ASSERT (SCM_INUMP (whence) && (SCM_INUM (whence) < 3) && (SCM_INUM (whence) >= 0),
- whence, SCM_ARG3, s_sys_fseek);
+ whence, SCM_ARG3, s_fseek);
+
SCM_CLRDY (port); /* Clear ungetted char */
/* Values of whence are interned in scm_init_ioext. */
- rv = fseek ((FILE *)SCM_STREAM (port), SCM_INUM (offset), SCM_INUM (whence));
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ rv = fseek ((FILE *)SCM_STREAM (port), loff, SCM_INUM (whence));
+ if (rv != 0)
+ scm_syserror (s_fseek);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_freopen, "%freopen", 3, 0, 0, scm_sys_freopen);
-#ifdef __STDC__
-SCM
-scm_sys_freopen (SCM filename, SCM modes, SCM port)
-#else
+SCM_PROC (s_freopen, "freopen", 3, 0, 0, scm_freopen);
+
SCM
-scm_sys_freopen (filename, modes, port)
+scm_freopen (filename, modes, port)
SCM filename;
SCM modes;
SCM port;
-#endif
{
FILE *f;
- SCM_ASSERT (SCM_NIMP (filename) && SCM_STRINGP (filename), filename, SCM_ARG1, s_sys_freopen);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_freopen);
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
+ SCM_ARG1, s_freopen);
+ SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
+ s_freopen);
SCM_DEFER_INTS;
- SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG3, s_sys_freopen);
- SCM_SYSCALL (f = freopen (SCM_CHARS (filename), SCM_CHARS (modes), (FILE *)SCM_STREAM (port)));
+ SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG3, s_freopen);
+ SCM_SYSCALL (f = freopen (SCM_ROCHARS (filename), SCM_ROCHARS (modes),
+ (FILE *)SCM_STREAM (port)));
if (!f)
{
SCM p;
p = port;
port = SCM_MAKINUM (errno);
- SCM_CAR (p) &= ~SCM_OPN;
+ SCM_SETAND_CAR (p, ~SCM_OPN);
scm_remove_from_port_table (p);
}
else
{
- SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes));
+ SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_ROCHARS (modes)));
SCM_SETSTREAM (port, (SCM)f);
- if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))))
+ SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_ROCHARS (modes)));
+ if (SCM_BUF0 & SCM_CAR (port))
scm_setbuf0 (port);
}
SCM_ALLOW_INTS;
@@ -134,49 +232,41 @@ scm_sys_freopen (filename, modes, port)
-SCM_PROC (s_sys_duplicate_port, "%duplicate-port", 2, 0, 0, scm_sys_duplicate_port);
-#ifdef __STDC__
-SCM
-scm_sys_duplicate_port (SCM oldpt, SCM modes)
-#else
+SCM_PROC (s_duplicate_port, "duplicate-port", 2, 0, 0, scm_duplicate_port);
+
SCM
-scm_sys_duplicate_port (oldpt, modes)
+scm_duplicate_port (oldpt, modes)
SCM oldpt;
SCM modes;
-#endif
{
int oldfd;
int newfd;
FILE *f;
SCM newpt;
- SCM_ASSERT (SCM_NIMP (oldpt) && SCM_OPPORTP (oldpt), oldpt, SCM_ARG1, s_sys_duplicate_port);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_duplicate_port);
+ SCM_ASSERT (SCM_NIMP (oldpt) && SCM_OPPORTP (oldpt), oldpt, SCM_ARG1,
+ s_duplicate_port);
+ SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
+ s_duplicate_port);
SCM_NEWCELL (newpt);
SCM_DEFER_INTS;
oldfd = fileno ((FILE *)SCM_STREAM (oldpt));
if (oldfd == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- };
+ scm_syserror (s_duplicate_port);
SCM_SYSCALL (newfd = dup (oldfd));
if (newfd == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- };
- f = fdopen (newfd, SCM_CHARS (modes));
+ scm_syserror (s_duplicate_port);
+ f = fdopen (newfd, SCM_ROCHARS (modes));
if (!f)
{
SCM_SYSCALL (close (newfd));
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ scm_syserror (s_duplicate_port);
}
{
struct scm_port_table * pt;
pt = scm_add_to_port_table (newpt);
SCM_SETPTAB_ENTRY (newpt, pt);
- if (SCM_BUF0 & (SCM_CAR (newpt) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))))
+ SCM_SETCAR (newpt, scm_tc16_fport | scm_mode_bits (SCM_ROCHARS (modes)));
+ if (SCM_BUF0 & SCM_CAR (newpt))
scm_setbuf0 (newpt);
SCM_SETSTREAM (newpt, (SCM)f);
SCM_PTAB_ENTRY (newpt)->file_name = SCM_PTAB_ENTRY (oldpt)->file_name;
@@ -187,121 +277,86 @@ scm_sys_duplicate_port (oldpt, modes)
-SCM_PROC (s_sys_redirect_port, "%redirect-port", 2, 0, 0, scm_sys_redirect_port);
-#ifdef __STDC__
-SCM
-scm_sys_redirect_port (SCM into_pt, SCM from_pt)
-#else
+SCM_PROC (s_redirect_port, "redirect-port", 2, 0, 0, scm_redirect_port);
+
SCM
-scm_sys_redirect_port (into_pt, from_pt)
+scm_redirect_port (into_pt, from_pt)
SCM into_pt;
SCM from_pt;
-#endif
{
int ans, oldfd, newfd;
SCM_DEFER_INTS;
- SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port);
- SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port);
+ SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_redirect_port);
+ SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_redirect_port);
oldfd = fileno ((FILE *)SCM_STREAM (into_pt));
+ if (oldfd == -1)
+ scm_syserror (s_redirect_port);
newfd = fileno ((FILE *)SCM_STREAM (from_pt));
- if (oldfd == -1 || newfd == -1)
- ans = -1;
- else
- SCM_SYSCALL (ans = dup2 (oldfd, newfd));
+ if (newfd == -1)
+ scm_syserror (s_redirect_port);
+ SCM_SYSCALL (ans = dup2 (oldfd, newfd));
+ if (ans == -1)
+ scm_syserror (s_redirect_port);
SCM_ALLOW_INTS;
- return (ans == -1) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
-}
-
-SCM_PROC (s_sys_fileno, "%fileno", 1, 0, 0, scm_sys_fileno);
-#ifdef __STDC__
-SCM
-scm_sys_fileno (SCM port)
-#else
-SCM
-scm_sys_fileno (port)
- SCM port;
-#endif
-{
- int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno);
- fd = fileno ((FILE *)SCM_STREAM (port));
- return (fd == -1) ? SCM_BOOL_F : SCM_MAKINUM (fd);
+ return SCM_UNSPECIFIED;
}
+SCM_PROC (s_fileno, "fileno", 1, 0, 0, scm_fileno);
-SCM_PROC (s_sys_soft_fileno, "%soft-fileno", 1, 0, 0, scm_sys_soft_fileno);
-#ifdef __STDC__
-SCM
-scm_sys_soft_fileno (SCM port)
-#else
SCM
-scm_sys_soft_fileno (port)
+scm_fileno (port)
SCM port;
-#endif
{
int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_sys_fileno);
-
- if (!SCM_OPFPORTP (port))
- return SCM_BOOL_F;
-
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_fileno);
fd = fileno ((FILE *)SCM_STREAM (port));
- return (fd == -1) ? SCM_BOOL_F : SCM_MAKINUM (fd);
+ if (fd == -1)
+ scm_syserror (s_fileno);
+ return SCM_MAKINUM (fd);
}
+SCM_PROC (s_isatty, "isatty?", 1, 0, 0, scm_isatty_p);
-
-SCM_PROC (s_sys_isatty, "%isatty?", 1, 0, 0, scm_sys_isatty_p);
-#ifdef __STDC__
-SCM
-scm_sys_isatty_p (SCM port)
-#else
SCM
-scm_sys_isatty_p (port)
+scm_isatty_p (port)
SCM port;
-#endif
{
int rv;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_isatty);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_isatty);
rv = fileno ((FILE *)SCM_STREAM (port));
if (rv == -1)
- return SCM_MAKINUM (errno);
- else
- {
- rv = isatty (rv);
- return rv ? SCM_BOOL_T : SCM_BOOL_F;
- }
+ scm_syserror (s_isatty);
+ rv = isatty (rv);
+ return rv ? SCM_BOOL_T : SCM_BOOL_F;
}
-SCM_PROC (s_sys_fdopen, "%fdopen", 2, 0, 0, scm_sys_fdopen);
-#ifdef __STDC__
-SCM
-scm_sys_fdopen (SCM fdes, SCM modes)
-#else
+SCM_PROC (s_fdopen, "fdopen", 2, 0, 0, scm_fdopen);
+
SCM
-scm_sys_fdopen (fdes, modes)
+scm_fdopen (fdes, modes)
SCM fdes;
SCM modes;
-#endif
{
FILE *f;
SCM port;
+ struct scm_port_table * pt;
- SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_sys_fdopen);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_fdopen);
+ SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_fdopen);
+ SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
+ s_fdopen);
+ SCM_NEWCELL (port);
SCM_DEFER_INTS;
- f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes));
+ f = fdopen (SCM_INUM (fdes), SCM_ROCHARS (modes));
if (f == NULL)
- {
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
- }
- SCM_NEWCELL (port);
- SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes));
- SCM_SETSTREAM (port,(SCM)f);
- scm_add_to_port_table (port);
+ scm_syserror (s_fdopen);
+ pt = scm_add_to_port_table (port);
+ SCM_SETPTAB_ENTRY (port, pt);
+ SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_ROCHARS (modes)));
+ if (SCM_BUF0 & SCM_CAR (port))
+ scm_setbuf0 (port);
+ SCM_SETSTREAM (port, (SCM)f);
SCM_ALLOW_INTS;
return port;
}
@@ -309,29 +364,24 @@ scm_sys_fdopen (fdes, modes)
/* Move a port's underlying file descriptor to a given value.
- * Returns: #f for error.
- * 0 if fdes is already the given value.
- * 1 if fdes moved.
+ * Returns #f if fdes is already the given value.
+ * #t if fdes moved.
* MOVE->FDES is implemented in Scheme and calls this primitive.
*/
-SCM_PROC (s_sys_primitive_move_to_fdes, "%primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes);
-#ifdef __STDC__
-SCM
-scm_sys_primitive_move_to_fdes (SCM port, SCM fd)
-#else
+SCM_PROC (s_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_primitive_move_to_fdes);
+
SCM
-scm_sys_primitive_move_to_fdes (port, fd)
+scm_primitive_move_to_fdes (port, fd)
SCM port;
SCM fd;
-#endif
{
FILE *stream;
int old_fd;
int new_fd;
int rv;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_primitive_move_to_fdes);
- SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_sys_primitive_move_to_fdes);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_primitive_move_to_fdes);
+ SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_move_to_fdes);
SCM_DEFER_INTS;
stream = (FILE *)SCM_STREAM (port);
old_fd = fileno (stream);
@@ -339,46 +389,31 @@ scm_sys_primitive_move_to_fdes (port, fd)
if (old_fd == new_fd)
{
SCM_ALLOW_INTS;
- return SCM_MAKINUM (0);
+ return SCM_BOOL_F;
}
scm_evict_ports (new_fd);
rv = dup2 (old_fd, new_fd);
if (rv == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_primitive_move_to_fdes);
scm_setfileno (stream, new_fd);
SCM_SYSCALL (close (old_fd));
SCM_ALLOW_INTS;
- return SCM_MAKINUM (1);
+ return SCM_BOOL_T;
}
+#ifdef FD_SETTER
+#define SET_FILE_FD_FIELD(F,D) ((F)->FD_SETTER = (D))
+#endif
-
-/* FIXME */
-#ifdef __STDC__
-void
-scm_setfileno (FILE *fs, int fd)
-#else
void
scm_setfileno (fs, fd)
FILE *fs;
int fd;
-#endif
{
#ifdef SET_FILE_FD_FIELD
SET_FILE_FD_FIELD(fs, fd);
#else
- Configure could not guess the name of the correct field in a FILE *.
-
- This function needs to be ported to your system.
-
- SET_FILE_FD_FIELD should change the descriptor refered to by a stdio
- stream, and nothing else.
-
- The way to port this file is to add cases to configure.in. Search
- that file for "SET_FILE_FD_FIELD" and follow the examples there.
+ scm_misc_error ("scm_setfileno", "Not fully implemented");
#endif
}
@@ -386,14 +421,10 @@ scm_setfileno (fs, fd)
* reseting the revealed count to 0.
* Should be called with SCM_DEFER_INTS active.
*/
-#ifdef __STDC__
-void
-scm_evict_ports (int fd)
-#else
+
void
scm_evict_ports (fd)
int fd;
-#endif
{
int i;
@@ -410,14 +441,10 @@ scm_evict_ports (fd)
/* Return a list of ports using a given file descriptor. */
SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports);
-#ifdef __STDC__
-SCM
-scm_fdes_to_ports (SCM fd)
-#else
+
SCM
scm_fdes_to_ports (fd)
SCM fd;
-#endif
{
SCM result = SCM_EOL;
int int_fd;
@@ -437,99 +464,15 @@ scm_fdes_to_ports (fd)
return result;
}
-#ifdef __STDC__
-void
-scm_init_ioext (void)
-#else
+
void
scm_init_ioext ()
-#endif
{
/* fseek() symbols. */
scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET));
scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR));
scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END));
- /* access() symbols. */
- scm_sysintern ("R_OK", SCM_MAKINUM (R_OK));
- scm_sysintern ("W_OK", SCM_MAKINUM (W_OK));
- scm_sysintern ("X_OK", SCM_MAKINUM (X_OK));
- scm_sysintern ("F_OK", SCM_MAKINUM (F_OK));
-
- /* File type/permission bits. */
-#ifdef S_IRUSR
- scm_sysintern ("S_IRUSR", SCM_MAKINUM (S_IRUSR));
-#endif
-#ifdef S_IWUSR
- scm_sysintern ("S_IWUSR", SCM_MAKINUM (S_IWUSR));
-#endif
-#ifdef S_IXUSR
- scm_sysintern ("S_IXUSR", SCM_MAKINUM (S_IXUSR));
-#endif
-#ifdef S_IRWXU
- scm_sysintern ("S_IRWXU", SCM_MAKINUM (S_IRWXU));
-#endif
-
-#ifdef S_IRGRP
- scm_sysintern ("S_IRGRP", SCM_MAKINUM (S_IRGRP));
-#endif
-#ifdef S_IWGRP
- scm_sysintern ("S_IWGRP", SCM_MAKINUM (S_IWGRP));
-#endif
-#ifdef S_IXGRP
- scm_sysintern ("S_IXGRP", SCM_MAKINUM (S_IXGRP));
-#endif
-#ifdef S_IRWXG
- scm_sysintern ("S_IRWXG", SCM_MAKINUM (S_IRWXG));
-#endif
-
-#ifdef S_IROTH
- scm_sysintern ("S_IROTH", SCM_MAKINUM (S_IROTH));
-#endif
-#ifdef S_IWOTH
- scm_sysintern ("S_IWOTH", SCM_MAKINUM (S_IWOTH));
-#endif
-#ifdef S_IXOTH
- scm_sysintern ("S_IXOTH", SCM_MAKINUM (S_IXOTH));
-#endif
-#ifdef S_IRWXO
- scm_sysintern ("S_IRWXO", SCM_MAKINUM (S_IRWXO));
-#endif
-
-#ifdef S_ISUID
- scm_sysintern ("S_ISUID", SCM_MAKINUM (S_ISUID));
-#endif
-#ifdef S_ISGID
- scm_sysintern ("S_ISGID", SCM_MAKINUM (S_ISGID));
-#endif
-#ifdef S_ISVTX
- scm_sysintern ("S_ISVTX", SCM_MAKINUM (S_ISVTX));
-#endif
-
-#ifdef S_IFMT
- scm_sysintern ("S_IFMT", SCM_MAKINUM (S_IFMT));
-#endif
-#ifdef S_IFDIR
- scm_sysintern ("S_IFDIR", SCM_MAKINUM (S_IFDIR));
-#endif
-#ifdef S_IFCHR
- scm_sysintern ("S_IFCHR", SCM_MAKINUM (S_IFCHR));
-#endif
-#ifdef S_IFBLK
- scm_sysintern ("S_IFBLK", SCM_MAKINUM (S_IFBLK));
-#endif
-#ifdef S_IFREG
- scm_sysintern ("S_IFREG", SCM_MAKINUM (S_IFREG));
-#endif
-#ifdef S_IFLNK
- scm_sysintern ("S_IFLNK", SCM_MAKINUM (S_IFLNK));
-#endif
-#ifdef S_IFSOCK
- scm_sysintern ("S_IFSOCK", SCM_MAKINUM (S_IFSOCK));
-#endif
-#ifdef S_IFIFO
- scm_sysintern ("S_IFIFO", SCM_MAKINUM (S_IFIFO));
-#endif
#include "ioext.x"
}
diff --git a/libguile/ioext.h b/libguile/ioext.h
index b7a30e2c0..b7d5ae597 100644
--- a/libguile/ioext.h
+++ b/libguile/ioext.h
@@ -2,7 +2,7 @@
#ifndef IOEXTH
#define IOEXTH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,44 +44,24 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
-
-#ifdef __STDC__
-extern SCM scm_sys_ftell (SCM port);
-extern SCM scm_sys_fseek (SCM port, SCM offset, SCM whence);
-extern SCM scm_sys_freopen (SCM filename, SCM modes, SCM port);
-extern SCM scm_sys_duplicate_port (SCM oldpt, SCM modes);
-extern SCM scm_sys_redirect_port (SCM into_pt, SCM from_pt);
-extern SCM scm_sys_fileno (SCM port);
-extern SCM scm_sys_isatty (SCM port);
-extern SCM scm_sys_fdopen (SCM fdes, SCM modes);
-extern SCM scm_sys_primitive_move_to_fdes (SCM port, SCM fd);
-extern void scm_setfileno (FILE *fs, int fd);
-extern void scm_evict_ports (int fd);
-extern SCM scm_fdes_to_ports (SCM fd);
-extern void scm_init_ioext (void);
-
-#else /* STDC */
-extern SCM scm_sys_ftell ();
-extern SCM scm_sys_fseek ();
-extern SCM scm_sys_freopen ();
-extern SCM scm_sys_duplicate_port ();
-extern SCM scm_sys_redirect_port ();
-extern SCM scm_sys_fileno ();
-extern SCM scm_sys_isatty ();
-extern SCM scm_sys_fdopen ();
-extern SCM scm_sys_primitive_move_to_fdes ();
-extern void scm_setfileno ();
-extern void scm_evict_ports ();
-extern SCM scm_fdes_to_ports ();
-extern void scm_init_ioext ();
-
-#endif /* STDC */
-
-
+extern SCM scm_read_delimited_x SCM_P ((SCM delims, SCM buf, SCM gobble, SCM port, SCM offset, SCM length));
+extern SCM scm_write_line SCM_P ((SCM obj, SCM port));
+extern SCM scm_ftell SCM_P ((SCM port));
+extern SCM scm_fseek SCM_P ((SCM port, SCM offset, SCM whence));
+extern SCM scm_freopen SCM_P ((SCM filename, SCM modes, SCM port));
+extern SCM scm_duplicate_port SCM_P ((SCM oldpt, SCM modes));
+extern SCM scm_redirect_port SCM_P ((SCM into_pt, SCM from_pt));
+extern SCM scm_fileno SCM_P ((SCM port));
+extern SCM scm_isatty_p SCM_P ((SCM port));
+extern SCM scm_fdopen SCM_P ((SCM fdes, SCM modes));
+extern SCM scm_primitive_move_to_fdes SCM_P ((SCM port, SCM fd));
+extern void scm_setfileno SCM_P ((FILE *fs, int fd));
+extern void scm_evict_ports SCM_P ((int fd));
+extern SCM scm_fdes_to_ports SCM_P ((SCM fd));
+extern void scm_init_ioext SCM_P ((void));
#endif /* IOEXTH */
diff --git a/libguile/kw.c b/libguile/kw.c
index e559ef3ea..76ca88050 100644
--- a/libguile/kw.c
+++ b/libguile/kw.c
@@ -42,31 +42,31 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "mbstrings.h"
+#include "smob.h"
+#include "kw.h"
-#ifdef __STDC__
-static scm_sizet
-free_kw (SCM obj)
-#else
+
+static scm_sizet free_kw SCM_P ((SCM obj));
+
static scm_sizet
free_kw (obj)
SCM obj;
-#endif
{
return 0;
}
-#ifdef __STDC__
-static int
-prin_kw (SCM exp, SCM port, int writing)
-#else
+
+static int prin_kw SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prin_kw (exp, port, writing)
+prin_kw (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_gen_puts (scm_regular_string, ":", port);
scm_gen_puts((SCM_MB_STRINGP(SCM_CDR (exp))
@@ -84,14 +84,10 @@ static scm_smobfuns kw_smob = {scm_markcdr, free_kw, prin_kw, 0};
SCM_PROC (s_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, scm_make_keyword_from_dash_symbol);
-#ifdef __STDC__
-SCM
-scm_make_keyword_from_dash_symbol (SCM symbol)
-#else
+
SCM
scm_make_keyword_from_dash_symbol (symbol)
SCM symbol;
-#endif
{
SCM vcell;
@@ -105,25 +101,21 @@ scm_make_keyword_from_dash_symbol (symbol)
{
SCM kw;
SCM_NEWCELL(kw);
- SCM_CAR(kw) = (SCM)scm_tc16_kw;
- SCM_CDR(kw) = symbol;
+ SCM_SETCAR (kw, (SCM)scm_tc16_kw);
+ SCM_SETCDR (kw, symbol);
scm_intern_symbol (scm_kw_obarray, symbol);
vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray);
- SCM_CDR (vcell) = kw;
+ SCM_SETCDR (vcell, kw);
}
SCM_ALLOW_INTS;
return SCM_CDR (vcell);
}
SCM_PROC(s_keyword_p, "keyword?", 1, 0, 0, scm_keyword_p);
-#ifdef __STDC__
-SCM
-scm_keyword_p (SCM obj)
-#else
+
SCM
scm_keyword_p (obj)
SCM obj;
-#endif
{
return ( (SCM_NIMP(obj) && SCM_KEYWORDP (obj))
? SCM_BOOL_T
@@ -133,14 +125,10 @@ scm_keyword_p (obj)
SCM_PROC(s_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, scm_keyword_dash_symbol);
-#ifdef __STDC__
-SCM
-scm_keyword_dash_symbol (SCM kw)
-#else
+
SCM
scm_keyword_dash_symbol (kw)
SCM kw;
-#endif
{
SCM_ASSERT (SCM_NIMP (kw) && SCM_KEYWORDP (kw), kw, SCM_ARG1, s_keyword_dash_symbol);
return SCM_CDR (kw);
@@ -149,13 +137,9 @@ scm_keyword_dash_symbol (kw)
-#ifdef __STDC__
-void
-scm_init_kw (void)
-#else
+
void
scm_init_kw ()
-#endif
{
scm_tc16_kw = scm_newsmob (&kw_smob);
scm_kw_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL, SCM_UNDEFINED);
diff --git a/libguile/kw.h b/libguile/kw.h
index c84899cff..89387c5b3 100644
--- a/libguile/kw.h
+++ b/libguile/kw.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -54,17 +54,10 @@ extern int scm_tc16_kw;
-#ifdef __STDC__
-extern SCM scm_make_keyword_from_dash_symbol (SCM symbol);
-extern SCM scm_keyword_p (SCM obj);
-extern SCM scm_keyword_dash_symbol (SCM kw);
-extern void scm_init_kw (void);
-#else /* STDC */
-extern SCM scm_make_keyword_from_dash_symbol ();
-extern SCM scm_keyword_p ();
-extern SCM scm_keyword_dash_symbol ();
-extern void scm_init_kw ();
+extern SCM scm_make_keyword_from_dash_symbol SCM_P ((SCM symbol));
+extern SCM scm_keyword_p SCM_P ((SCM obj));
+extern SCM scm_keyword_dash_symbol SCM_P ((SCM kw));
+extern void scm_init_kw SCM_P ((void));
-#endif /* STDC */
#endif /* KWH */
diff --git a/libguile/libguile.h b/libguile/libguile.h
index ea18a23db..a35a09b11 100644
--- a/libguile/libguile.h
+++ b/libguile/libguile.h
@@ -45,98 +45,86 @@
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# ifdef AMIGA
-# include <stddef.h>
-# endif /* def AMIGA */
-# define scm_sizet size_t
-#else
-# ifdef _SIZE_T
-# define scm_sizet size_t
-# else
-# define scm_sizet unsigned int
-# endif /* def _SIZE_T */
-#endif /* def STDC_HEADERS */
+#include "libguile/__scm.h"
-#include "__scm.h"
-
-#include "smob.h"
-
-
-
-#include "alist.h"
-#include "append.h"
-#include "arbiters.h"
-#include "async.h"
-#include "boolean.h"
-#include "chars.h"
-#include "continuations.h"
-#include "dynwind.h"
-#include "eq.h"
-#include "error.h"
-#include "eval.h"
-#include "extchrs.h"
-#include "fdsocket.h"
-#include "feature.h"
-#include "files.h"
-#include "filesys.h"
-#include "fports.h"
-#include "gc.h"
-#include "genio.h"
-#include "gsubr.h"
-#include "hash.h"
-#include "hashtab.h"
-#include "init.h"
-#include "ioext.h"
-#include "kw.h"
-#include "libguile.h"
-#include "list.h"
-#include "load.h"
-#include "mallocs.h"
-#include "markers.h"
-#include "marksweep.h"
-#include "mbstrings.h"
-#include "numbers.h"
-#include "pairs.h"
-#include "params.h"
-#include "ports.h"
-#include "posix.h"
-#include "print.h"
-#include "procprop.h"
-#include "procs.h"
-#include "ramap.h"
-#include "read.h"
-#include "root.h"
-#include "scmsigs.h"
-#include "sequences.h"
-#include "simpos.h"
-#include "socket.h"
-#include "stackchk.h"
-#include "stime.h"
-#include "strings.h"
-#include "strop.h"
-#include "strorder.h"
-#include "strports.h"
-#include "struct.h"
-#include "symbols.h"
-#include "tag.h"
-#include "tags.h"
-#include "throw.h"
-#include "unif.h"
-#include "variable.h"
-#include "vectors.h"
-#include "vports.h"
-#include "weaks.h"
+/* These files define typedefs used by later files, so they need to
+ come first. */
+#include "libguile/print.h"
+#include "libguile/smob.h"
+#include "libguile/pairs.h"
+#include "libguile/alist.h"
+#include "libguile/append.h"
+#include "libguile/arbiters.h"
+#include "libguile/async.h"
+#include "libguile/boolean.h"
+#include "libguile/chars.h"
+#include "libguile/continuations.h"
+#ifdef DEBUG_EXTENSIONS
+#include "libguile/backtrace.h"
+#include "libguile/debug.h"
+#include "libguile/stacks.h"
+#endif
+#include "libguile/dynwind.h"
+#include "libguile/eq.h"
+#include "libguile/error.h"
+#include "libguile/eval.h"
+#include "libguile/extchrs.h"
+#include "libguile/feature.h"
+#include "libguile/filesys.h"
+#include "libguile/fports.h"
+#include "libguile/gc.h"
+#include "libguile/gdbint.h"
+#include "libguile/genio.h"
+#include "libguile/gsubr.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/init.h"
+#include "libguile/ioext.h"
+#include "libguile/kw.h"
+#include "libguile/list.h"
+#include "libguile/load.h"
+#include "libguile/mallocs.h"
+#include "libguile/markers.h"
+#include "libguile/mbstrings.h"
+#include "libguile/net_db.h"
+#include "libguile/numbers.h"
+#include "libguile/objprop.h"
+#include "libguile/options.h"
+#include "libguile/ports.h"
+#include "libguile/posix.h"
+#include "libguile/procprop.h"
+#include "libguile/procs.h"
+#include "libguile/ramap.h"
+#include "libguile/read.h"
+#include "libguile/root.h"
+#include "libguile/scmsigs.h"
+#include "libguile/sequences.h"
+#include "libguile/simpos.h"
+#include "libguile/snarf.h"
+#include "libguile/socket.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/stime.h"
+#include "libguile/strings.h"
+#include "libguile/strop.h"
+#include "libguile/strorder.h"
+#include "libguile/strports.h"
+#include "libguile/struct.h"
+#include "libguile/symbols.h"
+#include "libguile/tag.h"
+#include "libguile/tags.h"
+#include "libguile/throw.h"
+#include "libguile/unif.h"
+#include "libguile/variable.h"
+#include "libguile/vectors.h"
+#include "libguile/version.h"
+#include "libguile/vports.h"
+#include "libguile/weaks.h"
+#ifdef USE_THREADS
+#include "libguile/threads.h"
+#endif
-#ifdef __STDC__
-
-#else /* STDC */
-
-#endif /* STDC */
-
-
#endif /* LIBGUILEH */
diff --git a/libguile/list.c b/libguile/list.c
index 15c20fd32..f0040ec58 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -41,6 +41,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "eq.h"
+
+#include "list.h"
#ifdef __STDC__
#include <stdarg.h>
@@ -51,8 +54,9 @@
#endif
+/* creating lists */
-
+/* SCM_P won't help us deal with varargs here. */
#ifdef __STDC__
SCM
scm_listify (SCM elt, ...)
@@ -61,7 +65,6 @@ SCM
scm_listify (elt, va_alist)
SCM elt;
va_dcl
-
#endif
{
va_list foo;
@@ -74,7 +77,7 @@ scm_listify (elt, va_alist)
while (elt != SCM_UNDEFINED)
{
*pos = scm_cons (elt, SCM_EOL);
- pos = &SCM_CDR (*pos);
+ pos = SCM_CDRLOC (*pos);
elt = va_arg (foo, SCM);
}
return answer;
@@ -82,14 +85,9 @@ scm_listify (elt, va_alist)
SCM_PROC(s_list, "list", 0, 0, 1, scm_list);
-#ifdef __STDC__
-SCM
-scm_list(SCM objs)
-#else
SCM
scm_list(objs)
SCM objs;
-#endif
{
return objs;
}
@@ -97,29 +95,20 @@ scm_list(objs)
+/* general questions about lists --- null?, list?, length, etc. */
SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p);
-#ifdef __STDC__
-SCM
-scm_null_p(SCM x)
-#else
SCM
scm_null_p(x)
SCM x;
-#endif
{
return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p);
-#ifdef __STDC__
-SCM
-scm_list_p(SCM x)
-#else
SCM
scm_list_p(x)
SCM x;
-#endif
{
if (scm_ilength(x)<0)
return SCM_BOOL_F;
@@ -128,41 +117,41 @@ scm_list_p(x)
}
-#ifdef __STDC__
-long
-scm_ilength(SCM sx)
-#else
+/* Return the length of SX, or -1 if it's not a proper list.
+ This uses the "tortoise and hare" algorithm to detect "infinitely
+ long" lists (i.e. lists with cycles in their cdrs), and returns -1
+ if it does find one. */
long
scm_ilength(sx)
SCM sx;
-#endif
{
register long i = 0;
- register SCM x = sx;
+ register SCM tortoise = sx;
+ register SCM hare = sx;
+
do {
- if SCM_IMP(x) return SCM_NULLP(x) ? i : -1;
- if SCM_NCONSP(x) return -1;
- x = SCM_CDR(x);
+ if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
+ if SCM_NCONSP(hare) return -1;
+ hare = SCM_CDR(hare);
i++;
- if SCM_IMP(x) return SCM_NULLP(x) ? i : -1;
- if SCM_NCONSP(x) return -1;
- x = SCM_CDR(x);
+ if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
+ if SCM_NCONSP(hare) return -1;
+ hare = SCM_CDR(hare);
i++;
- sx = SCM_CDR(sx);
+ /* For every two steps the hare takes, the tortoise takes one. */
+ tortoise = SCM_CDR(tortoise);
}
- while (x != sx);
+ while (hare != tortoise);
+
+ /* If the tortoise ever catches the hare, then the list must contain
+ a cycle. */
return -1;
}
SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length);
-#ifdef __STDC__
-SCM
-scm_list_length(SCM x)
-#else
SCM
scm_list_length(x)
SCM x;
-#endif
{
int i;
i = scm_ilength(x);
@@ -172,16 +161,12 @@ scm_list_length(x)
+/* appending lists */
SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append);
-#ifdef __STDC__
-SCM
-scm_list_append(SCM args)
-#else
SCM
scm_list_append(args)
SCM args;
-#endif
{
SCM res = SCM_EOL;
SCM *lloc = &res, arg;
@@ -202,7 +187,7 @@ scm_list_append(args)
for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) {
SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_list_append);
*lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
- lloc = &SCM_CDR(*lloc);
+ lloc = SCM_CDRLOC(*lloc);
}
SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_list_append);
}
@@ -210,14 +195,9 @@ scm_list_append(args)
SCM_PROC (s_list_append_x, "list-append!", 0, 0, 1, scm_list_append_x);
-#ifdef __STDC__
-SCM
-scm_list_append_x(SCM args)
-#else
SCM
scm_list_append_x(args)
SCM args;
-#endif
{
SCM arg;
tail:
@@ -227,23 +207,42 @@ scm_list_append_x(args)
args = SCM_CDR(args);
if SCM_NULLP(args) return arg;
if SCM_NULLP(arg) goto tail;
- SCM_CDR(scm_last_pair(arg)) = scm_list_append_x(args);
+ SCM_SETCDR (scm_last_pair (arg), scm_list_append_x (args));
return arg;
}
-
+SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
+SCM
+scm_last_pair(sx)
+ SCM sx;
+{
+ register SCM res = sx;
+ register SCM x;
+
+ if (SCM_NULLP (sx))
+ return SCM_EOL;
+
+ SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair);
+ while (!0) {
+ x = SCM_CDR(res);
+ if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
+ res = x;
+ x = SCM_CDR(res);
+ if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
+ res = x;
+ sx = SCM_CDR(sx);
+ SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair);
+ }
+}
+
+/* reversing lists */
SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse);
-#ifdef __STDC__
-SCM
-scm_list_reverse(SCM lst)
-#else
SCM
scm_list_reverse(lst)
SCM lst;
-#endif
{
SCM res = SCM_EOL;
SCM p = lst;
@@ -256,15 +255,10 @@ scm_list_reverse(lst)
}
SCM_PROC (s_list_reverse_x, "list-reverse!", 1, 1, 0, scm_list_reverse_x);
-#ifdef __STDC__
-SCM
-scm_list_reverse_x (SCM lst, SCM newtail)
-#else
SCM
scm_list_reverse_x (lst, newtail)
SCM lst;
SCM newtail;
-#endif
{
SCM old_tail;
if (newtail == SCM_UNDEFINED)
@@ -286,18 +280,13 @@ scm_list_reverse_x (lst, newtail)
-
+/* indexing lists by element number */
SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref);
-#ifdef __STDC__
-SCM
-scm_list_ref(SCM lst, SCM k)
-#else
SCM
scm_list_ref(lst, k)
SCM lst;
SCM k;
-#endif
{
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref);
@@ -313,16 +302,11 @@ erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
}
SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x);
-#ifdef __STDC__
-SCM
-scm_list_set_x(SCM lst, SCM k, SCM val)
-#else
SCM
scm_list_set_x(lst, k, val)
SCM lst;
SCM k;
SCM val;
-#endif
{
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x);
@@ -334,23 +318,35 @@ scm_list_set_x(lst, k, val)
}
erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x);
- SCM_CAR (lst) = val;
+ SCM_SETCAR (lst, val);
return val;
}
+SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
+SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
+SCM
+scm_list_tail(lst, k)
+ SCM lst;
+ SCM k;
+{
+ register long i;
+ SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail);
+ i = SCM_INUM(k);
+ while (i-- > 0) {
+ SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail);
+ lst = SCM_CDR(lst);
+ }
+ return lst;
+}
+
SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x);
-#ifdef __STDC__
-SCM
-scm_list_cdr_set_x(SCM lst, SCM k, SCM val)
-#else
SCM
scm_list_cdr_set_x(lst, k, val)
SCM lst;
SCM k;
SCM val;
-#endif
{
register long i;
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x);
@@ -368,71 +364,13 @@ erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
-
-
-
-SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
-#ifdef __STDC__
-SCM
-scm_last_pair(SCM sx)
-#else
-SCM
-scm_last_pair(sx)
- SCM sx;
-#endif
-{
- register SCM res = sx;
- register SCM x;
-
- if (SCM_NULLP (sx))
- return SCM_EOL;
-
- SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair);
- while (!0) {
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- sx = SCM_CDR(sx);
- SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair);
- }
-}
-
-SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
-SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
-#ifdef __STDC__
-SCM
-scm_list_tail(SCM lst, SCM k)
-#else
-SCM
-scm_list_tail(lst, k)
- SCM lst;
- SCM k;
-#endif
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail);
- i = SCM_INUM(k);
- while (i-- > 0) {
- SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail);
- lst = SCM_CDR(lst);
- }
- return lst;
-}
-
+/* copying lists, perhaps partially */
SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head);
-#ifdef __STDC__
-SCM
-scm_list_head(SCM lst, SCM k)
-#else
SCM
scm_list_head(lst, k)
SCM lst;
SCM k;
-#endif
{
SCM answer;
SCM * pos;
@@ -446,40 +384,57 @@ scm_list_head(lst, k)
{
SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head);
*pos = scm_cons (SCM_CAR (lst), SCM_EOL);
- pos = &SCM_CDR (*pos);
+ pos = SCM_CDRLOC (*pos);
lst = SCM_CDR(lst);
}
return answer;
}
+SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy);
+SCM
+scm_list_copy (lst)
+ SCM lst;
+{
+ SCM newlst;
+ SCM * fill_here;
+ SCM from_here;
+
+ newlst = SCM_EOL;
+ fill_here = &newlst;
+ from_here = lst;
+
+ while (SCM_NIMP (from_here) && SCM_CONSP (from_here))
+ {
+ SCM c;
+ c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
+ *fill_here = c;
+ fill_here = SCM_CDRLOC (c);
+ from_here = SCM_CDR (from_here);
+ }
+ return newlst;
+}
+
+/* membership tests (memq, memv, etc.) */
+
+static void sloppy_mem_check SCM_P ((SCM obj, char * where, char * why));
-#ifdef __STDC__
-static void
-sloppy_mem_check (SCM obj, char * where, char * why)
-#else
static void
sloppy_mem_check (obj, where, why)
SCM obj;
char * where;
char * why;
-#endif
{
SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why);
}
SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq);
-#ifdef __STDC__
-SCM
-scm_sloppy_memq(SCM x, SCM lst)
-#else
SCM
scm_sloppy_memq(x, lst)
SCM x;
SCM lst;
-#endif
{
for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
{
@@ -491,15 +446,10 @@ scm_sloppy_memq(x, lst)
SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv);
-#ifdef __STDC__
-SCM
-scm_sloppy_memv(SCM x, SCM lst)
-#else
SCM
scm_sloppy_memv(x, lst)
SCM x;
SCM lst;
-#endif
{
for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
{
@@ -511,15 +461,10 @@ scm_sloppy_memv(x, lst)
SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member);
-#ifdef __STDC__
-SCM
-scm_sloppy_member (SCM x, SCM lst)
-#else
SCM
scm_sloppy_member (x, lst)
SCM x;
SCM lst;
-#endif
{
for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
{
@@ -532,208 +477,126 @@ scm_sloppy_member (x, lst)
SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq);
-#ifdef __STDC__
-SCM
-scm_memq(SCM x, SCM lst)
-#else
SCM
scm_memq(x, lst)
SCM x;
SCM lst;
-#endif
{
SCM answer;
answer = scm_sloppy_memq (x, lst);
sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq);
- return answer;
+ return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
}
SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv);
-#ifdef __STDC__
-SCM
-scm_memv(SCM x, SCM lst)
-#else
SCM
scm_memv(x, lst)
SCM x;
SCM lst;
-#endif
{
SCM answer;
answer = scm_sloppy_memv (x, lst);
sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv);
- return answer;
+ return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
}
SCM_PROC(s_member, "member", 2, 0, 0, scm_member);
-#ifdef __STDC__
-SCM
-scm_member(SCM x, SCM lst)
-#else
SCM
scm_member(x, lst)
SCM x;
SCM lst;
-#endif
{
SCM answer;
answer = scm_sloppy_member (x, lst);
sloppy_mem_check (answer, (char *)SCM_ARG2, s_member);
- return answer;
+ return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
}
+/* deleting elements from a list (delq, etc.) */
SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x);
-#ifdef __STDC__
-SCM
-scm_delq_x (SCM item, SCM lst)
-#else
SCM
scm_delq_x (item, lst)
SCM item;
SCM lst;
-#endif
{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
+ SCM walk;
+ SCM *prev;
- if (SCM_CAR (lst) == item)
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
+ for (prev = &lst, walk = lst;
+ SCM_NIMP (walk) && SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
{
- if (SCM_CAR (SCM_CDR (lst)) == item)
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
+ if (SCM_CAR (walk) == item)
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
}
- return start;
+
+ return lst;
}
SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x);
-#ifdef __STDC__
-SCM
-scm_delv_x (SCM item, SCM lst)
-#else
SCM
scm_delv_x (item, lst)
SCM item;
SCM lst;
-#endif
{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (lst), item))
- return SCM_CDR (lst);
-
- start = lst;
+ SCM walk;
+ SCM *prev;
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
+ for (prev = &lst, walk = lst;
+ SCM_NIMP (walk) && SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
{
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (SCM_CDR (lst)), item))
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
+ if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (walk), item))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
}
- return start;
+
+ return lst;
}
SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x);
-#ifdef __STDC__
-SCM
-scm_delete_x (SCM item, SCM lst)
-#else
SCM
scm_delete_x (item, lst)
SCM item;
SCM lst;
-#endif
{
- SCM start;
+ SCM walk;
+ SCM *prev;
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (lst), item))
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
+ for (prev = &lst, walk = lst;
+ SCM_NIMP (walk) && SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
{
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (SCM_CDR (lst)), item))
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
+ if (SCM_BOOL_F != scm_equal_p (SCM_CAR (walk), item))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
}
- return start;
-}
-
-
-
-SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy);
-#ifdef __STDC__
-SCM
-scm_list_copy (SCM lst)
-#else
-SCM
-scm_list_copy (lst)
- SCM lst;
-#endif
-{
- SCM newlst;
- SCM * fill_here;
- SCM from_here;
+ return lst;
+}
- newlst = SCM_EOL;
- fill_here = &newlst;
- from_here = lst;
- while (SCM_NIMP (from_here) && SCM_CONSP (from_here))
- {
- SCM c;
- c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
- *fill_here = c;
- fill_here = &SCM_CDR (c);
- from_here = SCM_CDR (from_here);
- }
- return newlst;
-}
SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq);
-#ifdef __STDC__
-SCM
-scm_delq (SCM item, SCM lst)
-#else
SCM
scm_delq (item, lst)
SCM item;
SCM lst;
-#endif
{
SCM copy;
@@ -742,15 +605,10 @@ scm_delq (item, lst)
}
SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv);
-#ifdef __STDC__
-SCM
-scm_delv (SCM item, SCM lst)
-#else
SCM
scm_delv (item, lst)
SCM item;
SCM lst;
-#endif
{
SCM copy;
@@ -759,15 +617,10 @@ scm_delv (item, lst)
}
SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete);
-#ifdef __STDC__
-SCM
-scm_delete (SCM item, SCM lst)
-#else
SCM
scm_delete (item, lst)
SCM item;
SCM lst;
-#endif
{
SCM copy;
@@ -777,15 +630,8 @@ scm_delete (item, lst)
-
-#ifdef __STDC__
-void
-scm_init_list (void)
-#else
void
scm_init_list ()
-#endif
{
#include "list.x"
}
-
diff --git a/libguile/list.h b/libguile/list.h
index ab0555540..277128375 100644
--- a/libguile/list.h
+++ b/libguile/list.h
@@ -44,83 +44,38 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
-
-
-
-#ifdef __STDC__
-extern SCM scm_listify (SCM elt, ...);
-extern SCM scm_list(SCM objs);
-extern SCM scm_null_p(SCM x);
-extern SCM scm_list_p(SCM x);
-extern long scm_ilength(SCM sx);
-extern SCM scm_list_length(SCM x);
-extern SCM scm_list_append(SCM args);
-extern SCM scm_list_append_x(SCM args);
-extern SCM scm_list_reverse(SCM lst);
-extern SCM scm_list_reverse_x (SCM lst, SCM newtail);
-extern SCM scm_list_ref(SCM lst, SCM k);
-extern SCM scm_list_set_x(SCM lst, SCM k, SCM val);
-extern SCM scm_list_cdr_ref(SCM lst, SCM k);
-extern SCM scm_list_cdr_set_x(SCM lst, SCM k, SCM val);
-extern SCM scm_last_pair(SCM sx);
-extern SCM scm_list_tail(SCM lst, SCM k);
-extern SCM scm_sloppy_memq(SCM x, SCM lst);
-extern SCM scm_sloppy_memv(SCM x, SCM lst);
-extern SCM scm_sloppy_member (SCM x, SCM lst);
-extern SCM scm_memq(SCM x, SCM lst);
-extern SCM scm_memv(SCM x, SCM lst);
-extern SCM scm_member(SCM x, SCM lst);
-extern SCM scm_delq_x (SCM item, SCM lst);
-extern SCM scm_delv_x (SCM item, SCM lst);
-extern SCM scm_delete_x (SCM item, SCM lst);
-extern SCM scm_list_copy (SCM lst);
-extern SCM scm_delq (SCM item, SCM lst);
-extern SCM scm_delv (SCM item, SCM lst);
-extern SCM scm_delete (SCM item, SCM lst);
-extern void scm_init_list (void);
-
-#else /* STDC */
-extern SCM scm_listify ();
-extern SCM scm_list();
-extern SCM scm_null_p();
-extern SCM scm_list_p();
-extern long scm_ilength();
-extern SCM scm_list_length();
-extern SCM scm_list_append();
-extern SCM scm_list_append_x();
-extern SCM scm_list_reverse();
-extern SCM scm_list_reverse_x ();
-extern SCM scm_list_ref();
-extern SCM scm_list_set_x();
-extern SCM scm_list_cdr_ref();
-extern SCM scm_list_cdr_set_x();
-extern SCM scm_last_pair();
-extern SCM scm_list_tail();
-extern SCM scm_sloppy_memq();
-extern SCM scm_sloppy_memv();
-extern SCM scm_sloppy_member ();
-extern SCM scm_memq();
-extern SCM scm_memv();
-extern SCM scm_member();
-extern SCM scm_delq_x ();
-extern SCM scm_delv_x ();
-extern SCM scm_delete_x ();
-extern SCM scm_list_copy ();
-extern SCM scm_delq ();
-extern SCM scm_delv ();
-extern SCM scm_delete ();
-extern void scm_init_list ();
-
-#endif /* STDC */
-
-
-
-
-
-
+extern SCM scm_list_head SCM_P ((SCM lst, SCM k));
+extern SCM scm_listify SCM_P ((SCM elt, ...));
+extern SCM scm_list SCM_P ((SCM objs));
+extern SCM scm_null_p SCM_P ((SCM x));
+extern SCM scm_list_p SCM_P ((SCM x));
+extern long scm_ilength SCM_P ((SCM sx));
+extern SCM scm_list_length SCM_P ((SCM x));
+extern SCM scm_list_append SCM_P ((SCM args));
+extern SCM scm_list_append_x SCM_P ((SCM args));
+extern SCM scm_list_reverse SCM_P ((SCM lst));
+extern SCM scm_list_reverse_x SCM_P ((SCM lst, SCM newtail));
+extern SCM scm_list_ref SCM_P ((SCM lst, SCM k));
+extern SCM scm_list_set_x SCM_P ((SCM lst, SCM k, SCM val));
+extern SCM scm_list_cdr_set_x SCM_P ((SCM lst, SCM k, SCM val));
+extern SCM scm_last_pair SCM_P ((SCM sx));
+extern SCM scm_list_tail SCM_P ((SCM lst, SCM k));
+extern SCM scm_sloppy_memq SCM_P ((SCM x, SCM lst));
+extern SCM scm_sloppy_memv SCM_P ((SCM x, SCM lst));
+extern SCM scm_sloppy_member SCM_P ((SCM x, SCM lst));
+extern SCM scm_memq SCM_P ((SCM x, SCM lst));
+extern SCM scm_memv SCM_P ((SCM x, SCM lst));
+extern SCM scm_member SCM_P ((SCM x, SCM lst));
+extern SCM scm_delq_x SCM_P ((SCM item, SCM lst));
+extern SCM scm_delv_x SCM_P ((SCM item, SCM lst));
+extern SCM scm_delete_x SCM_P ((SCM item, SCM lst));
+extern SCM scm_list_copy SCM_P ((SCM lst));
+extern SCM scm_delq SCM_P ((SCM item, SCM lst));
+extern SCM scm_delv SCM_P ((SCM item, SCM lst));
+extern SCM scm_delete SCM_P ((SCM item, SCM lst));
+extern void scm_init_list SCM_P ((void));
#endif /* LISTH */
diff --git a/libguile/load.c b/libguile/load.c
index b2a54d79a..04ee995ed 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -42,50 +42,296 @@
#include <stdio.h>
#include "_scm.h"
+#include "libpath.h"
+#include "fports.h"
+#include "read.h"
+#include "eval.h"
+#include "throw.h"
+
+#include "load.h"
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif /* HAVE_UNISTD_H */
+
+#ifndef R_OK
+#define R_OK 4
+#endif
+/* Loading a file, given an absolute filename. */
-SCM_PROC(s_sys_try_load, "%try-load", 1, 2, 0, scm_sys_try_load);
-#ifdef __STDC__
-SCM
-scm_sys_try_load (SCM filename, SCM case_insensative_p, SCM sharp)
-#else
+/* Hook to run when we load a file, perhaps to announce the fact somewhere.
+ Applied to the full name of the file. */
+static SCM *scm_loc_load_hook;
+
+SCM_PROC(s_primitive_load, "primitive-load", 1, 0, 0, scm_primitive_load);
SCM
-scm_sys_try_load (filename, case_insensative_p, sharp)
+scm_primitive_load (filename)
SCM filename;
- SCM case_insensative_p;
- SCM sharp;
-#endif
{
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_try_load);
+ SCM hook = *scm_loc_load_hook;
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
+ SCM_ARG1, s_primitive_load);
+ SCM_ASSERT (hook == SCM_BOOL_F
+ || (scm_procedure_p (hook) == SCM_BOOL_T),
+ hook, "value of %load-hook is neither a procedure nor #f",
+ s_primitive_load);
+
+ if (hook != SCM_BOOL_F)
+ scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL);
+
{
SCM form, port;
port = scm_open_file (filename,
scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
- if (SCM_FALSEP (port))
- return SCM_BOOL_F;
while (1)
{
- form = scm_read (port, case_insensative_p, sharp);
+ form = scm_read (port);
if (SCM_EOF_VAL == form)
break;
scm_eval_x (form);
}
scm_close_port (port);
}
- return SCM_BOOL_T;
+ return SCM_UNSPECIFIED;
}
+/* Builtin path to scheme library files. */
+#ifdef SCM_PKGDATA_DIR
+SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir);
+SCM
+scm_sys_package_data_dir ()
+{
+ return scm_makfrom0str (SCM_PKGDATA_DIR);
+}
+#endif /* SCM_PKGDATA_DIR */
+
+
+/* Initializing the load path, and searching it. */
+
+/* List of names of directories we search for files to load. */
+static SCM *scm_loc_load_path;
-#ifdef __STDC__
+/* List of extensions we try adding to the filenames. */
+static SCM *scm_loc_load_extensions;
+
+/* Initialize the global variable %load-path, given the value of the
+ SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
+ SCHEME_LOAD_PATH environment variable. */
void
-scm_init_load (void)
-#else
+scm_init_load_path ()
+{
+ SCM path = SCM_EOL;
+
+#ifdef SCM_LIBRARY_DIR
+ path = scm_cons2 (scm_makfrom0str (SCM_SITE_DIR),
+ scm_makfrom0str (SCM_LIBRARY_DIR),
+ path);
+#endif /* SCM_LIBRARY_DIR */
+
+ {
+ char *path_string = getenv ("SCHEME_LOAD_PATH");
+
+ if (path_string && path_string[0] != '\0')
+ {
+ char *scan, *elt_end;
+
+ /* Scan backwards from the end of the string, to help
+ construct the list in the right order. */
+ scan = elt_end = path_string + strlen (path_string);
+ do {
+ /* Scan back to the beginning of the current element. */
+ do scan--;
+ while (scan >= path_string && *scan != ':');
+ path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
+ path);
+ elt_end = scan;
+ } while (scan >= path_string);
+ }
+ }
+
+ *scm_loc_load_path = path;
+}
+
+
+/* Search %load-path for a directory containing a file named FILENAME.
+ The file must be readable, and not a directory.
+ If we find one, return its full filename; otherwise, return #f.
+ If FILENAME is absolute, return it unchanged. */
+SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
+SCM
+scm_sys_search_load_path (filename)
+ SCM filename;
+{
+ SCM path = *scm_loc_load_path;
+ SCM exts = *scm_loc_load_extensions;
+ char *buf;
+ int filename_len;
+ int max_path_len;
+ int max_ext_len;
+
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
+ SCM_ARG1, s_sys_search_load_path);
+ SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list",
+ s_sys_search_load_path);
+ SCM_ASSERT (scm_ilength (exts) >= 0, exts,
+ "load extension list is not a proper list",
+ s_sys_search_load_path);
+ filename_len = SCM_ROLENGTH (filename);
+
+ /* If FILENAME is absolute, return it unchanged. */
+ if (filename_len >= 1
+ && SCM_ROCHARS (filename)[0] == '/')
+ return filename;
+
+ /* Find the length of the longest element of path. */
+ {
+ SCM walk;
+
+ max_path_len = 0;
+ for (walk = path; SCM_NIMP (walk); walk = SCM_CDR (walk))
+ {
+ SCM elt = SCM_CAR (walk);
+ SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
+ "load path is not a list of strings",
+ s_sys_search_load_path);
+ if (SCM_LENGTH (elt) > max_path_len)
+ max_path_len = SCM_LENGTH (elt);
+ }
+ }
+
+ /* Find the length of the longest element of the load extensions
+ list. */
+ {
+ SCM walk;
+
+ max_ext_len = 0;
+ for (walk = exts; SCM_NIMP (walk); walk = SCM_CDR (walk))
+ {
+ SCM elt = SCM_CAR (walk);
+ SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
+ "load extension list is not a list of strings",
+ s_sys_search_load_path);
+ if (SCM_LENGTH (elt) > max_ext_len)
+ max_ext_len = SCM_LENGTH (elt);
+ }
+ }
+
+ SCM_DEFER_INTS;
+
+ buf = scm_must_malloc (max_path_len + 1 + filename_len + max_ext_len + 1,
+ s_sys_search_load_path);
+
+ /* Try every path element. At this point, we know it's a proper
+ list of strings. */
+ for (; SCM_NIMP (path); path = SCM_CDR (path))
+ {
+ SCM path_elt = SCM_CAR (path);
+
+ /* Try every extension. At this point, we know it's a proper
+ list of strings. */
+ for (exts = *scm_loc_load_extensions;
+ SCM_NIMP (exts);
+ exts = SCM_CDR (exts))
+ {
+ SCM ext_elt = SCM_CAR (exts);
+ int i;
+
+ /* Concatenate the path name, the filename, and the extension. */
+ i = SCM_ROLENGTH (path_elt);
+ memcpy (buf, SCM_ROCHARS (path_elt), i);
+ if (i >= 1 && buf[i - 1] != '/')
+ buf[i++] = '/';
+ memcpy (buf + i, SCM_ROCHARS (filename), filename_len);
+ i += filename_len;
+ memcpy (buf + i, SCM_ROCHARS (ext_elt), SCM_LENGTH (ext_elt));
+ i += SCM_LENGTH (ext_elt);
+ buf[i] = '\0';
+
+ {
+ struct stat mode;
+
+ if (stat (buf, &mode) >= 0
+ && ! (mode.st_mode & S_IFDIR)
+ && access (buf, R_OK) == 0)
+ {
+ SCM result = scm_makfromstr (buf, i, 0);
+ scm_must_free (buf);
+ SCM_ALLOW_INTS;
+ return result;
+ }
+ }
+ }
+ }
+
+ scm_must_free (buf);
+ SCM_ALLOW_INTS;
+ return SCM_BOOL_F;
+}
+
+
+SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 0, 0, scm_primitive_load_path);
+SCM
+scm_primitive_load_path (filename)
+ SCM filename;
+{
+ SCM full_filename;
+
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
+ SCM_ARG1, s_primitive_load_path);
+
+ full_filename = scm_sys_search_load_path (filename);
+
+ if (SCM_FALSEP (full_filename))
+ {
+ int absolute = (SCM_LENGTH (filename) >= 1
+ && SCM_ROCHARS (filename)[0] == '/');
+ scm_misc_error (s_primitive_load_path,
+ (absolute
+ ? "Unable to load file %S"
+ : "Unable to find file %S in load path"),
+ scm_listify (filename, SCM_UNDEFINED));
+ }
+
+ return scm_primitive_load (full_filename);
+}
+
+/* The following function seems trivial - and indeed it is. Its
+ * existence is motivated by its ability to evaluate expressions
+ * without copying them first (as is done in "eval").
+ */
+
+SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
+
+SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 1, 0, scm_read_and_eval_x);
+
+SCM
+scm_read_and_eval_x (port)
+ SCM port;
+{
+ SCM form = scm_read (port);
+ if (form == SCM_EOF_VAL)
+ scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
+ return scm_eval_x (form);
+}
+
+
+
void
scm_init_load ()
-#endif
{
+ scm_loc_load_path = SCM_CDRLOC(scm_sysintern("%load-path", SCM_EOL));
+ scm_loc_load_extensions
+ = SCM_CDRLOC(scm_sysintern("%load-extensions",
+ scm_listify (scm_makfrom0str (""),
+ scm_makfrom0str (".scm"),
+ SCM_UNDEFINED)));
+ scm_loc_load_hook = SCM_CDRLOC(scm_sysintern("%load-hook", SCM_BOOL_F));
+
#include "load.x"
}
-
diff --git a/libguile/load.h b/libguile/load.h
index eab41b173..93db7fdbb 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -43,20 +43,15 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_sys_try_load (SCM filename, SCM casep, SCM sharp);
-extern void scm_init_load (void);
-
-#else /* STDC */
-extern SCM scm_sys_try_load ();
-extern void scm_init_load ();
-
-#endif /* STDC */
-
-
-
+extern void scm_init_load_path SCM_P ((void));
+extern SCM scm_primitive_load SCM_P ((SCM filename));
+extern SCM scm_sys_package_data_dir SCM_P ((void));
+extern SCM scm_sys_search_load_path SCM_P ((SCM filename));
+extern SCM scm_primitive_load_path SCM_P ((SCM filename));
+extern SCM scm_read_and_eval_x SCM_P ((SCM port));
+extern void scm_init_load SCM_P ((void));
#endif /* LOADH */
diff --git a/libguile/mallocs.c b/libguile/mallocs.c
index 27f1a791c..4201adca8 100644
--- a/libguile/mallocs.c
+++ b/libguile/mallocs.c
@@ -21,42 +21,42 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "smob.h"
+
#include "mallocs.h"
+
#ifdef HAVE_MALLOC_H
-#include "malloc.h"
+#include <malloc.h>
#endif
#ifdef HAVE_UNISTD_H
-#include "unistd.h"
+#include <unistd.h>
#endif
-#ifdef __STDC__
-static scm_sizet
-fmalloc(SCM ptr)
-#else
+
+static scm_sizet fmalloc SCM_P ((SCM ptr));
+
static scm_sizet
fmalloc(ptr)
SCM ptr;
-#endif
{
if (SCM_MALLOCDATA (ptr))
free (SCM_MALLOCDATA (ptr));
return 0;
}
-#ifdef __STDC__
-static int
-prinmalloc (SCM exp, SCM port, int writing)
-#else
+
+static int prinmalloc SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinmalloc (exp, port, writing)
+prinmalloc (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_gen_puts(scm_regular_string, "#<malloc ", port);
scm_intprint(SCM_CDR(exp), 16, port);
@@ -70,14 +70,10 @@ static scm_smobfuns mallocsmob = {scm_mark0, fmalloc, prinmalloc, 0};
-#ifdef __STDC__
-SCM
-scm_malloc_obj (scm_sizet n)
-#else
+
SCM
scm_malloc_obj (n)
scm_sizet n;
-#endif
{
SCM answer;
SCM mem;
@@ -92,21 +88,17 @@ scm_malloc_obj (n)
SCM_ALLOW_INTS;
return SCM_BOOL_F;
}
- SCM_CDR (answer) = mem;
- SCM_CAR (answer) = scm_tc16_malloc;
+ SCM_SETCDR (answer, mem);
+ SCM_SETCAR (answer, scm_tc16_malloc);
SCM_ALLOW_INTS;
return answer;
}
-#ifdef __STDC__
-void
-scm_init_mallocs (void)
-#else
+
void
scm_init_mallocs ()
-#endif
{
scm_tc16_malloc = scm_newsmob (&mallocsmob);
}
diff --git a/libguile/mallocs.h b/libguile/mallocs.h
index 779c25d18..19fa8e5cd 100644
--- a/libguile/mallocs.h
+++ b/libguile/mallocs.h
@@ -43,7 +43,9 @@
* If you do not wish that, delete this exception notice.
*/
+#include "libguile/__scm.h"
+
extern int scm_tc16_malloc;
#define SCM_MALLOCP(X) (SCM_TYP16 (X) == scm_tc16_malloc)
@@ -51,16 +53,8 @@ extern int scm_tc16_malloc;
#define SCM_SETMALLOCDATA(obj, val) ((char *)SCM_SETCDR(obj, val))
-#ifdef __STDC__
-extern SCM scm_malloc_obj (scm_sizet n);
-extern void scm_init_mallocs (void);
-
-#else /* STDC */
-extern SCM scm_malloc_obj ();
-extern void scm_init_mallocs ();
-
-#endif /* STDC */
-
+extern SCM scm_malloc_obj SCM_P ((scm_sizet n));
+extern void scm_init_mallocs SCM_P ((void));
#endif /* MALLOCSH */
diff --git a/libguile/markers.c b/libguile/markers.c
index d6a3c8288..2736b0df5 100644
--- a/libguile/markers.c
+++ b/libguile/markers.c
@@ -43,33 +43,26 @@
#include <stdio.h>
#include "_scm.h"
+#include "markers.h"
/* {GC marking}
*/
-#ifdef __STDC__
-SCM
-scm_mark0 (SCM ptr)
-#else
+
SCM
scm_mark0 (ptr)
SCM ptr;
-#endif
{
SCM_SETGC8MARK (ptr);
return SCM_BOOL_F;
}
-#ifdef __STDC__
-SCM
-scm_markcdr (SCM ptr)
-#else
+
SCM
scm_markcdr (ptr)
SCM ptr;
-#endif
{
if (SCM_GC8MARKP (ptr))
return SCM_BOOL_F;
@@ -77,14 +70,10 @@ scm_markcdr (ptr)
return SCM_CDR (ptr);
}
-#ifdef __STDC__
-scm_sizet
-scm_free0 (SCM ptr)
-#else
+
scm_sizet
scm_free0 (ptr)
SCM ptr;
-#endif
{
return 0;
}
diff --git a/libguile/markers.h b/libguile/markers.h
index 0debbc4ac..6a80e61a2 100644
--- a/libguile/markers.h
+++ b/libguile/markers.h
@@ -44,25 +44,16 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_mark0 (SCM ptr);
-extern SCM scm_markcdr (SCM ptr);
-extern scm_sizet scm_free0 (SCM ptr);
-
-#else /* STDC */
-extern SCM scm_mark0 ();
-extern SCM scm_markcdr ();
-extern scm_sizet scm_free0 ();
-
-#endif /* STDC */
-
+extern SCM scm_mark0 SCM_P ((SCM ptr));
+extern SCM scm_markcdr SCM_P ((SCM ptr));
+extern scm_sizet scm_free0 SCM_P ((SCM ptr));
#endif /* MARKERSH */
diff --git a/libguile/mbstrings.c b/libguile/mbstrings.c
index 4d8bb1834..41e04bf80 100644
--- a/libguile/mbstrings.c
+++ b/libguile/mbstrings.c
@@ -46,18 +46,19 @@
#include "extchrs.h"
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "unif.h"
+#include "genio.h"
+#include "read.h"
+#include "mbstrings.h"
SCM_PROC(s_multi_byte_string_p, "multi-byte-string?", 1, 0, 0, scm_multi_byte_string_p);
-#ifdef __STDC__
-SCM
-scm_multi_byte_string_p (SCM obj)
-#else
+
SCM
scm_multi_byte_string_p (obj)
SCM obj;
-#endif
{
return (SCM_MB_STRINGP (obj)
? SCM_BOOL_T
@@ -65,14 +66,10 @@ scm_multi_byte_string_p (obj)
}
-#ifdef __STDC__
-SCM
-scm_regular_string_p (SCM obj)
-#else
+
SCM
scm_regular_string_p (obj)
SCM obj;
-#endif
{
return (SCM_REGULAR_STRINGP (obj)
? SCM_BOOL_T
@@ -81,14 +78,10 @@ scm_regular_string_p (obj)
SCM_PROC(s_list_to_multi_byte_string, "list->multi-byte-string", 1, 0, 0, scm_multi_byte_string);
SCM_PROC(s_multi_byte_string, "multi-byte-string", 0, 0, 1, scm_multi_byte_string);
-#ifdef __STDC__
-SCM
-scm_multi_byte_string (SCM chrs)
-#else
+
SCM
scm_multi_byte_string (chrs)
SCM chrs;
-#endif
{
SCM res;
register char *data;
@@ -120,15 +113,11 @@ scm_multi_byte_string (chrs)
return res;
}
-#ifdef __STDC__
-int
-scm_mb_ilength (unsigned char * data, int size)
-#else
+
int
scm_mb_ilength (data, size)
unsigned char * data;
int size;
-#endif
{
int pos;
int len;
@@ -155,14 +144,10 @@ scm_mb_ilength (data, size)
}
SCM_PROC(s_multi_byte_string_length, "multi-byte-string-length", 1, 0, 0, scm_multi_byte_string_length);
-#ifdef __STDC__
-SCM
-scm_multi_byte_string_length (SCM str)
-#else
+
SCM
scm_multi_byte_string_length (str)
SCM str;
-#endif
{
int size;
int len;
@@ -179,32 +164,24 @@ scm_multi_byte_string_length (str)
SCM_PROC(s_symbol_multi_byte_p, "symbol-multi-byte?", 1, 0, 0, scm_symbol_multi_byte_p);
-#ifdef __STDC__
-SCM
-scm_symbol_multi_byte_p (SCM symbol)
-#else
+
SCM
scm_symbol_multi_byte_p (symbol)
SCM symbol;
-#endif
{
- return SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP(symbol);
+ return SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol);
}
SCM_PROC(s_set_symbol_multi_byte_x, "set-symbol-multi-byte!", 2, 0, 0, scm_set_symbol_multi_byte_x);
-#ifdef __STDC__
-SCM
-scm_set_symbol_multi_byte_x (SCM symbol, SCM val)
-#else
+
SCM
scm_set_symbol_multi_byte_x (symbol, val)
SCM symbol;
SCM val;
-#endif
{
if (SCM_TYP7 (symbol) == scm_tc7_msymbol)
{
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP(symbol) = (SCM_FALSEP (val)
+ SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol) = (SCM_FALSEP (val)
? SCM_BOOL_F
: SCM_BOOL_T);
}
@@ -213,14 +190,10 @@ scm_set_symbol_multi_byte_x (symbol, val)
SCM_PROC(s_regular_port_p, "regular-port?", 1, 0, 0, scm_regular_port_p);
-#ifdef __STDC__
-SCM
-scm_regular_port_p (SCM p)
-#else
+
SCM
scm_regular_port_p (p)
SCM p;
-#endif
{
return (SCM_PORT_REPRESENTATION(p) == scm_regular_port
? SCM_BOOL_T
@@ -228,28 +201,20 @@ scm_regular_port_p (p)
}
SCM_PROC(s_regular_port_x, "regular-port!", 1, 0, 0, scm_regular_port_x);
-#ifdef __STDC__
-SCM
-scm_regular_port_x (SCM p)
-#else
+
SCM
scm_regular_port_x (p)
SCM p;
-#endif
{
SCM_PORT_REPRESENTATION(p) = scm_regular_port;
return SCM_UNSPECIFIED;
}
SCM_PROC(s_multi_byte_port_p, "multi-byte-port?", 1, 0, 0, scm_multi_byte_port_p);
-#ifdef __STDC__
-SCM
-scm_multi_byte_port_p (SCM p)
-#else
+
SCM
scm_multi_byte_port_p (p)
SCM p;
-#endif
{
return (SCM_PORT_REPRESENTATION(p) == scm_mb_port
? SCM_BOOL_T
@@ -257,14 +222,10 @@ scm_multi_byte_port_p (p)
}
SCM_PROC(s_multi_byte_port_x, "multi-byte-port!", 1, 0, 0, scm_multi_byte_port_x);
-#ifdef __STDC__
-SCM
-scm_multi_byte_port_x (SCM p)
-#else
+
SCM
scm_multi_byte_port_x (p)
SCM p;
-#endif
{
SCM_PORT_REPRESENTATION(p) = scm_mb_port;
return SCM_UNSPECIFIED;
@@ -272,14 +233,10 @@ scm_multi_byte_port_x (p)
SCM_PROC(s_wide_character_port_p, "wide-character-port?", 1, 0, 0, scm_wide_character_port_p);
-#ifdef __STDC__
-SCM
-scm_wide_character_port_p (SCM p)
-#else
+
SCM
scm_wide_character_port_p (p)
SCM p;
-#endif
{
return (SCM_PORT_REPRESENTATION(p) == scm_wchar_port
? SCM_BOOL_T
@@ -287,14 +244,10 @@ scm_wide_character_port_p (p)
}
SCM_PROC(s_wide_character_port_x, "wide-character-port!", 1, 0, 0, scm_wide_character_port_x);
-#ifdef __STDC__
-SCM
-scm_wide_character_port_x (SCM p)
-#else
+
SCM
scm_wide_character_port_x (p)
SCM p;
-#endif
{
SCM_PORT_REPRESENTATION(p) = scm_wchar_port;
return SCM_UNSPECIFIED;
@@ -304,16 +257,12 @@ scm_wide_character_port_x (p)
-#ifdef __STDC__
-void
-scm_put_wchar (int c, SCM port, int writing)
-#else
+
void
scm_put_wchar (c, port, writing)
int c;
SCM port;
int writing;
-#endif
{
if (writing)
scm_gen_puts (scm_regular_string, "#\\", port);
@@ -374,16 +323,12 @@ scm_put_wchar (c, port, writing)
-#ifdef __STDC__
-void
-scm_print_mb_string (SCM exp, SCM port, int writing)
-#else
+
void
scm_print_mb_string (exp, port, writing)
SCM exp;
SCM port;
int writing;
-#endif
{
if (writing)
{
@@ -426,15 +371,11 @@ scm_print_mb_string (exp, port, writing)
}
-#ifdef __STDC__
-void
-scm_print_mb_symbol (SCM exp, SCM port)
-#else
+
void
scm_print_mb_symbol (exp, port)
SCM exp;
SCM port;
-#endif
{
int pos;
int end;
@@ -442,8 +383,8 @@ scm_print_mb_symbol (exp, port)
char * str;
int weird;
int maybe_weird;
- int mw_pos;
- int inc;
+ int mw_pos = 0; /* initialized to placate compiler */
+ int inc = 0; /* same */
xwchar_t c;
len = SCM_LENGTH (exp);
@@ -555,13 +496,9 @@ scm_print_mb_symbol (exp, port)
-#ifdef __STDC__
-void
-scm_init_mbstrings (void)
-#else
+
void
scm_init_mbstrings ()
-#endif
{
#include "mbstrings.x"
}
diff --git a/libguile/mbstrings.h b/libguile/mbstrings.h
index e1d3ef0cb..84482c5a8 100644
--- a/libguile/mbstrings.h
+++ b/libguile/mbstrings.h
@@ -44,57 +44,35 @@
*/
-#include "__scm.h"
-#include "symbols.h"
+#include "libguile/__scm.h"
+#include "libguile/symbols.h"
#define SCM_MB_STRINGP(x) ( (SCM_TYP7(x)==scm_tc7_mb_string) \
|| ( (SCM_TYP7(x) == scm_tc7_msymbol) \
- && (SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (x) != SCM_BOOL_F)))
+ && (SCM_SYMBOL_MULTI_BYTE_STRINGP (x) != SCM_BOOL_F)))
#define SCM_REGULAR_STRINGP(x) (SCM_TYP7D(x)==scm_tc7_string)
-#ifdef __STDC__
-extern SCM scm_multi_byte_string_p (SCM obj);
-extern SCM scm_regular_string_p (SCM obj);
-extern SCM scm_multi_byte_string (SCM chrs);
-extern int scm_mb_ilength (unsigned char * data, int size);
-extern SCM scm_multi_byte_string_length (SCM str);
-extern SCM scm_symbol_multi_byte_p (SCM symbol);
-extern SCM scm_set_symbol_multi_byte_x (SCM symbol, SCM val);
-extern SCM scm_regular_port_p (SCM p);
-extern SCM scm_regular_port_x (SCM p);
-extern SCM scm_multi_byte_port_p (SCM p);
-extern SCM scm_multi_byte_port_x (SCM p);
-extern SCM scm_wide_character_port_p (SCM p);
-extern SCM scm_wide_character_port_x (SCM p);
-extern void scm_put_wchar (int c, SCM port, int writing);
-extern void scm_print_mb_string (SCM exp, SCM port, int writing);
-extern void scm_print_mb_symbol (SCM exp, SCM port);
-extern void scm_init_mbstrings (void);
-
-#else /* STDC */
-extern SCM scm_multi_byte_string_p ();
-extern SCM scm_regular_string_p ();
-extern SCM scm_multi_byte_string ();
-extern int scm_mb_ilength ();
-extern SCM scm_multi_byte_string_length ();
-extern SCM scm_symbol_multi_byte_p ();
-extern SCM scm_set_symbol_multi_byte_x ();
-extern SCM scm_regular_port_p ();
-extern SCM scm_regular_port_x ();
-extern SCM scm_multi_byte_port_p ();
-extern SCM scm_multi_byte_port_x ();
-extern SCM scm_wide_character_port_p ();
-extern SCM scm_wide_character_port_x ();
-extern void scm_put_wchar ();
-extern void scm_print_mb_string ();
-extern void scm_print_mb_symbol ();
-extern void scm_init_mbstrings ();
-
-#endif /* STDC */
+extern SCM scm_multi_byte_string_p SCM_P ((SCM obj));
+extern SCM scm_regular_string_p SCM_P ((SCM obj));
+extern SCM scm_multi_byte_string SCM_P ((SCM chrs));
+extern int scm_mb_ilength SCM_P ((unsigned char * data, int size));
+extern SCM scm_multi_byte_string_length SCM_P ((SCM str));
+extern SCM scm_symbol_multi_byte_p SCM_P ((SCM symbol));
+extern SCM scm_set_symbol_multi_byte_x SCM_P ((SCM symbol, SCM val));
+extern SCM scm_regular_port_p SCM_P ((SCM p));
+extern SCM scm_regular_port_x SCM_P ((SCM p));
+extern SCM scm_multi_byte_port_p SCM_P ((SCM p));
+extern SCM scm_multi_byte_port_x SCM_P ((SCM p));
+extern SCM scm_wide_character_port_p SCM_P ((SCM p));
+extern SCM scm_wide_character_port_x SCM_P ((SCM p));
+extern void scm_put_wchar SCM_P ((int c, SCM port, int writing));
+extern void scm_print_mb_string SCM_P ((SCM exp, SCM port, int writing));
+extern void scm_print_mb_symbol SCM_P ((SCM exp, SCM port));
+extern void scm_init_mbstrings SCM_P ((void));
#endif /* MBSTRINGSH */
diff --git a/libguile/mit-pthreads.c b/libguile/mit-pthreads.c
new file mode 100644
index 000000000..d58912c39
--- /dev/null
+++ b/libguile/mit-pthreads.c
@@ -0,0 +1,495 @@
+/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+typedef struct scm_pthread_info {
+ queue q; /* the dequeue on which this structure exists */
+ /* reqired to be the first element */
+ pthread_t thread; /* the corresponding thread structure */
+ void *stack_top; /* the highest address in this thread's stack */
+ scm_root_state *root; /* root for this thread */
+} scm_pthread_info;
+
+pthread_mutex_t scm_critical_section_mutex;
+pthread_t scm_critical_section_owner;
+
+static queue infos = { &infos, &infos }; /* the dequeue of info structures */
+
+/* Key to thread specific data */
+pthread_key_t info_key;
+
+#ifdef __STDC__
+size_t
+scm_threads_free_thread (SCM t)
+#else
+size_t
+scm_threads_free_thread (t)
+ SCM t;
+#endif
+{
+ scm_must_free (SCM_THREAD_DATA (t));
+ return sizeof (pthread_t);
+}
+
+#ifdef __STDC__
+size_t
+scm_threads_free_mutex (SCM m)
+#else
+size_t
+scm_threads_free_mutex (m)
+ SCM m;
+#endif
+{
+ pthread_mutex_destroy (SCM_MUTEX_DATA (m));
+ scm_must_free (SCM_MUTEX_DATA (m));
+ return sizeof (pthread_mutex_t);
+}
+
+#ifdef __STDC__
+size_t
+scm_threads_free_condvar (SCM c)
+#else
+size_t
+scm_threads_free_condvar (c)
+ SCM c;
+#endif
+{
+ pthread_cond_destroy (SCM_CONDVAR_DATA (c));
+ scm_must_free (SCM_CONDVAR_DATA (c));
+ return sizeof (pthread_cond_t);
+}
+
+/* cleanup for info structure
+ */
+#ifdef __STDC__
+static void
+scm_pthread_delete_info (void *ptr)
+#else
+static void
+scm_pthread_delete_info (ptr)
+ void *ptr;
+#endif
+{
+ scm_pthread_info *info = (scm_pthread_info *) ptr;
+ info->q.blink->flink = info->q.flink;
+ info->q.flink->blink = info->q.blink;
+ scm_must_free ((char *) info);
+}
+
+#ifdef __STDC__
+void
+scm_threads_init (SCM_STACKITEM *i)
+#else
+void
+scm_threads_init (i)
+ SCM_STACKITEM *i;
+#endif
+{
+ /*
+ * each info structure is made thread-specific, so that the cleanup
+ * mechanism can be used to reclaim the space in a timely fashion.
+ */
+ pthread_key_create (&info_key, scm_pthread_delete_info);
+
+ /* initialize various mutex variables */
+ pthread_mutex_init (&scm_critical_section_mutex, NULL);
+
+ /*
+ * create an info structure for the initial thread and push it onto
+ * the info dequeue
+ */
+ {
+ scm_pthread_info *info;
+ info = (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
+ "threads_init");
+ infos.flink = infos.blink = &info->q;
+ info->q.flink = info->q.blink = &infos;
+ info->thread = pthread_initial;
+ info->stack_top = (void *) i;
+ pthread_setspecific(info_key, info);
+ }
+ /* The root state pointer gets initialized in init.c. */
+}
+
+/* given some thread, find the corresponding info
+ */
+static scm_pthread_info *pthreads_find_info (pthread_t target)
+{
+ queue *ptr = infos.flink;
+
+ while (ptr != &infos)
+ {
+ scm_pthread_info *info = (scm_pthread_info *) ptr;
+
+ if (info->thread == target)
+ {
+ return (info);
+ }
+ ptr = ptr->flink;
+ }
+}
+
+#ifdef __STDC__
+void
+scm_threads_mark_stacks ()
+#else
+void
+scm_threads_mark_stacks ()
+#endif
+{
+ scm_pthread_info *info;
+ pthread_t thread;
+ int j;
+
+ for (info = (scm_pthread_info *) infos.flink;
+ info != (scm_pthread_info *) &infos;
+ info = (scm_pthread_info *) info->q.flink)
+ {
+ thread = info->thread;
+ if (thread == pthread_run)
+ {
+ /* Active thread */
+ /* stack_len is long rather than sizet in order to guarantee
+ that &stack_len is long aligned */
+#ifdef STACK_GROWS_UP
+ long stack_len = ((SCM_STACKITEM *) (&thread) -
+ (SCM_STACKITEM *) info->stack_top);
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the values from SCM_LENGTH and SCM_CHARS must remain
+ * usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((scm_sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations (((size_t) info->stack_top,
+ (sizet) stack_len));
+#else
+ long stack_len = ((SCM_STACKITEM *) info->stack_top -
+ (SCM_STACKITEM *) (&thread));
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the values from SCM_LENGTH and SCM_CHARS must remain
+ * usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((scm_sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations ((SCM_STACKITEM *) &thread,
+ stack_len);
+#endif
+ }
+ else
+ {
+ /* Suspended thread */
+#ifdef STACK_GROWS_UP
+ long stack_len = ((SCM_STACKITEM *) (thread->THREAD_SP) -
+ (SCM_STACKITEM *) info->stack_top);
+
+ scm_mark_locations ((size_t)info->stack_top,
+ (sizet) stack_len);
+#else
+ long stack_len = ((SCM_STACKITEM *) info->stack_top -
+ (SCM_STACKITEM *) (thread->THREAD_SP));
+
+ scm_mark_locations ((SCM_STACKITEM *) thread->machdep_data.machdep_state,
+ ((scm_sizet) sizeof (*thread->machdep_data.machdep_state)
+ / sizeof (SCM_STACKITEM)));
+ scm_mark_locations ((SCM_STACKITEM *) (size_t) thread->THREAD_SP,
+ stack_len);
+#endif
+ }
+
+ /* Mark this thread's root */
+ scm_gc_mark (((scm_root_state *) info->root) -> handle);
+ }
+}
+
+#ifdef __STDC__
+void *
+launch_thread (void *p)
+#else
+void *
+launch_thread (p)
+ void *p;
+#endif
+{
+ /* The thread object will be GC protected by being a member of the
+ list given as argument to launch_thread. It will be marked
+ during the conservative sweep of the stack. */
+ SCM args = (SCM) p;
+ pthread_attr_setcleanup (&pthread_self () -> attr,
+ NULL,
+ SCM_ROOT_STATE (SCM_CAR (args)));
+ scm_call_with_dynamic_root (SCM_CADDR (args), SCM_CADDDR (args));
+ return NULL;
+}
+
+#ifdef __STDC__
+SCM
+scm_call_with_new_thread (SCM argl)
+#else
+SCM
+scm_call_with_new_thread (argl)
+ SCM argl;
+#endif
+{
+ SCM thread;
+
+ /* Check arguments. */
+ {
+ register SCM args = argl;
+ SCM thunk, handler;
+ SCM_ASSERT (SCM_NIMP (args), argl, SCM_WNA, s_call_with_new_thread);
+ thunk = SCM_CAR (args);
+ SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
+ thunk,
+ SCM_ARG1,
+ s_call_with_new_thread);
+ args = SCM_CDR (args);
+ SCM_ASSERT (SCM_NIMP (args), argl, SCM_WNA, s_call_with_new_thread);
+ handler = SCM_CAR (args);
+ SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)),
+ handler,
+ SCM_ARG2,
+ s_call_with_new_thread);
+ SCM_ASSERT (SCM_NULLP (SCM_CDR (args)), argl, SCM_WNA, s_call_with_new_thread);
+ }
+
+ /* Make new thread. */
+ {
+ pthread_attr_t attr;
+ pthread_t t;
+ scm_pthread_info *info =
+ (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
+ "pthread_info");
+ SCM root, old_winds;
+
+ /* Unwind wind chain. */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
+
+ /* Allocate thread locals. */
+ root = scm_make_root (scm_root->handle);
+ /* Make thread. */
+ SCM_NEWCELL (thread);
+ SCM_DEFER_INTS;
+ SCM_SETCAR (thread, scm_tc16_thread);
+ argl = scm_cons2 (root, thread, argl);
+
+ /* thread mustn't start until we've built the info struct */
+ pthread_kernel_lock++;
+
+ /* initialize and create the thread. */
+ pthread_attr_init (&attr);
+ pthread_attr_setschedpolicy (&attr, SCHED_RR);
+
+ pthread_create (&t, &attr, launch_thread, (void *) argl);
+ pthread_attr_destroy (&attr);
+
+ /* push the info onto the dequeue */
+ info->q.flink = infos.flink;
+ info->q.blink = &infos;
+ infos.flink->blink = &info->q;
+ infos.flink = &info->q;
+ /* pthread_create filled in the initial SP -- profitons-en ! */
+ info->stack_top = (void *) (t->THREAD_SP);
+ info->thread = t;
+ info->root = SCM_ROOT_STATE (root);
+ SCM_SETCDR (thread, t);
+ SCM_ALLOW_INTS;
+
+ /* we're now ready for the thread to begin */
+ pthread_kernel_lock--;
+
+ /* Return to old dynamic context. */
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+ }
+
+ return thread;
+}
+
+#ifdef __STDC__
+SCM
+scm_join_thread (SCM t)
+#else
+SCM
+scm_join_thread (t)
+ SCM t;
+#endif
+{
+ void *value;
+ pthread_join (SCM_THREAD_DATA (t), &value);
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_yield ()
+#else
+SCM
+scm_yield ()
+#endif
+{
+ pthread_yield ();
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_make_mutex ()
+#else
+SCM
+scm_make_mutex ()
+#endif
+{
+ SCM m;
+ pthread_mutex_t *data = (pthread_mutex_t *) scm_must_malloc (sizeof (pthread_mutex_t), "mutex");
+ SCM_NEWCELL (m);
+ SCM_DEFER_INTS;
+ SCM_SETCAR (m, scm_tc16_mutex);
+ SCM_SETCDR (m, data);
+ SCM_ALLOW_INTS;
+ pthread_mutex_init (SCM_MUTEX_DATA (m), NULL);
+ return m;
+}
+
+#ifdef __STDC__
+SCM
+scm_lock_mutex (SCM m)
+#else
+SCM
+scm_lock_mutex (m)
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
+ pthread_mutex_lock (SCM_MUTEX_DATA (m));
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_unlock_mutex (SCM m)
+#else
+SCM
+scm_unlock_mutex (m)
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
+ pthread_mutex_unlock (SCM_MUTEX_DATA (m));
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_make_condition_variable ()
+#else
+SCM
+scm_make_condition_variable ()
+#endif
+{
+ SCM c;
+ pthread_cond_t *data = (pthread_cond_t *) scm_must_malloc (sizeof (pthread_cond_t), "condvar");
+ SCM_NEWCELL (c);
+ SCM_DEFER_INTS;
+ SCM_SETCAR (c, scm_tc16_condvar);
+ SCM_SETCDR (c, data);
+ SCM_ALLOW_INTS;
+ pthread_cond_init (SCM_CONDVAR_DATA (c), NULL);
+ return c;
+}
+
+#ifdef __STDC__
+SCM
+scm_wait_condition_variable (SCM c, SCM m)
+#else
+SCM
+scm_wait_condition_variable (c, m)
+ SCM c;
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
+ c,
+ SCM_ARG1,
+ s_wait_condition_variable);
+ SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m),
+ m,
+ SCM_ARG2,
+ s_wait_condition_variable);
+ pthread_cond_wait (SCM_CONDVAR_DATA (m), SCM_MUTEX_DATA (c));
+ return SCM_BOOL_T;
+}
+
+#ifdef __STDC__
+SCM
+scm_signal_condition_variable (SCM c)
+#else
+SCM
+scm_signal_condition_variable (c)
+ SCM c;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
+ c,
+ SCM_ARG1,
+ s_signal_condition_variable);
+ pthread_cond_signal (SCM_CONDVAR_DATA (c));
+ return SCM_BOOL_T;
+}
diff --git a/libguile/mit-pthreads.h b/libguile/mit-pthreads.h
new file mode 100644
index 000000000..ea93c63d1
--- /dev/null
+++ b/libguile/mit-pthreads.h
@@ -0,0 +1,187 @@
+/* classes: h_files */
+
+#ifndef MIT_PTHREADSH
+#define MIT_PTHREADSH
+
+/* Copyright (C) 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include "libguile/__scm.h"
+
+#define PTHREAD_KERNEL
+#include <pthread.h>
+
+/* Identify where the stack pointer can be found in a jmpbuf.
+ */
+
+/* Solaris 2.4 */
+#if defined(__sparc_setjmp_h)
+# define THREAD_SP machdep_data.machdep_state[2]
+#endif
+
+/* Solaris 2.5 */
+#if defined(__sparc)
+#ifndef THREAD_SP
+# define THREAD_SP machdep_data.machdep_state[2]
+#endif
+#endif
+
+#if defined(linux)
+# define THREAD_SP machdep_data.machdep_state[0].__sp
+#endif
+
+#if defined(sgi)
+# define THREAD_SP machdep_data.machdep_state[JB_SP]
+#endif
+
+/* ...define THREAD_SP for your architecture here...
+ */
+
+#if !defined(THREAD_SP)
+--> where is your stack pointer?
+#endif
+
+
+
+/* Boost the priority of this thread so that it is the only
+ one running. PTHREAD_MAX_PRIORITY is reserved for this
+ purpose */
+
+#define SCM_THREAD_CRITICAL_SECTION_START \
+ struct sched_param param; \
+ int previous_prio; \
+ int policy; \
+ pthread_getschedparam(pthread_self(), &policy, &param); \
+ previous_prio = param.prio; \
+ param.prio = PTHREAD_MAX_PRIORITY; \
+ pthread_setschedparam(pthread_self(), policy, &param)
+
+#define SCM_THREAD_CRITICAL_SECTION_END \
+ param.prio = previous_prio; \
+ pthread_setschedparam(pthread_self(), policy, &param)
+
+
+
+#if 1
+
+#define SCM_NO_CRITICAL_SECTION_OWNER 0
+
+#define SCM_THREAD_DEFER pthread_kernel_lock++
+#define SCM_THREAD_ALLOW pthread_kernel_lock--
+
+#define SCM_THREAD_REDEFER pthread_kernel_lock++
+#define SCM_THREAD_REALLOW_1 pthread_kernel_lock--
+#define SCM_THREAD_REALLOW_2 \
+{ \
+ scm_critical_section_owner = SCM_NO_CRITICAL_SECTION_OWNER; \
+ pthread_mutex_unlock(&scm_critical_section_mutex); \
+}
+
+#else
+
+#define SCM_NO_CRITICAL_SECTION_OWNER 0
+
+#define SCM_THREAD_DEFER \
+{ \
+ pthread_mutex_lock (&scm_critical_section_mutex); \
+ scm_critical_section_owner = pthread_self(); \
+}
+
+#define SCM_THREAD_ALLOW \
+{ \
+ scm_critical_section_owner = SCM_NO_CRITICAL_SECTION_OWNER; \
+ pthread_mutex_unlock (&scm_critical_section_mutex); \
+}
+
+#define SCM_THREAD_REDEFER \
+{ \
+ if ((scm_critical_section_owner != pthread_self()) || \
+ (scm_critical_section_owner == SCM_NO_CRITICAL_SECTION_OWNER)) \
+ { \
+ pthread_mutex_lock(&scm_critical_section_mutex); \
+ scm_critical_section_owner = pthread_self(); \
+ } \
+}
+
+#define SCM_THREAD_REALLOW_1
+#define SCM_THREAD_REALLOW_2 \
+{ \
+ scm_critical_section_owner = SCM_NO_CRITICAL_SECTION_OWNER; \
+ pthread_mutex_unlock (&scm_critical_section_mutex); \
+}
+
+#endif
+
+#define SCM_THREAD_SWITCHING_CODE
+
+#define SCM_THREAD_LOCAL_DATA (pthread_self () -> attr.arg_attr)
+#define SCM_SET_THREAD_LOCAL_DATA(new_root) \
+{ \
+ pthread_t t = pthread_self (); \
+ void *r = (new_root); \
+ pthread_attr_setcleanup (&t -> attr, NULL, r); \
+ pthreads_find_info (t) -> root = r; \
+}
+
+
+
+
+void scm_threads_init_mit_pthreads ();
+
+typedef struct QUEUE {
+ struct QUEUE *flink, *blink;
+} queue;
+
+extern pthread_mutex_t scm_critical_section_mutex;
+extern pthread_t scm_critical_section_owner;
+
+/* Key to thread specific data */
+extern pthread_key_t info_key;
+
+struct scm_pthread_create_info_type
+{
+ SCM thunk;
+ SCM error;
+ SCM *prots;
+} scm_pthread_create_info;
+
+#endif /* MIT_PTHREADSH */
diff --git a/libguile/net_db.c b/libguile/net_db.c
new file mode 100644
index 000000000..6f86f10f0
--- /dev/null
+++ b/libguile/net_db.c
@@ -0,0 +1,410 @@
+/* "net_db.c" network database support
+ * Copyright (C) 1995,1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* Written in 1994 by Aubrey Jaffer.
+ * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
+ * Rewritten by Gary Houston to be a closer interface to the C socket library.
+ * Split into net_db.c and socket.c.
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+#include "feature.h"
+
+#include "net_db.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <netdb.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+
+
+
+#ifndef STDC_HEADERS
+int close ();
+#endif /* STDC_HEADERS */
+
+extern int inet_aton ();
+
+SCM_PROC (s_inet_aton, "inet-aton", 1, 0, 0, scm_inet_aton);
+
+SCM
+scm_inet_aton (address)
+ SCM address;
+{
+ struct in_addr soka;
+
+ SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_inet_aton);
+ if (SCM_SUBSTRP (address))
+ address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
+ if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
+ scm_syserror (s_inet_aton);
+ return scm_ulong2num (ntohl (soka.s_addr));
+}
+
+
+SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
+
+SCM
+scm_inet_ntoa (inetid)
+ SCM inetid;
+{
+ struct in_addr addr;
+ char *s;
+ SCM answer;
+ addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
+ SCM_DEFER_INTS;
+ s = inet_ntoa (addr);
+ answer = scm_makfromstr (s, strlen (s), 0);
+ SCM_ALLOW_INTS;
+ return answer;
+}
+
+SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
+
+SCM
+scm_inet_netof (address)
+ SCM address;
+{
+ struct in_addr addr;
+ addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
+ return scm_ulong2num ((unsigned long) inet_netof (addr));
+}
+
+SCM_PROC (s_lnaof, "inet-lnaof", 1, 0, 0, scm_lnaof);
+
+SCM
+scm_lnaof (address)
+ SCM address;
+{
+ struct in_addr addr;
+ addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
+ return scm_ulong2num ((unsigned long) inet_lnaof (addr));
+}
+
+
+SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
+
+SCM
+scm_inet_makeaddr (net, lna)
+ SCM net;
+ SCM lna;
+{
+ struct in_addr addr;
+ unsigned long netnum;
+ unsigned long lnanum;
+
+ netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
+ lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
+ addr = inet_makeaddr (netnum, lnanum);
+ return scm_ulong2num (ntohl (addr.s_addr));
+}
+
+
+/* !!! Doesn't take address format.
+ * Assumes hostent stream isn't reused.
+ */
+
+SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost);
+
+SCM
+scm_gethost (name)
+ SCM name;
+{
+ SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F);
+ SCM *ve = SCM_VELTS (ans);
+ SCM lst = SCM_EOL;
+ struct hostent *entry;
+ struct in_addr inad;
+ char **argv;
+ int i = 0;
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = gethostent ();
+ }
+ else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = gethostbyname (SCM_ROCHARS (name));
+ }
+ else
+ {
+ inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
+ SCM_DEFER_INTS;
+ entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
+ }
+ SCM_ALLOW_INTS;
+ if (!entry)
+ scm_syserror (s_gethost);
+ ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->h_aliases);
+ ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
+ ve[3] = SCM_MAKINUM (entry->h_length + 0L);
+ if (sizeof (struct in_addr) != entry->h_length)
+ {
+ ve[4] = SCM_BOOL_F;
+ return ans;
+ }
+ for (argv = entry->h_addr_list; argv[i]; i++);
+ while (i--)
+ {
+ inad = *(struct in_addr *) argv[i];
+ lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
+ }
+ ve[4] = lst;
+ return ans;
+}
+
+
+SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet);
+
+SCM
+scm_getnet (name)
+ SCM name;
+{
+ SCM ans;
+ SCM *ve;
+ struct netent *entry;
+
+ ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (ans);
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getnetent ();
+ }
+ else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getnetbyname (SCM_ROCHARS (name));
+ }
+ else
+ {
+ unsigned long netnum;
+ netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
+ SCM_DEFER_INTS;
+ entry = getnetbyaddr (netnum, AF_INET);
+ }
+ SCM_ALLOW_INTS;
+ if (!entry)
+ scm_syserror (s_getnet);
+ ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->n_aliases);
+ ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
+ ve[3] = scm_ulong2num (entry->n_net + 0L);
+ return ans;
+}
+
+SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto);
+
+SCM
+scm_getproto (name)
+ SCM name;
+{
+ SCM ans;
+ SCM *ve;
+ struct protoent *entry;
+
+ ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (ans);
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getprotoent ();
+ }
+ else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getprotobyname (SCM_ROCHARS (name));
+ }
+ else
+ {
+ unsigned long protonum;
+ protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
+ SCM_DEFER_INTS;
+ entry = getprotobynumber (protonum);
+ }
+ SCM_ALLOW_INTS;
+ if (!entry)
+ scm_syserror (s_getproto);
+ ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->p_aliases);
+ ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
+ return ans;
+}
+
+
+static SCM scm_return_entry SCM_P ((struct servent *entry));
+
+static SCM
+scm_return_entry (entry)
+ struct servent *entry;
+{
+ SCM ans;
+ SCM *ve;
+
+ ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (ans);
+ ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->s_aliases);
+ ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
+ ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
+ SCM_ALLOW_INTS;
+ return ans;
+}
+
+SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv);
+
+SCM
+scm_getserv (name, proto)
+ SCM name;
+ SCM proto;
+{
+ struct servent *entry;
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getservent ();
+ if (!entry)
+ scm_syserror (s_getserv);
+ SCM_ALLOW_INTS;
+ return scm_return_entry (entry);
+ }
+ SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv);
+ if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
+ }
+ else
+ {
+ SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
+ SCM_DEFER_INTS;
+ entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
+ }
+ if (!entry)
+ scm_syserror (s_getserv);
+ SCM_ALLOW_INTS;
+ return scm_return_entry (entry);
+}
+
+SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
+
+SCM
+scm_sethost (arg)
+ SCM arg;
+{
+ if (SCM_UNBNDP (arg))
+ endhostent ();
+ else
+ sethostent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
+
+SCM
+scm_setnet (arg)
+ SCM arg;
+{
+ if (SCM_UNBNDP (arg))
+ endnetent ();
+ else
+ setnetent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
+
+SCM
+scm_setproto (arg)
+ SCM arg;
+{
+ if (SCM_UNBNDP (arg))
+ endprotoent ();
+ else
+ setprotoent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
+
+SCM
+scm_setserv (arg)
+ SCM arg;
+{
+ if (SCM_UNBNDP (arg))
+ endservent ();
+ else
+ setservent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+
+void
+scm_init_net_db ()
+{
+#ifdef INADDR_ANY
+ scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
+#endif
+#ifdef INADDR_BROADCAST
+ scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
+#endif
+#ifdef INADDR_NONE
+ scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
+#endif
+#ifdef INADDR_LOOPBACK
+ scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
+#endif
+
+ scm_add_feature ("net-db");
+#include "net_db.x"
+}
+
+
diff --git a/libguile/net_db.h b/libguile/net_db.h
new file mode 100644
index 000000000..76afcca25
--- /dev/null
+++ b/libguile/net_db.h
@@ -0,0 +1,69 @@
+/* classes: h_files */
+
+#ifndef NETDBH
+#define NETDBH
+/* Copyright (C) 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+
+
+
+extern SCM scm_gethost SCM_P ((SCM name));
+extern SCM scm_inet_aton SCM_P ((SCM address));
+extern SCM scm_inet_ntoa SCM_P ((SCM inetid));
+extern SCM scm_inet_netof SCM_P ((SCM address));
+extern SCM scm_lnaof SCM_P ((SCM address));
+extern SCM scm_inet_makeaddr SCM_P ((SCM net, SCM lna));
+extern SCM scm_getnet SCM_P ((SCM name));
+extern SCM scm_getproto SCM_P ((SCM name));
+extern SCM scm_getserv SCM_P ((SCM name, SCM proto));
+extern SCM scm_sethost SCM_P ((SCM arg));
+extern SCM scm_setnet SCM_P ((SCM arg));
+extern SCM scm_setproto SCM_P ((SCM arg));
+extern SCM scm_setserv SCM_P ((SCM arg));
+extern void scm_init_net_db SCM_P ((void));
+
+#endif /* NETDBH */
diff --git a/libguile/numbers.c b/libguile/numbers.c
index b572ed79f..474fc4afd 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -43,8 +43,10 @@
#include <stdio.h>
#include <math.h>
#include "_scm.h"
+#include "genio.h"
+#include "unif.h"
-
+#include "numbers.h"
#define DIGITS '0':case '1':case '2':case '3':case '4':\
case '5':case '6':case '7':case '8':case '9'
@@ -81,14 +83,10 @@
SCM_PROC(s_exact_p, "exact?", 1, 0, 0, scm_exact_p);
-#ifdef __STDC__
-SCM
-scm_exact_p(SCM x)
-#else
+
SCM
scm_exact_p(x)
SCM x;
-#endif
{
if SCM_INUMP(x) return SCM_BOOL_T;
#ifdef SCM_BIGDIG
@@ -98,14 +96,10 @@ scm_exact_p(x)
}
SCM_PROC(s_odd_p, "odd?", 1, 0, 0, scm_odd_p);
-#ifdef __STDC__
-SCM
-scm_odd_p(SCM n)
-#else
+
SCM
scm_odd_p(n)
SCM n;
-#endif
{
#ifdef SCM_BIGDIG
if SCM_NINUMP(n) {
@@ -119,14 +113,10 @@ scm_odd_p(n)
}
SCM_PROC(s_even_p, "even?", 1, 0, 0, scm_even_p);
-#ifdef __STDC__
-SCM
-scm_even_p(SCM n)
-#else
+
SCM
scm_even_p(n)
SCM n;
-#endif
{
#ifdef SCM_BIGDIG
if SCM_NINUMP(n) {
@@ -140,14 +130,10 @@ scm_even_p(n)
}
SCM_PROC(s_abs, "abs", 1, 0, 0, scm_abs);
-#ifdef __STDC__
-SCM
-scm_abs(SCM x)
-#else
+
SCM
scm_abs(x)
SCM x;
-#endif
{
#ifdef SCM_BIGDIG
if SCM_NINUMP(x) {
@@ -160,25 +146,21 @@ scm_abs(x)
#endif
if (SCM_INUM(x) >= 0) return x;
x = -SCM_INUM(x);
- if (!SCM_POSSCM_FIXABLE(x))
+ if (!SCM_POSFIXABLE(x))
#ifdef SCM_BIGDIG
return scm_long2big(x);
#else
- scm_wta(SCM_MAKINUM(-x), (char *)SCM_OVSCM_FLOW, s_abs);
+ scm_num_overflow (s_abs);
#endif
return SCM_MAKINUM(x);
}
SCM_PROC(s_quotient, "quotient", 2, 0, 0, scm_quotient);
-#ifdef __STDC__
-SCM
-scm_quotient(SCM x, SCM y)
-#else
+
SCM
scm_quotient(x, y)
SCM x;
SCM y;
-#endif
{
register long z;
#ifdef SCM_BIGDIG
@@ -227,7 +209,7 @@ scm_quotient(x, y)
SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_quotient);
#endif
if ((z = SCM_INUM(y))==0)
- ov: scm_wta(y, (char *)SCM_OVSCM_FLOW, s_quotient);
+ ov: scm_num_overflow (s_quotient);
z = SCM_INUM(x)/z;
#ifdef BADIVSGNS
{
@@ -247,21 +229,17 @@ scm_quotient(x, y)
#ifdef SCM_BIGDIG
return scm_long2big(z);
#else
- scm_wta(x, (char *)SCM_OVSCM_FLOW, s_quotient);
+ scm_num_overflow (s_quotient);
#endif
return SCM_MAKINUM(z);
}
SCM_PROC(s_remainder, "remainder", 2, 0, 0, scm_remainder);
-#ifdef __STDC__
-SCM
-scm_remainder(SCM x, SCM y)
-#else
+
SCM
scm_remainder(x, y)
SCM x;
SCM y;
-#endif
{
register long z;
#ifdef SCM_BIGDIG
@@ -287,7 +265,7 @@ scm_remainder(x, y)
SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_remainder);
#endif
if (!(z = SCM_INUM(y)))
- ov: scm_wta(y, (char *)SCM_OVSCM_FLOW, s_remainder);
+ ov: scm_num_overflow (s_remainder);
#if (__TURBOC__==1)
if (z < 0) z = -z;
#endif
@@ -303,15 +281,11 @@ scm_remainder(x, y)
}
SCM_PROC(s_modulo, "modulo", 2, 0, 0, scm_modulo);
-#ifdef __STDC__
-SCM
-scm_modulo(SCM x, SCM y)
-#else
+
SCM
scm_modulo(x, y)
SCM x;
SCM y;
-#endif
{
register long yy, z;
#ifdef SCM_BIGDIG
@@ -337,7 +311,7 @@ scm_modulo(x, y)
SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_modulo);
#endif
if (!(yy = SCM_INUM(y)))
- ov: scm_wta(y, (char *)SCM_OVSCM_FLOW, s_modulo);
+ ov: scm_num_overflow (s_modulo);
#if (__TURBOC__==1)
z = SCM_INUM(x);
z = ((yy<0) ? -z : z)%yy;
@@ -348,15 +322,11 @@ scm_modulo(x, y)
}
SCM_PROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd);
-#ifdef __STDC__
-SCM
-scm_gcd(SCM x, SCM y)
-#else
+
SCM
scm_gcd(x, y)
SCM x;
SCM y;
-#endif
{
register long u, v, k, t;
if SCM_UNBNDP(y) return SCM_UNBNDP(x) ? SCM_INUM0 : x;
@@ -404,25 +374,21 @@ scm_gcd(x, y)
if ((t = u-v)) goto b3;
u = u*k;
getout:
- if (!SCM_POSSCM_FIXABLE(u))
+ if (!SCM_POSFIXABLE(u))
#ifdef SCM_BIGDIG
return scm_long2big(u);
#else
- scm_wta(x, (char *)SCM_OVSCM_FLOW, s_gcd);
+ scm_num_overflow (s_gcd);
#endif
return SCM_MAKINUM(u);
}
SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm);
-#ifdef __STDC__
-SCM
-scm_lcm(SCM n1, SCM n2)
-#else
+
SCM
scm_lcm(n1, n2)
SCM n1;
SCM n2;
-#endif
{
SCM d;
if SCM_UNBNDP(n2) {
@@ -442,60 +408,44 @@ scm_lcm(n1, n2)
#ifndef scm_long2num
SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand);
-#ifdef __STDC__
-SCM
-scm_logand(SCM n1, SCM n2)
-#else
+
SCM
scm_logand(n1, n2)
SCM n1;
SCM n2;
-#endif
{
return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logand)
& scm_num2long(n2, (char *)SCM_ARG2, s_logand));
}
SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior);
-#ifdef __STDC__
-SCM
-scm_logior(SCM n1, SCM n2)
-#else
+
SCM
scm_logior(n1, n2)
SCM n1;
SCM n2;
-#endif
{
return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logior)
| scm_num2long(n2, (char *)SCM_ARG2, s_logior));
}
SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor);
-#ifdef __STDC__
-SCM
-scm_logxor(SCM n1, SCM n2)
-#else
+
SCM
scm_logxor(n1, n2)
SCM n1;
SCM n2;
-#endif
{
return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logxor)
^ scm_num2long(n2, (char *)SCM_ARG2, s_logxor));
}
SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest);
-#ifdef __STDC__
-SCM
-scm_logtest(SCM n1, SCM n2)
-#else
+
SCM
scm_logtest(n1, n2)
SCM n1;
SCM n2;
-#endif
{
return ((scm_num2long (n1, (char *)SCM_ARG1, s_logtest)
& scm_num2long (n2, (char *)SCM_ARG2, s_logtest))
@@ -504,15 +454,11 @@ scm_logtest(n1, n2)
SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p);
-#ifdef __STDC__
-SCM
-scm_logbit_p(SCM n1, SCM n2)
-#else
+
SCM
scm_logbit_p(n1, n2)
SCM n1;
SCM n2;
-#endif
{
return (((1 << scm_num2long (n1, (char *)SCM_ARG1, s_logtest))
& scm_num2long (n2, (char *)SCM_ARG2, s_logtest))
@@ -522,15 +468,11 @@ scm_logbit_p(n1, n2)
#else
SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand);
-#ifdef __STDC__
-SCM
-scm_logand(SCM n1, SCM n2)
-#else
+
SCM
scm_logand(n1, n2)
SCM n1;
SCM n2;
-#endif
{
SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logand);
SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logand);
@@ -538,15 +480,11 @@ scm_logand(n1, n2)
}
SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior);
-#ifdef __STDC__
-SCM
-scm_logior(SCM n1, SCM n2)
-#else
+
SCM
scm_logior(n1, n2)
SCM n1;
SCM n2;
-#endif
{
SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logior);
SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logior);
@@ -554,15 +492,11 @@ scm_logior(n1, n2)
}
SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor);
-#ifdef __STDC__
-SCM
-scm_logxor(SCM n1, SCM n2)
-#else
+
SCM
scm_logxor(n1, n2)
SCM n1;
SCM n2;
-#endif
{
SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logxor);
SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logxor);
@@ -570,15 +504,11 @@ scm_logxor(n1, n2)
}
SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest);
-#ifdef __STDC__
-SCM
-scm_logtest(SCM n1, SCM n2)
-#else
+
SCM
scm_logtest(n1, n2)
SCM n1;
SCM n2;
-#endif
{
SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logtest);
SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logtest);
@@ -586,15 +516,11 @@ scm_logtest(n1, n2)
}
SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p);
-#ifdef __STDC__
-SCM
-scm_logbit_p(SCM n1, SCM n2)
-#else
+
SCM
scm_logbit_p(n1, n2)
SCM n1;
SCM n2;
-#endif
{
SCM_ASSERT(SCM_INUMP(n1) && SCM_INUM(n1) >= 0, n1, SCM_ARG1, s_logbit_p);
SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logbit_p);
@@ -603,29 +529,21 @@ scm_logbit_p(n1, n2)
#endif
SCM_PROC(s_lognot, "lognot", 1, 0, 0, scm_lognot);
-#ifdef __STDC__
-SCM
-scm_lognot(SCM n)
-#else
+
SCM
scm_lognot(n)
SCM n;
-#endif
{
SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_lognot);
return scm_difference(SCM_MAKINUM(-1L), n);
}
SCM_PROC(s_integer_expt, "integer-expt", 2, 0, 0, scm_integer_expt);
-#ifdef __STDC__
-SCM
-scm_integer_expt(SCM z1, SCM z2)
-#else
+
SCM
scm_integer_expt(z1, z2)
SCM z1;
SCM z2;
-#endif
{
SCM acc = SCM_MAKINUM(1L);
#ifdef SCM_BIGDIG
@@ -648,15 +566,11 @@ scm_integer_expt(z1, z2)
}
SCM_PROC(s_ash, "ash", 2, 0, 0, scm_ash);
-#ifdef __STDC__
-SCM
-scm_ash(SCM n, SCM cnt)
-#else
+
SCM
scm_ash(n, cnt)
SCM n;
SCM cnt;
-#endif
{
SCM res = SCM_INUM(n);
SCM_ASSERT(SCM_INUMP(cnt), cnt, SCM_ARG2, s_ash);
@@ -673,22 +587,19 @@ scm_ash(n, cnt)
cnt = SCM_INUM(cnt);
if (cnt < 0) return SCM_MAKINUM(SCM_SRS(res, -cnt));
res = SCM_MAKINUM(res<<cnt);
- if (SCM_INUM(res)>>cnt != SCM_INUM(n)) scm_wta(n, (char *)SCM_OVSCM_FLOW, s_ash);
+ if (SCM_INUM(res)>>cnt != SCM_INUM(n))
+ scm_num_overflow (s_ash);
return res;
#endif
}
SCM_PROC(s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract);
-#ifdef __STDC__
-SCM
-scm_bit_extract(SCM n, SCM start, SCM end)
-#else
+
SCM
scm_bit_extract(n, start, end)
SCM n;
SCM start;
SCM end;
-#endif
{
SCM_ASSERT(SCM_INUMP(start), start, SCM_ARG2, s_bit_extract);
SCM_ASSERT(SCM_INUMP(end), end, SCM_ARG3, s_bit_extract);
@@ -708,14 +619,10 @@ scm_bit_extract(n, start, end)
char scm_logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
SCM_PROC(s_logcount, "logcount", 1, 0, 0, scm_logcount);
-#ifdef __STDC__
-SCM
-scm_logcount (SCM n)
-#else
+
SCM
scm_logcount(n)
SCM n;
-#endif
{
register unsigned long c = 0;
register long nn;
@@ -739,14 +646,10 @@ scm_logcount(n)
char scm_ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
SCM_PROC(s_integer_length, "integer-length", 1, 0, 0, scm_integer_length);
-#ifdef __STDC__
-SCM
-scm_integer_length(SCM n)
-#else
+
SCM
scm_integer_length(n)
SCM n;
-#endif
{
register unsigned long c = 0;
register long nn;
@@ -772,15 +675,11 @@ scm_integer_length(n)
#ifdef SCM_BIGDIG
char s_bignum[] = "bignum";
-#ifdef __STDC__
-SCM
-scm_mkbig(scm_sizet nlen, int sign)
-#else
+
SCM
scm_mkbig(nlen, sign)
scm_sizet nlen;
int sign;
-#endif
{
SCM v = nlen;
if (((v << 16) >> 16) != nlen)
@@ -793,37 +692,29 @@ scm_mkbig(nlen, sign)
return v;
}
-#ifdef __STDC__
-SCM
-scm_big2inum(SCM b, scm_sizet l)
-#else
+
SCM
scm_big2inum(b, l)
SCM b;
scm_sizet l;
-#endif
{
unsigned long num = 0;
SCM_BIGDIG *tmp = SCM_BDIGITS(b);
while (l--) num = SCM_BIGUP(num) + tmp[l];
if (SCM_TYP16(b)==scm_tc16_bigpos) {
- if SCM_POSSCM_FIXABLE(num) return SCM_MAKINUM(num);
+ if SCM_POSFIXABLE(num) return SCM_MAKINUM(num);
}
- else if SCM_UNEGSCM_FIXABLE(num) return SCM_MAKINUM(-num);
+ else if SCM_UNEGFIXABLE(num) return SCM_MAKINUM(-num);
return b;
}
char s_adjbig[] = "scm_adjbig";
-#ifdef __STDC__
-SCM
-scm_adjbig(SCM b, scm_sizet nlen)
-#else
+
SCM
scm_adjbig(b, nlen)
SCM b;
scm_sizet nlen;
-#endif
{
long nsiz = nlen;
if (((nsiz << 16) >> 16) != nlen) scm_wta(SCM_MAKINUM(nsiz), (char *)SCM_NALLOC, s_adjbig);
@@ -837,14 +728,10 @@ scm_adjbig(b, nlen)
}
-#ifdef __STDC__
-SCM
-scm_normbig(SCM b)
-#else
+
SCM
scm_normbig(b)
SCM b;
-#endif
{
#ifndef _UNICOS
scm_sizet nlen = SCM_NUMDIGS(b);
@@ -860,15 +747,11 @@ scm_normbig(b)
}
-#ifdef __STDC__
-SCM
-scm_copybig(SCM b, int sign)
-#else
+
SCM
scm_copybig(b, sign)
SCM b;
int sign;
-#endif
{
scm_sizet i = SCM_NUMDIGS(b);
SCM ans = scm_mkbig(i, sign);
@@ -878,14 +761,10 @@ scm_copybig(b, sign)
}
-#ifdef __STDC__
-SCM
-scm_long2big(long n)
-#else
+
SCM
scm_long2big(n)
long n;
-#endif
{
scm_sizet i = 0;
SCM_BIGDIG *digits;
@@ -900,14 +779,10 @@ scm_long2big(n)
}
#ifdef LONGLONGS
-#ifdef __STDC__
-SCM
-scm_long_long2big(long_long n)
-#else
+
SCM
scm_long_long2big(n)
long_long n;
-#endif
{
scm_sizet i;
SCM_BIGDIG *digits;
@@ -943,14 +818,10 @@ scm_long_long2big(n)
}
#endif
-#ifdef __STDC__
-SCM
-scm_2ulong2big(unsigned long * np)
-#else
+
SCM
scm_2ulong2big(np)
unsigned long * np;
-#endif
{
unsigned long n;
scm_sizet i;
@@ -976,14 +847,10 @@ scm_2ulong2big(np)
}
-#ifdef __STDC__
-SCM
-scm_ulong2big(unsigned long n)
-#else
+
SCM
scm_ulong2big(n)
unsigned long n;
-#endif
{
scm_sizet i = 0;
SCM_BIGDIG *digits;
@@ -997,15 +864,11 @@ scm_ulong2big(n)
}
-#ifdef __STDC__
-int
-scm_bigcomp(SCM x, SCM y)
-#else
+
int
scm_bigcomp(x, y)
SCM x;
SCM y;
-#endif
{
int xsign = SCM_BIGSIGN(x);
int ysign = SCM_BIGSIGN(y);
@@ -1022,14 +885,10 @@ scm_bigcomp(x, y)
#ifndef SCM_DIGSTOOBIG
-#ifdef __STDC__
-long
-scm_pseudolong(long x)
-#else
+
long
scm_pseudolong(x)
long x;
-#endif
{
union {
long l;
@@ -1044,15 +903,11 @@ scm_pseudolong(x)
#else
-#ifdef __STDC__
-void
-scm_longdigs(long x, SCM_BIGDIG digs[])
-#else
+
void
scm_longdigs(x, digs)
long x;
SCM_BIGDIG digs[];
-#endif
{
scm_sizet i = 0;
if (x < 0) x = -x;
@@ -1061,10 +916,7 @@ scm_longdigs(x, digs)
#endif
-#ifdef __STDC__
-SCM
-scm_addbig(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny)
-#else
+
SCM
scm_addbig(x, nx, xsgn, bigy, sgny)
SCM_BIGDIG *x;
@@ -1072,7 +924,6 @@ scm_addbig(x, nx, xsgn, bigy, sgny)
int xsgn;
SCM bigy;
int sgny;
-#endif
{
/* Assumes nx <= SCM_NUMDIGS(bigy) */
/* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
@@ -1088,7 +939,7 @@ scm_addbig(x, nx, xsgn, bigy, sgny)
} while (++i < nx);
if (num && nx==ny) {
num = 1; i = 0;
- SCM_CAR(z) ^= 0x0100;
+ SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100);
do {
num += (SCM_BIGRAD-1) - zds[i];
zds[i++] = SCM_BIGLO(num);
@@ -1118,10 +969,7 @@ scm_addbig(x, nx, xsgn, bigy, sgny)
return scm_normbig(z);
}
-#ifdef __STDC__
-SCM
-scm_mulbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn)
-#else
+
SCM
scm_mulbig(x, nx, y, ny, sgn)
SCM_BIGDIG *x;
@@ -1129,7 +977,6 @@ scm_mulbig(x, nx, y, ny, sgn)
SCM_BIGDIG *y;
scm_sizet ny;
int sgn;
-#endif
{
scm_sizet i = 0, j = nx + ny;
unsigned long n = 0;
@@ -1150,16 +997,17 @@ scm_mulbig(x, nx, y, ny, sgn)
return scm_normbig(z);
}
-#ifdef __STDC__
-unsigned int
-scm_divbigdig(SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div)
-#else
+
+/* Sun's compiler complains about the fact that this function has an
+ ANSI prototype in numbers.h, but a K&R declaration here, and the
+ two specify different promotions for the third argument. I'm going
+ to turn this into an ANSI declaration, and see if anyone complains
+ about it not being K&R. */
+
unsigned int
-scm_divbigdig(ds, h, div)
- SCM_BIGDIG *ds;
- scm_sizet h;
- SCM_BIGDIG div;
-#endif
+scm_divbigdig(SCM_BIGDIG *ds,
+ scm_sizet h,
+ SCM_BIGDIG div)
{
register unsigned long t2 = 0;
while(h--) {
@@ -1171,17 +1019,13 @@ scm_divbigdig(ds, h, div)
}
-#ifdef __STDC__
-SCM
-scm_divbigint(SCM x, long z, int sgn, int mode)
-#else
+
SCM
scm_divbigint(x, z, sgn, mode)
SCM x;
long z;
int sgn;
int mode;
-#endif
{
if (z < 0) z = -z;
if (z < SCM_BIGRAD) {
@@ -1189,7 +1033,7 @@ scm_divbigint(x, z, sgn, mode)
register SCM_BIGDIG *ds = SCM_BDIGITS(x);
scm_sizet nd = SCM_NUMDIGS(x);
while(nd--) t2 = (SCM_BIGUP(t2) + ds[nd]) % z;
- if (mode) t2 = z - t2;
+ if (mode && t2) t2 = z - t2;
return SCM_MAKINUM(sgn ? -t2 : t2);
}
{
@@ -1205,10 +1049,7 @@ scm_divbigint(x, z, sgn, mode)
}
}
-#ifdef __STDC__
-SCM
-scm_divbigbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes)
-#else
+
SCM
scm_divbigbig(x, nx, y, ny, sgn, modes)
SCM_BIGDIG *x;
@@ -1217,7 +1058,6 @@ scm_divbigbig(x, nx, y, ny, sgn, modes)
scm_sizet ny;
int sgn;
int modes;
-#endif
{
/* modes description
0 remainder
@@ -1333,15 +1173,13 @@ static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
-#ifdef __STDC__
-static scm_sizet
-idbl2str(double f, char *a)
-#else
+
+static scm_sizet idbl2str SCM_P ((double f, char *a));
+
static scm_sizet
idbl2str(f, a)
double f;
char *a;
-#endif
{
int efmt, dpt, d, i, wp = scm_dblprec;
scm_sizet ch = 0;
@@ -1427,15 +1265,13 @@ idbl2str(f, a)
return ch;
}
-#ifdef __STDC__
-static scm_sizet
-iflo2str(SCM flt, char *str)
-#else
+
+static scm_sizet iflo2str SCM_P ((SCM flt, char *str));
+
static scm_sizet
iflo2str(flt, str)
SCM flt;
char *str;
-#endif
{
scm_sizet i;
# ifdef SCM_SINGLES
@@ -1453,16 +1289,12 @@ iflo2str(flt, str)
}
#endif /* SCM_FLOATS */
-#ifdef __STDC__
-scm_sizet
-scm_iint2str(long num, int rad, char *p)
-#else
+
scm_sizet
scm_iint2str(num, rad, p)
long num;
int rad;
char *p;
-#endif
{
scm_sizet j;
register int i = 1, d;
@@ -1482,15 +1314,13 @@ scm_iint2str(num, rad, p)
#ifdef SCM_BIGDIG
-#ifdef __STDC__
-static SCM
-big2str(SCM b, register unsigned int radix)
-#else
+
+static SCM big2str SCM_P ((SCM b, register unsigned int radix));
+
static SCM
big2str(b, radix)
SCM b;
register unsigned int radix;
-#endif
{
SCM t = scm_copybig(b, 0); /* sign of temp doesn't matter */
register SCM_BIGDIG *ds = SCM_BDIGITS(t);
@@ -1529,15 +1359,11 @@ big2str(b, radix)
SCM_PROC(s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string);
-#ifdef __STDC__
-SCM
-scm_number_to_string(SCM x, SCM radix)
-#else
+
SCM
scm_number_to_string(x, radix)
SCM x;
SCM radix;
-#endif
{
if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_number_to_string);
@@ -1576,16 +1402,12 @@ scm_number_to_string(x, radix)
/* These print routines are stubbed here so that scm_repl.c doesn't need
SCM_FLOATS or SCM_BIGDIGs conditionals */
-#ifdef __STDC__
-int
-scm_floprint(SCM sexp, SCM port, int writing)
-#else
+
int
-scm_floprint(sexp, port, writing)
+scm_floprint(sexp, port, pstate)
SCM sexp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
#ifdef SCM_FLOATS
char num_buf[SCM_FLOBUFLEN];
@@ -1597,16 +1419,12 @@ scm_floprint(sexp, port, writing)
}
-#ifdef __STDC__
-int
-scm_bigprint(SCM exp, SCM port, int writing)
-#else
+
int
-scm_bigprint(exp, port, writing)
+scm_bigprint(exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
#ifdef SCM_BIGDIG
exp = big2str(exp, (unsigned int)10);
@@ -1619,17 +1437,59 @@ scm_bigprint(exp, port, writing)
/*** END nums->strs ***/
/*** STRINGS -> NUMBERS ***/
-#ifdef SCM_BIGDIG
-#ifdef __STDC__
-SCM
-scm_istr2int(char *str, long len, long radix)
-#else
+
+static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix));
+
+static SCM
+scm_small_istr2int(str, len, radix)
+ char *str;
+ long len;
+ long radix;
+{
+ register long n = 0, ln;
+ register int c;
+ register int i = 0;
+ int lead_neg = 0;
+ if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
+ switch (*str) { /* leading sign */
+ case '-': lead_neg = 1;
+ case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
+ }
+
+ do {
+ switch (c = str[i++]) {
+ case DIGITS:
+ c = c - '0';
+ goto accumulate;
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ c = c-'A'+10;
+ goto accumulate;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ c = c-'a'+10;
+ accumulate:
+ if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
+ ln = n;
+ n = n * radix - c;
+ /* Negation is a workaround for HP700 cc bug */
+ if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl;
+ break;
+ default:
+ return SCM_BOOL_F; /* not a digit */
+ }
+ } while (i < len);
+ if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl;
+ return SCM_MAKINUM(n);
+ ovfl: /* overflow scheme integer */
+ return SCM_BOOL_F;
+}
+
+
+
SCM
scm_istr2int(str, len, radix)
char *str;
long len;
long radix;
-#endif
{
scm_sizet j;
register scm_sizet k, blen = 1;
@@ -1640,6 +1500,12 @@ scm_istr2int(str, len, radix)
register unsigned long t2;
if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
+
+ /* Short numbers we parse directly into an int, to avoid the overhead
+ of creating a bignum. */
+ if (len < 6)
+ return scm_small_istr2int (str, len, radix);
+
if (16==radix) j = 1+(4*len*sizeof(char))/(SCM_BITSPERDIG);
else if (10 <= radix)
j = 1+(84*len*sizeof(char))/(SCM_BITSPERDIG*25);
@@ -1672,7 +1538,8 @@ scm_istr2int(str, len, radix)
ds[k++] = SCM_BIGLO(t2);
t2 = SCM_BIGDN(t2);
}
- SCM_ASSERT(blen <= j, (SCM)SCM_MAKINUM(blen), SCM_OVSCM_FLOW, "bignum");
+ if (blen > j)
+ scm_num_overflow ("bignum");
if (t2) {blen++; goto moretodo;}
break;
default:
@@ -1684,70 +1551,14 @@ scm_istr2int(str, len, radix)
if (j==blen) return res;
return scm_adjbig(res, blen);
}
-#else
-
-
-
-#ifdef __STDC__
-SCM
-scm_istr2int(char *str, long len, long radix)
-#else
-SCM
-scm_istr2int(str, len, radix)
- char *str;
- long len;
- long radix;
-#endif
-{
- register long n = 0, ln;
- register int c;
- register int i = 0;
- int lead_neg = 0;
- if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
- switch (*str) { /* leading sign */
- case '-': lead_neg = 1;
- case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
- }
-
- do {
- switch (c = str[i++]) {
- case DIGITS:
- c = c - '0';
- goto accumulate;
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
- c = c-'A'+10;
- goto accumulate;
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
- c = c-'a'+10;
- accumulate:
- if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
- ln = n;
- n = n * radix - c;
- /* Negation is a workaround for HP700 cc bug */
- if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl;
- break;
- default:
- return SCM_BOOL_F; /* not a digit */
- }
- } while (i < len);
- if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl;
- return SCM_MAKINUM(n);
- ovfl: /* overflow scheme integer */
- return SCM_BOOL_F;
-}
-#endif
#ifdef SCM_FLOATS
-#ifdef __STDC__
-SCM
-scm_istr2flo(char *str, long len, long radix)
-#else
+
SCM
scm_istr2flo(str, len, radix)
char *str;
long len;
long radix;
-#endif
{
register int c, i = 0;
double lead_sgn;
@@ -1939,16 +1750,12 @@ scm_istr2flo(str, len, radix)
#endif /* SCM_FLOATS */
-#ifdef __STDC__
-SCM
-scm_istring2number(char *str, long len, long radix)
-#else
+
SCM
scm_istring2number(str, len, radix)
char *str;
long len;
long radix;
-#endif
{
int i = 0;
char ex = 0;
@@ -1984,15 +1791,11 @@ scm_istring2number(str, len, radix)
SCM_PROC(s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number);
-#ifdef __STDC__
-SCM
-scm_string_to_number(SCM str, SCM radix)
-#else
+
SCM
scm_string_to_number(str, radix)
SCM str;
SCM radix;
-#endif
{
SCM answer;
if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
@@ -2004,15 +1807,11 @@ scm_string_to_number(str, radix)
/*** END strs->nums ***/
#ifdef SCM_FLOATS
-#ifdef __STDC__
-SCM
-scm_makdbl (double x, double y)
-#else
+
SCM
scm_makdbl (x, y)
double x;
double y;
-#endif
{
SCM z;
if ((y==0.0) && (x==0.0)) return scm_flo0;
@@ -2025,18 +1824,18 @@ scm_makdbl (x, y)
if ((-FLTMAX < x) && (x < FLTMAX) && (fx==x))
# endif
{
- SCM_CAR(z) = scm_tc_flo;
+ SCM_SETCAR (z, scm_tc_flo);
SCM_FLO(z) = x;
SCM_ALLOW_INTS;
return z;
}
# endif/* def SCM_SINGLES */
- SCM_CDR(z) = (SCM)scm_must_malloc(1L*sizeof(double), "real");
- SCM_CAR(z) = scm_tc_dblr;
+ SCM_SETCDR (z, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
+ SCM_SETCAR (z, scm_tc_dblr);
}
else {
- SCM_CDR(z) = (SCM)scm_must_malloc(2L*sizeof(double), "complex");
- SCM_CAR(z) = scm_tc_dblc;
+ SCM_SETCDR (z, (SCM)scm_must_malloc(2L*sizeof(double), "complex"));
+ SCM_SETCAR (z, scm_tc_dblc);
SCM_IMAG(z) = y;
}
SCM_REAL(z) = x;
@@ -2046,15 +1845,11 @@ scm_makdbl (x, y)
#endif
-#ifdef __STDC__
-SCM
-scm_bigequal(SCM x, SCM y)
-#else
+
SCM
scm_bigequal(x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_BIGDIG
if (0==scm_bigcomp(x, y)) return SCM_BOOL_T;
@@ -2063,15 +1858,11 @@ scm_bigequal(x, y)
}
-#ifdef __STDC__
-SCM
-scm_floequal(SCM x, SCM y)
-#else
+
SCM
scm_floequal(x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_FLOATS
if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
@@ -2085,14 +1876,10 @@ scm_floequal(x, y)
SCM_PROC(s_number_p, "number?", 1, 0, 0, scm_number_p);
SCM_PROC(s_complex_p, "complex?", 1, 0, 0, scm_number_p);
-#ifdef __STDC__
-SCM
-scm_number_p(SCM x)
-#else
+
SCM
scm_number_p(x)
SCM x;
-#endif
{
if SCM_INUMP(x) return SCM_BOOL_T;
#ifdef SCM_FLOATS
@@ -2110,14 +1897,10 @@ scm_number_p(x)
#ifdef SCM_FLOATS
SCM_PROC(s_real_p, "real?", 1, 0, 0, scm_real_p);
SCM_PROC(s_rational_p, "rational?", 1, 0, 0, scm_real_p);
-#ifdef __STDC__
-SCM
-scm_real_p(SCM x)
-#else
+
SCM
scm_real_p(x)
SCM x;
-#endif
{
if (SCM_INUMP(x))
return SCM_BOOL_T;
@@ -2134,15 +1917,11 @@ scm_real_p(x)
-SCM_PROC(s_int_p, "int?", 1, 0, 0, scm_int_p);
-#ifdef __STDC__
-SCM
-scm_int_p(SCM x)
-#else
+SCM_PROC(s_int_p, "integer?", 1, 0, 0, scm_integer_p);
+
SCM
-scm_int_p(x)
+scm_integer_p(x)
SCM x;
-#endif
{
double r;
if SCM_INUMP(x) return SCM_BOOL_T;
@@ -2151,7 +1930,7 @@ scm_int_p(x)
if SCM_BIGP(x) return SCM_BOOL_T;
# endif
if (!SCM_INEXP(x)) return SCM_BOOL_F;
- if SCM_CPLXP(x) return SCM_BOOL_F;
+ if (SCM_CPLXP(x)) return SCM_BOOL_F;
r = SCM_REALPART(x);
if (r==floor(r)) return SCM_BOOL_T;
return SCM_BOOL_F;
@@ -2162,14 +1941,10 @@ scm_int_p(x)
#endif /* SCM_FLOATS */
SCM_PROC(s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p);
-#ifdef __STDC__
-SCM
-scm_inexact_p(SCM x)
-#else
+
SCM
scm_inexact_p(x)
SCM x;
-#endif
{
#ifdef SCM_FLOATS
if (SCM_NIMP(x) && SCM_INEXP(x)) return SCM_BOOL_T;
@@ -2180,16 +1955,12 @@ scm_inexact_p(x)
-SCM_PROC1 (s_eq_p, "=?", scm_tc7_rpsubr, scm_num_eq_p);
-#ifdef __STDC__
-SCM
-scm_num_eq_p (SCM x, SCM y)
-#else
+SCM_PROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p);
+
SCM
scm_num_eq_p (x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_FLOATS
SCM t;
@@ -2266,16 +2037,12 @@ scm_num_eq_p (x, y)
-SCM_PROC1 (s_less_p, "<?", scm_tc7_rpsubr, scm_less_p);
-#ifdef __STDC__
-SCM
-scm_less_p(SCM x, SCM y)
-#else
+SCM_PROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p);
+
SCM
scm_less_p(x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_FLOATS
if SCM_NINUMP(x) {
@@ -2346,48 +2113,36 @@ scm_less_p(x, y)
}
-SCM_PROC1 (s_gr_p, ">?", scm_tc7_rpsubr, scm_gr_p);
-#ifdef __STDC__
-SCM
-scm_gr_p(SCM x, SCM y)
-#else
+SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p);
+
SCM
scm_gr_p(x, y)
SCM x;
SCM y;
-#endif
{
return scm_less_p(y, x);
}
-SCM_PROC1 (s_leq_p, "<=?", scm_tc7_rpsubr, scm_leq_p);
-#ifdef __STDC__
-SCM
-scm_leq_p(SCM x, SCM y)
-#else
+SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p);
+
SCM
scm_leq_p(x, y)
SCM x;
SCM y;
-#endif
{
return SCM_BOOL_NOT(scm_less_p(y, x));
}
-SCM_PROC1 (s_geq_p, ">=?", scm_tc7_rpsubr, scm_geq_p);
-#ifdef __STDC__
-SCM
-scm_geq_p(SCM x, SCM y)
-#else
+SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p);
+
SCM
scm_geq_p(x, y)
SCM x;
SCM y;
-#endif
{
return SCM_BOOL_NOT(scm_less_p(x, y));
}
@@ -2395,14 +2150,10 @@ scm_geq_p(x, y)
SCM_PROC(s_zero_p, "zero?", 1, 0, 0, scm_zero_p);
-#ifdef __STDC__
-SCM
-scm_zero_p(SCM z)
-#else
+
SCM
scm_zero_p(z)
SCM z;
-#endif
{
#ifdef SCM_FLOATS
if SCM_NINUMP(z) {
@@ -2434,14 +2185,10 @@ scm_zero_p(z)
SCM_PROC(s_positive_p, "positive?", 1, 0, 0, scm_positive_p);
-#ifdef __STDC__
-SCM
-scm_positive_p(SCM x)
-#else
+
SCM
scm_positive_p(x)
SCM x;
-#endif
{
#ifdef SCM_FLOATS
if SCM_NINUMP(x) {
@@ -2473,14 +2220,10 @@ scm_positive_p(x)
SCM_PROC(s_negative_p, "negative?", 1, 0, 0, scm_negative_p);
-#ifdef __STDC__
-SCM
-scm_negative_p(SCM x)
-#else
+
SCM
scm_negative_p(x)
SCM x;
-#endif
{
#ifdef SCM_FLOATS
if SCM_NINUMP(x) {
@@ -2511,15 +2254,11 @@ scm_negative_p(x)
SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max);
-#ifdef __STDC__
-SCM
-scm_max(SCM x, SCM y)
-#else
+
SCM
scm_max(x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_FLOATS
double z;
@@ -2602,15 +2341,11 @@ scm_max(x, y)
SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min);
-#ifdef __STDC__
-SCM
-scm_min(SCM x, SCM y)
-#else
+
SCM
scm_min(x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_FLOATS
double z;
@@ -2691,15 +2426,11 @@ scm_min(x, y)
SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum);
-#ifdef __STDC__
-SCM
-scm_sum(SCM x, SCM y)
-#else
+
SCM
scm_sum(x, y)
SCM x;
SCM y;
-#endif
{
if SCM_UNBNDP(y) {
if SCM_UNBNDP(x) return SCM_INUM0;
@@ -2806,7 +2537,7 @@ scm_sum(x, y)
# ifdef SCM_FLOATS
return scm_makdbl((double)x, 0.0);
# else
- scm_wta(y, (char *)SCM_OVSCM_FLOW, s_sum);
+ scm_num_overflow (s_sum);
return SCM_UNSPECIFIED;
# endif
#endif
@@ -2816,15 +2547,11 @@ scm_sum(x, y)
SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference);
-#ifdef __STDC__
-SCM
-scm_difference(SCM x, SCM y)
-#else
+
SCM
scm_difference(x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_FLOATS
if SCM_NINUMP(x) {
@@ -2949,7 +2676,7 @@ scm_difference(x, y)
# ifdef SCM_FLOATS
return scm_makdbl((double)x, 0.0);
# else
- scm_wta(y, (char *)SCM_OVSCM_FLOW, s_difference);
+ scm_num_overflow (s_difference);
return SCM_UNSPECIFIED;
# endif
#endif
@@ -2959,15 +2686,11 @@ scm_difference(x, y)
SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product);
-#ifdef __STDC__
-SCM
-scm_product(SCM x, SCM y)
-#else
+
SCM
scm_product(x, y)
SCM x;
SCM y;
-#endif
{
if SCM_UNBNDP(y) {
if SCM_UNBNDP(x) return SCM_MAKINUM(1L);
@@ -3103,7 +2826,7 @@ scm_product(x, y)
# ifdef SCM_FLOATS
return scm_makdbl(((double)i)*((double)j), 0.0);
# else
- scm_wta(y, (char *)SCM_OVSCM_FLOW, s_product);
+ scm_num_overflow (s_product);
# endif
#endif
return y;
@@ -3111,15 +2834,11 @@ scm_product(x, y)
}
-#ifdef __STDC__
-double
-scm_num2dbl (SCM a, char * why)
-#else
+
double
scm_num2dbl (a, why)
SCM a;
char * why;
-#endif
{
if (SCM_INUMP (a))
return (double) SCM_INUM (a);
@@ -3136,29 +2855,12 @@ scm_num2dbl (a, why)
}
-SCM_PROC(s_fuck, "fuck", 1, 0, 0, scm_fuck);
-#ifdef __STDC__
-SCM
-scm_fuck (SCM a)
-#else
-SCM
-scm_fuck (a)
- SCM a;
-#endif
-{
- return scm_makdbl (scm_num2dbl (a, "just because"), 0.0);
-}
-
SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide);
-#ifdef __STDC__
-SCM
-scm_divide(SCM x, SCM y)
-#else
+
SCM
scm_divide(x, y)
SCM x;
SCM y;
-#endif
{
#ifdef SCM_FLOATS
double d, r, i, a;
@@ -3181,7 +2883,10 @@ scm_divide(x, y)
SCM z;
if SCM_INUMP(y) {
z = SCM_INUM(y);
- SCM_ASSERT(z, y, SCM_OVSCM_FLOW, s_divide);
+#ifndef RECKLESS
+ if (!z)
+ scm_num_overflow (s_divide);
+#endif
if (1==z) return x;
if (z < 0) z = -z;
if (z < SCM_BIGRAD) {
@@ -3321,7 +3026,7 @@ scm_divide(x, y)
#ifdef SCM_FLOATS
ov: return scm_makdbl(((double)SCM_INUM(x))/((double)SCM_INUM(y)), 0.0);
#else
- ov: scm_wta(x, (char *)SCM_OVSCM_FLOW, s_divide);
+ ov: scm_num_overflow (s_divide);
return SCM_UNSPECIFIED;
#endif
}
@@ -3332,14 +3037,10 @@ scm_divide(x, y)
#ifdef SCM_FLOATS
SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh);
-#ifdef __STDC__
-double
-scm_asinh(double x)
-#else
+
double
scm_asinh(x)
double x;
-#endif
{
return log(x+sqrt(x*x+1));
}
@@ -3348,14 +3049,10 @@ scm_asinh(x)
SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh);
-#ifdef __STDC__
-double
-scm_acosh(double x)
-#else
+
double
scm_acosh(x)
double x;
-#endif
{
return log(x+sqrt(x*x-1));
}
@@ -3364,14 +3061,10 @@ scm_acosh(x)
SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh);
-#ifdef __STDC__
-double
-scm_atanh(double x)
-#else
+
double
scm_atanh(x)
double x;
-#endif
{
return 0.5*log((1+x)/(1-x));
}
@@ -3380,14 +3073,10 @@ scm_atanh(x)
SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate);
-#ifdef __STDC__
-double
-scm_truncate(double x)
-#else
+
double
scm_truncate(x)
double x;
-#endif
{
if (x < 0.0) return -floor(-x);
return floor(x);
@@ -3396,14 +3085,10 @@ scm_truncate(x)
SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round);
-#ifdef __STDC__
-double
-scm_round(double x)
-#else
+
double
scm_round(x)
double x;
-#endif
{
double plus_half = x + 0.5;
double result = floor(plus_half);
@@ -3415,14 +3100,10 @@ scm_round(x)
SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact);
-#ifdef __STDC__
-double
-scm_exact_to_inexact(double z)
-#else
+
double
scm_exact_to_inexact(z)
double z;
-#endif
{
return z;
}
@@ -3446,7 +3127,10 @@ SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)())tanh);
struct dpair {double x, y;};
-void scm_two_doubles(z1, z2, sstring, xy)
+static void scm_two_doubles SCM_P ((SCM z1, SCM z2, char *sstring, struct dpair *xy));
+
+static void
+scm_two_doubles(z1, z2, sstring, xy)
SCM z1, z2;
char *sstring;
struct dpair *xy;
@@ -3488,16 +3172,12 @@ void scm_two_doubles(z1, z2, sstring, xy)
-SCM_PROC(s_sys_expt, "%expt", 2, 0, 0, scm_sys_expt);
-#ifdef __STDC__
-SCM
-scm_sys_expt(SCM z1, SCM z2)
-#else
+SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt);
+
SCM
scm_sys_expt(z1, z2)
SCM z1;
SCM z2;
-#endif
{
struct dpair xy;
scm_two_doubles(z1, z2, s_sys_expt, &xy);
@@ -3506,16 +3186,12 @@ scm_sys_expt(z1, z2)
-SCM_PROC(s_sys_atan2, "%atan2", 2, 0, 0, scm_sys_atan2);
-#ifdef __STDC__
-SCM
-scm_sys_atan2(SCM z1, SCM z2)
-#else
+SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2);
+
SCM
scm_sys_atan2(z1, z2)
SCM z1;
SCM z2;
-#endif
{
struct dpair xy;
scm_two_doubles(z1, z2, s_sys_atan2, &xy);
@@ -3525,15 +3201,11 @@ scm_sys_atan2(z1, z2)
SCM_PROC(s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular);
-#ifdef __STDC__
-SCM
-scm_make_rectangular(SCM z1, SCM z2)
-#else
+
SCM
scm_make_rectangular(z1, z2)
SCM z1;
SCM z2;
-#endif
{
struct dpair xy;
scm_two_doubles(z1, z2, s_make_rectangular, &xy);
@@ -3543,15 +3215,11 @@ scm_make_rectangular(z1, z2)
SCM_PROC(s_make_polar, "make-polar", 2, 0, 0, scm_make_polar);
-#ifdef __STDC__
-SCM
-scm_make_polar(SCM z1, SCM z2)
-#else
+
SCM
scm_make_polar(z1, z2)
SCM z1;
SCM z2;
-#endif
{
struct dpair xy;
scm_two_doubles(z1, z2, s_make_polar, &xy);
@@ -3562,14 +3230,10 @@ scm_make_polar(z1, z2)
SCM_PROC(s_real_part, "real-part", 1, 0, 0, scm_real_part);
-#ifdef __STDC__
-SCM
-scm_real_part(SCM z)
-#else
+
SCM
scm_real_part(z)
SCM z;
-#endif
{
if SCM_NINUMP(z) {
# ifdef SCM_BIGDIG
@@ -3590,14 +3254,10 @@ scm_real_part(z)
SCM_PROC(s_imag_part, "imag-part", 1, 0, 0, scm_imag_part);
-#ifdef __STDC__
-SCM
-scm_imag_part(SCM z)
-#else
+
SCM
scm_imag_part(z)
SCM z;
-#endif
{
if SCM_INUMP(z) return SCM_INUM0;
# ifdef SCM_BIGDIG
@@ -3617,14 +3277,10 @@ scm_imag_part(z)
SCM_PROC(s_magnitude, "magnitude", 1, 0, 0, scm_magnitude);
-#ifdef __STDC__
-SCM
-scm_magnitude(SCM z)
-#else
+
SCM
scm_magnitude(z)
SCM z;
-#endif
{
if SCM_INUMP(z) return scm_abs(z);
# ifdef SCM_BIGDIG
@@ -3649,14 +3305,10 @@ scm_magnitude(z)
SCM_PROC(s_angle, "angle", 1, 0, 0, scm_angle);
-#ifdef __STDC__
-SCM
-scm_angle(SCM z)
-#else
+
SCM
scm_angle(z)
SCM z;
-#endif
{
double x, y = 0.0;
if SCM_INUMP(z) {x = (z>=SCM_INUM0) ? 1.0 : -1.0; goto do_angle;}
@@ -3682,14 +3334,10 @@ scm_angle(z)
SCM_PROC(s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact);
-#ifdef __STDC__
-SCM
-scm_inexact_to_exact(SCM z)
-#else
+
SCM
scm_inexact_to_exact(z)
SCM z;
-#endif
{
if SCM_INUMP(z) return z;
# ifdef SCM_BIGDIG
@@ -3722,14 +3370,10 @@ scm_inexact_to_exact(z)
#else /* ~SCM_FLOATS */
SCM_PROC(s_trunc, "truncate", 1, 0, 0, scm_trunc);
-#ifdef __STDC__
-SCM
-scm_trunc(SCM x)
-#else
+
SCM
scm_trunc(x)
SCM x;
-#endif
{
SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_truncate);
return x;
@@ -3742,14 +3386,10 @@ scm_trunc(x)
#ifdef SCM_BIGDIG
# ifdef SCM_FLOATS
/* d must be integer */
-#ifdef __STDC__
-SCM
-scm_dbl2big(double d)
-#else
+
SCM
scm_dbl2big(d)
double d;
-#endif
{
scm_sizet i = 0;
long c;
@@ -3765,20 +3405,19 @@ scm_dbl2big(d)
u -= c;
digits[i] = c;
}
- SCM_ASSERT(0==u, SCM_INUM0, SCM_OVSCM_FLOW, "dbl2big");
+#ifndef RECKLESS
+ if (u != 0)
+ scm_num_overflow ("dbl2big");
+#endif
return ans;
}
-#ifdef __STDC__
-double
-scm_big2dbl(SCM b)
-#else
+
double
scm_big2dbl(b)
SCM b;
-#endif
{
double ans = 0.0;
scm_sizet i = SCM_NUMDIGS(b);
@@ -3790,14 +3429,10 @@ scm_big2dbl(b)
# endif
#endif
-#ifdef __STDC__
-SCM
-scm_long2num(long sl)
-#else
+
SCM
scm_long2num(sl)
long sl;
-#endif
{
if (!SCM_FIXABLE(sl)) {
#ifdef SCM_BIGDIG
@@ -3815,14 +3450,10 @@ scm_long2num(sl)
#ifdef LONGLONGS
-#ifdef __STDC__
-SCM
-scm_long_long2num(long_long sl)
-#else
+
SCM
scm_long_long2num(sl)
long_long sl;
-#endif
{
if (!SCM_FIXABLE(sl)) {
#ifdef SCM_BIGDIG
@@ -3840,16 +3471,12 @@ scm_long_long2num(sl)
#endif
-#ifdef __STDC__
-SCM
-scm_ulong2num(unsigned long sl)
-#else
+
SCM
scm_ulong2num(sl)
unsigned long sl;
-#endif
{
- if (!SCM_POSSCM_FIXABLE(sl)) {
+ if (!SCM_POSFIXABLE(sl)) {
#ifdef SCM_BIGDIG
return scm_ulong2big(sl);
#else
@@ -3863,16 +3490,12 @@ scm_ulong2num(sl)
return SCM_MAKINUM(sl);
}
-#ifdef __STDC__
-long
-scm_num2long(SCM num, char *pos, char *s_caller)
-#else
+
long
scm_num2long(num, pos, s_caller)
SCM num;
char *pos;
char *s_caller;
-#endif
{
long res;
if (SCM_INUMP(num))
@@ -3918,16 +3541,12 @@ scm_num2long(num, pos, s_caller)
-#ifdef __STDC__
-long
-num2long(SCM num, char *pos, char *s_caller)
-#else
+
long
num2long(num, pos, s_caller)
SCM num;
char *pos;
char *s_caller;
-#endif
{
long res;
if SCM_INUMP(num) {
@@ -3960,16 +3579,12 @@ num2long(num, pos, s_caller)
#ifdef LONGLONGS
-#ifdef __STDC__
-long_long
-scm_num2long_long(SCM num, char *pos, char *s_caller)
-#else
+
long_long
scm_num2long_long(num, pos, s_caller)
SCM num;
char *pos;
char *s_caller;
-#endif
{
long_long res;
if SCM_INUMP(num) {
@@ -3992,7 +3607,7 @@ scm_num2long_long(num, pos, s_caller)
scm_sizet l = SCM_NUMDIGS(num);
SCM_ASRTGO(SCM_DIGSPERLONGLONG >= l, errout);
res = 0;
- for(;l--;) res = SCM_LONGLONGSCM_BIGUP(res) + SCM_BDIGITS(num)[l];
+ for(;l--;) res = SCM_LONGLONGBIGUP(res) + SCM_BDIGITS(num)[l];
return res;
}
#endif
@@ -4002,16 +3617,12 @@ scm_num2long_long(num, pos, s_caller)
#endif
-#ifdef __STDC__
-unsigned long
-scm_num2ulong(SCM num, char *pos, char *s_caller)
-#else
+
unsigned long
scm_num2ulong(num, pos, s_caller)
SCM num;
char *pos;
char *s_caller;
-#endif
{
unsigned long res;
if (SCM_INUMP(num))
@@ -4054,6 +3665,7 @@ scm_num2ulong(num, pos, s_caller)
#ifdef SCM_FLOATS
# ifndef DBL_DIG
+static void add1 SCM_P ((double f, double *fsum));
static void add1(f, fsum)
double f, *fsum;
{
@@ -4063,23 +3675,19 @@ static void add1(f, fsum)
#endif
-#ifdef __STDC__
-void
-scm_init_numbers (void)
-#else
+
void
scm_init_numbers ()
-#endif
{
#ifdef SCM_FLOATS
SCM_NEWCELL(scm_flo0);
# ifdef SCM_SINGLES
- SCM_CAR(scm_flo0) = scm_tc_flo;
+ SCM_SETCAR (scm_flo0, scm_tc_flo);
SCM_FLO(scm_flo0) = 0.0;
# else
- SCM_CDR(scm_flo0) = (SCM)scm_must_malloc(1L*sizeof(double), "real");
+ SCM_SETCDR (scm_flo0, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
SCM_REAL(scm_flo0) = 0.0;
- SCM_CAR(scm_flo0) = scm_tc_dblr;
+ SCM_SETCAR (scm_flo0, scm_tc_dblr);
# endif
# ifdef DBL_DIG
scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
diff --git a/libguile/numbers.h b/libguile/numbers.h
index abd1e7a24..d34e09d9c 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -97,10 +97,10 @@
/* SCM_FIXABLE is non-0 if its long argument can be encoded in an SCM_INUM.
*/
-#define SCM_POSSCM_FIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
-#define SCM_NEGSCM_FIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
-#define SCM_UNEGSCM_FIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM)
-#define SCM_FIXABLE(n) (SCM_POSSCM_FIXABLE(n) && SCM_NEGSCM_FIXABLE(n))
+#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
+#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
+#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM)
+#define SCM_FIXABLE(n) (SCM_POSFIXABLE(n) && SCM_NEGFIXABLE(n))
/* SCM_INTBUFLEN is the maximum number of characters neccessary for the
* printed or scm_string representation of an exact immediate.
@@ -167,7 +167,7 @@
# define SCM_DIGSPERLONG ((scm_sizet)((sizeof(long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG))
# define SCM_DIGSPERLONGLONG ((scm_sizet)((sizeof(long long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG))
# define SCM_BIGUP(x) ((unsigned long)(x) << SCM_BITSPERDIG)
-# define SCM_LONGLONGSCM_BIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG)
+# define SCM_LONGLONGBIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG)
# define SCM_BIGDN(x) ((x) >> SCM_BITSPERDIG)
# define SCM_BIGLO(x) ((x) & (SCM_BIGRAD-1))
#endif /* def BIGNUMS */
@@ -177,7 +177,7 @@
* prototypes to compile with conditionalization.
*/
# define SCM_BIGDIG unsigned short
-# define NO_SCM_BIGDIG
+# define SCM_NO_BIGDIG
# ifndef SCM_FLOATS
# define SCM_INUMS_ONLY
# endif /* ndef SCM_FLOATS */
@@ -197,7 +197,7 @@
#define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x))
#define SCM_BDIGITS(x) ((SCM_BIGDIG *)(SCM_CDR(x)))
#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CAR(x)>>16))
-#define SCM_SETNUMDIGS(x, v, t) SCM_CAR(x) = (((v)+0L)<<16)+(t)
+#define SCM_SETNUMDIGS(x, v, t) SCM_SETCAR(x, (((v)+0L)<<16)+(t))
#ifdef SCM_FLOATS
@@ -225,212 +225,99 @@ typedef struct scm_dbl
-#ifdef __STDC__
-extern SCM scm_exact_p(SCM x);
-extern SCM scm_odd_p(SCM n);
-extern SCM scm_even_p(SCM n);
-extern SCM scm_abs(SCM x);
-extern SCM scm_quotient(SCM x, SCM y);
-extern SCM scm_remainder(SCM x, SCM y);
-extern SCM scm_modulo(SCM x, SCM y);
-extern SCM scm_gcd(SCM x, SCM y);
-extern SCM scm_lcm(SCM n1, SCM n2);
-extern SCM scm_logand(SCM n1, SCM n2);
-extern SCM scm_logior(SCM n1, SCM n2);
-extern SCM scm_logxor(SCM n1, SCM n2);
-extern SCM scm_logtest(SCM n1, SCM n2);
-extern SCM scm_logbit_p(SCM n1, SCM n2);
-extern SCM scm_logand(SCM n1, SCM n2);
-extern SCM scm_logior(SCM n1, SCM n2);
-extern SCM scm_logxor(SCM n1, SCM n2);
-extern SCM scm_logtest(SCM n1, SCM n2);
-extern SCM scm_logbit_p(SCM n1, SCM n2);
-extern SCM scm_lognot(SCM n);
-extern SCM scm_integer_expt(SCM z1, SCM z2);
-extern SCM scm_ash(SCM n, SCM cnt);
-extern SCM scm_bit_extract(SCM n, SCM start, SCM end);
-extern SCM scm_logcount (SCM n);
-extern SCM scm_integer_length(SCM n);
-extern SCM scm_mkbig(scm_sizet nlen, int sign);
-extern SCM scm_big2inum(SCM b, scm_sizet l);
-extern SCM scm_adjbig(SCM b, scm_sizet nlen);
-extern SCM scm_normbig(SCM b);
-extern SCM scm_copybig(SCM b, int sign);
-extern SCM scm_long2big(long n);
-extern SCM scm_long_long2big(long_long n);
-extern SCM scm_2ulong2big(unsigned long * np);
-extern SCM scm_ulong2big(unsigned long n);
-extern int scm_bigcomp(SCM x, SCM y);
-extern long scm_pseudolong(long x);
-extern void scm_longdigs(long x, SCM_BIGDIG digs[]);
-extern SCM scm_addbig(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny);
-extern SCM scm_mulbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn);
-extern unsigned int scm_divbigdig(SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div);
-extern SCM scm_divbigint(SCM x, long z, int sgn, int mode);
-extern SCM scm_divbigbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes);
-extern scm_sizet scm_iint2str(long num, int rad, char *p);
-extern SCM scm_number_to_string(SCM x, SCM radix);
-extern int scm_floprint(SCM sexp, SCM port, int writing);
-extern int scm_bigprint(SCM exp, SCM port, int writing);
-extern SCM scm_istr2int(char *str, long len, long radix);
-extern SCM scm_istr2int(char *str, long len, long radix);
-extern SCM scm_istr2flo(char *str, long len, long radix);
-extern SCM scm_istring2number(char *str, long len, long radix);
-extern SCM scm_string_to_number(SCM str, SCM radix);
-extern SCM scm_makdbl (double x, double y);
-extern SCM scm_bigequal(SCM x, SCM y);
-extern SCM scm_floequal(SCM x, SCM y);
-extern SCM scm_number_p(SCM x);
-extern SCM scm_real_p(SCM x);
-extern SCM scm_int_p(SCM x);
-extern SCM scm_inexact_p(SCM x);
-extern SCM scm_num_eq_p (SCM x, SCM y);
-extern SCM scm_less_p(SCM x, SCM y);
-extern SCM scm_gr_p(SCM x, SCM y);
-extern SCM scm_leq_p(SCM x, SCM y);
-extern SCM scm_geq_p(SCM x, SCM y);
-extern SCM scm_zero_p(SCM z);
-extern SCM scm_positive_p(SCM x);
-extern SCM scm_negative_p(SCM x);
-extern SCM scm_max(SCM x, SCM y);
-extern SCM scm_min(SCM x, SCM y);
-extern SCM scm_sum(SCM x, SCM y);
-extern SCM scm_difference(SCM x, SCM y);
-extern SCM scm_product(SCM x, SCM y);
-extern double scm_num2dbl (SCM a, char * why);
-extern SCM scm_fuck (SCM a);
-extern SCM scm_divide(SCM x, SCM y);
-extern double scm_asinh(double x);
-extern double scm_acosh(double x);
-extern double scm_atanh(double x);
-extern double scm_truncate(double x);
-extern double scm_round(double x);
-extern double scm_exact_to_inexact(double z);
-extern SCM scm_sys_expt(SCM z1, SCM z2);
-extern SCM scm_sys_atan2(SCM z1, SCM z2);
-extern SCM scm_make_rectangular(SCM z1, SCM z2);
-extern SCM scm_make_polar(SCM z1, SCM z2);
-extern SCM scm_real_part(SCM z);
-extern SCM scm_imag_part(SCM z);
-extern SCM scm_magnitude(SCM z);
-extern SCM scm_angle(SCM z);
-extern SCM scm_inexact_to_exact(SCM z);
-extern SCM scm_trunc(SCM x);
-extern SCM scm_dbl2big(double d);
-extern double scm_big2dbl(SCM b);
-extern SCM scm_long2num(long sl);
-extern SCM scm_long_long2num(long_long sl);
-extern SCM scm_ulong2num(unsigned long sl);
-extern long scm_num2long(SCM num, char *pos, char *s_caller);
-extern long num2long(SCM num, char *pos, char *s_caller);
-extern long_long scm_num2long_long(SCM num, char *pos, char *s_caller);
-extern unsigned long scm_num2ulong(SCM num, char *pos, char *s_caller);
-extern void scm_init_numbers (void);
-
-#else /* STDC */
-extern SCM scm_exact_p();
-extern SCM scm_odd_p();
-extern SCM scm_even_p();
-extern SCM scm_abs();
-extern SCM scm_quotient();
-extern SCM scm_remainder();
-extern SCM scm_modulo();
-extern SCM scm_gcd();
-extern SCM scm_lcm();
-extern SCM scm_logand();
-extern SCM scm_logior();
-extern SCM scm_logxor();
-extern SCM scm_logtest();
-extern SCM scm_logbit_p();
-extern SCM scm_logand();
-extern SCM scm_logior();
-extern SCM scm_logxor();
-extern SCM scm_logtest();
-extern SCM scm_logbit_p();
-extern SCM scm_lognot();
-extern SCM scm_integer_expt();
-extern SCM scm_ash();
-extern SCM scm_bit_extract();
-extern SCM scm_logcount ();
-extern SCM scm_integer_length();
-extern SCM scm_mkbig();
-extern SCM scm_big2inum();
-extern SCM scm_adjbig();
-extern SCM scm_normbig();
-extern SCM scm_copybig();
-extern SCM scm_long2big();
-extern SCM scm_long_long2big();
-extern SCM scm_2ulong2big();
-extern SCM scm_ulong2big();
-extern int scm_bigcomp();
-extern long scm_pseudolong();
-extern void scm_longdigs();
-extern SCM scm_addbig();
-extern SCM scm_mulbig();
-extern unsigned int scm_divbigdig();
-extern SCM scm_divbigint();
-extern SCM scm_divbigbig();
-extern scm_sizet scm_iint2str();
-extern SCM scm_number_to_string();
-extern int scm_floprint();
-extern int scm_bigprint();
-extern SCM scm_istr2int();
-extern SCM scm_istr2int();
-extern SCM scm_istr2flo();
-extern SCM scm_istring2number();
-extern SCM scm_string_to_number();
-extern SCM scm_makdbl ();
-extern SCM scm_bigequal();
-extern SCM scm_floequal();
-extern SCM scm_number_p();
-extern SCM scm_real_p();
-extern SCM scm_int_p();
-extern SCM scm_inexact_p();
-extern SCM scm_num_eq_p ();
-extern SCM scm_less_p();
-extern SCM scm_gr_p();
-extern SCM scm_leq_p();
-extern SCM scm_geq_p();
-extern SCM scm_zero_p();
-extern SCM scm_positive_p();
-extern SCM scm_negative_p();
-extern SCM scm_max();
-extern SCM scm_min();
-extern SCM scm_sum();
-extern SCM scm_difference();
-extern SCM scm_product();
-extern double scm_num2dbl ();
-extern SCM scm_fuck ();
-extern SCM scm_divide();
-extern double scm_asinh();
-extern double scm_acosh();
-extern double scm_atanh();
-extern double scm_truncate();
-extern double scm_round();
-extern double scm_exact_to_inexact();
-extern SCM scm_sys_expt();
-extern SCM scm_sys_atan2();
-extern SCM scm_make_rectangular();
-extern SCM scm_make_polar();
-extern SCM scm_real_part();
-extern SCM scm_imag_part();
-extern SCM scm_magnitude();
-extern SCM scm_angle();
-extern SCM scm_inexact_to_exact();
-extern SCM scm_trunc();
-extern SCM scm_dbl2big();
-extern double scm_big2dbl();
-extern SCM scm_long2num();
-extern SCM scm_long_long2num();
-extern SCM scm_ulong2num();
-extern long scm_num2long();
-extern long num2long();
-extern long_long scm_num2long_long();
-extern unsigned long scm_num2ulong();
-extern void scm_init_numbers ();
-
-#endif /* STDC */
-
+extern SCM scm_exact_p SCM_P ((SCM x));
+extern SCM scm_odd_p SCM_P ((SCM n));
+extern SCM scm_even_p SCM_P ((SCM n));
+extern SCM scm_abs SCM_P ((SCM x));
+extern SCM scm_quotient SCM_P ((SCM x, SCM y));
+extern SCM scm_remainder SCM_P ((SCM x, SCM y));
+extern SCM scm_modulo SCM_P ((SCM x, SCM y));
+extern SCM scm_gcd SCM_P ((SCM x, SCM y));
+extern SCM scm_lcm SCM_P ((SCM n1, SCM n2));
+extern SCM scm_logand SCM_P ((SCM n1, SCM n2));
+extern SCM scm_logior SCM_P ((SCM n1, SCM n2));
+extern SCM scm_logxor SCM_P ((SCM n1, SCM n2));
+extern SCM scm_logtest SCM_P ((SCM n1, SCM n2));
+extern SCM scm_logbit_p SCM_P ((SCM n1, SCM n2));
+extern SCM scm_lognot SCM_P ((SCM n));
+extern SCM scm_integer_expt SCM_P ((SCM z1, SCM z2));
+extern SCM scm_ash SCM_P ((SCM n, SCM cnt));
+extern SCM scm_bit_extract SCM_P ((SCM n, SCM start, SCM end));
+extern SCM scm_logcount SCM_P ((SCM n));
+extern SCM scm_integer_length SCM_P ((SCM n));
+extern SCM scm_mkbig SCM_P ((scm_sizet nlen, int sign));
+extern SCM scm_big2inum SCM_P ((SCM b, scm_sizet l));
+extern SCM scm_adjbig SCM_P ((SCM b, scm_sizet nlen));
+extern SCM scm_normbig SCM_P ((SCM b));
+extern SCM scm_copybig SCM_P ((SCM b, int sign));
+extern SCM scm_long2big SCM_P ((long n));
+extern SCM scm_long_long2big SCM_P ((long_long n));
+extern SCM scm_2ulong2big SCM_P ((unsigned long * np));
+extern SCM scm_ulong2big SCM_P ((unsigned long n));
+extern int scm_bigcomp SCM_P ((SCM x, SCM y));
+extern long scm_pseudolong SCM_P ((long x));
+extern void scm_longdigs SCM_P ((long x, SCM_BIGDIG digs[]));
+extern SCM scm_addbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny));
+extern SCM scm_mulbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn));
+extern unsigned int scm_divbigdig SCM_P ((SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div));
+extern SCM scm_divbigint SCM_P ((SCM x, long z, int sgn, int mode));
+extern SCM scm_divbigbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes));
+extern scm_sizet scm_iint2str SCM_P ((long num, int rad, char *p));
+extern SCM scm_number_to_string SCM_P ((SCM x, SCM radix));
+extern int scm_floprint SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
+extern int scm_bigprint SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+extern SCM scm_istr2int SCM_P ((char *str, long len, long radix));
+extern SCM scm_istr2flo SCM_P ((char *str, long len, long radix));
+extern SCM scm_istring2number SCM_P ((char *str, long len, long radix));
+extern SCM scm_string_to_number SCM_P ((SCM str, SCM radix));
+extern SCM scm_makdbl SCM_P ((double x, double y));
+extern SCM scm_bigequal SCM_P ((SCM x, SCM y));
+extern SCM scm_floequal SCM_P ((SCM x, SCM y));
+extern SCM scm_number_p SCM_P ((SCM x));
+extern SCM scm_real_p SCM_P ((SCM x));
+extern SCM scm_integer_p SCM_P ((SCM x));
+extern SCM scm_inexact_p SCM_P ((SCM x));
+extern SCM scm_num_eq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_less_p SCM_P ((SCM x, SCM y));
+extern SCM scm_gr_p SCM_P ((SCM x, SCM y));
+extern SCM scm_leq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_geq_p SCM_P ((SCM x, SCM y));
+extern SCM scm_zero_p SCM_P ((SCM z));
+extern SCM scm_positive_p SCM_P ((SCM x));
+extern SCM scm_negative_p SCM_P ((SCM x));
+extern SCM scm_max SCM_P ((SCM x, SCM y));
+extern SCM scm_min SCM_P ((SCM x, SCM y));
+extern SCM scm_sum SCM_P ((SCM x, SCM y));
+extern SCM scm_difference SCM_P ((SCM x, SCM y));
+extern SCM scm_product SCM_P ((SCM x, SCM y));
+extern double scm_num2dbl SCM_P ((SCM a, char * why));
+extern SCM scm_divide SCM_P ((SCM x, SCM y));
+extern double scm_asinh SCM_P ((double x));
+extern double scm_acosh SCM_P ((double x));
+extern double scm_atanh SCM_P ((double x));
+extern double scm_truncate SCM_P ((double x));
+extern double scm_round SCM_P ((double x));
+extern double scm_exact_to_inexact SCM_P ((double z));
+extern SCM scm_sys_expt SCM_P ((SCM z1, SCM z2));
+extern SCM scm_sys_atan2 SCM_P ((SCM z1, SCM z2));
+extern SCM scm_make_rectangular SCM_P ((SCM z1, SCM z2));
+extern SCM scm_make_polar SCM_P ((SCM z1, SCM z2));
+extern SCM scm_real_part SCM_P ((SCM z));
+extern SCM scm_imag_part SCM_P ((SCM z));
+extern SCM scm_magnitude SCM_P ((SCM z));
+extern SCM scm_angle SCM_P ((SCM z));
+extern SCM scm_inexact_to_exact SCM_P ((SCM z));
+extern SCM scm_trunc SCM_P ((SCM x));
+extern SCM scm_dbl2big SCM_P ((double d));
+extern double scm_big2dbl SCM_P ((SCM b));
+extern SCM scm_long2num SCM_P ((long sl));
+extern SCM scm_long_long2num SCM_P ((long_long sl));
+extern SCM scm_ulong2num SCM_P ((unsigned long sl));
+extern long scm_num2long SCM_P ((SCM num, char *pos, char *s_caller));
+extern long num2long SCM_P ((SCM num, char *pos, char *s_caller));
+extern long_long scm_num2long_long SCM_P ((SCM num, char *pos, char *s_caller));
+extern unsigned long scm_num2ulong SCM_P ((SCM num, char *pos, char *s_caller));
+extern void scm_init_numbers SCM_P ((void));
#endif /* NUMBERSH */
diff --git a/libguile/objprop.c b/libguile/objprop.c
index e97b591ce..22bbf7fe1 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -42,70 +42,57 @@
#include <stdio.h>
#include "_scm.h"
+#include "hashtab.h"
+#include "alist.h"
+#include "weaks.h"
+#include "objprop.h"
/* {Object Properties}
*/
SCM_PROC(s_object_properties, "object-properties", 1, 0, 0, scm_object_properties);
-#ifdef __STDC__
-SCM
-scm_object_properties (SCM obj)
-#else
+
SCM
scm_object_properties (obj)
SCM obj;
-#endif
{
- return scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
+ return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
}
SCM_PROC(s_set_object_properties_x, "set-object-properties!", 2, 0, 0, scm_set_object_properties_x);
-#ifdef __STDC__
-SCM
-scm_set_object_properties_x (SCM obj, SCM plist)
-#else
+
SCM
scm_set_object_properties_x (obj, plist)
SCM obj;
SCM plist;
-#endif
{
- SCM handle;
- scm_hashq_create_handle_x (scm_object_whash, obj, plist);
+ SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist);
SCM_SETCDR (handle, plist);
return plist;
}
SCM_PROC(s_object_property, "object-property", 2, 0, 0, scm_object_property);
-#ifdef __STDC__
-SCM
-scm_object_property (SCM obj, SCM key)
-#else
+
SCM
scm_object_property (obj, key)
SCM obj;
SCM key;
-#endif
{
SCM assoc;
- assoc = scm_assq (key, SCM_CDR (scm_object_properties (obj)));
+ assoc = scm_assq (key, scm_object_properties (obj));
return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
SCM_PROC(s_set_object_property_x, "set-object-property!", 3, 0, 0, scm_set_object_property_x);
-#ifdef __STDC__
-SCM
-scm_set_object_property_x (SCM obj, SCM key, SCM val)
-#else
+
SCM
scm_set_object_property_x (obj, key, val)
SCM obj;
SCM key;
SCM val;
-#endif
{
SCM h;
SCM assoc;
@@ -123,15 +110,11 @@ scm_set_object_property_x (obj, key, val)
return val;
}
-#ifdef __STDC__
-void
-scm_init_objprop (void)
-#else
+
void
scm_init_objprop ()
-#endif
{
- scm_object_whash = scm_make_weak_hash_table (SCM_MAKINUM (511));
+ scm_object_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511));
#include "objprop.x"
}
diff --git a/libguile/objprop.h b/libguile/objprop.h
index af3771c22..89a662346 100644
--- a/libguile/objprop.h
+++ b/libguile/objprop.h
@@ -45,29 +45,18 @@
#include <stdio.h>
-#include "_scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_object_properties (SCM obj);
-extern SCM scm_set_object_properties_x (SCM obj, SCM plist);
-extern SCM scm_object_property (SCM obj, SCM key);
-extern SCM scm_set_object_property_x (SCM obj, SCM key, SCM val);
-extern void scm_init_objprop (void);
-
-#else /* STDC */
-extern SCM scm_object_properties ();
-extern SCM scm_set_object_properties_x ();
-extern SCM scm_object_property ();
-extern SCM scm_set_object_property_x ();
-extern void scm_init_objprop ();
-
-#endif /* STDC */
-
+extern SCM scm_object_properties SCM_P ((SCM obj));
+extern SCM scm_set_object_properties_x SCM_P ((SCM obj, SCM plist));
+extern SCM scm_object_property SCM_P ((SCM obj, SCM key));
+extern SCM scm_set_object_property_x SCM_P ((SCM obj, SCM key, SCM val));
+extern void scm_init_objprop SCM_P ((void));
#endif /* OBJPROPH */
diff --git a/libguile/options.c b/libguile/options.c
new file mode 100644
index 000000000..d0aba0a17
--- /dev/null
+++ b/libguile/options.c
@@ -0,0 +1,226 @@
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+
+#include "options.h"
+
+
+/* {Run-time options}
+ *
+ * This is the basic interface for low-level configuration of the
+ * Guile library. It is used for configuring the reader, evaluator,
+ * printer and debugger.
+ *
+ * Motivation:
+ *
+ * 1. Altering option settings can have side effects.
+ * 2. Option values can be stored in native format.
+ * (Important for efficiency in, e. g., the evaluator.)
+ * 3. Doesn't use up name space.
+ * 4. Options can be naturally grouped => ease of use.
+ */
+
+/* scm_options is the core of all options interface procedures.
+ *
+ * Some definitions:
+ *
+ * Run time options in Guile are arranged in groups. Each group
+ * affects a certain aspect of the behaviour of the library.
+ *
+ * An "options interface procedure" manages one group of options. It
+ * can be used to check or set options, or to get documentation for
+ * all options of a group. The options interface procedure is not
+ * intended to be called directly by the user. The user should
+ * instead call
+ *
+ * (<group>-options)
+ * (<group>-options 'help)
+ * (<group>-options 'full)
+ *
+ * to display current option settings (The second version also
+ * displays documentation. The third version also displays
+ * information about programmer's options.), and
+ *
+ * (<group>-enable '<option-symbol>)
+ * (<group>-disable '<option-symbol>)
+ * (<group>-set! <option-symbol> <value>)
+ * (<group>-options <option setting>)
+ *
+ * to alter the state of an option (The last version sets all
+ * options according to <option setting>.) where <group> is the name
+ * of the option group.
+ *
+ * An "option setting" represents the state of all low-level options
+ * managed by one options interface procedure. It is a list of
+ * single symbols and symbols followed by a value.
+ *
+ * For boolean options, the presence of the symbol of that option in
+ * the option setting indicates a true value. If the symbol isn't a
+ * member of the option setting this represents a false value.
+ *
+ * Other options are represented by a symbol followed by the value.
+ *
+ * If scm_options is called without arguments, the current option
+ * setting is returned. If the argument is an option setting, options
+ * are altered and the old setting is returned. If the argument isn't
+ * a list, a list of sublists is returned, where each sublist contains
+ * option name, value and documentation string.
+ */
+
+SCM_SYMBOL (scm_yes_sym, "yes");
+SCM_SYMBOL (scm_no_sym, "no");
+
+
+SCM
+scm_options (new_mode, options, n, s)
+ SCM new_mode;
+ scm_option options[];
+ int n;
+ char *s;
+{
+ int i, docp = (!SCM_UNBNDP (new_mode)
+ && (SCM_IMP (new_mode) || SCM_NCONSP (new_mode)));
+ SCM ans = SCM_EOL, ls;
+ for (i = 0; i < n; ++i)
+ {
+ ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans;
+ switch (options[i].type)
+ {
+ case SCM_OPTION_BOOLEAN:
+ if (docp)
+ ls = scm_cons ((int) options[i].val
+ ? scm_yes_sym
+ : scm_no_sym,
+ ls);
+ break;
+ case SCM_OPTION_INTEGER:
+ ls = scm_cons (SCM_MAKINUM ((int) options[i].val), ls);
+ break;
+ case SCM_OPTION_SCM:
+ ls = scm_cons ((SCM) options[i].val, ls);
+ }
+ if (!((options[i].type == SCM_OPTION_BOOLEAN)
+ && !docp
+ && ! (int) options[i].val))
+ ls = scm_cons ((SCM) options[i].name, ls);
+ ans = docp ? scm_cons (ls, ans) : ls;
+ }
+ if (!(SCM_UNBNDP (new_mode) || docp))
+ {
+ unsigned long *flags;
+ flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long),
+ "mode buffer");
+ for (i = 0; i < n; ++i)
+ if (options[i].type == SCM_OPTION_BOOLEAN)
+ flags[i] = 0;
+ else
+ flags[i] = (unsigned long) options[i].val;
+ while (SCM_NNULLP (new_mode))
+ {
+ SCM_ASSERT (SCM_NIMP (new_mode) && SCM_CONSP (new_mode),
+ new_mode,
+ SCM_ARG1,
+ s);
+ for (i = 0; i < n; ++i)
+ if (SCM_CAR (new_mode) == (SCM) options[i].name)
+ switch (options[i].type)
+ {
+ case SCM_OPTION_BOOLEAN:
+ flags[i] = 1;
+ goto cont;
+ case SCM_OPTION_INTEGER:
+ new_mode = SCM_CDR (new_mode);
+ SCM_ASSERT (SCM_NIMP (new_mode)
+ && SCM_CONSP (new_mode)
+ && SCM_INUMP (SCM_CAR (new_mode)),
+ new_mode,
+ SCM_ARG1,
+ s);
+ flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode));
+ goto cont;
+ case SCM_OPTION_SCM:
+ new_mode = SCM_CDR (new_mode);
+ flags[i] = SCM_CAR (new_mode);
+ goto cont;
+ }
+#ifndef RECKLESS
+ scm_must_free ((char *) flags);
+ scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s);
+#endif
+ cont:
+ new_mode = SCM_CDR (new_mode);
+ }
+ for (i = 0; i < n; ++i) options[i].val = flags[i];
+ scm_must_free ((char *) flags);
+ }
+ return ans;
+}
+
+
+void
+scm_init_opts (func, options, n)
+ SCM (*func) (SCM);
+ scm_option options[];
+ int n;
+{
+ int i;
+
+ for (i = 0; i < n; ++i)
+ {
+ options[i].name = (char *) SCM_CAR (scm_sysintern0 (options[i].name));
+ options[i].doc = (char *) scm_permanent_object (scm_take0str
+ (options[i].doc));
+ }
+ func (SCM_UNDEFINED);
+}
+
+
+void
+scm_init_options ()
+{
+#include "options.x"
+}
diff --git a/libguile/options.h b/libguile/options.h
new file mode 100644
index 000000000..62363a862
--- /dev/null
+++ b/libguile/options.h
@@ -0,0 +1,71 @@
+/* classes: h_files */
+
+#ifndef OPTIONSH
+#define OPTIONSH
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+typedef struct scm_option
+{
+ int type;
+ char *name;
+ unsigned long val;
+ char *doc;
+} scm_option;
+
+#define SCM_OPTION_BOOLEAN 0
+#define SCM_OPTION_INTEGER 1
+#define SCM_OPTION_SCM 2
+
+
+extern SCM scm_options SCM_P ((SCM new_mode, scm_option options[], int n, char *s));
+extern void scm_init_opts SCM_P ((SCM (*func) (SCM), scm_option options[], int n));
+extern void scm_init_options SCM_P ((void));
+
+#endif /* OPTIONSH */
diff --git a/libguile/pairs.c b/libguile/pairs.c
index 26cd3da1f..619529e64 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -42,104 +42,75 @@
#include <stdio.h>
#include "_scm.h"
-#ifdef __STDC__
-#include <stdarg.h>
-#define var_start(x, y) va_start(x, y)
-#else
-#include <varargs.h>
-#define var_start(x, y) va_start(x)
-#endif
-
-
/* {Pairs}
*/
SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons);
-#ifdef __STDC__
-SCM
-scm_cons (SCM x, SCM y)
-#else
+
SCM
scm_cons (x, y)
SCM x;
SCM y;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CAR (z) = x;
- SCM_CDR (z) = y;
+ SCM_SETCAR (z, x);
+ SCM_SETCDR (z, y);
return z;
}
-#ifdef __STDC__
-SCM
-scm_cons2 (SCM w, SCM x, SCM y)
-#else
+
SCM
scm_cons2 (w, x, y)
SCM w;
SCM x;
SCM y;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CAR (z) = x;
- SCM_CDR (z) = y;
+ SCM_SETCAR (z, x);
+ SCM_SETCDR (z, y);
x = z;
SCM_NEWCELL (z);
- SCM_CAR (z) = w;
- SCM_CDR (z) = x;
+ SCM_SETCAR (z, w);
+ SCM_SETCDR (z, x);
return z;
}
SCM_PROC(s_pair_p, "pair?", 1, 0, 0, scm_pair_p);
-#ifdef __STDC__
-SCM
-scm_pair_p(SCM x)
-#else
+
SCM
scm_pair_p(x)
SCM x;
-#endif
{
if SCM_IMP(x) return SCM_BOOL_F;
return SCM_CONSP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x);
-#ifdef __STDC__
-SCM
-scm_set_car_x(SCM pair, SCM value)
-#else
+
SCM
scm_set_car_x(pair, value)
SCM pair;
SCM value;
-#endif
{
SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_car_x);
- SCM_CAR(pair) = value;
+ SCM_SETCAR (pair, value);
return value;
}
SCM_PROC(s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x);
-#ifdef __STDC__
-SCM
-scm_set_cdr_x(SCM pair, SCM value)
-#else
+
SCM
scm_set_cdr_x(pair, value)
SCM pair;
SCM value;
-#endif
{
SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_cdr_x);
- SCM_CDR(pair) = value;
+ SCM_SETCDR (pair, value);
return value;
}
@@ -182,13 +153,9 @@ static scm_iproc cxrs[] =
};
-#ifdef __STDC__
-void
-scm_init_pairs (void)
-#else
+
void
scm_init_pairs ()
-#endif
{
scm_init_iprocs(cxrs, scm_tc7_cxr);
#include "pairs.x"
diff --git a/libguile/pairs.h b/libguile/pairs.h
index b27e9c908..ec074f77b 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -89,7 +89,6 @@ typedef SCM huge *SCMPTR;
#define SCM_PTR_LE(x, y) (!SCM_PTR_GT(x, y))
#define SCM_PTR_GE(x, y) (!SCM_PTR_LT(x, y))
-#define SCM_EOL SCM_BOOL_F
#define SCM_NULLP(x) (SCM_EOL == (x))
#define SCM_NNULLP(x) (SCM_EOL != (x))
@@ -102,8 +101,16 @@ typedef SCM huge *SCMPTR;
#define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car)
#define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr)
#define SCM_GCCDR(x) (~1L & SCM_CDR(x))
-#define SCM_SETCDR(x, v) SCM_CDR(x) = (SCM)(v)
-#define SCM_SETCAR(x, v) SCM_CAR(x) = (SCM)(v)
+#define SCM_SETCAR(x, v) (SCM_CAR(x) = (SCM)(v))
+#define SCM_SETCDR(x, v) (SCM_CDR(x) = (SCM)(v))
+
+#define SCM_CARLOC(x) (&SCM_CAR (x))
+#define SCM_CDRLOC(x) (&SCM_CDR (x))
+
+#define SCM_SETAND_CAR(x, y) (SCM_CAR (x) &= (y))
+#define SCM_SETAND_CDR(x, y) (SCM_CDR (x) &= (y))
+#define SCM_SETOR_CAR(x, y) (SCM_CAR (x) |= (y))
+#define SCM_SETOR_CDR(x, y) (SCM_CDR (x) |= (y))
#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))
@@ -137,6 +144,9 @@ typedef SCM huge *SCMPTR;
#define SCM_CDDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
+#ifdef DEBUG_FREELIST
+#define SCM_NEWCELL(_into) (scm_debug_newcell (&_into))
+#else
#define SCM_NEWCELL(_into) \
{ \
if (SCM_IMP(scm_freelist)) \
@@ -148,23 +158,15 @@ typedef SCM huge *SCMPTR;
++scm_cells_allocated; \
} \
}
+#endif
-#ifdef __STDC__
-extern SCM scm_cons (SCM x, SCM y);
-extern SCM scm_cons2 (SCM w, SCM x, SCM y);
-extern SCM scm_pair_p(SCM x);
-extern SCM scm_set_car_x(SCM pair, SCM value);
-extern SCM scm_set_cdr_x(SCM pair, SCM value);
-extern void scm_init_pairs (void);
-
-#else /* STDC */
-extern SCM scm_cons ();
-extern SCM scm_cons2 ();
-extern SCM scm_pair_p();
-extern SCM scm_set_car_x();
-extern SCM scm_set_cdr_x();
-extern void scm_init_pairs ();
-
-#endif /* STDC */
+
+extern SCM scm_cons SCM_P ((SCM x, SCM y));
+extern SCM scm_cons2 SCM_P ((SCM w, SCM x, SCM y));
+extern SCM scm_pair_p SCM_P ((SCM x));
+extern SCM scm_set_car_x SCM_P ((SCM pair, SCM value));
+extern SCM scm_set_cdr_x SCM_P ((SCM pair, SCM value));
+extern void scm_init_pairs SCM_P ((void));
+
#endif /* PAIRSH */
diff --git a/libguile/ports.c b/libguile/ports.c
index cbaecbc03..0126c2f25 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -41,16 +41,28 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "chars.h"
+#include "markers.h"
+#include "filesys.h"
+#include "fports.h"
+#include "strports.h"
+#include "vports.h"
+
+#include "ports.h"
#ifdef HAVE_MALLOC_H
-#include "malloc.h"
+#include <malloc.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
+#ifdef HAVE_SYS_IOCTL_H
+#include <sys/ioctl.h>
+#endif
@@ -62,14 +74,10 @@
scm_ptobfuns *scm_ptobs;
scm_sizet scm_numptob;
-#ifdef __STDC__
-SCM
-scm_markstream (SCM ptr)
-#else
+
SCM
scm_markstream (ptr)
SCM ptr;
-#endif
{
int openp;
if (SCM_GC8MARKP (ptr))
@@ -83,14 +91,10 @@ scm_markstream (ptr)
}
-#ifdef __STDC__
-long
-scm_newptob (scm_ptobfuns *ptob)
-#else
+
long
scm_newptob (ptob)
scm_ptobfuns *ptob;
-#endif
{
char *tmp;
if (255 <= scm_numptob)
@@ -120,14 +124,10 @@ scm_newptob (ptob)
/* internal SCM call */
-#ifdef __STDC__
-void
-scm_fflush (SCM port)
-#else
+
void
scm_fflush (port)
SCM port;
-#endif
{
scm_sizet i = SCM_PTOBNUM (port);
(scm_ptobs[i].fflush) (SCM_STREAM (port));
@@ -135,79 +135,11 @@ scm_fflush (port)
+SCM_PROC(s_char_ready_p, "char-ready?", 0, 1, 0, scm_char_ready_p);
-#ifdef __IBMC__
-# define MSDOS
-#endif
-#ifdef MSDOS
-# ifndef GO32
-# include <io.h>
-# include <conio.h>
-#ifdef __STDC__
-static int
-input_waiting (FILE *f)
-#else
-static int
-input_waiting (f)
- FILE *f;
-#endif
-{
- if (feof (f))
- return 1;
- if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin))))
- return kbhit ();
- return -1;
-}
-# endif
-#else
-# ifdef _DCC
-# include <ioctl.h>
-# else
-# ifndef AMIGA
-# ifndef vms
-# ifdef MWC
-# include <sys/io.h>
-# else
-# ifndef THINK_C
-# ifndef ARM_ULIB
-# include <sys/ioctl.h>
-# endif
-# endif
-# endif
-# endif
-# endif
-# endif
-
-
-#ifdef __STDC__
-static int
-input_waiting(FILE *f)
-#else
-static int
-input_waiting(f)
- FILE *f;
-#endif
-{
-# ifdef FIONREAD
- long remir;
- if (feof(f)) return 1;
- ioctl(fileno(f), FIONREAD, &remir);
- return remir;
-# else
- return -1;
-# endif
-}
-#endif
-
-SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p);
-#ifdef __STDC__
-SCM
-scm_char_ready_p (SCM port)
-#else
SCM
scm_char_ready_p (port)
SCM port;
-#endif
{
if (SCM_UNBNDP (port))
port = scm_cur_inp;
@@ -215,27 +147,7 @@ scm_char_ready_p (port)
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p);
if (SCM_CRDYP (port) || !SCM_FPORTP (port))
return SCM_BOOL_T;
- return input_waiting ((FILE *)SCM_STREAM (port)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-
-
-SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p);
-#ifdef __STDC__
-SCM
-scm_ungetc_char_ready_p (SCM port)
-#else
-SCM
-scm_ungetc_char_ready_p (port)
- SCM port;
-#endif
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p);
- return (SCM_CRDYP (port)
+ return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p)
? SCM_BOOL_T
: SCM_BOOL_F);
}
@@ -247,50 +159,34 @@ scm_ungetc_char_ready_p (port)
/* {Standard Ports}
*/
SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port);
-#ifdef __STDC__
-SCM
-scm_current_input_port (void)
-#else
+
SCM
scm_current_input_port ()
-#endif
{
return scm_cur_inp;
}
SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port);
-#ifdef __STDC__
-SCM
-scm_current_output_port (void)
-#else
+
SCM
scm_current_output_port ()
-#endif
{
return scm_cur_outp;
}
SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port);
-#ifdef __STDC__
-SCM
-scm_current_error_port (void)
-#else
+
SCM
scm_current_error_port ()
-#endif
{
return scm_cur_errp;
}
SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port);
-#ifdef __STDC__
-SCM
-scm_set_current_input_port (SCM port)
-#else
+
SCM
scm_set_current_input_port (port)
SCM port;
-#endif
{
SCM oinp = scm_cur_inp;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port);
@@ -300,14 +196,10 @@ scm_set_current_input_port (port)
SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port);
-#ifdef __STDC__
-SCM
-scm_set_current_output_port (SCM port)
-#else
+
SCM
scm_set_current_output_port (port)
SCM port;
-#endif
{
SCM ooutp = scm_cur_outp;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port);
@@ -317,14 +209,10 @@ scm_set_current_output_port (port)
SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port);
-#ifdef __STDC__
-SCM
-scm_set_current_error_port (SCM port)
-#else
+
SCM
scm_set_current_error_port (port)
SCM port;
-#endif
{
SCM oerrp = scm_cur_errp;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port);
@@ -345,14 +233,10 @@ int scm_port_table_size = 0; /* Number of ports in scm_port_table. */
int scm_port_table_room = 20; /* Size of the array. */
/* Add a port to the table. Call with SCM_DEFER_INTS active. */
-#ifdef __STDC__
-struct scm_port_table *
-scm_add_to_port_table (SCM port)
-#else
+
struct scm_port_table *
scm_add_to_port_table (port)
SCM port;
-#endif
{
if (scm_port_table_size == scm_port_table_room)
{
@@ -377,14 +261,10 @@ scm_add_to_port_table (port)
}
/* Remove a port from the table. Call with SCM_DEFER_INTS active. */
-#ifdef __STDC__
-void
-scm_remove_from_port_table (SCM port)
-#else
+
void
scm_remove_from_port_table (port)
SCM port;
-#endif
{
int i = 0;
while (scm_port_table[i]->port != port)
@@ -401,31 +281,22 @@ scm_remove_from_port_table (port)
scm_port_table_size--;
}
-#ifdef DEBUG
+#ifdef GUILE_DEBUG
/* Undocumented functions for debugging. */
/* Return the number of ports in the table. */
-static char s_pt_size[] = "pt-size";
-#ifdef __STDC__
-SCM
-scm_pt_size (void)
-#else
+
+SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size);
SCM
scm_pt_size ()
-#endif
{
return SCM_MAKINUM (scm_port_table_size);
}
/* Return the ith member of the port table. */
-static char s_pt_member[] = "pt-member";
-#ifdef __STDC__
-SCM
-scm_pt_member (SCM member)
-#else
+SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member);
SCM
scm_pt_member (member)
SCM member;
-#endif
{
int i;
SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member);
@@ -438,18 +309,13 @@ scm_pt_member (member)
#endif
-/* Find a port in the table and return its revealed count. Return -1
- * if the port isn't in the table (should not happen). Also used by
- * the garbage collector.
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
*/
-#ifdef __STDC__
-int
-scm_revealed_count (SCM port)
-#else
+
int
scm_revealed_count (port)
SCM port;
-#endif
{
return SCM_REVEALED(port);
}
@@ -459,57 +325,39 @@ scm_revealed_count (port)
/* Return the revealed count for a port. */
SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed);
-#ifdef __STDC__
-SCM
-scm_port_revealed (SCM port)
-#else
+
SCM
scm_port_revealed (port)
SCM port;
-#endif
{
- int result;
-
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed);
-
- if ((result = scm_revealed_count (port)) == -1)
- return SCM_BOOL_F;
- else
- return SCM_MAKINUM (result);
+ return SCM_MAKINUM (scm_revealed_count (port));
}
/* Set the revealed count for a port. */
SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x);
-#ifdef __STDC__
-SCM
-scm_set_port_revealed_x (SCM port, SCM rcount)
-#else
+
SCM
scm_set_port_revealed_x (port, rcount)
SCM port;
SCM rcount;
-#endif
{
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x);
SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x);
SCM_DEFER_INTS;
SCM_REVEALED (port) = SCM_INUM (rcount);
SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ return SCM_UNSPECIFIED;
}
/* scm_close_port
* Call the close operation on a port object.
*/
SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port);
-#ifdef __STDC__
-SCM
-scm_close_port (SCM port)
-#else
+
SCM
scm_close_port (port)
SCM port;
-#endif
{
scm_sizet i;
SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port);
@@ -520,20 +368,16 @@ scm_close_port (port)
if (scm_ptobs[i].fclose)
SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port)));
scm_remove_from_port_table (port);
- SCM_CAR (port) &= ~SCM_OPN;
+ SCM_SETAND_CAR (port, ~SCM_OPN);
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except);
-#ifdef __STDC__
-SCM
-scm_close_all_ports_except (SCM ports)
-#else
+
SCM
scm_close_all_ports_except (ports)
SCM ports;
-#endif
{
int i = 0;
SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except);
@@ -564,14 +408,10 @@ scm_close_all_ports_except (ports)
}
SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p);
-#ifdef __STDC__
-SCM
-scm_input_port_p (SCM x)
-#else
+
SCM
scm_input_port_p (x)
SCM x;
-#endif
{
if (SCM_IMP (x))
return SCM_BOOL_F;
@@ -579,14 +419,10 @@ scm_input_port_p (x)
}
SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p);
-#ifdef __STDC__
-SCM
-scm_output_port_p (SCM x)
-#else
+
SCM
scm_output_port_p (x)
SCM x;
-#endif
{
if (SCM_IMP (x))
return SCM_BOOL_F;
@@ -595,27 +431,19 @@ scm_output_port_p (x)
SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p);
-#ifdef __STDC__
-SCM
-scm_eof_object_p (SCM x)
-#else
+
SCM
scm_eof_object_p (x)
SCM x;
-#endif
{
return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output);
-#ifdef __STDC__
-SCM
-scm_force_output (SCM port)
-#else
+
SCM
scm_force_output (port)
SCM port;
-#endif
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
@@ -630,18 +458,14 @@ scm_force_output (port)
SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char);
-#ifdef __STDC__
-SCM
-scm_read_char (SCM port)
-#else
+
SCM
scm_read_char (port)
SCM port;
-#endif
{
int c;
if (SCM_UNBNDP (port))
- port = scm_cur_inp;
+ port = scm_cur_inp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char);
c = scm_gen_getc (port);
@@ -652,14 +476,10 @@ scm_read_char (port)
SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char);
-#ifdef __STDC__
-SCM
-scm_peek_char (SCM port)
-#else
+
SCM
scm_peek_char (port)
SCM port;
-#endif
{
int c;
if (SCM_UNBNDP (port))
@@ -674,15 +494,11 @@ scm_peek_char (port)
}
SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char);
-#ifdef __STDC__
-SCM
-scm_unread_char (SCM cobj, SCM port)
-#else
+
SCM
scm_unread_char (cobj, port)
SCM cobj;
SCM port;
-#endif
{
int c;
@@ -702,15 +518,11 @@ scm_unread_char (cobj, port)
-SCM_PROC (s_line_number, "line-number", 0, 1, 0, scm_line_number);
-#ifdef __STDC__
-SCM
-scm_line_number (SCM port)
-#else
+SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line);
+
SCM
-scm_line_number (port)
+scm_port_line (port)
SCM port;
-#endif
{
SCM p;
p = ((port == SCM_UNDEFINED)
@@ -722,15 +534,31 @@ scm_line_number (port)
return SCM_MAKINUM (SCM_LINUM (p));
}
-SCM_PROC (s_column_number, "column-number", 0, 1, 0, scm_column_number);
-#ifdef __STDC__
-SCM
-scm_column_number (SCM port)
-#else
+SCM_PROC (s_set_port_line_x, "set-port-line!", 1, 1, 0, scm_set_port_line_x);
+
+SCM
+scm_set_port_line_x (port, line)
+ SCM port;
+ SCM line;
+{
+ if (line == SCM_UNDEFINED)
+ {
+ line = port;
+ port = scm_cur_inp;
+ }
+ else
+ SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
+ port,
+ SCM_ARG1,
+ s_set_port_line_x);
+ return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
+}
+
+SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column);
+
SCM
-scm_column_number (port)
+scm_port_column (port)
SCM port;
-#endif
{
SCM p;
p = ((port == SCM_UNDEFINED)
@@ -742,16 +570,31 @@ scm_column_number (port)
return SCM_MAKINUM (SCM_COL (p));
}
-/* !!! dubious feature */
-SCM_PROC (s_port_file_name, "port-file-name", 0, 1, 0, scm_port_file_name);
-#ifdef __STDC__
+SCM_PROC (s_set_port_column_x, "set-port-column!", 1, 1, 0, scm_set_port_column_x);
+
SCM
-scm_port_file_name (SCM port)
-#else
+scm_set_port_column_x (port, column)
+ SCM port;
+ SCM column;
+{
+ if (column == SCM_UNDEFINED)
+ {
+ column = port;
+ port = scm_cur_inp;
+ }
+ else
+ SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
+ port,
+ SCM_ARG1,
+ s_set_port_column_x);
+ return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
+}
+
+SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename);
+
SCM
-scm_port_file_name (port)
+scm_port_filename (port)
SCM port;
-#endif
{
SCM p;
p = ((port == SCM_UNDEFINED)
@@ -763,20 +606,36 @@ scm_port_file_name (port)
return SCM_PTAB_ENTRY (p)->file_name;
}
+SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x);
+
+SCM
+scm_set_port_filename_x (port, filename)
+ SCM port;
+ SCM filename;
+{
+ if (filename == SCM_UNDEFINED)
+ {
+ filename = port;
+ port = scm_cur_inp;
+ }
+ else
+ SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
+ port,
+ SCM_ARG1,
+ s_set_port_filename_x);
+ return SCM_PTAB_ENTRY (port)->file_name = filename;
+}
+
#ifndef ttyname
extern char * ttyname();
#endif
-#ifdef __STDC__
-void
-scm_prinport (SCM exp, SCM port, char *type)
-#else
+
void
scm_prinport (exp, port, type)
SCM exp;
SCM port;
char *type;
-#endif
{
scm_gen_puts (scm_regular_string, "#<", port);
if (SCM_CLOSEDP (exp))
@@ -810,13 +669,9 @@ scm_prinport (exp, port, type)
scm_gen_putc ('>', port);
}
-#ifdef __STDC__
-void
-scm_ports_prehistory (void)
-#else
+
void
scm_ports_prehistory ()
-#endif
{
scm_numptob = 0;
scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns));
@@ -875,51 +730,43 @@ write_void_port (ptr, size, nitems, strm)
return len;
}
-#ifdef __STDC__
-static int
-flush_void_port (SCM strm)
-#else
+
+static int flush_void_port SCM_P ((SCM strm));
+
static int
flush_void_port (strm)
SCM strm;
-#endif
{
return 0;
}
-#ifdef __STDC__
-static int
-getc_void_port (SCM strm)
-#else
+
+static int getc_void_port SCM_P ((SCM strm));
+
static int
getc_void_port (strm)
SCM strm;
-#endif
{
return EOF;
}
-#ifdef __STDC__
-static int
-close_void_port (SCM strm)
-#else
+
+static int close_void_port SCM_P ((SCM strm));
+
static int
close_void_port (strm)
SCM strm;
-#endif
{
return 0; /* this is ignored by scm_close_port. */
}
-#ifdef __STDC__
-static int
-noop0 (FILE *stream)
-#else
+
+static int noop0 SCM_P ((SCM stream));
+
static int
noop0 (stream)
- FILE *stream;
-#endif
+ SCM stream;
{
return 0;
}
@@ -941,14 +788,10 @@ static struct scm_ptobfuns void_port_ptob =
-#ifdef __STDC__
-SCM
-scm_void_port (char * mode_str)
-#else
+
SCM
scm_void_port (mode_str)
char * mode_str;
-#endif
{
int mode_bits;
SCM answer;
@@ -958,7 +801,7 @@ scm_void_port (mode_str)
SCM_DEFER_INTS;
mode_bits = scm_mode_bits (mode_str);
pt = scm_add_to_port_table (answer);
- SCM_CAR (answer) = scm_tc16_void_port | mode_bits;
+ SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
SCM_SETPTAB_ENTRY (answer, pt);
SCM_SETSTREAM (answer, SCM_BOOL_F);
SCM_ALLOW_INTS;
@@ -967,14 +810,10 @@ scm_void_port (mode_str)
SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port);
-#ifdef __STDC__
-SCM
-scm_sys_make_void_port (SCM mode)
-#else
+
SCM
scm_sys_make_void_port (mode)
SCM mode;
-#endif
{
SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode,
SCM_ARG1, s_sys_make_void_port);
@@ -986,13 +825,9 @@ scm_sys_make_void_port (mode)
-#ifdef __STDC__
-void
-scm_init_ports (void)
-#else
+
void
scm_init_ports ()
-#endif
{
scm_tc16_void_port = scm_newptob (&void_port_ptob);
#include "ports.x"
diff --git a/libguile/ports.h b/libguile/ports.h
index fac20af77..f89c92be6 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -44,8 +44,7 @@
*/
-#include "__scm.h"
-#include "smob.h"
+#include "libguile/__scm.h"
@@ -72,23 +71,23 @@ struct scm_port_table
*/
SCM stream;
- SCM file_name;
+ SCM file_name; /* debugging support. */
int unchr; /* pushed back character, if any */
- int line_number;
- int column_number;
+ int line_number; /* debugging support. */
+ int column_number; /* debugging support. */
enum scm_port_representation_type representation;
};
extern struct scm_port_table **scm_port_table;
-extern scm_port_table_size; /* Number of ports in scm_port_table. */
+extern int scm_port_table_size; /* Number of ports in scm_port_table. */
/* PORT FLAGS
- * A set of flags caracterizes a port.
+ * A set of flags characterizes a port.
*/
#define SCM_OPN (1L<<16) /* Is the port open? */
#define SCM_RDNG (2L<<16) /* Is it a readable port? */
@@ -116,114 +115,85 @@ extern scm_port_table_size; /* Number of ports in scm_port_table. */
#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent))
#define SCM_STREAM(x) SCM_PTAB_ENTRY(x)->stream
#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = s)
+#define SCM_FILENAME(x) SCM_PTAB_ENTRY(x)->file_name
#define SCM_LINUM(x) SCM_PTAB_ENTRY(x)->line_number
#define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number
#define SCM_REVEALED(x) SCM_PTAB_ENTRY(x)->revealed
#define SCM_SETREVEALED(x,s) (SCM_PTAB_ENTRY(x)->revealed = s)
#define SCM_PORT_REPRESENTATION(x) SCM_PTAB_ENTRY(x)->representation
#define SCM_SET_PORT_REPRESENTATION(x,s) (SCM_PTAB_ENTRY(x)->representation = s)
-#define SCM_CRDYP(port) (SCM_CAR(port) & SCM_CRDY)
-#define SCM_CLRDY(port) {SCM_CAR(port) &= SCM_CUC;}
-#define SCM_SETRDY(port) {SCM_CAR(port) |= SCM_CRDY;}
+#define SCM_CRDYP(port) (SCM_CAR (port) & SCM_CRDY)
+#define SCM_CLRDY(port) {SCM_SETAND_CAR (port, SCM_CUC);}
+#define SCM_SETRDY(port) {SCM_SETOR_CAR (port, SCM_CRDY);}
#define SCM_CUNGET(c,port) {SCM_PTAB_ENTRY(port)->unchr = c; SCM_SETRDY(port);}
#define SCM_CGETUN(port) (SCM_PTAB_ENTRY(port)->unchr)
#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;}
#define SCM_INCCOL(port) {SCM_COL (port) += 1;}
-#define SCM_TABCOL(port) {SCM_COL (port) += (SCM_COL (port) + 1) % 8;}
+#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;}
+typedef struct scm_ptobfuns
+{
+ SCM (*mark) SCM_P ((SCM));
+ int (*free) SCM_P ((SCM));
+ int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+ SCM (*equalp) SCM_P ((SCM, SCM));
+ int (*fputc) SCM_P ((int, SCM stream));
+ int (*fputs) SCM_P ((char *, SCM stream));
+ scm_sizet (*fwrite) SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM stream));
+ int (*fflush) SCM_P ((SCM stream));
+ int (*fgetc) SCM_P ((SCM stream));
+ int (*fclose) SCM_P ((SCM stream));
+} scm_ptobfuns;
+
+#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8))
+
+
+
extern scm_ptobfuns *scm_ptobs;
extern scm_sizet scm_numptob;
extern int scm_port_table_room;
-#ifdef __STDC__
-extern SCM scm_markstream (SCM ptr);
-extern long scm_newptob (scm_ptobfuns *ptob);
-extern void scm_fflush (SCM port);
-extern SCM scm_char_ready_p (SCM port);
-extern SCM scm_ungetc_char_ready_p (SCM port);
-extern SCM scm_current_input_port (void);
-extern SCM scm_current_output_port (void);
-extern SCM scm_current_error_port (void);
-extern SCM scm_set_current_input_port (SCM port);
-extern SCM scm_set_current_output_port (SCM port);
-extern SCM scm_set_current_error_port (SCM port);
-extern struct scm_port_table * scm_add_to_port_table (SCM port);
-extern void scm_remove_from_port_table (SCM port);
-extern SCM scm_pt_size (void);
-extern SCM scm_pt_member (SCM member);
-extern int scm_revealed_count (SCM port);
-extern SCM scm_port_revealed (SCM port);
-extern SCM scm_set_port_revealed_x (SCM port, SCM rcount);
-extern SCM scm_close_port (SCM port);
-extern SCM scm_input_port_p (SCM x);
-extern SCM scm_output_port_p (SCM x);
-extern SCM scm_eof_object_p (SCM x);
-extern SCM scm_force_output (SCM port);
-extern SCM scm_read_char (SCM port);
-extern SCM scm_peek_char (SCM port);
-extern SCM scm_unread_char (SCM cobj, SCM port);
-extern SCM scm_line_number (SCM port);
-extern SCM scm_column_number (SCM port);
-extern SCM scm_port_file_name (SCM port);
-extern void scm_prinport (SCM exp, SCM port, char *type);
-extern void scm_ports_prehistory (void);
-extern SCM scm_void_port (char * mode_str);
-extern SCM scm_sys_make_void_port (SCM mode);
-extern void scm_init_ports (void);
-
-#else /* STDC */
-extern SCM scm_markstream ();
-extern long scm_newptob ();
-extern void scm_fflush ();
-extern SCM scm_char_ready_p ();
-extern SCM scm_ungetc_char_ready_p ();
-extern SCM scm_current_input_port ();
-extern SCM scm_current_output_port ();
-extern SCM scm_current_error_port ();
-extern SCM scm_set_current_input_port ();
-extern SCM scm_set_current_output_port ();
-extern SCM scm_set_current_error_port ();
-extern struct scm_port_table * scm_add_to_port_table ();
-extern void scm_remove_from_port_table ();
-extern SCM scm_pt_size ();
-extern SCM scm_pt_member ();
-extern int scm_revealed_count ();
-extern SCM scm_port_revealed ();
-extern SCM scm_set_port_revealed_x ();
-extern SCM scm_close_port ();
-extern SCM scm_input_port_p ();
-extern SCM scm_output_port_p ();
-extern SCM scm_eof_object_p ();
-extern SCM scm_force_output ();
-extern SCM scm_read_char ();
-extern SCM scm_peek_char ();
-extern SCM scm_unread_char ();
-extern SCM scm_line_number ();
-extern SCM scm_column_number ();
-extern SCM scm_port_file_name ();
-extern void scm_prinport ();
-extern void scm_ports_prehistory ();
-extern SCM scm_void_port ();
-extern SCM scm_sys_make_void_port ();
-extern void scm_init_ports ();
-
-#endif /* STDC */
-
-
-
-
-
-
-
-
-
-
+extern SCM scm_markstream SCM_P ((SCM ptr));
+extern long scm_newptob SCM_P ((scm_ptobfuns *ptob));
+extern void scm_fflush SCM_P ((SCM port));
+extern SCM scm_char_ready_p SCM_P ((SCM port));
+extern SCM scm_current_input_port SCM_P ((void));
+extern SCM scm_current_output_port SCM_P ((void));
+extern SCM scm_current_error_port SCM_P ((void));
+extern SCM scm_set_current_input_port SCM_P ((SCM port));
+extern SCM scm_set_current_output_port SCM_P ((SCM port));
+extern SCM scm_set_current_error_port SCM_P ((SCM port));
+extern struct scm_port_table * scm_add_to_port_table SCM_P ((SCM port));
+extern void scm_remove_from_port_table SCM_P ((SCM port));
+extern SCM scm_pt_size SCM_P ((void));
+extern SCM scm_pt_member SCM_P ((SCM member));
+extern int scm_revealed_count SCM_P ((SCM port));
+extern SCM scm_port_revealed SCM_P ((SCM port));
+extern SCM scm_set_port_revealed_x SCM_P ((SCM port, SCM rcount));
+extern SCM scm_close_port SCM_P ((SCM port));
+extern SCM scm_close_all_ports_except SCM_P ((SCM ports));
+extern SCM scm_input_port_p SCM_P ((SCM x));
+extern SCM scm_output_port_p SCM_P ((SCM x));
+extern SCM scm_eof_object_p SCM_P ((SCM x));
+extern SCM scm_force_output SCM_P ((SCM port));
+extern SCM scm_read_char SCM_P ((SCM port));
+extern SCM scm_peek_char SCM_P ((SCM port));
+extern SCM scm_unread_char SCM_P ((SCM cobj, SCM port));
+extern SCM scm_port_line SCM_P ((SCM port));
+extern SCM scm_port_column SCM_P ((SCM port));
+extern SCM scm_port_filename SCM_P ((SCM port));
+extern SCM scm_set_port_filename_x SCM_P ((SCM port, SCM filename));
+extern void scm_prinport SCM_P ((SCM exp, SCM port, char *type));
+extern void scm_ports_prehistory SCM_P ((void));
+extern SCM scm_void_port SCM_P ((char * mode_str));
+extern SCM scm_sys_make_void_port SCM_P ((SCM mode));
+extern void scm_init_ports SCM_P ((void));
#endif /* PORTSH */
diff --git a/libguile/posix.c b/libguile/posix.c
index 11136be1d..b511179c1 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -42,9 +42,16 @@
#include <stdio.h>
#include "_scm.h"
+#include "fports.h"
+#include "scmsigs.h"
+#include "feature.h"
+#include "posix.h"
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
@@ -58,12 +65,21 @@
#ifdef HAVE_UNISTD_H
#include <unistd.h>
+#else
+#ifndef ttyname
+extern char *ttyname();
+#endif
+#endif
+
+#ifdef LIBC_H_WITH_UNISTD_H
+#include <libc.h>
#endif
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
#endif
+#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
@@ -98,7 +114,6 @@
#endif /* no FD_SET */
-extern char *ttyname ();
extern FILE *popen ();
extern char ** environ;
@@ -122,43 +137,72 @@ extern char ** environ;
# endif
#endif
-char *strptime ();
-
#ifdef HAVE_SETLOCALE
#include <locale.h>
#endif
+/* Some Unix systems don't define these. CPP hair is dangerous, but
+ this seems safe enough... */
+#ifndef R_OK
+#define R_OK 4
+#endif
+
+#ifndef W_OK
+#define W_OK 2
+#endif
+
+#ifndef X_OK
+#define X_OK 1
+#endif
+
+#ifndef F_OK
+#define F_OK 0
+#endif
+
+/* On NextStep, <utime.h> doesn't define struct utime, unless we
+ #define _POSIX_SOURCE before #including it. I think this is less
+ of a kludge than defining struct utimbuf ourselves. */
+#ifdef UTIMBUF_NEEDS_POSIX
+#define _POSIX_SOURCE
+#endif
+
+#ifdef HAVE_SYS_UTIME_H
+#include <sys/utime.h>
+#endif
+
+#ifdef HAVE_UTIME_H
+#include <utime.h>
+#endif
+
+/* Please don't add any more #includes or #defines here. The hack
+ above means that _POSIX_SOURCE may be #defined, which will
+ encourage header files to do strange things. */
-SCM_PROC (s_sys_pipe, "%pipe", 0, 0, 0, scm_sys_pipe);
-#ifdef __STDC__
-SCM
-scm_sys_pipe (void)
-#else
+SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe);
+
SCM
-scm_sys_pipe ()
-#endif
+scm_pipe ()
{
int fd[2], rv;
FILE *f_rd, *f_wt;
SCM p_rd, p_wt;
+ struct scm_port_table * ptr;
+ struct scm_port_table * ptw;
+
SCM_NEWCELL (p_rd);
SCM_NEWCELL (p_wt);
rv = pipe (fd);
if (rv)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_pipe);
f_rd = fdopen (fd[0], "r");
if (!f_rd)
{
SCM_SYSCALL (close (fd[0]));
SCM_SYSCALL (close (fd[1]));
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ scm_syserror (s_pipe);
}
f_wt = fdopen (fd[1], "w");
if (!f_wt)
@@ -167,54 +211,46 @@ scm_sys_pipe ()
en = errno;
fclose (f_rd);
SCM_SYSCALL (close (fd[1]));
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (en);
- }
- {
- struct scm_port_table * ptr;
- struct scm_port_table * ptw;
-
- ptr = scm_add_to_port_table (p_rd);
- ptw = scm_add_to_port_table (p_wt);
- SCM_SETPTAB_ENTRY (p_rd, ptr);
- SCM_SETPTAB_ENTRY (p_wt, ptw);
- SCM_CAR (p_rd) = scm_tc16_fport | scm_mode_bits ("r");
- SCM_CAR (p_wt) = scm_tc16_fport | scm_mode_bits ("w");
- SCM_SETSTREAM (p_rd, (SCM)f_rd);
- SCM_SETSTREAM (p_wt, (SCM)f_wt);
+ errno = en;
+ scm_syserror (s_pipe);
}
+ ptr = scm_add_to_port_table (p_rd);
+ ptw = scm_add_to_port_table (p_wt);
+ SCM_SETPTAB_ENTRY (p_rd, ptr);
+ SCM_SETPTAB_ENTRY (p_wt, ptw);
+ SCM_SETCAR (p_rd, scm_tc16_fport | scm_mode_bits ("r"));
+ SCM_SETCAR (p_wt, scm_tc16_fport | scm_mode_bits ("w"));
+ SCM_SETSTREAM (p_rd, (SCM)f_rd);
+ SCM_SETSTREAM (p_wt, (SCM)f_wt);
+
SCM_ALLOW_INTS;
return scm_cons (p_rd, p_wt);
}
-SCM_PROC (s_sys_getgroups, "%getgroups", 0, 0, 0, scm_sys_getgroups);
-#ifdef __STDC__
-SCM
-scm_sys_getgroups(void)
-#else
+SCM_PROC (s_getgroups, "getgroups", 0, 0, 0, scm_getgroups);
+
SCM
-scm_sys_getgroups()
-#endif
+scm_getgroups()
{
SCM grps, ans;
int ngroups = getgroups (0, NULL);
- if (!ngroups) return SCM_BOOL_F;
+ if (!ngroups)
+ scm_syserror (s_getgroups);
SCM_NEWCELL(grps);
SCM_DEFER_INTS;
{
GETGROUPS_T *groups;
int val;
- groups = (gid_t *)scm_must_malloc(ngroups * sizeof(GETGROUPS_T),
- s_sys_getgroups);
+ groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T),
+ s_getgroups);
val = getgroups(ngroups, groups);
if (val < 0)
{
scm_must_free((char *)groups);
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
+ scm_syserror (s_getgroups);
}
SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */
SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string);
@@ -228,15 +264,11 @@ scm_sys_getgroups()
-SCM_PROC (s_sys_getpwuid, "%getpw", 0, 1, 0, scm_sys_getpwuid);
-#ifdef __STDC__
-SCM
-scm_sys_getpwuid (SCM user)
-#else
+SCM_PROC (s_getpwuid, "getpw", 0, 1, 0, scm_getpwuid);
+
SCM
-scm_sys_getpwuid (user)
+scm_getpwuid (user)
SCM user;
-#endif
{
SCM result;
struct passwd *entry;
@@ -256,17 +288,15 @@ scm_sys_getpwuid (user)
}
else
{
- SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_sys_getpwuid);
+ SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid);
if (SCM_SUBSTRP (user))
user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0);
SCM_DEFER_INTS;
entry = getpwnam (SCM_ROCHARS (user));
}
if (!entry)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_getpwuid);
+
ve[0] = scm_makfrom0str (entry->pw_name);
ve[1] = scm_makfrom0str (entry->pw_passwd);
ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid);
@@ -287,14 +317,10 @@ scm_sys_getpwuid (user)
SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent);
-#ifdef __STDC__
-SCM
-scm_setpwent (SCM arg)
-#else
+
SCM
scm_setpwent (arg)
SCM arg;
-#endif
{
if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
endpwent ();
@@ -306,15 +332,11 @@ scm_setpwent (arg)
/* Combines getgrgid and getgrnam. */
-SCM_PROC (s_sys_getgrgid, "%getgr", 0, 1, 0, scm_sys_getgrgid);
-#ifdef __STDC__
-SCM
-scm_sys_getgrgid (SCM name)
-#else
+SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid);
+
SCM
-scm_sys_getgrgid (name)
+scm_getgrgid (name)
SCM name;
-#endif
{
SCM result;
struct group *entry;
@@ -328,16 +350,13 @@ scm_sys_getgrgid (name)
SCM_SYSCALL (entry = getgrgid (SCM_INUM (name)));
else
{
- SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, SCM_ARG1, s_sys_getgrgid);
- if (SCM_SUBSTRP (name))
- name = scm_makfromstr (SCM_ROCHARS (name), SCM_ROLENGTH (name), 0);
- SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name)));
+ SCM_ASSERT (SCM_NIMP (name) && SCM_ROSTRINGP (name), name, SCM_ARG1,
+ s_getgrgid);
+ SCM_SYSCALL (entry = getgrnam (SCM_ROCHARS (name)));
}
if (!entry)
- {
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
- }
+ scm_syserror (s_getgrgid);
+
ve[0] = scm_makfrom0str (entry->gr_name);
ve[1] = scm_makfrom0str (entry->gr_passwd);
ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid);
@@ -349,14 +368,10 @@ scm_sys_getgrgid (name)
SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent);
-#ifdef __STDC__
-SCM
-scm_setgrent (SCM arg)
-#else
+
SCM
scm_setgrent (arg)
SCM arg;
-#endif
{
if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
endgrent ();
@@ -367,66 +382,108 @@ scm_setgrent (arg)
-SCM_PROC (s_sys_kill, "%kill", 2, 0, 0, scm_sys_kill);
-#ifdef __STDC__
-SCM
-scm_sys_kill (SCM pid, SCM sig)
-#else
+SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill);
+
SCM
-scm_sys_kill (pid, sig)
+scm_kill (pid, sig)
SCM pid;
SCM sig;
-#endif
{
- int i;
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_kill);
- SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_sys_kill);
+ SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill);
+ SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill);
/* Signal values are interned in scm_init_posix(). */
- SCM_SYSCALL (i = kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)));
- return i ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
+ scm_syserror (s_kill);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_waitpid, "%waitpid", 1, 1, 0, scm_sys_waitpid);
-#ifdef __STDC__
-SCM
-scm_sys_waitpid (SCM pid, SCM options)
-#else
+SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid);
+
SCM
-scm_sys_waitpid (pid, options)
+scm_waitpid (pid, options)
SCM pid;
SCM options;
-#endif
{
+#ifdef HAVE_WAITPID
int i;
int status;
int ioptions;
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_waitpid);
+ SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid);
if (SCM_UNBNDP (options))
ioptions = 0;
else
{
- SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_sys_waitpid);
+ SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_waitpid);
/* Flags are interned in scm_init_posix. */
ioptions = SCM_INUM (options);
}
SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions));
- return ((i == -1)
- ? SCM_MAKINUM (errno)
- : scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status)));
+ if (i == -1)
+ scm_syserror (s_waitpid);
+ return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
+#else
+ scm_sysmissing (s_waitpid);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
+SCM_PROC (s_status_exit_val, "status:exit-val", 1, 0, 0, scm_status_exit_val);
+SCM
+scm_status_exit_val (status)
+ SCM status;
+{
+ int lstatus;
+ SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_exit_val);
+
+ /* On Ultrix, the WIF... macros assume their argument is an lvalue;
+ go figure. SCM_INUM does not yield an lvalue. */
+ lstatus = SCM_INUM (status);
+ if (WIFEXITED (lstatus))
+ return (SCM_MAKINUM (WEXITSTATUS (lstatus)));
+ else
+ return SCM_BOOL_F;
+}
+
+SCM_PROC (s_status_term_sig, "status:term-sig", 1, 0, 0, scm_status_term_sig);
+SCM
+scm_status_term_sig (status)
+ SCM status;
+{
+ int lstatus;
+
+ SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_term_sig);
+
+ lstatus = SCM_INUM (status);
+ if (WIFSIGNALED (lstatus))
+ return SCM_MAKINUM (WTERMSIG (lstatus));
+ else
+ return SCM_BOOL_F;
+}
+
+SCM_PROC (s_status_stop_sig, "status:stop-sig", 1, 0, 0, scm_status_stop_sig);
+SCM
+scm_status_stop_sig (status)
+ SCM status;
+{
+ int lstatus;
+
+ SCM_ASSERT (SCM_INUMP (status), status, SCM_ARG1,s_status_stop_sig);
+
+ lstatus = SCM_INUM (status);
+ if (WIFSTOPPED (lstatus))
+ return SCM_MAKINUM (WSTOPSIG (lstatus));
+ else
+ return SCM_BOOL_F;
+}
SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid);
-#ifdef __STDC__
-SCM
-scm_getppid (void)
-#else
+
SCM
scm_getppid ()
-#endif
{
return SCM_MAKINUM (0L + getppid ());
}
@@ -434,13 +491,9 @@ scm_getppid ()
SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid);
-#ifdef __STDC__
-SCM
-scm_getuid (void)
-#else
+
SCM
scm_getuid ()
-#endif
{
return SCM_MAKINUM (0L + getuid ());
}
@@ -448,13 +501,9 @@ scm_getuid ()
SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid);
-#ifdef __STDC__
-SCM
-scm_getgid (void)
-#else
+
SCM
scm_getgid ()
-#endif
{
return SCM_MAKINUM (0L + getgid ());
}
@@ -462,13 +511,9 @@ scm_getgid ()
SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid);
-#ifdef __STDC__
-SCM
-scm_geteuid (void)
-#else
+
SCM
scm_geteuid ()
-#endif
{
#ifdef HAVE_GETEUID
return SCM_MAKINUM (0L + geteuid ());
@@ -480,13 +525,9 @@ scm_geteuid ()
SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid);
-#ifdef __STDC__
-SCM
-scm_getegid (void)
-#else
+
SCM
scm_getegid ()
-#endif
{
#ifdef HAVE_GETEUID
return SCM_MAKINUM (0L + getegid ());
@@ -496,68 +537,67 @@ scm_getegid ()
}
-SCM_PROC (s_sys_setuid, "%setuid", 1, 0, 0, scm_sys_setuid);
-#ifdef __STDC__
-SCM
-scm_sys_setuid (SCM id)
-#else
+SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid);
+
SCM
-scm_sys_setuid (id)
+scm_setuid (id)
SCM id;
-#endif
{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setuid);
- return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid);
+ if (setuid (SCM_INUM (id)) != 0)
+ scm_syserror (s_setuid);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_setgid, "%setgid", 1, 0, 0, scm_sys_setgid);
-#ifdef __STDC__
-SCM
-scm_sys_setgid (SCM id)
-#else
+SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid);
+
SCM
-scm_sys_setgid (id)
+scm_setgid (id)
SCM id;
-#endif
{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setgid);
- return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid);
+ if (setgid (SCM_INUM (id)) != 0)
+ scm_syserror (s_setgid);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_seteuid, "%seteuid", 1, 0, 0, scm_sys_seteuid);
-#ifdef __STDC__
-SCM
-scm_sys_seteuid (SCM id)
-#else
+SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid);
+
SCM
-scm_sys_seteuid (id)
+scm_seteuid (id)
SCM id;
-#endif
{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_seteuid);
+ int rv;
+
+ SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid);
#ifdef HAVE_SETEUID
- return seteuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ rv = seteuid (SCM_INUM (id));
#else
- return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ rv = setuid (SCM_INUM (id));
#endif
+ if (rv != 0)
+ scm_syserror (s_seteuid);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_setegid, "%setegid", 1, 0, 0, scm_sys_setegid);
-#ifdef __STDC__
-SCM
-scm_sys_setegid (SCM id)
-#else
+SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid);
+
SCM
-scm_sys_setegid (id)
+scm_setegid (id)
SCM id;
-#endif
{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setegid);
+ int rv;
+
+ SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid);
#ifdef HAVE_SETEUID
- return setegid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ rv = setegid (SCM_INUM (id));
#else
- return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ rv = setgid (SCM_INUM (id));
#endif
+ if (rv != 0)
+ scm_syserror (s_setegid);
+ return SCM_UNSPECIFIED;
+
}
SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp);
@@ -565,42 +605,50 @@ SCM
scm_getpgrp ()
{
int (*fn)();
- fn = getpgrp;
+ fn = (int (*) ()) getpgrp;
return SCM_MAKINUM (fn (0));
}
-SCM_PROC (s_setpgid, "%setpgid", 2, 0, 0, scm_setpgid);
+SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid);
SCM
scm_setpgid (pid, pgid)
SCM pid, pgid;
{
+#ifdef HAVE_SETPGID
SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid);
SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid);
- /* This may be known as setpgrp, from BSD. */
- return setpgid (SCM_INUM (pid), SCM_INUM (pgid)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ /* FIXME(?): may be known as setpgrp. */
+ if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
+ scm_syserror (s_setpgid);
+ return SCM_UNSPECIFIED;
+#else
+ scm_sysmissing (s_setpgid);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
-SCM_PROC (s_setsid, "%setsid", 0, 0, 0, scm_setsid);
+SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid);
SCM
scm_setsid ()
{
+#ifdef HAVE_SETSID
pid_t sid = setsid ();
- return (sid == -1) ? SCM_BOOL_F : SCM_MAKINUM (sid);
+ if (sid == -1)
+ scm_syserror (s_setsid);
+ return SCM_UNSPECIFIED;
+#else
+ scm_sysmissing (s_setsid);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
-#ifndef ttyname
-extern char * ttyname();
-#endif
+SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname);
-SCM_PROC (s_ttyname, "%ttyname", 1, 0, 0, scm_ttyname);
-#ifdef __STDC__
-SCM
-scm_ttyname (SCM port)
-#else
SCM
scm_ttyname (port)
SCM port;
-#endif
{
char *ans;
int fd;
@@ -608,62 +656,79 @@ scm_ttyname (port)
if (scm_tc16_fport != SCM_TYP16 (port))
return SCM_BOOL_F;
fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd != -1)
- SCM_SYSCALL (ans = ttyname (fd));
+ if (fd == -1)
+ scm_syserror (s_ttyname);
+ SCM_SYSCALL (ans = ttyname (fd));
+ if (!ans)
+ scm_syserror (s_ttyname);
/* ans could be overwritten by another call to ttyname */
- return (((fd != -1) && ans)
- ? scm_makfrom0str (ans)
- : SCM_MAKINUM (errno));
+ return (scm_makfrom0str (ans));
}
-SCM_PROC (s_ctermid, "%ctermid", 0, 0, 0, scm_ctermid);
+SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid);
SCM
scm_ctermid ()
{
+#ifdef HAVE_CTERMID
char *result = ctermid (NULL);
- return *result == '\0' ? SCM_BOOL_F : scm_makfrom0str (result);
+ if (*result == '\0')
+ scm_syserror (s_ctermid);
+ return scm_makfrom0str (result);
+#else
+ scm_sysmissing (s_ctermid);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
-SCM_PROC (s_tcgetpgrp, "%tcgetpgrp", 1, 0, 0, scm_tcgetpgrp);
+SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp);
SCM
scm_tcgetpgrp (port)
SCM port;
{
+#ifdef HAVE_TCGETPGRP
int fd;
pid_t pgid;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp);
fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1)
- return SCM_BOOL_F;
- else
- return SCM_MAKINUM (pgid);
+ scm_syserror (s_tcgetpgrp);
+ return SCM_MAKINUM (pgid);
+#else
+ scm_sysmissing (s_tcgetpgrp);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
-SCM_PROC (s_tcsetpgrp, "%tcsetpgrp", 2, 0, 0, scm_tcsetpgrp);
+SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp);
SCM
scm_tcsetpgrp (port, pgid)
SCM port, pgid;
{
+#ifdef HAVE_TCSETPGRP
int fd;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp);
SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp);
fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
- return SCM_BOOL_F;
- else
- return SCM_BOOL_T;
+ scm_syserror (s_tcsetpgrp);
+ return SCM_UNSPECIFIED;
+#else
+ scm_sysmissing (s_tcsetpgrp);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
/* Copy exec args from an SCM vector into a new C array. */
-#ifdef __STDC__
-static char **
-scm_convert_exec_args (SCM args)
-#else
+
+static char ** scm_convert_exec_args SCM_P ((SCM args));
+
static char **
scm_convert_exec_args (args)
SCM args;
-#endif
{
char **execargv;
int num_args;
@@ -677,8 +742,8 @@ scm_convert_exec_args (args)
scm_sizet len;
char *dst;
char *src;
- SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), SCM_CAR (args),
- "wrong type in SCM_ARG", "exec arg");
+ SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)),
+ SCM_CAR (args), "wrong type in SCM_ARG", "exec arg");
len = 1 + SCM_ROLENGTH (SCM_CAR (args));
dst = (char *) scm_must_malloc ((long) len, s_ttyname);
src = SCM_ROCHARS (SCM_CAR (args));
@@ -691,106 +756,94 @@ scm_convert_exec_args (args)
return execargv;
}
-SCM_PROC (s_sys_execl, "%execl", 0, 0, 1, scm_sys_execl);
-#ifdef __STDC__
-SCM
-scm_sys_execl (SCM args)
-#else
+SCM_PROC (s_execl, "execl", 0, 0, 1, scm_execl);
+
SCM
-scm_sys_execl (args)
+scm_execl (args)
SCM args;
-#endif
{
char **execargv;
SCM filename = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_execl);
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execl);
if (SCM_SUBSTRP (filename))
filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
args = SCM_CDR (args);
execargv = scm_convert_exec_args (args);
execv (SCM_ROCHARS (filename), execargv);
- return SCM_MAKINUM (errno);
+ scm_syserror (s_execl);
+ /* not reached. */
+ return SCM_BOOL_F;
}
-SCM_PROC (s_sys_execlp, "%execlp", 0, 0, 1, scm_sys_execlp);
-#ifdef __STDC__
-SCM
-scm_sys_execlp (SCM args)
-#else
+SCM_PROC (s_execlp, "execlp", 0, 0, 1, scm_execlp);
+
SCM
-scm_sys_execlp (args)
+scm_execlp (args)
SCM args;
-#endif
{
char **execargv;
SCM filename = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_execlp);
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
+ SCM_ARG1, s_execlp);
if (SCM_SUBSTRP (filename))
- filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
+ filename = scm_makfromstr (SCM_ROCHARS (filename),
+ SCM_ROLENGTH (filename), 0);
args = SCM_CDR (args);
execargv = scm_convert_exec_args (args);
execvp (SCM_ROCHARS (filename), execargv);
- return SCM_MAKINUM (errno);
+ scm_syserror (s_execlp);
+ /* not reached. */
+ return SCM_BOOL_F;
}
-/* Flushing streams etc., is not done here. */
-SCM_PROC (s_sys_fork, "%fork", 0, 0, 0, scm_sys_fork);
-#ifdef __STDC__
-SCM
-scm_sys_fork(void)
-#else
+SCM_PROC (s_fork, "primitive-fork", 0, 0, 0, scm_fork);
+
SCM
-scm_sys_fork()
-#endif
+scm_fork()
{
- pid_t pid;
+ int pid;
pid = fork ();
if (pid == -1)
- return SCM_BOOL_F;
- else
- return SCM_MAKINUM (0L+pid);
+ scm_syserror (s_fork);
+ return SCM_MAKINUM (0L+pid);
}
-SCM_PROC (s_sys_uname, "%uname", 0, 0, 0, scm_sys_uname);
-#ifdef __STDC__
-SCM
-scm_sys_uname (void)
-#else
+SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname);
+
SCM
-scm_sys_uname ()
-#endif
+scm_uname ()
{
#ifdef HAVE_UNAME
struct utsname buf;
SCM ans = scm_make_vector(SCM_MAKINUM(5), SCM_UNSPECIFIED, SCM_BOOL_F);
SCM *ve = SCM_VELTS (ans);
+ SCM_DEFER_INTS;
if (uname (&buf))
- return SCM_MAKINUM (errno);
+ scm_syserror (s_uname);
ve[0] = scm_makfrom0str (buf.sysname);
ve[1] = scm_makfrom0str (buf.nodename);
ve[2] = scm_makfrom0str (buf.release);
ve[3] = scm_makfrom0str (buf.version);
ve[4] = scm_makfrom0str (buf.machine);
/*
- FIXME
+ a linux special?
ve[5] = scm_makfrom0str (buf.domainname);
*/
+ SCM_ALLOW_INTS;
return ans;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_uname);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ);
-#ifdef __STDC__
-SCM
-scm_environ (SCM env)
-#else
+
SCM
scm_environ (env)
SCM env;
-#endif
{
if (SCM_UNBNDP (env))
return scm_makfromstrs (-1, environ);
@@ -802,17 +855,20 @@ scm_environ (env)
SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
env, SCM_ARG1, s_environ);
num_strings = scm_ilength (env);
- new_environ = (char **) scm_must_malloc ((num_strings + 1)
- * sizeof (char *),
- s_environ);
+ new_environ = (char **) malloc ((num_strings + 1) * sizeof (char *));
+ if (new_environ == NULL)
+ scm_memory_error (s_environ);
while (SCM_NNULLP (env))
{
int len;
char *src;
- SCM_ASSERT (SCM_NIMP (SCM_CAR (env)) && SCM_ROSTRINGP (SCM_CAR (env)), env, SCM_ARG1,
- s_environ);
+ SCM_ASSERT (SCM_NIMP (SCM_CAR (env))
+ && SCM_ROSTRINGP (SCM_CAR (env)),
+ env, SCM_ARG1, s_environ);
len = 1 + SCM_ROLENGTH (SCM_CAR (env));
- new_environ[i] = scm_must_malloc ((long) len, s_environ);
+ new_environ[i] = malloc ((long) len);
+ if (new_environ[i] == NULL)
+ scm_memory_error (s_environ);
src = SCM_ROCHARS (SCM_CAR (env));
while (len--)
new_environ[i][len] = src[len];
@@ -829,8 +885,8 @@ scm_environ (env)
if (!first)
{
for (ep = environ; *ep != NULL; ep++)
- scm_must_free (*ep);
- scm_must_free ((char *) environ);
+ free (*ep);
+ free ((char *) environ);
}
first = 0;
}
@@ -839,24 +895,36 @@ scm_environ (env)
}
}
+#ifdef L_tmpnam
+
+SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam);
+
+SCM scm_tmpnam()
+{
+ char name[L_tmpnam];
+ SCM_SYSCALL (tmpnam (name););
+ return scm_makfrom0str (name);
+}
+#endif
SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe);
-#ifdef __STDC__
-SCM
-scm_open_pipe (SCM pipestr, SCM modes)
-#else
+
SCM
scm_open_pipe (pipestr, modes)
SCM pipestr;
SCM modes;
-#endif
{
FILE *f;
register SCM z;
- SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe);
+ struct scm_port_table * pt;
+
+ SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr,
+ SCM_ARG1, s_open_pipe);
if (SCM_SUBSTRP (pipestr))
- pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_pipe);
+ pipestr = scm_makfromstr (SCM_ROCHARS (pipestr),
+ SCM_ROLENGTH (pipestr), 0);
+ SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
+ s_open_pipe);
if (SCM_SUBSTRP (modes))
modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
SCM_NEWCELL (z);
@@ -865,280 +933,117 @@ scm_open_pipe (pipestr, modes)
SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes)));
scm_unignore_signals ();
if (!f)
- z = SCM_BOOL_F;
- else
- {
- struct scm_port_table * pt;
- pt = scm_add_to_port_table (z);
- SCM_SETPTAB_ENTRY (z, pt);
- SCM_CAR (z) = scm_tc16_pipe | SCM_OPN | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG);
- SCM_SETSTREAM (z, (SCM)f);
- }
+ scm_syserror (s_open_pipe);
+ pt = scm_add_to_port_table (z);
+ SCM_SETPTAB_ENTRY (z, pt);
+ SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN
+ | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG));
+ SCM_SETSTREAM (z, (SCM)f);
SCM_ALLOW_INTS;
return z;
}
+SCM_PROC (s_close_pipe, "close-pipe", 1, 0, 0, scm_close_pipe);
-SCM_PROC (s_open_input_pipe, "open-input-pipe", 1, 0, 0, scm_open_input_pipe);
-#ifdef __STDC__
-SCM
-scm_open_input_pipe(SCM pipestr)
-#else
-SCM
-scm_open_input_pipe(pipestr)
- SCM pipestr;
-#endif
+SCM
+scm_close_pipe (port)
+ SCM port;
{
- return scm_open_pipe(pipestr, scm_makfromstr("r", (sizeof "r")-1, 0));
-}
+ int rv;
-SCM_PROC (s_open_output_pipe, "open-output-pipe", 1, 0, 0, scm_open_output_pipe);
-#ifdef __STDC__
-SCM
-scm_open_output_pipe(SCM pipestr)
-#else
-SCM
-scm_open_output_pipe(pipestr)
- SCM pipestr;
-#endif
-{
- return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0));
+ SCM_ASSERT (SCM_NIMP (port) && SCM_TYP16(port) == scm_tc16_pipe
+ && SCM_OPENP (port), port, SCM_ARG1, s_close_pipe);
+ SCM_DEFER_INTS;
+ rv = pclose ((FILE *) SCM_STREAM (port));
+ if (rv == -1)
+ scm_syserror (s_close_pipe);
+ SCM_ALLOW_INTS;
+ return SCM_MAKINUM (rv);
}
+SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime);
-#ifdef __EMX__
-#include <sys/utime.h>
-#else
-#include <utime.h>
-#endif
-
-SCM_PROC (s_sys_utime, "%utime", 1, 2, 0, scm_sys_utime);
-#ifdef __STDC__
SCM
-scm_sys_utime (SCM pathname, SCM actime, SCM modtime)
-#else
-SCM
-scm_sys_utime (pathname, actime, modtime)
+scm_utime (pathname, actime, modtime)
SCM pathname;
SCM actime;
SCM modtime;
-#endif
{
int rv;
struct utimbuf utm_tmp;
- SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname, SCM_ARG1, s_sys_utime);
+ SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname,
+ SCM_ARG1, s_utime);
if (SCM_UNBNDP (actime))
SCM_SYSCALL (time (&utm_tmp.actime));
else
- utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_sys_utime);
+ utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime);
if (SCM_UNBNDP (modtime))
SCM_SYSCALL (time (&utm_tmp.modtime));
else
- utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_sys_utime);
+ utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime);
SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp));
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (rv != 0)
+ scm_syserror (s_utime);
+ return SCM_UNSPECIFIED;
}
+SCM_PROC (s_access, "access?", 2, 0, 0, scm_access);
-
-
-
-SCM_PROC (s_sys_access, "access?", 2, 0, 0, scm_sys_access);
-#ifdef __STDC__
-SCM
-scm_sys_access (SCM path, SCM how)
-#else
SCM
-scm_sys_access (path, how)
+scm_access (path, how)
SCM path;
SCM how;
-#endif
{
int rv;
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_access);
+ SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
+ s_access);
if (SCM_SUBSTRP (path))
path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
- SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_sys_access);
+ SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_access);
rv = access (SCM_ROCHARS (path), SCM_INUM (how));
return rv ? SCM_BOOL_F : SCM_BOOL_T;
}
-
-
SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid);
-#ifdef __STDC__
-SCM
-scm_getpid (void)
-#else
+
SCM
scm_getpid ()
-#endif
{
return SCM_MAKINUM ((unsigned long) getpid ());
}
+SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv);
-SCM_PROC (s_sys_putenv, "%putenv", 1, 0, 0, scm_sys_putenv);
-#ifdef __STDC__
SCM
-scm_sys_putenv (SCM str)
-#else
-SCM
-scm_sys_putenv (str)
+scm_putenv (str)
SCM str;
-#endif
{
-#ifdef HAVE_PUTENV
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_putenv);
- return putenv (SCM_CHARS (str)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
-#else
- return SCM_MAKINUM (ENOSYS);
-#endif
-}
-
-
-SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line);
-#ifdef __STDC__
-SCM
-scm_read_line (SCM port, SCM include_terminator)
-#else
-SCM
-scm_read_line (port, include_terminator)
- SCM port;
- SCM include_terminator;
-#endif
-{
- register int c;
- register int j = 0;
- scm_sizet len = 30;
- SCM tok_buf;
- register char *p;
- int include;
-
- tok_buf = scm_makstr ((long) len, 0);
- p = SCM_CHARS (tok_buf);
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_line);
-
- if (SCM_UNBNDP (include_terminator))
- include = 0;
- else
- include = SCM_NFALSEP (include_terminator);
-
- if (EOF == (c = scm_gen_getc (port)))
- return SCM_EOF_VAL;
- while (1)
- {
- switch (c)
- {
- case SCM_LINE_INCREMENTORS:
- if (j >= len)
- {
- p = scm_grow_tok_buf (&tok_buf);
- len = SCM_LENGTH (tok_buf);
- }
- p[j++] = c;
- /* fallthrough */
- case EOF:
- if (len == j)
- return tok_buf;
- return scm_vector_set_length_x (tok_buf, (SCM) SCM_MAKINUM (j));
-
- default:
- if (j >= len)
- {
- p = scm_grow_tok_buf (&tok_buf);
- len = SCM_LENGTH (tok_buf);
- }
- p[j++] = c;
- c = scm_gen_getc (port);
- break;
- }
- }
-}
-
-
-
-SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x);
-#ifdef __STDC__
-SCM
-scm_read_line_x (SCM str, SCM port)
-#else
-SCM
-scm_read_line_x (str, port)
- SCM str;
- SCM port;
-#endif
-{
- register int c;
- register int j = 0;
- register char *p;
- scm_sizet len;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_read_line_x);
- p = SCM_CHARS (str);
- len = SCM_LENGTH (str);
- if SCM_UNBNDP
- (port) port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_read_line_x);
- c = scm_gen_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- while (1)
- {
- switch (c)
- {
- case SCM_LINE_INCREMENTORS:
- case EOF:
- return SCM_MAKINUM (j);
- default:
- if (j >= len)
- {
- scm_gen_ungetc (c, port);
- return SCM_BOOL_F;
- }
- p[j++] = c;
- c = scm_gen_getc (port);
- }
- }
-}
-
-
-
-SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
-#ifdef __STDC__
-SCM
-scm_write_line (SCM obj, SCM port)
-#else
-SCM
-scm_write_line (obj, port)
- SCM obj;
- SCM port;
-#endif
-{
- scm_display (obj, port);
- return scm_newline (port);
+ int rv;
+ char *ptr;
+
+ SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_putenv);
+ /* must make a new copy to be left in the environment, safe from gc. */
+ ptr = malloc (SCM_LENGTH (str) + 1);
+ if (ptr == NULL)
+ scm_memory_error (s_putenv);
+ strcpy (ptr, SCM_CHARS (str));
+ rv = putenv (ptr);
+ if (rv < 0)
+ scm_syserror (s_putenv);
+ return SCM_UNSPECIFIED;
}
+SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale);
-
-SCM_PROC (s_setlocale, "%setlocale", 1, 1, 0, scm_setlocale);
-#ifdef __STDC__
-SCM
-scm_setlocale (SCM category, SCM locale)
-#else
SCM
scm_setlocale (category, locale)
SCM category;
SCM locale;
-#endif
{
#ifdef HAVE_SETLOCALE
char *clocale;
@@ -1151,213 +1056,112 @@ scm_setlocale (category, locale)
}
else
{
- SCM_ASSERT (SCM_NIMP (locale) && SCM_STRINGP (locale), locale, SCM_ARG2, s_setlocale);
+ SCM_ASSERT (SCM_NIMP (locale) && SCM_STRINGP (locale), locale,
+ SCM_ARG2, s_setlocale);
clocale = SCM_CHARS (locale);
}
rv = setlocale (SCM_INUM (category), clocale);
- return rv ? scm_makfrom0str (rv) : SCM_MAKINUM (errno);
-#else
- /* setlocale not available. */
- return SCM_MAKINUM (errno);
-#endif
-}
-
-SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
-#ifdef __STDC__
-SCM
-scm_strftime (SCM format, SCM stime)
-#else
-SCM
-scm_strftime (format, stime)
- SCM format;
- SCM stime;
-#endif
-{
- struct tm t;
-
- char *tbuf;
- int n;
- int size = 50;
- char *fmt;
- int len;
-
- SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1, s_strftime);
- SCM_ASSERT (SCM_NIMP (stime) && SCM_VECTORP (stime) && scm_obj_length (stime) == 9,
- stime, SCM_ARG2, s_strftime);
-
- fmt = SCM_ROCHARS (format);
- len = SCM_ROLENGTH (format);
-
-#define tm_deref scm_num2long (SCM_VELTS (stime)[n++], (char *)SCM_ARG2, s_strftime)
- n = 0;
- t.tm_sec = tm_deref;
- t.tm_min = tm_deref;
- t.tm_hour = tm_deref;
- t.tm_mday = tm_deref;
- t.tm_mon = tm_deref;
- t.tm_year = tm_deref;
- /* not used by mktime.
- t.tm_wday = tm_deref;
- t.tm_yday = tm_deref; */
- t.tm_isdst = tm_deref;
-#undef tm_deref
-
- /* fill in missing fields and set the timezone. */
- mktime (&t);
-
- tbuf = scm_must_malloc (size, s_strftime);
- while ((len = strftime (tbuf, size, fmt, &t)) == size)
- {
- scm_must_free (tbuf);
- size *= 2;
- tbuf = scm_must_malloc (size, s_strftime);
- }
- return scm_makfromstr (tbuf, len, 0);
-}
-
-
-
-SCM_PROC (s_sys_strptime, "%strptime", 2, 0, 0, scm_sys_strptime);
-#ifdef __STDC__
-SCM
-scm_sys_strptime (SCM format, SCM string)
+ if (rv == NULL)
+ scm_syserror (s_setlocale);
+ return scm_makfrom0str (rv);
#else
-SCM
-scm_sys_strptime (format, string)
- SCM format;
- SCM string;
-#endif
-{
-#ifdef HAVE_STRPTIME
- SCM stime;
- struct tm t;
-
- char *fmt, *str, *rest;
- int len;
- int n;
-
- SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_sys_strptime);
- if (SCM_SUBSTRP (format))
- format = scm_makfromstr (SCM_ROCHARS (format), SCM_ROLENGTH (format), 0);
- SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, s_sys_strptime);
- if (SCM_SUBSTRP (string))
- string = scm_makfromstr (SCM_ROCHARS (string), SCM_ROLENGTH (string), 0);
-
- fmt = SCM_CHARS (format);
- str = SCM_CHARS (string);
-
- /* initialize the struct tm */
-#define tm_init(field) t.field = 0
- tm_init (tm_sec);
- tm_init (tm_min);
- tm_init (tm_hour);
- tm_init (tm_mday);
- tm_init (tm_mon);
- tm_init (tm_year);
- tm_init (tm_wday);
- tm_init (tm_yday);
- tm_init (tm_isdst);
-#undef tm_init
-
- SCM_DEFER_INTS;
- rest = strptime (str, fmt, &t);
- SCM_ALLOW_INTS;
-
- if (rest == NULL) {
- return SCM_BOOL_F;
- }
-
- stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED);
-
-#define stime_set(val) scm_vector_set_x (stime, SCM_MAKINUM (n++), scm_long2num (t.val));
- n = 0;
- stime_set (tm_sec);
- stime_set (tm_min);
- stime_set (tm_hour);
- stime_set (tm_mday);
- stime_set (tm_mon);
- stime_set (tm_year);
- stime_set (tm_wday);
- stime_set (tm_yday);
- stime_set (tm_isdst);
-#undef stime_set
-
- return scm_cons (stime, scm_makfrom0str (rest));
-#else
- scm_wta (SCM_UNSPECIFIED, "strptime is not available and no replacement has (yet) been supplied", "strptime");
+ scm_sysmissing (s_setlocale);
+ /* not reached. */
return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_mknod, "%mknod", 3, 0, 0, scm_sys_mknod);
-#ifdef __STDC__
-SCM
-scm_sys_mknod(SCM path, SCM mode, SCM dev)
-#else
+SCM_PROC (s_mknod, "mknod", 4, 0, 0, scm_mknod);
+
SCM
-scm_sys_mknod(path, mode, dev)
+scm_mknod(path, type, perms, dev)
SCM path;
- SCM mode;
+ SCM type;
+ SCM perms;
SCM dev;
-#endif
{
#ifdef HAVE_MKNOD
int val;
- SCM_ASSERT(SCM_NIMP(path) && SCM_STRINGP(path), path, SCM_ARG1, s_sys_mknod);
- SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_sys_mknod);
- SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_sys_mknod);
- SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev)));
- return val ? SCM_BOOL_F : SCM_BOOL_T;
+ char *p;
+ int ctype;
+
+ SCM_ASSERT (SCM_NIMP(path) && SCM_ROSTRINGP(path), path, SCM_ARG1, s_mknod);
+ SCM_ASSERT (SCM_NIMP(type) && SCM_SYMBOLP (type), type, SCM_ARG2, s_mknod);
+ SCM_ASSERT (SCM_INUMP (perms), perms, SCM_ARG3, s_mknod);
+ SCM_ASSERT (SCM_INUMP(dev), dev, SCM_ARG4, s_mknod);
+
+ p = SCM_CHARS (type);
+ if (strcmp (p, "regular") == 0)
+ ctype = S_IFREG;
+ else if (strcmp (p, "directory") == 0)
+ ctype = S_IFDIR;
+ else if (strcmp (p, "symlink") == 0)
+ ctype = S_IFLNK;
+ else if (strcmp (p, "block-special") == 0)
+ ctype = S_IFBLK;
+ else if (strcmp (p, "char-special") == 0)
+ ctype = S_IFCHR;
+ else if (strcmp (p, "fifo") == 0)
+ ctype = S_IFIFO;
+ else if (strcmp (p, "socket") == 0)
+ ctype = S_IFSOCK;
+ else
+ scm_out_of_range (s_mknod, type);
+
+ SCM_DEFER_INTS;
+ SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms),
+ SCM_INUM (dev)));
+ if (val != 0)
+ scm_syserror (s_mknod);
+ SCM_ALLOW_INTS;
+ return SCM_UNSPECIFIED;
#else
+ scm_sysmissing (s_mknod);
+ /* not reached. */
return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_nice, "%nice", 1, 0, 0, scm_sys_nice);
-#ifdef __STDC__
-SCM
-scm_sys_nice(SCM incr)
-#else
+SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice);
+
SCM
-scm_sys_nice(incr)
+scm_nice(incr)
SCM incr;
-#endif
{
#ifdef HAVE_NICE
- SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_sys_nice);
- return nice(SCM_INUM(incr)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice);
+ if (nice(SCM_INUM(incr)) != 0)
+ scm_syserror (s_nice);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_nice);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync);
-#ifdef __STDC__
-SCM
-scm_sync(void)
-#else
+
SCM
scm_sync()
-#endif
{
#ifdef HAVE_SYNC
sync();
+#else
+ scm_sysmissing (s_sync);
+ /* not reached. */
#endif
- return SCM_UNSPECIFIED;
+ return SCM_BOOL_F;
}
-#ifdef __STDC__
-void
-scm_init_posix (void)
-#else
+
void
scm_init_posix ()
-#endif
{
scm_add_feature ("posix");
#ifdef HAVE_GETEUID
@@ -1376,109 +1180,6 @@ scm_init_posix ()
scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED));
#endif
-#ifdef EINTR
- scm_sysintern ("EINTR", SCM_MAKINUM (EINTR));
-#endif
-
-#ifdef SIGHUP
- scm_sysintern ("SIGHUP", SCM_MAKINUM (SIGHUP));
-#endif
-#ifdef SIGINT
- scm_sysintern ("SIGINT", SCM_MAKINUM (SIGINT));
-#endif
-#ifdef SIGQUIT
- scm_sysintern ("SIGQUIT", SCM_MAKINUM (SIGQUIT));
-#endif
-#ifdef SIGILL
- scm_sysintern ("SIGILL", SCM_MAKINUM (SIGILL));
-#endif
-#ifdef SIGTRAP
- scm_sysintern ("SIGTRAP", SCM_MAKINUM (SIGTRAP));
-#endif
-#ifdef SIGABRT
- scm_sysintern ("SIGABRT", SCM_MAKINUM (SIGABRT));
-#endif
-#ifdef SIGIOT
- scm_sysintern ("SIGIOT", SCM_MAKINUM (SIGIOT));
-#endif
-#ifdef SIGBUS
- scm_sysintern ("SIGBUS", SCM_MAKINUM (SIGBUS));
-#endif
-#ifdef SIGFPE
- scm_sysintern ("SIGFPE", SCM_MAKINUM (SIGFPE));
-#endif
-#ifdef SIGKILL
- scm_sysintern ("SIGKILL", SCM_MAKINUM (SIGKILL));
-#endif
-#ifdef SIGUSR1
- scm_sysintern ("SIGUSR1", SCM_MAKINUM (SIGUSR1));
-#endif
-#ifdef SIGSEGV
- scm_sysintern ("SIGSEGV", SCM_MAKINUM (SIGSEGV));
-#endif
-#ifdef SIGUSR2
- scm_sysintern ("SIGUSR2", SCM_MAKINUM (SIGUSR2));
-#endif
-#ifdef SIGPIPE
- scm_sysintern ("SIGPIPE", SCM_MAKINUM (SIGPIPE));
-#endif
-#ifdef SIGALRM
- scm_sysintern ("SIGALRM", SCM_MAKINUM (SIGALRM));
-#endif
-#ifdef SIGTERM
- scm_sysintern ("SIGTERM", SCM_MAKINUM (SIGTERM));
-#endif
-#ifdef SIGSTKFLT
- scm_sysintern ("SIGSTKFLT", SCM_MAKINUM (SIGSTKFLT));
-#endif
-#ifdef SIGCHLD
- scm_sysintern ("SIGCHLD", SCM_MAKINUM (SIGCHLD));
-#endif
-#ifdef SIGCONT
- scm_sysintern ("SIGCONT", SCM_MAKINUM (SIGCONT));
-#endif
-#ifdef SIGSTOP
- scm_sysintern ("SIGSTOP", SCM_MAKINUM (SIGSTOP));
-#endif
-#ifdef SIGTSTP
- scm_sysintern ("SIGTSTP", SCM_MAKINUM (SIGTSTP));
-#endif
-#ifdef SIGTTIN
- scm_sysintern ("SIGTTIN", SCM_MAKINUM (SIGTTIN));
-#endif
-#ifdef SIGTTOU
- scm_sysintern ("SIGTTOU", SCM_MAKINUM (SIGTTOU));
-#endif
-#ifdef SIGIO
- scm_sysintern ("SIGIO", SCM_MAKINUM (SIGIO));
-#endif
-#ifdef SIGPOLL
- scm_sysintern ("SIGPOLL", SCM_MAKINUM (SIGPOLL));
-#endif
-#ifdef SIGURG
- scm_sysintern ("SIGURG", SCM_MAKINUM (SIGURG));
-#endif
-#ifdef SIGXCPU
- scm_sysintern ("SIGXCPU", SCM_MAKINUM (SIGXCPU));
-#endif
-#ifdef SIGXFSZ
- scm_sysintern ("SIGXFSZ", SCM_MAKINUM (SIGXFSZ));
-#endif
-#ifdef SIGVTALRM
- scm_sysintern ("SIGVTALRM", SCM_MAKINUM (SIGVTALRM));
-#endif
-#ifdef SIGPROF
- scm_sysintern ("SIGPROF", SCM_MAKINUM (SIGPROF));
-#endif
-#ifdef SIGWINCH
- scm_sysintern ("SIGWINCH", SCM_MAKINUM (SIGWINCH));
-#endif
-#ifdef SIGLOST
- scm_sysintern ("SIGLOST", SCM_MAKINUM (SIGLOST));
-#endif
-#ifdef SIGPWR
- scm_sysintern ("SIGPWR", SCM_MAKINUM (SIGPWR));
-#endif
/* access() symbols. */
scm_sysintern ("R_OK", SCM_MAKINUM (R_OK));
scm_sysintern ("W_OK", SCM_MAKINUM (W_OK));
@@ -1506,5 +1207,6 @@ scm_init_posix ()
#ifdef LC_ALL
scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL));
#endif
+#include "cpp_sig_symbols.c"
#include "posix.x"
}
diff --git a/libguile/posix.h b/libguile/posix.h
index 2bef059c8..700591cd6 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -2,7 +2,7 @@
#ifndef POSIXH
#define POSIXH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,102 +44,55 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_sys_pipe (void);
-extern SCM scm_sys_getgroups(void);
-extern SCM scm_sys_getpwuid (SCM user);
-extern SCM scm_setpwent (SCM arg);
-extern SCM scm_sys_getgrgid (SCM name);
-extern SCM scm_setgrent (SCM arg);
-extern SCM scm_sys_kill (SCM pid, SCM sig);
-extern SCM scm_sys_waitpid (SCM pid, SCM options);
-extern SCM scm_getppid (void);
-extern SCM scm_getuid (void);
-extern SCM scm_getgid (void);
-extern SCM scm_geteuid (void);
-extern SCM scm_getegid (void);
-extern SCM scm_sys_setuid (SCM id);
-extern SCM scm_sys_setgid (SCM id);
-extern SCM scm_sys_seteuid (SCM id);
-extern SCM scm_sys_setegid (SCM id);
-extern SCM scm_ttyname (SCM port);
-extern SCM scm_sys_execl (SCM args);
-extern SCM scm_sys_execlp (SCM args);
-extern SCM scm_sys_fork(void);
-extern SCM scm_sys_uname (void);
-extern SCM scm_environ (SCM env);
-extern SCM scm_open_pipe (SCM pipestr, SCM modes);
-extern SCM scm_open_input_pipe(SCM pipestr);
-extern SCM scm_open_output_pipe(SCM pipestr);
-extern SCM scm_sys_utime (SCM pathname, SCM actime, SCM modtime);
-extern SCM scm_sys_access (SCM path, SCM how);
-extern SCM scm_getpid (void);
-extern SCM scm_sys_putenv (SCM str);
-extern SCM scm_read_line (SCM port, SCM include_terminator);
-extern SCM scm_read_line_x (SCM str, SCM port);
-extern SCM scm_write_line (SCM obj, SCM port);
-extern SCM scm_setlocale (SCM category, SCM locale);
-extern SCM scm_strftime (SCM format, SCM stime);
-extern SCM scm_sys_strptime (SCM format, SCM string);
-extern SCM scm_sys_mknod(SCM path, SCM mode, SCM dev);
-extern SCM scm_sys_nice(SCM incr);
-extern SCM scm_sync(void);
-extern void scm_init_posix (void);
-
-#else /* STDC */
-extern SCM scm_sys_pipe ();
-extern SCM scm_sys_getgroups();
-extern SCM scm_sys_getpwuid ();
-extern SCM scm_setpwent ();
-extern SCM scm_sys_getgrgid ();
-extern SCM scm_setgrent ();
-extern SCM scm_sys_kill ();
-extern SCM scm_sys_waitpid ();
-extern SCM scm_getppid ();
-extern SCM scm_getuid ();
-extern SCM scm_getgid ();
-extern SCM scm_geteuid ();
-extern SCM scm_getegid ();
-extern SCM scm_sys_setuid ();
-extern SCM scm_sys_setgid ();
-extern SCM scm_sys_seteuid ();
-extern SCM scm_sys_setegid ();
-extern SCM scm_ttyname ();
-extern SCM scm_sys_execl ();
-extern SCM scm_sys_execlp ();
-extern SCM scm_sys_fork();
-extern SCM scm_sys_uname ();
-extern SCM scm_environ ();
-extern SCM scm_open_pipe ();
-extern SCM scm_open_input_pipe();
-extern SCM scm_open_output_pipe();
-extern SCM scm_sys_utime ();
-extern SCM scm_sys_access ();
-extern SCM scm_getpid ();
-extern SCM scm_sys_putenv ();
-extern SCM scm_read_line ();
-extern SCM scm_read_line_x ();
-extern SCM scm_write_line ();
-extern SCM scm_setlocale ();
-extern SCM scm_strftime ();
-extern SCM scm_sys_strptime ();
-extern SCM scm_sys_mknod();
-extern SCM scm_sys_nice();
-extern SCM scm_sync();
-extern void scm_init_posix ();
-
-#endif /* STDC */
-
-
-
-
-
+extern SCM scm_tcsetpgrp SCM_P ((SCM port, SCM pgid));
+extern SCM scm_tcgetpgrp SCM_P ((SCM port));
+extern SCM scm_ctermid SCM_P ((void));
+extern SCM scm_setsid SCM_P ((void));
+extern SCM scm_setpgid SCM_P ((SCM pid, SCM pgid));
+extern SCM scm_pipe SCM_P ((void));
+extern SCM scm_getgroups SCM_P ((void));
+extern SCM scm_getpgrp SCM_P ((void));
+extern SCM scm_getpwuid SCM_P ((SCM user));
+extern SCM scm_setpwent SCM_P ((SCM arg));
+extern SCM scm_getgrgid SCM_P ((SCM name));
+extern SCM scm_setgrent SCM_P ((SCM arg));
+extern SCM scm_kill SCM_P ((SCM pid, SCM sig));
+extern SCM scm_waitpid SCM_P ((SCM pid, SCM options));
+extern SCM scm_status_exit_val SCM_P ((SCM status));
+extern SCM scm_status_term_sig SCM_P ((SCM status));
+extern SCM scm_status_stop_sig SCM_P ((SCM status));
+extern SCM scm_getppid SCM_P ((void));
+extern SCM scm_getuid SCM_P ((void));
+extern SCM scm_getgid SCM_P ((void));
+extern SCM scm_geteuid SCM_P ((void));
+extern SCM scm_getegid SCM_P ((void));
+extern SCM scm_setuid SCM_P ((SCM id));
+extern SCM scm_setgid SCM_P ((SCM id));
+extern SCM scm_seteuid SCM_P ((SCM id));
+extern SCM scm_setegid SCM_P ((SCM id));
+extern SCM scm_ttyname SCM_P ((SCM port));
+extern SCM scm_execl SCM_P ((SCM args));
+extern SCM scm_execlp SCM_P ((SCM args));
+extern SCM scm_fork SCM_P ((void));
+extern SCM scm_uname SCM_P ((void));
+extern SCM scm_environ SCM_P ((SCM env));
+extern SCM scm_open_pipe SCM_P ((SCM pipestr, SCM modes));
+extern SCM scm_close_pipe SCM_P ((SCM port));
+extern SCM scm_utime SCM_P ((SCM pathname, SCM actime, SCM modtime));
+extern SCM scm_access SCM_P ((SCM path, SCM how));
+extern SCM scm_getpid SCM_P ((void));
+extern SCM scm_putenv SCM_P ((SCM str));
+extern SCM scm_setlocale SCM_P ((SCM category, SCM locale));
+extern SCM scm_mknod SCM_P ((SCM path, SCM type, SCM perms, SCM dev));
+extern SCM scm_nice SCM_P ((SCM incr));
+extern SCM scm_sync SCM_P ((void));
+extern void scm_init_posix SCM_P ((void));
#endif /* POSIXH */
diff --git a/libguile/print.c b/libguile/print.c
index 0877f2ace..b7e8040ef 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -42,9 +42,19 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "genio.h"
+#include "mbstrings.h"
+#include "smob.h"
+#include "eval.h"
+#include "procprop.h"
+#include "read.h"
+#include "weaks.h"
+#include "unif.h"
+#include "alist.h"
+#include "struct.h"
-
-
+#include "print.h"
/* {Names of immediate symbols}
@@ -88,22 +98,183 @@ char *scm_isymnames[] =
"#<unspecified>"
};
+scm_option scm_print_opts[] = {
+ { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F,
+ "Hook for printing closures." },
+ { SCM_OPTION_BOOLEAN, "source", 0,
+ "Print closures with source." }
+};
+
+SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options);
+
+SCM
+scm_print_options (setting)
+ SCM setting;
+{
+ SCM ans = scm_options (setting,
+ scm_print_opts,
+ SCM_N_PRINT_OPTIONS,
+ s_print_options);
+ return ans;
+}
+
/* {Printing of Scheme Objects}
*/
-/* Print generally. Handles both write and display according to WRITING.
+/* Detection of circular references.
+ *
+ * Due to other constraints in the implementation, this code has bad
+ * time complexity (O (depth * N)), The printer code will be
+ * completely rewritten before next release of Guile. The new code
+ * will be O(N).
*/
-#ifdef __STDC__
-void
-scm_iprin1 (SCM exp, SCM port, int writing)
-#else
+#define PUSH_REF(pstate, obj) \
+{ \
+ pstate->ref_stack[pstate->top++] = (obj); \
+ if (pstate->top == pstate->ceiling) \
+ grow_ref_stack (pstate); \
+}
+
+#define ENTER_NESTED_DATA(pstate, obj, label) \
+{ \
+ register int i; \
+ for (i = 0; i < pstate->top; ++i) \
+ if (pstate->ref_stack[i] == (obj)) \
+ goto label; \
+ if (pstate->fancyp) \
+ { \
+ if (pstate->top - pstate->list_offset >= pstate->level) \
+ { \
+ scm_gen_putc ('#', port); \
+ return; \
+ } \
+ } \
+ PUSH_REF(pstate, obj); \
+} \
+
+#define EXIT_NESTED_DATA(pstate) { --pstate->top; }
+
+static SCM print_state_pool;
+
+#ifdef GUILE_DEBUG /* Used for debugging purposes */
+SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
+
+SCM
+scm_current_pstate ()
+{
+ return SCM_CADR (print_state_pool);
+}
+#endif
+
+#define PSTATE_SIZE 50L
+
+static SCM make_print_state SCM_P ((void));
+
+static SCM
+make_print_state ()
+{
+ SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
+ SCM_INUM0,
+ SCM_EOL);
+ scm_print_state *pstate = SCM_PRINT_STATE (print_state);
+ pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE),
+ SCM_UNDEFINED,
+ SCM_UNDEFINED);
+ pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
+ pstate->ceiling = SCM_LENGTH (pstate->ref_vect);
+ return print_state;
+}
+
+SCM
+scm_make_print_state ()
+{
+ SCM answer = 0;
+
+ /* First try to allocate a print state from the pool */
+ SCM_DEFER_INTS;
+ if (SCM_NNULLP (SCM_CDR (print_state_pool)))
+ {
+ answer = SCM_CADR (print_state_pool);
+ SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
+ }
+ SCM_ALLOW_INTS;
+
+ return answer ? answer : make_print_state ();
+}
+
+void
+scm_free_print_state (print_state)
+ SCM print_state;
+{
+ SCM handle;
+ scm_print_state *pstate = SCM_PRINT_STATE (print_state);
+ /* Cleanup before returning print state to pool.
+ * It is better to do it here. Doing it in scm_prin1
+ * would cost more since that function is called much more
+ * often.
+ */
+ pstate->fancyp = 0;
+ SCM_NEWCELL (handle);
+ SCM_DEFER_INTS;
+ SCM_SETCAR (handle, print_state);
+ SCM_SETCDR (handle, SCM_CDR (print_state_pool));
+ SCM_SETCDR (print_state_pool, handle);
+ SCM_ALLOW_INTS;
+}
+
+static void grow_ref_stack SCM_P ((scm_print_state *pstate));
+
+static void
+grow_ref_stack (pstate)
+ scm_print_state *pstate;
+{
+ int new_size = 2 * pstate->ceiling;
+ scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size));
+ pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
+ pstate->ceiling = new_size;
+}
+
+
+static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref));
+
+static void
+print_circref (port, pstate, ref)
+ SCM port;
+ scm_print_state *pstate;
+ SCM ref;
+{
+ register int i;
+ int self = pstate->top - 1;
+ i = pstate->top - 1;
+ if (SCM_CONSP (pstate->ref_stack[i]))
+ {
+ while (i > 0)
+ {
+ if (SCM_NCONSP (pstate->ref_stack[i - 1])
+ || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
+ break;
+ --i;
+ }
+ self = i;
+ }
+ for (i = pstate->top - 1; 1; --i)
+ if (pstate->ref_stack[i] == ref)
+ break;
+ scm_gen_putc ('#', port);
+ scm_intprint (i - self, 10, port);
+ scm_gen_putc ('#', port);
+}
+
+/* Print generally. Handles both write and display according to PSTATE.
+ */
+
+
void
-scm_iprin1 (exp, port, writing)
+scm_iprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
register long i;
taloop:
@@ -117,12 +288,12 @@ taloop:
if (SCM_ICHRP (exp))
{
i = SCM_ICHR (exp);
- scm_put_wchar (i, port, writing);
+ scm_put_wchar (i, port, SCM_WRITINGP (pstate));
}
- else if ( SCM_IFLAGP (exp)
+ else if (SCM_IFLAGP (exp)
&& (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
- scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (exp), port);
+ scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port);
else if (SCM_ILOCP (exp))
{
scm_gen_puts (scm_regular_string, "#@", port);
@@ -149,7 +320,7 @@ taloop:
if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
{
- scm_gen_write (scm_regular_string, "#<struct ", (scm_sizet) 9, port);
+ scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
scm_intprint(exp, 16, port);
scm_gen_putc ('>', port);
break;
@@ -157,49 +328,68 @@ taloop:
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
- scm_iprlist ("(", exp, ')', port, writing);
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprlist ("(", exp, ')', port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ break;
+ circref:
+ print_circref (port, pstate, exp);
break;
case scm_tcs_closures:
-#ifdef DEBUG_EXTENSIONS
- if (PRINT_PROCNAMES)
+ if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
+ {
+ SCM ans = scm_cons2 (exp, port,
+ scm_cons (SCM_WRITINGP (pstate)
+ ? SCM_BOOL_T
+ : SCM_BOOL_F,
+ SCM_EOL));
+ ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
+ }
+ else
{
- SCM name;
+ SCM name, code;
name = scm_procedure_property (exp, scm_i_name);
- scm_gen_puts (scm_regular_string, "#<procedure", port);
- if (SCM_NFALSEP (name))
+ code = SCM_CODE (exp);
+ scm_gen_puts (scm_regular_string, "#<procedure ", port);
+ if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
+ scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
scm_gen_putc (' ', port);
- /* FIXME */
- scm_gen_puts (scm_regular_string, SCM_CHARS (name), port);
}
- scm_gen_putc ('>', port);
- }
- else
-#endif
- {
- exp = SCM_CODE (exp);
- scm_iprlist ("#<CLOSURE ", exp, '>', port, writing);
+ scm_iprin1 (SCM_CAR (code), port, pstate);
+ if (SCM_PRINT_SOURCE_P)
+ {
+ code = scm_unmemocopy (SCM_CDR (code),
+ SCM_EXTEND_ENV (SCM_CAR (code),
+ SCM_EOL,
+ SCM_ENV (exp)));
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprlist (" ", code, '>', port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ }
+ else
+ scm_gen_putc ('>', port);
}
break;
case scm_tc7_mb_string:
case scm_tc7_mb_substring:
- scm_print_mb_string (exp, port, writing);
+ scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
break;
case scm_tc7_substring:
case scm_tc7_string:
- if (writing)
+ if (SCM_WRITINGP (pstate))
{
- scm_gen_putc ('\"', port);
+ scm_gen_putc ('"', port);
for (i = 0; i < SCM_ROLENGTH (exp); ++i)
switch (SCM_ROCHARS (exp)[i])
{
- case '\"':
+ case '"':
case '\\':
scm_gen_putc ('\\', port);
default:
scm_gen_putc (SCM_ROCHARS (exp)[i], port);
}
- scm_gen_putc ('\"', port);
+ scm_gen_putc ('"', port);
break;
}
else
@@ -221,7 +411,7 @@ taloop:
char * str;
int weird;
int maybe_weird;
- int mw_pos;
+ int mw_pos = 0;
len = SCM_LENGTH (exp);
str = SCM_CHARS (exp);
@@ -242,7 +432,7 @@ taloop:
#endif
case '(':
case ')':
- case '\"':
+ case '"':
case ';':
case SCM_WHITE_SPACES:
case SCM_LINE_INCREMENTORS:
@@ -293,6 +483,7 @@ taloop:
break;
}
case scm_tc7_wvect:
+ ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
scm_gen_puts (scm_regular_string, "#wh(", port);
else
@@ -300,20 +491,33 @@ taloop:
goto common_vector_printer;
case scm_tc7_vector:
+ ENTER_NESTED_DATA (pstate, exp, circref);
scm_gen_puts (scm_regular_string, "#(", port);
common_vector_printer:
- for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
- {
- /* CHECK_INTS; */
- scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
- scm_gen_putc (' ', port);
- }
- if (i < SCM_LENGTH (exp))
- {
- /* CHECK_INTS; */
- scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
- }
- scm_gen_putc (')', port);
+ {
+ int last = SCM_LENGTH (exp) - 1;
+ int cutp = 0;
+ if (pstate->fancyp && SCM_LENGTH (exp) > pstate->length)
+ {
+ last = pstate->length - 1;
+ cutp = 1;
+ }
+ for (i = 0; i < last; ++i)
+ {
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
+ scm_gen_putc (' ', port);
+ }
+ if (i == last)
+ {
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
+ }
+ if (cutp)
+ scm_gen_puts (scm_regular_string, " ...", port);
+ scm_gen_putc (')', port);
+ }
+ EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_bvect:
case scm_tc7_byvect:
@@ -326,7 +530,7 @@ taloop:
#ifdef LONGLONGS
case scm_tc7_llvect:
#endif
- scm_raprin1 (exp, port, writing);
+ scm_raprin1 (exp, port, pstate);
break;
case scm_tcs_subrs:
scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
@@ -339,7 +543,7 @@ taloop:
#ifdef CCLO
case scm_tc7_cclo:
scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
- scm_iprin1 (SCM_CCLO_SUBR (exp), port, writing);
+ scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
scm_gen_putc ('>', port);
break;
#endif
@@ -352,34 +556,74 @@ taloop:
break;
case scm_tc7_port:
i = SCM_PTOBNUM (exp);
- if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
+ if (i < scm_numptob
+ && scm_ptobs[i].print
+ && (scm_ptobs[i].print) (exp, port, pstate))
break;
goto punk;
case scm_tc7_smob:
+ ENTER_NESTED_DATA (pstate, exp, circref);
i = SCM_SMOBNUM (exp);
if (i < scm_numsmob && scm_smobs[i].print
- && (scm_smobs[i].print) (exp, port, writing))
- break;
- goto punk;
+ && (scm_smobs[i].print) (exp, port, pstate))
+ {
+ EXIT_NESTED_DATA (pstate);
+ break;
+ }
+ EXIT_NESTED_DATA (pstate);
default:
- punk:scm_ipruk ("type", exp, port);
+ punk:
+ scm_ipruk ("type", exp, port);
}
}
}
+/* Print states are necessary for circular reference safe printing.
+ * They are also expensive to allocate. Therefore print states are
+ * kept in a pool so that they can be reused.
+ */
+
+void
+scm_prin1 (exp, port, writingp)
+ SCM exp;
+ SCM port;
+ int writingp;
+{
+ SCM handle = 0; /* Will GC protect the handle whilst unlinked */
+ scm_print_state *pstate;
+
+ /* First try to allocate a print state from the pool */
+ SCM_DEFER_INTS;
+ if (SCM_NNULLP (SCM_CDR (print_state_pool)))
+ {
+ handle = SCM_CDR (print_state_pool);
+ SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
+ }
+ SCM_ALLOW_INTS;
+
+ if (!handle)
+ handle = scm_cons (make_print_state (), SCM_EOL);
+
+ pstate = SCM_PRINT_STATE (SCM_CAR (handle));
+ pstate->writingp = writingp;
+ scm_iprin1 (exp, port, pstate);
+
+ /* Return print state to pool */
+ SCM_DEFER_INTS;
+ SCM_SETCDR (handle, SCM_CDR (print_state_pool));
+ SCM_SETCDR (print_state_pool, handle);
+ SCM_ALLOW_INTS;
+}
+
/* Print an integer.
*/
-#ifdef __STDC__
-void
-scm_intprint (long n, int radix, SCM port)
-#else
+
void
scm_intprint (n, radix, port)
long n;
int radix;
SCM port;
-#endif
{
char num_buf[SCM_INTBUFLEN];
scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
@@ -387,16 +631,12 @@ scm_intprint (n, radix, port)
/* Print an object of unrecognized type.
*/
-#ifdef __STDC__
-void
-scm_ipruk (char *hdr, SCM ptr, SCM port)
-#else
+
void
scm_ipruk (hdr, ptr, port)
char *hdr;
SCM ptr;
SCM port;
-#endif
{
scm_gen_puts (scm_regular_string, "#<unknown-", port);
scm_gen_puts (scm_regular_string, hdr, port);
@@ -415,57 +655,127 @@ scm_ipruk (hdr, ptr, port)
/* Print a list.
*/
-#ifdef __STDC__
-void
-scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
-#else
+
+
void
-scm_iprlist (hdr, exp, tlr, port, writing)
+scm_iprlist (hdr, exp, tlr, port, pstate)
char *hdr;
SCM exp;
- char tlr;
+ int tlr;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
+ register int i;
+ register SCM hare, tortoise;
+ int floor = pstate->top - 2;
scm_gen_puts (scm_regular_string, hdr, port);
/* CHECK_INTS; */
- scm_iprin1 (SCM_CAR (exp), port, writing);
+ if (pstate->fancyp)
+ goto fancy_printing;
+
+ /* Run a hare and tortoise so that total time complexity will be
+ O(depth * N) instead of O(N^2). */
+ hare = SCM_CDR (exp);
+ tortoise = exp;
+ while (SCM_NIMP (hare) && SCM_ECONSP (hare))
+ {
+ if (hare == tortoise)
+ goto fancy_printing;
+ hare = SCM_CDR (hare);
+ if (SCM_IMP (hare) || SCM_NECONSP (hare))
+ break;
+ hare = SCM_CDR (hare);
+ tortoise = SCM_CDR (tortoise);
+ }
+
+ /* No cdr cycles intrinsic to this list */
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
exp = SCM_CDR (exp);
for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
{
if (SCM_NECONSP (exp))
break;
+ for (i = floor; i >= 0; --i)
+ if (pstate->ref_stack[i] == exp)
+ goto circref;
+ PUSH_REF (pstate, exp);
scm_gen_putc (' ', port);
/* CHECK_INTS; */
- scm_iprin1 (SCM_CAR (exp), port, writing);
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
}
if (SCM_NNULLP (exp))
{
scm_gen_puts (scm_regular_string, " . ", port);
- scm_iprin1 (exp, port, writing);
+ scm_iprin1 (exp, port, pstate);
}
+
+end:
scm_gen_putc (tlr, port);
+ pstate->top = floor + 2;
+ return;
+
+fancy_printing:
+ {
+ int n = pstate->length;
+
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ exp = SCM_CDR (exp); --n;
+ for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
+ {
+ if (SCM_NECONSP (exp))
+ break;
+ for (i = 0; i < pstate->top; ++i)
+ if (pstate->ref_stack[i] == exp)
+ goto fancy_circref;
+ if (pstate->fancyp)
+ {
+ if (n == 0)
+ {
+ scm_gen_puts (scm_regular_string, " ...", port);
+ goto skip_tail;
+ }
+ else
+ --n;
+ }
+ PUSH_REF(pstate, exp);
+ ++pstate->list_offset;
+ scm_gen_putc (' ', port);
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ }
+ }
+ if (SCM_NNULLP (exp))
+ {
+ scm_gen_puts (scm_regular_string, " . ", port);
+ scm_iprin1 (exp, port, pstate);
+ }
+skip_tail:
+ pstate->list_offset -= pstate->top - floor - 2;
+ goto end;
+
+fancy_circref:
+ pstate->list_offset -= pstate->top - floor - 2;
+
+circref:
+ scm_gen_puts (scm_regular_string, " . ", port);
+ print_circref (port, pstate, exp);
+ goto end;
}
SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
-#ifdef __STDC__
-SCM
-scm_write (SCM obj, SCM port)
-#else
+
SCM
scm_write (obj, port)
SCM obj;
SCM port;
-#endif
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
- scm_iprin1 (obj, port, 1);
+ scm_prin1 (obj, port, 1);
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
@@ -477,21 +787,17 @@ scm_write (obj, port)
SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
-#ifdef __STDC__
-SCM
-scm_display (SCM obj, SCM port)
-#else
+
SCM
scm_display (obj, port)
SCM obj;
SCM port;
-#endif
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
- scm_iprin1 (obj, port, 0);
+ scm_prin1 (obj, port, 0);
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
@@ -502,14 +808,10 @@ scm_display (obj, port)
}
SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
-#ifdef __STDC__
-SCM
-scm_newline(SCM port)
-#else
+
SCM
scm_newline (port)
SCM port;
-#endif
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
@@ -529,15 +831,11 @@ scm_newline (port)
}
SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
-#ifdef __STDC__
-SCM
-scm_write_char (SCM chr, SCM port)
-#else
+
SCM
scm_write_char (chr, port)
SCM chr;
SCM port;
-#endif
{
if (SCM_UNBNDP (port))
port = scm_cur_outp;
@@ -557,14 +855,17 @@ scm_write_char (chr, port)
-#ifdef __STDC__
-void
-scm_init_print (void)
-#else
+
void
scm_init_print ()
-#endif
{
+ SCM vtable, type;
+ scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
+ vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL);
+ type = scm_make_struct (vtable,
+ SCM_INUM0,
+ scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)),
+ SCM_EOL));
+ print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
#include "print.x"
}
-
diff --git a/libguile/print.h b/libguile/print.h
index ae23eaf00..d16d4f64d 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -44,31 +44,57 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/options.h"
-#ifdef __STDC__
-extern void scm_intprint (long n, int radix, SCM port);
-extern void scm_ipruk (char *hdr, SCM ptr, SCM port);
-extern void scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing);
-extern void scm_iprin1 (SCM exp, SCM port, int writing);
-extern SCM scm_write (SCM obj, SCM port);
-extern SCM scm_display (SCM obj, SCM port);
-extern SCM scm_newline(SCM port);
-extern SCM scm_write_char (SCM chr, SCM port);
-extern void scm_init_print (void);
+extern scm_option scm_print_opts[];
-#else /* STDC */
-extern void scm_intprint ();
-extern void scm_ipruk ();
-extern void scm_iprlist ();
-extern void scm_iprin1 ();
-extern SCM scm_write ();
-extern SCM scm_display ();
-extern SCM scm_newline();
-extern SCM scm_write_char ();
-extern void scm_init_print ();
+#define SCM_PRINT_CLOSURE ((SCM) scm_print_opts[0].val)
+#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
+#define SCM_N_PRINT_OPTIONS 2
-#endif /* STDC */
+/* State information passed around during printing.
+ */
+#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj))
+
+#define RESET_PRINT_STATE(pstate) \
+{ \
+ pstate->list_offset = 0; \
+ pstate->top = 0; \
+}
+
+#define SCM_WRITINGP(pstate) ((pstate)->writingp)
+#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); }
+
+#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwpwuwuwuruopr"
+typedef struct scm_print_state {
+ SCM handle; /* Struct handle */
+ unsigned long writingp; /* Writing? */
+ unsigned long fancyp; /* Fancy printing? */
+ unsigned long level; /* Max level */
+ unsigned long length; /* Max number of objects per level */
+ SCM hot_ref; /* Hot reference */
+ unsigned long list_offset;
+ unsigned long top; /* Top of reference stack */
+ unsigned long ceiling; /* Max size of reference stack */
+ SCM *ref_stack; /* Stack of references used during
+ circular reference detection */
+ SCM ref_vect;
+} scm_print_state;
+
+extern SCM scm_print_options SCM_P ((SCM setting));
+SCM scm_make_print_state SCM_P ((void));
+void scm_free_print_state SCM_P ((SCM print_state));
+extern void scm_intprint SCM_P ((long n, int radix, SCM port));
+extern void scm_ipruk SCM_P ((char *hdr, SCM ptr, SCM port));
+extern void scm_iprlist SCM_P ((char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate));
+extern void scm_prin1 SCM_P ((SCM exp, SCM port, int writingp));
+extern void scm_iprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+extern SCM scm_write SCM_P ((SCM obj, SCM port));
+extern SCM scm_display SCM_P ((SCM obj, SCM port));
+extern SCM scm_newline SCM_P ((SCM port));
+extern SCM scm_write_char SCM_P ((SCM chr, SCM port));
+extern void scm_init_print SCM_P ((void));
#endif /* PRINTH */
diff --git a/libguile/procprop.c b/libguile/procprop.c
index a984008db..686a26052 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -42,7 +42,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "alist.h"
+#include "eval.h"
+#include "procprop.h"
static SCM
@@ -64,69 +67,55 @@ scm_stand_in_scm_proc(proc)
}
SCM_PROC(s_procedure_properties, "procedure-properties", 1, 0, 0, scm_procedure_properties);
-#ifdef __STDC__
-SCM
-scm_procedure_properties (SCM proc)
-#else
+
SCM
scm_procedure_properties (proc)
SCM proc;
-#endif
{
- SCM_ASSERT (scm_procedure_p (proc), proc, SCM_ARG1, s_procedure_properties);
+ SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
+ proc, SCM_ARG1, s_procedure_properties);
if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
proc = scm_stand_in_scm_proc(proc);
return SCM_PROCPROPS (proc);
}
SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x);
-#ifdef __STDC__
-SCM
-scm_set_procedure_properties_x (SCM proc, SCM new_val)
-#else
+
SCM
scm_set_procedure_properties_x (proc, new_val)
SCM proc;
SCM new_val;
-#endif
{
if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
proc = scm_stand_in_scm_proc(proc);
SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x);
- SCM_PROCPROPS (proc) = new_val;
+ SCM_SETPROCPROPS (proc, new_val);
return SCM_UNSPECIFIED;
}
SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property);
-#ifdef __STDC__
-SCM
-scm_procedure_property (SCM p, SCM k)
-#else
+
SCM
scm_procedure_property (p, k)
SCM p;
SCM k;
-#endif
{
SCM assoc;
if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
p = scm_stand_in_scm_proc(p);
- SCM_ASSERT (scm_procedure_p (p), p, SCM_ARG1, s_procedure_property);
+ SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (p)),
+ p, SCM_ARG1, s_procedure_property);
assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
SCM_PROC(s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, scm_set_procedure_property_x);
-#ifdef __STDC__
-SCM
-scm_set_procedure_property_x (SCM p, SCM k, SCM v)
-#else
+
SCM
scm_set_procedure_property_x (p, k, v)
SCM p;
SCM k;
SCM v;
-#endif
{
SCM assoc;
if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
@@ -136,19 +125,15 @@ scm_set_procedure_property_x (p, k, v)
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, v);
else
- SCM_PROCPROPS (p) = scm_acons (k, v, SCM_PROCPROPS (p));
+ SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
return SCM_UNSPECIFIED;
}
-#ifdef __STDC__
-void
-scm_init_procprop (void)
-#else
+
void
scm_init_procprop ()
-#endif
{
#include "procprop.x"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index ee6f37cb3..cac97edd1 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -44,29 +44,18 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
+extern SCM scm_i_name;
-#ifdef __STDC__
-extern SCM scm_procedure_properties (SCM proc);
-extern SCM scm_set_procedure_properties_x (SCM proc, SCM new_val);
-extern SCM scm_procedure_property (SCM p, SCM k);
-extern SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v);
-extern void scm_init_procprop (void);
-
-#else /* STDC */
-extern SCM scm_procedure_properties ();
-extern SCM scm_set_procedure_properties_x ();
-extern SCM scm_procedure_property ();
-extern SCM scm_set_procedure_property_x ();
-extern void scm_init_procprop ();
-
-#endif /* STDC */
-
+extern SCM scm_procedure_properties SCM_P ((SCM proc));
+extern SCM scm_set_procedure_properties_x SCM_P ((SCM proc, SCM new_val));
+extern SCM scm_procedure_property SCM_P ((SCM p, SCM k));
+extern SCM scm_set_procedure_property_x SCM_P ((SCM p, SCM k, SCM v));
+extern void scm_init_procprop SCM_P ((void));
#endif /* PROCPROPH */
diff --git a/libguile/procs.c b/libguile/procs.c
index 6c5a5b2c4..c0fd561f0 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -43,24 +43,20 @@
#include <stdio.h>
#include "_scm.h"
-
+#include "procs.h"
/* {Procedures}
*/
-#ifdef __STDC__
-SCM
-scm_make_subr_opt (char *name, int type, SCM (*fcn) (), int set)
-#else
+
SCM
scm_make_subr_opt (name, type, fcn, set)
char *name;
int type;
SCM (*fcn) ();
int set;
-#endif
{
SCM symcell;
long tmp;
@@ -71,37 +67,29 @@ scm_make_subr_opt (name, type, fcn, set)
tmp = 0;
SCM_NEWCELL (z);
SCM_SUBRF (z) = fcn;
- SCM_CAR (z) = tmp + type;
+ SCM_SETCAR (z, tmp + type);
if (set)
- SCM_CDR (symcell) = z;
+ SCM_SETCDR (symcell, z);
return z;
}
-#ifdef __STDC__
-SCM
-scm_make_subr (char *name, int type, SCM (*fcn) ())
-#else
+
SCM
scm_make_subr (name, type, fcn)
char *name;
int type;
SCM (*fcn) ();
-#endif
{
return scm_make_subr_opt (name, type, fcn, 1);
}
#ifdef CCLO
-#ifdef __STDC__
-SCM
-scm_makcclo (SCM proc, long len)
-#else
+
SCM
scm_makcclo (proc, len)
SCM proc;
long len;
-#endif
{
SCM s;
SCM_NEWCELL (s);
@@ -114,19 +102,28 @@ scm_makcclo (proc, len)
SCM_ALLOW_INTS;
return s;
}
+
+/* Undocumented debugging procedure */
+#ifdef GUILE_DEBUG
+SCM_PROC (s_make_cclo, "make-cclo", 2, 0, 0, scm_make_cclo);
+
+SCM
+scm_make_cclo (proc, len)
+ SCM proc;
+ SCM len;
+{
+ return scm_makcclo (proc, SCM_INUM (len));
+}
+#endif
#endif
SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p);
-#ifdef __STDC__
-SCM
-scm_procedure_p (SCM obj)
-#else
+
SCM
scm_procedure_p (obj)
SCM obj;
-#endif
{
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
@@ -144,16 +141,60 @@ scm_procedure_p (obj)
return SCM_BOOL_F;
}
+SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p);
+
+SCM
+scm_closure_p (obj)
+ SCM obj;
+{
+ if (SCM_NIMP (obj))
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_closures:
+ return SCM_BOOL_T;
+ default: ;
+ }
+ return SCM_BOOL_F;
+}
+
+SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p);
#ifdef __STDC__
-void
-scm_init_iprocs(scm_iproc *subra, int type)
+SCM
+scm_thunk_p (SCM obj)
#else
+SCM
+scm_thunk_p (obj)
+ SCM obj;
+#endif
+{
+ if (SCM_NIMP (obj))
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_closures:
+ if (SCM_NULLP (SCM_CAR (SCM_CODE (obj))))
+ return SCM_BOOL_T;
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_1o:
+ case scm_tc7_lsubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ return SCM_BOOL_T;
+ default:
+ ;
+ }
+ return SCM_BOOL_F;
+}
+
+
+
void
scm_init_iprocs(subra, type)
scm_iproc *subra;
int type;
-#endif
{
for(;subra->scm_string; subra++)
scm_make_subr(subra->scm_string,
@@ -164,13 +205,9 @@ scm_init_iprocs(subra, type)
-#ifdef __STDC__
-void
-scm_init_procs (void)
-#else
+
void
scm_init_procs ()
-#endif
{
#include "procs.x"
}
diff --git a/libguile/procs.h b/libguile/procs.h
index 332e06c1f..50345e784 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -82,26 +82,22 @@ typedef struct scm_dsubr
#define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure)
#define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x))
#define SCM_PROCPROPS(x) SCM_CDR(SCM_CLOSCAR (x))
-#define SCM_SETCODE(x, e) SCM_CAR(x) = (scm_cons ((e), SCM_EOL) + scm_tc3_closure)
+#define SCM_SETPROCPROPS(x, p) SCM_SETCDR(SCM_CLOSCAR (x), p)
+#define SCM_SETCODE(x, e) (SCM_SETCAR (x, scm_cons ((e), SCM_EOL) + scm_tc3_closure))
#define SCM_ENV(x) SCM_CDR(x)
+#define SCM_SETENV(x, e) SCM_SETCDR (x, e)
#define SCM_TOP_LEVEL(SCM_ENV) (SCM_NULLP(SCM_ENV) || (SCM_BOOL_T == scm_procedure_p (SCM_CAR (SCM_ENV))))
-
-#ifdef __STDC__
-extern SCM scm_make_subr (char *name, int type, SCM (*fcn) ());
-extern SCM scm_makcclo (SCM proc, long len);
-extern SCM scm_procedure_p (SCM obj);
-extern void scm_init_iprocs(scm_iproc *subra, int type);
-extern void scm_init_procs (void);
-
-#else /* STDC */
-extern SCM scm_make_subr ();
-extern SCM scm_makcclo ();
-extern SCM scm_procedure_p ();
-extern void scm_init_iprocs();
-extern void scm_init_procs ();
+extern SCM scm_make_subr SCM_P ((char *name, int type, SCM (*fcn) ()));
+extern SCM scm_make_subr_opt SCM_P ((char *name, int type, SCM (*fcn) (),
+ int set));
+extern SCM scm_makcclo SCM_P ((SCM proc, long len));
+extern SCM scm_procedure_p SCM_P ((SCM obj));
+extern SCM scm_thunk_p SCM_P ((SCM obj));
+extern void scm_init_iprocs SCM_P ((scm_iproc *subra, int type));
+extern void scm_init_procs SCM_P ((void));
-#endif /* STDC */
+
#endif /* PROCSH */
diff --git a/libguile/putenv.c b/libguile/putenv.c
new file mode 100644
index 000000000..2700fe721
--- /dev/null
+++ b/libguile/putenv.c
@@ -0,0 +1,111 @@
+/* Copyright (C) 1991 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 program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifdef HAVE_CONFIG_H
+#include "libguile/scmconfig.h"
+#endif
+
+#include <sys/types.h>
+#include <errno.h>
+#ifndef errno
+extern int errno;
+#endif
+
+/* Don't include stdlib.h for non-GNU C libraries because some of them
+ contain conflicting prototypes for getopt.
+ This needs to come after some library #include
+ to get __GNU_LIBRARY__ defined. */
+#ifdef __GNU_LIBRARY__
+#include <stdlib.h>
+#else
+char *malloc ();
+#endif /* GNU C library. */
+
+#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
+#include <string.h>
+#else
+#include <strings.h>
+#ifndef strchr
+#define strchr index
+#endif
+#ifndef memcpy
+#define memcpy(d, s, n) bcopy((s), (d), (n))
+#endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+extern char **environ;
+
+/* Put STRING, which is of the form "NAME=VALUE", in the environment. */
+int
+putenv (string)
+ const char *string;
+{
+ char *name_end = strchr (string, '=');
+ register size_t size;
+ register char **ep;
+
+ if (name_end == NULL)
+ {
+ /* Remove the variable from the environment. */
+ size = strlen (string);
+ for (ep = environ; *ep != NULL; ++ep)
+ if (!strncmp (*ep, string, size) && (*ep)[size] == '=')
+ {
+ while (ep[1] != NULL)
+ {
+ ep[0] = ep[1];
+ ++ep;
+ }
+ *ep = NULL;
+ return 0;
+ }
+ }
+
+ size = 0;
+ for (ep = environ; *ep != NULL; ++ep)
+ if (!strncmp (*ep, string, name_end - string) &&
+ (*ep)[name_end - string] == '=')
+ break;
+ else
+ ++size;
+
+ if (*ep == NULL)
+ {
+ static char **last_environ = NULL;
+ char **new_environ = (char **) malloc ((size + 2) * sizeof (char *));
+ if (new_environ == NULL)
+ return -1;
+ memcpy ((char *) new_environ, (char *) environ, size * sizeof (char *));
+ new_environ[size] = (char *) string;
+ new_environ[size + 1] = NULL;
+ if (last_environ != NULL)
+ free ((char *) last_environ);
+ last_environ = new_environ;
+ environ = new_environ;
+ }
+ else
+ *ep = (char *) string;
+
+ return 0;
+}
diff --git a/libguile/ramap.c b/libguile/ramap.c
index a913da0e6..ec903ece4 100644
--- a/libguile/ramap.c
+++ b/libguile/ramap.c
@@ -45,7 +45,14 @@
#include <stdio.h>
#include "_scm.h"
-
+#include "unif.h"
+#include "smob.h"
+#include "chars.h"
+#include "eq.h"
+#include "eval.h"
+#include "feature.h"
+
+#include "ramap.h"
#ifdef ARRAYS
@@ -57,8 +64,32 @@ typedef struct
int (*vproc) ();
} ra_iproc;
-static ra_iproc ra_rpsubrs[];
-static ra_iproc ra_asubrs[];
+
+/* These tables are a kluge that will not scale well when more
+ * vectorized subrs are added. It is tempting to steal some bits from
+ * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
+ * offset into a table of vectorized subrs.
+ */
+
+static ra_iproc ra_rpsubrs[] =
+{
+ {"=", SCM_UNDEFINED, scm_ra_eqp},
+ {"<", SCM_UNDEFINED, scm_ra_lessp},
+ {"<=", SCM_UNDEFINED, scm_ra_leqp},
+ {">", SCM_UNDEFINED, scm_ra_grp},
+ {">=", SCM_UNDEFINED, scm_ra_greqp},
+ {0, 0, 0}
+};
+
+static ra_iproc ra_asubrs[] =
+{
+ {"+", SCM_UNDEFINED, scm_ra_sum},
+ {"-", SCM_UNDEFINED, scm_ra_difference},
+ {"*", SCM_UNDEFINED, scm_ra_product},
+ {"/", SCM_UNDEFINED, scm_ra_divide},
+ {0, 0, 0}
+};
+
#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT)))
@@ -81,15 +112,13 @@ static ra_iproc ra_asubrs[];
/* inds must be a uvect or ivect, no check. */
-#ifdef __STDC__
-static scm_sizet
-cind (SCM ra, SCM inds)
-#else
+
+static scm_sizet cind SCM_P ((SCM ra, SCM inds));
+
static scm_sizet
cind (ra, inds)
SCM ra;
SCM inds;
-#endif
{
scm_sizet i;
int k;
@@ -110,15 +139,11 @@ cind (ra, inds)
1 --> ras are at least as big as ra0;
0 --> no match.
*/
-#ifdef __STDC__
-int
-scm_ra_matchp (SCM ra0, SCM ras)
-#else
+
int
scm_ra_matchp (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
SCM ra1;
scm_array_dim dims;
@@ -135,6 +160,7 @@ scm_ra_matchp (ra0, ras)
return 0;
case scm_tc7_vector:
case scm_tc7_string:
+ case scm_tc7_byvect:
case scm_tc7_bvect:
case scm_tc7_uvect:
case scm_tc7_ivect:
@@ -166,6 +192,7 @@ scm_ra_matchp (ra0, ras)
return 0;
case scm_tc7_vector:
case scm_tc7_string:
+ case scm_tc7_byvect:
case scm_tc7_bvect:
case scm_tc7_uvect:
case scm_tc7_ivect:
@@ -221,10 +248,6 @@ scm_ra_matchp (ra0, ras)
static char s_ra_mismatch[] = "array shape mismatch";
-#ifdef __STDC__
-int
-scm_ramapc (int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what)
-#else
int
scm_ramapc (cproc, data, ra0, lra, what)
int (*cproc) ();
@@ -232,7 +255,6 @@ scm_ramapc (cproc, data, ra0, lra, what)
SCM ra0;
SCM lra;
char *what;
-#endif
{
SCM inds, z;
SCM vra0, ra1, vra1;
@@ -286,7 +308,7 @@ scm_ramapc (cproc, data, ra0, lra, what)
SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
}
*plvra = scm_cons (vra1, SCM_EOL);
- plvra = &SCM_CDR (*plvra);
+ plvra = SCM_CDRLOC (*plvra);
}
return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
case 1:
@@ -342,7 +364,7 @@ scm_ramapc (cproc, data, ra0, lra, what)
SCM_ARRAY_V (vra1) = ra1;
}
*plvra = scm_cons (vra1, SCM_EOL);
- plvra = &SCM_CDR (*plvra);
+ plvra = SCM_CDRLOC (*plvra);
}
inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L));
vinds = (long *) SCM_VELTS (inds);
@@ -377,17 +399,23 @@ scm_ramapc (cproc, data, ra0, lra, what)
}
-static char s_array_fill_x[];
-#ifdef __STDC__
-int
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
-#else
+SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x);
+
+SCM
+scm_array_fill_x (ra, fill)
+ SCM ra;
+ SCM fill;
+{
+ scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x);
+ return SCM_UNSPECIFIED;
+}
+
+
int
scm_array_fill_int (ra, fill, ignore)
SCM ra;
SCM fill;
SCM ignore;
-#endif
{
scm_sizet i, n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1;
long inc = SCM_ARRAY_DIMS (ra)->inc;
@@ -409,6 +437,15 @@ scm_array_fill_int (ra, fill, ignore)
for (i = base; n--; i += inc)
SCM_CHARS (ra)[i] = SCM_ICHR (fill);
break;
+ case scm_tc7_byvect:
+ if (SCM_ICHRP (fill))
+ fill = SCM_MAKINUM ((char) SCM_ICHR (fill));
+ SCM_ASRTGO (SCM_INUMP (fill)
+ && -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128,
+ badarg2);
+ for (i = base; n--; i += inc)
+ SCM_CHARS (ra)[i] = SCM_INUM (fill);
+ break;
case scm_tc7_bvect:
{
long *ve = (long *) SCM_VELTS (ra);
@@ -499,32 +536,15 @@ scm_array_fill_int (ra, fill, ignore)
return 1;
}
-SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x);
-#ifdef __STDC__
-SCM
-scm_array_fill_x (SCM ra, SCM fill)
-#else
-SCM
-scm_array_fill_x (ra, fill)
- SCM ra;
- SCM fill;
-#endif
-{
- scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x);
- return SCM_UNSPECIFIED;
-}
-#ifdef __STDC__
-static int
-racp (SCM dst, SCM src)
-#else
+static int racp SCM_P ((SCM dst, SCM src));
+
static int
racp (src, dst)
SCM dst;
SCM src;
-#endif
{
long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1);
long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc;
@@ -543,6 +563,7 @@ racp (src, dst)
scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d));
break;
case scm_tc7_string:
+ case scm_tc7_byvect:
if (scm_tc7_string != SCM_TYP7 (dst))
goto gencase;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
@@ -716,15 +737,11 @@ racp (src, dst)
SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x);
-#ifdef __STDC__
-SCM
-scm_array_copy_x (SCM src, SCM dst)
-#else
+
SCM
scm_array_copy_x (src, dst)
SCM src;
SCM dst;
-#endif
{
scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x);
return SCM_UNSPECIFIED;
@@ -732,15 +749,11 @@ scm_array_copy_x (src, dst)
/* Functions callable by ARRAY-MAP! */
-#ifdef __STDC__
-int
-scm_ra_eqp (SCM ra0, SCM ras)
-#else
+
int
scm_ra_eqp (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
@@ -803,17 +816,15 @@ scm_ra_eqp (ra0, ras)
}
/* opt 0 means <, nonzero means >= */
-#ifdef __STDC__
-static int
-ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
-#else
+
+static int ra_compare SCM_P ((SCM ra0, SCM ra1, SCM ra2, int opt));
+
static int
ra_compare (ra0, ra1, ra2, opt)
SCM ra0;
SCM ra1;
SCM ra2;
int opt;
-#endif
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
@@ -876,68 +887,48 @@ ra_compare (ra0, ra1, ra2, opt)
}
-#ifdef __STDC__
-int
-scm_ra_lessp (SCM ra0, SCM ras)
-#else
+
int
scm_ra_lessp (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
}
-#ifdef __STDC__
-int
-scm_ra_leqp (SCM ra0, SCM ras)
-#else
+
int
scm_ra_leqp (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
}
-#ifdef __STDC__
-int
-scm_ra_grp (SCM ra0, SCM ras)
-#else
+
int
scm_ra_grp (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
}
-#ifdef __STDC__
-int
-scm_ra_greqp (SCM ra0, SCM ras)
-#else
+
int
scm_ra_greqp (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
}
-#ifdef __STDC__
-int
-scm_ra_sum (SCM ra0, SCM ras)
-#else
+
int
scm_ra_sum (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@@ -967,7 +958,7 @@ scm_ra_sum (ra0, ras)
long *v1 = SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1]);
+ v0[i0] += v1[i1];)
break;
}
#ifdef SCM_FLOATS
@@ -978,7 +969,7 @@ scm_ra_sum (ra0, ras)
float *v1 = (float *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1]);
+ v0[i0] += v1[i1];)
break;
}
#endif /* SCM_SINGLES */
@@ -988,7 +979,7 @@ scm_ra_sum (ra0, ras)
double *v1 = (double *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1]);
+ v0[i0] += v1[i1];)
break;
}
case scm_tc7_cvect:
@@ -1011,15 +1002,11 @@ scm_ra_sum (ra0, ras)
}
-#ifdef __STDC__
-int
-scm_ra_difference (SCM ra0, SCM ras)
-#else
+
int
scm_ra_difference (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@@ -1091,7 +1078,7 @@ scm_ra_difference (ra0, ras)
float *v1 = (float *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] -= v1[i1]);
+ v0[i0] -= v1[i1];)
break;
}
#endif /* SCM_SINGLES */
@@ -1101,7 +1088,7 @@ scm_ra_difference (ra0, ras)
double *v1 = (double *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] -= v1[i1]);
+ v0[i0] -= v1[i1];)
break;
}
case scm_tc7_cvect:
@@ -1124,15 +1111,11 @@ scm_ra_difference (ra0, ras)
}
-#ifdef __STDC__
-int
-scm_ra_product (SCM ra0, SCM ras)
-#else
+
int
scm_ra_product (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@@ -1162,7 +1145,7 @@ scm_ra_product (ra0, ras)
long *v1 = SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1]);
+ v0[i0] *= v1[i1];)
break;
}
#ifdef SCM_FLOATS
@@ -1173,7 +1156,7 @@ scm_ra_product (ra0, ras)
float *v1 = (float *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1]);
+ v0[i0] *= v1[i1];)
break;
}
#endif /* SCM_SINGLES */
@@ -1183,7 +1166,7 @@ scm_ra_product (ra0, ras)
double *v1 = (double *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1]);
+ v0[i0] *= v1[i1];)
break;
}
case scm_tc7_cvect:
@@ -1207,15 +1190,11 @@ scm_ra_product (ra0, ras)
return 1;
}
-#ifdef __STDC__
-int
-scm_ra_divide (SCM ra0, SCM ras)
-#else
+
int
scm_ra_divide (ra0, ras)
SCM ra0;
SCM ras;
-#endif
{
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@@ -1289,7 +1268,7 @@ scm_ra_divide (ra0, ras)
float *v1 = (float *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] /= v1[i1]);
+ v0[i0] /= v1[i1];)
break;
}
#endif /* SCM_SINGLES */
@@ -1299,7 +1278,7 @@ scm_ra_divide (ra0, ras)
double *v1 = (double *) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] /= v1[i1]);
+ v0[i0] /= v1[i1];)
break;
}
case scm_tc7_cvect:
@@ -1324,31 +1303,24 @@ scm_ra_divide (ra0, ras)
return 1;
}
-#ifdef __STDC__
-int
-scm_array_identity (SCM src, SCM dst)
-#else
+
int
scm_array_identity (dst, src)
SCM src;
SCM dst;
-#endif
{
return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
}
-#ifdef __STDC__
-static
-int
-ramap (SCM ra0, SCM proc, SCM ras)
-#else
+
+static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras));
+
static int
ramap (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
-#endif
{
long i = SCM_ARRAY_DIMS (ra0)->lbnd;
long inc = SCM_ARRAY_DIMS (ra0)->inc;
@@ -1387,16 +1359,14 @@ ramap (ra0, proc, ras)
return 1;
}
-#ifdef __STDC__
-static int
-ramap_cxr (SCM ra0, SCM proc, SCM ras)
-#else
+
+static int ramap_cxr SCM_P ((SCM ra0, SCM proc, SCM ras));
+
static int
ramap_cxr (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
-#endif
{
SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED;
@@ -1462,16 +1432,14 @@ ramap_cxr (ra0, proc, ras)
}
-#ifdef __STDC__
-static int
-ramap_rp (SCM ra0, SCM proc, SCM ras)
-#else
+
+static int ramap_rp SCM_P ((SCM ra0, SCM proc, SCM ras));
+
static int
ramap_rp (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
-#endif
{
SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
@@ -1561,16 +1529,14 @@ ramap_rp (ra0, proc, ras)
}
-#ifdef __STDC__
-static int
-ramap_1 (SCM ra0, SCM proc, SCM ras)
-#else
+
+static int ramap_1 SCM_P ((SCM ra0, SCM proc, SCM ras));
+
static int
ramap_1 (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
-#endif
{
SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED;
@@ -1589,16 +1555,14 @@ ramap_1 (ra0, proc, ras)
}
-#ifdef __STDC__
-static int
-ramap_2o (SCM ra0, SCM proc, SCM ras)
-#else
+
+static int ramap_2o SCM_P ((SCM ra0, SCM proc, SCM ras));
+
static int
ramap_2o (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
-#endif
{
SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED;
@@ -1642,16 +1606,14 @@ ramap_2o (ra0, proc, ras)
}
-#ifdef __STDC__
-static int
-ramap_a (SCM ra0, SCM proc, SCM ras)
-#else
+
+static int ramap_a SCM_P ((SCM ra0, SCM proc, SCM ras));
+
static int
ramap_a (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
-#endif
{
SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
@@ -1677,16 +1639,12 @@ ramap_a (ra0, proc, ras)
SCM_PROC(s_serial_array_map, "serial-array-map", 2, 0, 1, scm_array_map);
SCM_PROC(s_array_map, "array-map", 2, 0, 1, scm_array_map);
-#ifdef __STDC__
-SCM
-scm_array_map (SCM ra0, SCM proc, SCM lra)
-#else
+
SCM
scm_array_map (ra0, proc, lra)
SCM ra0;
SCM proc;
SCM lra;
-#endif
{
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map);
switch (SCM_TYP7 (proc))
@@ -1787,16 +1745,14 @@ scm_array_map (ra0, proc, lra)
}
}
-#ifdef __STDC__
-static int
-rafe (SCM ra0, SCM proc, SCM ras)
-#else
+
+static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras));
+
static int
rafe (ra0, proc, ras)
SCM ra0;
SCM proc;
SCM ras;
-#endif
{
long i = SCM_ARRAY_DIMS (ra0)->lbnd;
scm_sizet i0 = SCM_ARRAY_BASE (ra0);
@@ -1837,16 +1793,12 @@ rafe (ra0, proc, ras)
SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each);
-#ifdef __STDC__
-SCM
-scm_array_for_each (SCM proc, SCM ra0, SCM lra)
-#else
+
SCM
scm_array_for_each (proc, ra0, lra)
SCM proc;
SCM ra0;
SCM lra;
-#endif
{
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each);
scm_ramapc (rafe, proc, ra0, lra, s_array_for_each);
@@ -1854,15 +1806,11 @@ scm_array_for_each (proc, ra0, lra)
}
SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x);
-#ifdef __STDC__
-SCM
-scm_array_index_map_x (SCM ra, SCM proc)
-#else
+
SCM
scm_array_index_map_x (ra, proc)
SCM ra;
SCM proc;
-#endif
{
scm_sizet i;
SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x);
@@ -1880,6 +1828,7 @@ scm_array_index_map_x (ra, proc)
return SCM_UNSPECIFIED;
}
case scm_tc7_string:
+ case scm_tc7_byvect:
case scm_tc7_bvect:
case scm_tc7_uvect:
case scm_tc7_ivect:
@@ -1930,16 +1879,14 @@ scm_array_index_map_x (ra, proc)
}
}
-#ifdef __STDC__
-static int
-raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
-#else
+
+static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
+
static int
raeql_1 (ra0, as_equal, ra1)
SCM ra0;
SCM as_equal;
SCM ra1;
-#endif
{
SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
scm_sizet i0 = 0, i1 = 0;
@@ -1981,6 +1928,7 @@ raeql_1 (ra0, as_equal, ra1)
}
return 1;
case scm_tc7_string:
+ case scm_tc7_byvect:
{
char *v0 = SCM_CHARS (ra0) + i0;
char *v1 = SCM_CHARS (ra1) + i1;
@@ -2043,16 +1991,14 @@ raeql_1 (ra0, as_equal, ra1)
}
-#ifdef __STDC__
-static int
-raeql (SCM ra0, SCM as_equal, SCM ra1)
-#else
+
+static int raeql SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
+
static int
raeql (ra0, as_equal, ra1)
SCM ra0;
SCM as_equal;
SCM ra1;
-#endif
{
SCM v0 = ra0, v1 = ra1;
scm_array_dim dim0, dim1;
@@ -2109,30 +2055,22 @@ raeql (ra0, as_equal, ra1)
return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
}
-#ifdef __STDC__
-SCM
-scm_raequal (SCM ra0, SCM ra1)
-#else
+
SCM
scm_raequal (ra0, ra1)
SCM ra0;
SCM ra1;
-#endif
{
return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
}
static char s_array_equal_p[] = "array-equal?";
-#ifdef __STDC__
-SCM
-scm_array_equal_p (SCM ra0, SCM ra1)
-#else
+
SCM
scm_array_equal_p (ra0, ra1)
SCM ra0;
SCM ra1;
-#endif
{
if (SCM_IMP (ra0) || SCM_IMP (ra1))
callequal:return scm_equal_p (ra0, ra1);
@@ -2143,6 +2081,7 @@ scm_array_equal_p (ra0, ra1)
goto callequal;
case scm_tc7_bvect:
case scm_tc7_string:
+ case scm_tc7_byvect:
case scm_tc7_uvect:
case scm_tc7_ivect:
case scm_tc7_fvect:
@@ -2161,6 +2100,7 @@ scm_array_equal_p (ra0, ra1)
goto callequal;
case scm_tc7_bvect:
case scm_tc7_string:
+ case scm_tc7_byvect:
case scm_tc7_uvect:
case scm_tc7_ivect:
case scm_tc7_fvect:
@@ -2177,46 +2117,17 @@ scm_array_equal_p (ra0, ra1)
-
-/* These tables are a kluge that will not scale well when more
- * vectorized subrs are added. It is tempting to steal some bits from
- * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
- * offset into a table of vectorized subrs.
- */
-
-static ra_iproc ra_rpsubrs[] =
-{
- {"=", SCM_UNDEFINED, scm_ra_eqp},
- {"<", SCM_UNDEFINED, scm_ra_lessp},
- {"<=", SCM_UNDEFINED, scm_ra_leqp},
- {">", SCM_UNDEFINED, scm_ra_grp},
- {">=", SCM_UNDEFINED, scm_ra_greqp},
- {0, 0, 0}
-};
-
-static ra_iproc ra_asubrs[] =
-{
- {"+", SCM_UNDEFINED, scm_ra_sum},
- {"-", SCM_UNDEFINED, scm_ra_difference},
- {"*", SCM_UNDEFINED, scm_ra_product},
- {"/", SCM_UNDEFINED, scm_ra_divide},
- {0, 0, 0}
-};
-
-static void init_raprocs (subra)
+static void
+init_raprocs (subra)
ra_iproc *subra;
{
for (; subra->name; subra++)
subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name)));
}
-#ifdef __STDC__
-void
-scm_init_ramap (void)
-#else
+
void
scm_init_ramap ()
-#endif
{
init_raprocs (ra_rpsubrs);
init_raprocs (ra_asubrs);
diff --git a/libguile/ramap.h b/libguile/ramap.h
index a198f59ee..da4ec2691 100644
--- a/libguile/ramap.h
+++ b/libguile/ramap.h
@@ -44,58 +44,30 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern int scm_ra_matchp (SCM ra0, SCM ras);
-extern int scm_ramapc (int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what);
-extern int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
-extern SCM scm_array_fill_x (SCM ra, SCM fill);
-extern SCM scm_array_copy (SCM src, SCM dst);
-extern int scm_ra_eqp (SCM ra0, SCM ras);
-extern int scm_ra_lessp (SCM ra0, SCM ras);
-extern int scm_ra_leqp (SCM ra0, SCM ras);
-extern int scm_ra_grp (SCM ra0, SCM ras);
-extern int scm_ra_greqp (SCM ra0, SCM ras);
-extern int scm_ra_sum (SCM ra0, SCM ras);
-extern int scm_ra_difference (SCM ra0, SCM ras);
-extern int scm_ra_product (SCM ra0, SCM ras);
-extern int scm_ra_divide (SCM ra0, SCM ras);
-extern int scm_array_identity (SCM src, SCM dst);
-extern SCM scm_array_map (SCM ra0, SCM proc, SCM lra);
-extern SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
-extern SCM scm_array_index_map_x (SCM ra, SCM proc);
-extern SCM scm_raequal (SCM ra0, SCM ra1);
-extern SCM scm_array_equal_p (SCM ra0, SCM ra1);
-extern void scm_init_ramap (void);
-
-#else /* STDC */
-extern int scm_ra_matchp ();
-extern int scm_ramapc ();
-extern int scm_array_fill_int ();
-extern SCM scm_array_fill_x ();
-extern SCM scm_array_copy ();
-extern int scm_ra_eqp ();
-extern int scm_ra_lessp ();
-extern int scm_ra_leqp ();
-extern int scm_ra_grp ();
-extern int scm_ra_greqp ();
-extern int scm_ra_sum ();
-extern int scm_ra_difference ();
-extern int scm_ra_product ();
-extern int scm_ra_divide ();
-extern int scm_array_identity ();
-extern SCM scm_array_map ();
-extern SCM scm_array_for_each ();
-extern SCM scm_array_index_map_x ();
-extern SCM scm_raequal ();
-extern SCM scm_array_equal_p ();
-extern void scm_init_ramap ();
-
-#endif /* STDC */
-
-
+extern int scm_ra_matchp SCM_P ((SCM ra0, SCM ras));
+extern int scm_ramapc SCM_P ((int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what));
+extern int scm_array_fill_int SCM_P ((SCM ra, SCM fill, SCM ignore));
+extern SCM scm_array_fill_x SCM_P ((SCM ra, SCM fill));
+extern SCM scm_array_copy_x SCM_P ((SCM src, SCM dst));
+extern int scm_ra_eqp SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_lessp SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_leqp SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_grp SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_greqp SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_sum SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_difference SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_product SCM_P ((SCM ra0, SCM ras));
+extern int scm_ra_divide SCM_P ((SCM ra0, SCM ras));
+extern int scm_array_identity SCM_P ((SCM src, SCM dst));
+extern SCM scm_array_map SCM_P ((SCM ra0, SCM proc, SCM lra));
+extern SCM scm_array_for_each SCM_P ((SCM proc, SCM ra0, SCM lra));
+extern SCM scm_array_index_map_x SCM_P ((SCM ra, SCM proc));
+extern SCM scm_raequal SCM_P ((SCM ra0, SCM ra1));
+extern SCM scm_array_equal_p SCM_P ((SCM ra0, SCM ra1));
+extern void scm_init_ramap SCM_P ((void));
#endif /* RAMAPH */
diff --git a/libguile/read.c b/libguile/read.c
index 1340fc1f4..99c291c03 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -43,41 +43,68 @@
#include "extchrs.h"
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "genio.h"
+#include "eval.h"
+#include "unif.h"
+#include "mbstrings.h"
+#include "kw.h"
+#include "alist.h"
+#include "srcprop.h"
+#include "hashtab.h"
+#include "hash.h"
+
#include "read.h"
-#define default_case_i 0
+SCM_SYMBOL (scm_keyword_prefix, "prefix");
-
+scm_option scm_read_opts[] = {
+ { SCM_OPTION_BOOLEAN, "copy", 0,
+ "Copy source code expressions." },
+ { SCM_OPTION_BOOLEAN, "positions", 0,
+ "Record positions of source code expressions." },
+ { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
+ "Convert symbols to lower case."},
+ { SCM_OPTION_SCM, "keywords", SCM_BOOL_F,
+ "Style of keyword recognition: #f or 'prefix"}
+};
+
+SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options);
+
+SCM
+scm_read_options (setting)
+ SCM setting;
+{
+ SCM ans = scm_options (setting,
+ scm_read_opts,
+ SCM_N_READ_OPTIONS,
+ s_read_options);
+ if (SCM_COPY_SOURCE_P)
+ SCM_RECORD_POSITIONS_P = 1;
+ return ans;
+}
+
+/* An association list mapping extra hash characters to procedures. */
+static SCM *scm_read_hash_procedures;
+
+SCM_PROC (s_read, "read", 0, 1, 0, scm_read);
-SCM_PROC (s_read, "read", 0, 3, 0, scm_read);
-#ifdef __STDC__
-SCM
-scm_read (SCM port, SCM case_insensative_p, SCM sharp)
-#else
SCM
-scm_read (port, case_insensative_p, sharp)
+scm_read (port)
SCM port;
- SCM case_insensative_p;
- SCM sharp;
-#endif
{
int c;
- SCM tok_buf;
- int case_i;
+ SCM tok_buf, copy;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read);
-
- case_i = (SCM_UNBNDP (case_insensative_p)
- ? default_case_i
- : (case_insensative_p == SCM_BOOL_F));
-
- if (SCM_UNBNDP (sharp))
- sharp = SCM_BOOL_F;
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
+ port,
+ SCM_ARG1,
+ s_read);
c = scm_flush_ws (port, (char *) NULL);
if (EOF == c)
@@ -85,48 +112,25 @@ scm_read (port, case_insensative_p, sharp)
scm_gen_ungetc (c, port);
tok_buf = scm_makstr (30L, 0);
- return scm_lreadr (&tok_buf, port, case_i, sharp);
+ return scm_lreadr (&tok_buf, port, &copy);
}
-#ifdef __STDC__
-char *
-scm_grow_tok_buf (SCM * tok_buf)
-#else
+
char *
scm_grow_tok_buf (tok_buf)
SCM * tok_buf;
-#endif
{
- SCM t2;
- scm_sizet len;
-
- len = SCM_LENGTH (*tok_buf);
- len += (len / 2 ? len / 2 : 1);
- t2 = scm_makstr (len, 0);
- {
- char * a;
- char * b;
- int l;
- for (a = SCM_CHARS (*tok_buf), b = SCM_CHARS (t2), l = SCM_LENGTH (*tok_buf);
- l;
- --l, ++a, ++b)
- *b = *a;
- }
- *tok_buf = t2;
+ scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf)));
return SCM_CHARS (*tok_buf);
}
-#ifdef __STDC__
-int
-scm_flush_ws (SCM port, char *eoferr)
-#else
+
int
scm_flush_ws (port, eoferr)
SCM port;
char *eoferr;
-#endif
{
register int c;
while (1)
@@ -150,12 +154,8 @@ scm_flush_ws (port, eoferr)
}
break;
case SCM_LINE_INCREMENTORS:
- break;
case SCM_SINGLE_SPACES:
- SCM_INCCOL (port);
- break;
case '\t':
- SCM_TABCOL (port);
break;
default:
return c;
@@ -163,15 +163,11 @@ scm_flush_ws (port, eoferr)
}
-#ifdef __STDC__
-int
-scm_casei_streq (char * s1, char * s2)
-#else
+
int
scm_casei_streq (s1, s2)
char * s1;
char * s2;
-#endif
{
while (*s1 && *s2)
if (scm_downcase((int)*s1) != scm_downcase((int)*s2))
@@ -185,42 +181,123 @@ scm_casei_streq (s1, s2)
}
-#ifdef __STDC__
-SCM
-scm_lreadr (SCM * tok_buf, SCM port, int case_i, SCM sharp)
-#else
+/* recsexpr is used when recording expressions
+ * constructed by read:sharp.
+ */
+
+static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename));
+
+static SCM
+recsexpr (obj, line, column, filename)
+ SCM obj;
+ int line;
+ int column;
+ SCM filename;
+{
+ if (SCM_IMP (obj) || SCM_NCONSP(obj))
+ return obj;
+ {
+ SCM tmp = obj, copy;
+ /* If this sexpr is visible in the read:sharp source, we want to
+ keep that information, so only record non-constant cons cells
+ which haven't previously been read by the reader. */
+ if (SCM_FALSEP (scm_whash_lookup (scm_source_whash, obj)))
+ {
+ if (SCM_COPY_SOURCE_P)
+ {
+ copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
+ SCM_UNDEFINED);
+ while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
+ {
+ SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
+ line,
+ column,
+ filename),
+ SCM_UNDEFINED));
+ copy = SCM_CDR (copy);
+ }
+ SCM_SETCDR (copy, tmp);
+ }
+ else
+ {
+ recsexpr (SCM_CAR (obj), line, column, filename);
+ while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
+ recsexpr (SCM_CAR (tmp), line, column, filename);
+ copy = SCM_UNDEFINED;
+ }
+ scm_whash_insert (scm_source_whash,
+ obj,
+ scm_make_srcprops (line,
+ column,
+ filename,
+ copy,
+ SCM_EOL));
+ }
+ return obj;
+ }
+}
+
+
+/* Consume an SCSH-style block comment. Assume that we've already
+ read the initial `#!', and eat characters until the matching `!#'. */
+
+static void
+skip_scsh_block_comment (port)
+ SCM port;
+{
+ char last_c = '\0';
+
+ for (;;)
+ {
+ int c = scm_gen_getc (port);
+
+ if (c == EOF)
+ scm_wta (SCM_UNDEFINED,
+ "unterminated `#! ... !#' comment", "read");
+ else if (c == '#' && last_c == '!')
+ return;
+
+ last_c = c;
+ }
+}
+
+static SCM
+scm_get_hash_procedure SCM_P ((int c));
+
+static char s_list[]="list";
+
SCM
-scm_lreadr (tok_buf, port, case_i, sharp)
- SCM * tok_buf;
+scm_lreadr (tok_buf, port, copy)
+ SCM *tok_buf;
SCM port;
- int case_i;
- SCM sharp;
-#endif
+ SCM *copy;
{
int c;
scm_sizet j;
SCM p;
-
+
tryagain:
c = scm_flush_ws (port, s_read);
+tryagain_no_flush_ws:
switch (c)
{
case EOF:
return SCM_EOF_VAL;
case '(':
- return scm_lreadparen (tok_buf, port, "list", case_i, sharp);
-
+ return SCM_RECORD_POSITIONS_P
+ ? scm_lreadrecparen (tok_buf, port, s_list, copy)
+ : scm_lreadparen (tok_buf, port, s_list, copy);
case ')':
scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read");
goto tryagain;
case '\'':
- return scm_cons2 (scm_i_quote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ p = scm_i_quote;
+ goto recquote;
case '`':
- return scm_cons2 (scm_i_quasiquote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ p = scm_i_quasiquote;
+ goto recquote;
case ',':
c = scm_gen_getc (port);
if ('@' == c)
@@ -230,14 +307,29 @@ tryagain:
scm_gen_ungetc (c, port);
p = scm_i_unquote;
}
- return scm_cons2 (p, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ recquote:
+ p = scm_cons2 (p,
+ scm_lreadr (tok_buf, port, copy),
+ SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash,
+ p,
+ scm_make_srcprops (SCM_LINUM (port),
+ SCM_COL (port) - 1,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (*copy = scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+ return p;
case '#':
c = scm_gen_getc (port);
switch (c)
{
case '(':
- p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp);
+ p = scm_lreadparen (tok_buf, port, "vector", copy);
return SCM_NULLP (p) ? scm_nullvect : scm_vector (p);
case 't':
@@ -263,8 +355,16 @@ tryagain:
c = '#';
goto num;
+ case '!':
+ /* start of a shell script. Parse as a block comment,
+ terminated by !#, just like SCSH. */
+ skip_scsh_block_comment (port);
+ /* EOF is not an error here */
+ c = scm_flush_ws (port, (char *)NULL);
+ goto tryagain_no_flush_ws;
+
case '*':
- j = scm_read_token (c, tok_buf, port, case_i, 0);
+ j = scm_read_token (c, tok_buf, port, 0);
p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1));
if (SCM_NFALSEP (p))
return p;
@@ -272,7 +372,7 @@ tryagain:
goto unkshrp;
case '{':
- j = scm_read_token (c, tok_buf, port, case_i, 1);
+ j = scm_read_token (c, tok_buf, port, 1);
p = scm_intern (SCM_CHARS (*tok_buf), j);
if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
@@ -280,7 +380,7 @@ tryagain:
case '\\':
c = scm_gen_getc (port);
- j = scm_read_token (c, tok_buf, port, case_i, 0);
+ j = scm_read_token (c, tok_buf, port, 0);
if (j == 1)
return SCM_MAKICHR (c);
if (c >= '0' && c < '8')
@@ -298,15 +398,30 @@ tryagain:
default:
callshrp:
- if (SCM_NIMP (sharp))
- {
- SCM got;
- got = scm_apply (sharp, SCM_MAKICHR (c), scm_acons (port, SCM_EOL, SCM_EOL));
- if (SCM_UNSPECIFIED == got)
- goto unkshrp;
- return got;
- }
- unkshrp:scm_wta ((SCM) SCM_MAKICHR (c), "unknown # object", "");
+ {
+ SCM sharp = scm_get_hash_procedure (c);
+
+ if (SCM_NIMP (sharp))
+ {
+ int line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 2;
+ SCM got;
+
+ got = scm_apply (sharp,
+ SCM_MAKICHR (c),
+ scm_acons (port, SCM_EOL, SCM_EOL));
+ if (SCM_UNSPECIFIED == got)
+ goto unkshrp;
+ if (SCM_RECORD_POSITIONS_P)
+ return *copy = recsexpr (got, line, column,
+ SCM_FILENAME (port));
+ else
+ return got;
+ }
+ }
+ unkshrp:
+ scm_misc_error (s_read, "Unknown # object: %S",
+ scm_listify (SCM_MAKICHR (c), SCM_UNDEFINED));
}
case '"':
@@ -379,7 +494,7 @@ tryagain:
case '-':
case '+':
num:
- j = scm_read_token (c, tok_buf, port, case_i, 0);
+ j = scm_read_token (c, tok_buf, port, 0);
p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L);
if (SCM_NFALSEP (p))
return p;
@@ -396,14 +511,17 @@ tryagain:
goto tok;
case ':':
- j = scm_read_token ('-', tok_buf, port, case_i, 0);
- p = scm_intern (SCM_CHARS (*tok_buf), j);
- if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
- scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
- return scm_make_keyword_from_dash_symbol (SCM_CAR (p));
-
+ if (SCM_KEYWORD_STYLE == scm_keyword_prefix)
+ {
+ j = scm_read_token ('-', tok_buf, port, 0);
+ p = scm_intern (SCM_CHARS (*tok_buf), j);
+ if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
+ scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
+ return scm_make_keyword_from_dash_symbol (SCM_CAR (p));
+ }
+ /* fallthrough */
default:
- j = scm_read_token (c, tok_buf, port, case_i, 0);
+ j = scm_read_token (c, tok_buf, port, 0);
/* fallthrough */
tok:
@@ -417,24 +535,19 @@ tryagain:
#ifdef _UNICOS
_Pragma ("noopt"); /* # pragma _CRI noopt */
#endif
-#ifdef __STDC__
-scm_sizet
-scm_read_token (int ic, SCM * tok_buf, SCM port, int case_i, int weird)
-#else
+
scm_sizet
-scm_read_token (ic, * tok_buf, port, case_i, weird)
+scm_read_token (ic, tok_buf, port, weird)
int ic;
SCM *tok_buf;
SCM port;
- int case_i;
int weird;
-#endif
{
register scm_sizet j;
register int c;
register char *p;
- c = ic;
+ c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(ic) : ic);
p = SCM_CHARS (*tok_buf);
if (weird)
@@ -512,7 +625,7 @@ scm_read_token (ic, * tok_buf, port, case_i, weird)
default:
default_case:
{
- c = (case_i ? scm_downcase(c) : c);
+ c = (SCM_CASE_INSENSITIVE_P ? scm_downcase(c) : c);
if (SCM_PORT_REPRESENTATION(port) == scm_regular_port)
{
p[j] = c;
@@ -532,22 +645,17 @@ scm_read_token (ic, * tok_buf, port, case_i, weird)
}
}
}
+
#ifdef _UNICOS
_Pragma ("opt"); /* # pragma _CRI opt */
#endif
-#ifdef __STDC__
SCM
-scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp)
-#else
-SCM
-scm_lreadparen (tok_buf, port, name, case_i, sharp)
+scm_lreadparen (tok_buf, port, name, copy)
SCM *tok_buf;
SCM port;
char *name;
- int case_i;
- SCM sharp;
-#endif
+ SCM *copy;
{
SCM tmp;
SCM tl;
@@ -558,9 +666,9 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp)
if (')' == c)
return SCM_EOL;
scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp)))
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
{
- ans = scm_lreadr (tok_buf, port, case_i, sharp);
+ ans = scm_lreadr (tok_buf, port, copy);
closeit:
if (')' != (c = scm_flush_ws (port, name)))
scm_wta (SCM_UNDEFINED, "missing close paren", "");
@@ -570,28 +678,172 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp)
while (')' != (c = scm_flush_ws (port, name)))
{
scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp)))
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
{
- SCM_CDR (tl) = scm_lreadr (tok_buf, port, case_i, sharp);
+ SCM_SETCDR (tl, scm_lreadr (tok_buf, port, copy));
goto closeit;
}
- tl = (SCM_CDR (tl) = scm_cons (tmp, SCM_EOL));
+ SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
+ tl = SCM_CDR (tl);
+ }
+ return ans;
+}
+
+
+SCM
+scm_lreadrecparen (tok_buf, port, name, copy)
+ SCM *tok_buf;
+ SCM port;
+ char *name;
+ SCM *copy;
+{
+ register int c;
+ register SCM tmp;
+ register SCM tl, tl2 = SCM_EOL;
+ SCM ans, ans2 = SCM_EOL;
+ /* Need to capture line and column numbers here. */
+ int line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ c = scm_flush_ws (port, name);
+ if (')' == c)
+ return SCM_EOL;
+ scm_gen_ungetc (c, port);
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
+ {
+ ans = scm_lreadr (tok_buf, port, copy);
+ if (')' != (c = scm_flush_ws (port, name)))
+ scm_wta (SCM_UNDEFINED, "missing close paren", "");
+ return ans;
+ }
+ /* Build the head of the list structure. */
+ ans = tl = scm_cons (tmp, SCM_EOL);
+ if (SCM_COPY_SOURCE_P)
+ ans2 = tl2 = scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL);
+ while (')' != (c = scm_flush_ws (port, name)))
+ {
+ scm_gen_ungetc (c, port);
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, copy)))
+ {
+ SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, copy));
+ if (SCM_COPY_SOURCE_P)
+ SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL));
+ if (')' != (c = scm_flush_ws (port, name)))
+ scm_wta (SCM_UNDEFINED, "missing close paren", "");
+ goto exit;
+ }
+ tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
+ if (SCM_COPY_SOURCE_P)
+ tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL));
}
+exit:
+ scm_whash_insert (scm_source_whash,
+ ans,
+ scm_make_srcprops (line,
+ column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? *copy = ans2
+ : SCM_UNDEFINED,
+ SCM_EOL));
return ans;
}
+/* Manipulate the read-hash-procedures alist. This could be written in
+ Scheme, but maybe it will also be used by C code during initialisation. */
+SCM_PROC (s_read_hash_extend, "read-hash-extend", 2, 0, 0, scm_read_hash_extend);
+SCM
+scm_read_hash_extend (chr, proc)
+ SCM chr;
+ SCM proc;
+{
+ SCM this;
+ SCM prev;
+
+ SCM_ASSERT (SCM_ICHRP(chr), chr, SCM_ARG1, s_read_hash_extend);
+ SCM_ASSERT (SCM_FALSEP (proc) || SCM_NIMP(proc), proc, SCM_ARG2,
+ s_read_hash_extend);
+
+ /* Check if chr is already in the alist. */
+ this = *scm_read_hash_procedures;
+ prev = SCM_BOOL_F;
+ while (1)
+ {
+ if (SCM_NULLP (this))
+ {
+ /* not found, so add it to the beginning. */
+ if (SCM_NFALSEP (proc))
+ {
+ *scm_read_hash_procedures =
+ scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
+ }
+ break;
+ }
+ if (chr == SCM_CAAR (this))
+ {
+ /* already in the alist. */
+ if (SCM_FALSEP (proc))
+ {
+ /* remove it. */
+ if (prev == SCM_BOOL_F)
+ {
+ *scm_read_hash_procedures =
+ SCM_CDR (*scm_read_hash_procedures);
+ }
+ else
+ scm_set_cdr_x (prev, SCM_CDR (this));
+ }
+ else
+ {
+ /* replace it. */
+ scm_set_cdr_x (SCM_CAR (this), proc);
+ }
+ break;
+ }
+ prev = this;
+ this = SCM_CDR (this);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+/* Recover the read-hash procedure corresponding to char c. */
+static SCM
+scm_get_hash_procedure (c)
+ int c;
+{
+ SCM rest = *scm_read_hash_procedures;
+
+ while (1)
+ {
+ if (SCM_NULLP (rest))
+ return SCM_BOOL_F;
+
+ if (SCM_ICHR (SCM_CAAR (rest)) == c)
+ return SCM_CDAR (rest);
+
+ rest = SCM_CDR (rest);
+ }
+}
-#ifdef __STDC__
-void
-scm_init_read (void)
-#else
void
scm_init_read ()
-#endif
{
+ scm_read_hash_procedures =
+ SCM_CDRLOC (scm_sysintern ("read-hash-procedures", SCM_EOL));
+
+ scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
#include "read.x"
}
-
diff --git a/libguile/read.h b/libguile/read.h
index edaea932b..f30e6660f 100644
--- a/libguile/read.h
+++ b/libguile/read.h
@@ -44,8 +44,9 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/options.h"
/* SCM_LINE_INCREMENTORS are the characters which cause the line count to
@@ -66,29 +67,26 @@
#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t'
-
-
-#ifdef __STDC__
-extern SCM scm_read (SCM port, SCM casep, SCM sharp);
-extern char * scm_grow_tok_buf (SCM * tok_buf);
-extern int scm_flush_ws (SCM port, char *eoferr);
-extern int scm_casei_streq (char * s1, char * s2);
-extern SCM scm_lreadr (SCM * tok_buf, SCM port, int case_i, SCM sharp);
-extern scm_sizet scm_read_token (int ic, SCM * tok_buf, SCM port, int case_i, int weird);
-extern SCM scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp);
-extern void scm_init_read (void);
+extern scm_option scm_read_opts[];
-#else /* STDC */
-extern SCM scm_read ();
-extern char * scm_grow_tok_buf ();
-extern int scm_flush_ws ();
-extern int scm_casei_streq ();
-extern SCM scm_lreadr ();
-extern scm_sizet scm_read_token ();
-extern SCM scm_lreadparen ();
-extern void scm_init_read ();
+#define SCM_COPY_SOURCE_P scm_read_opts[0].val
+#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
+#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
+#define SCM_KEYWORD_STYLE scm_read_opts[3].val
+#define SCM_N_READ_OPTIONS 4
-#endif /* STDC */
+
+extern SCM scm_read_options SCM_P ((SCM setting));
+extern SCM scm_read SCM_P ((SCM port));
+extern char * scm_grow_tok_buf SCM_P ((SCM * tok_buf));
+extern int scm_flush_ws SCM_P ((SCM port, char *eoferr));
+extern int scm_casei_streq SCM_P ((char * s1, char * s2));
+extern SCM scm_lreadr SCM_P ((SCM * tok_buf, SCM port, SCM *copy));
+extern scm_sizet scm_read_token SCM_P ((int ic, SCM * tok_buf, SCM port, int weird));
+extern SCM scm_lreadparen SCM_P ((SCM * tok_buf, SCM port, char *name, SCM *copy));
+extern SCM scm_lreadrecparen SCM_P ((SCM * tok_buf, SCM port, char *name, SCM *copy));
+extern SCM scm_read_hash_extend SCM_P ((SCM chr, SCM proc));
+extern void scm_init_read SCM_P ((void));
#endif /* READH */
diff --git a/libguile/root.c b/libguile/root.c
index 9db2e9b18..f90750802 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -42,16 +42,280 @@
#include <stdio.h>
#include "_scm.h"
+#include "stackchk.h"
+#include "dynwind.h"
+#include "eval.h"
+#include "genio.h"
+#include "smob.h"
+#include "pairs.h"
+#include "throw.h"
+#include "root.h"
SCM scm_sys_protects[SCM_NUM_PROTECTS];
-struct scm_root_state the_scm_root;
-struct scm_root_state * scm_root = &the_scm_root;
+
+long scm_tc16_root;
+
+#ifndef USE_THREADS
+struct scm_root_state *scm_root;
+#endif
+static SCM mark_root SCM_P ((SCM));
+
+static SCM
+mark_root (root)
+ SCM root;
+{
+ scm_root_state *s = SCM_ROOT_STATE (root);
+ SCM_SETGC8MARK (root);
+ scm_gc_mark (s->rootcont);
+ scm_gc_mark (s->dynwinds);
+ scm_gc_mark (s->continuation_stack);
+ scm_gc_mark (s->continuation_stack_ptr);
+ scm_gc_mark (s->progargs);
+ scm_gc_mark (s->exitval);
+ scm_gc_mark (s->cur_inp);
+ scm_gc_mark (s->cur_outp);
+ scm_gc_mark (s->cur_errp);
+ scm_gc_mark (s->def_inp);
+ scm_gc_mark (s->def_outp);
+ scm_gc_mark (s->def_errp);
+ scm_gc_mark (s->top_level_lookup_closure_var);
+ scm_gc_mark (s->system_transformer);
+ scm_gc_mark (s->the_last_stack_var);
+ return SCM_ROOT_STATE (root) -> parent;
+}
+
+static scm_sizet free_root SCM_P ((SCM));
+
+static scm_sizet
+free_root (root)
+ SCM root;
+{
+ scm_must_free ((char *) SCM_ROOT_STATE (root));
+ return sizeof (scm_root_state);
+}
+static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
+static int
+print_root (exp, port, pstate)
+ SCM exp;
+ SCM port;
+ scm_print_state *pstate;
+{
+ scm_gen_puts (scm_regular_string, "#<root ", port);
+ scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
+ scm_gen_putc('>', port);
+ return 1;
+}
+
+static scm_smobfuns root_smob =
+{
+ mark_root,
+ free_root,
+ print_root,
+ 0
+};
+
+
+
+SCM
+scm_make_root (parent)
+ SCM parent;
+{
+ SCM root;
+ scm_root_state *root_state;
+
+ root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
+ "scm_make_root");
+ if (SCM_NIMP (parent) && SCM_ROOTP (parent))
+ {
+ memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
+ root_state->parent = parent;
+ }
+ else
+ {
+ root_state->parent = SCM_BOOL_F;
+ }
+ SCM_NEWCELL (root);
+ SCM_REDEFER_INTS;
+ SCM_SETCAR (root, scm_tc16_root);
+ SCM_SETCDR (root, root_state);
+ root_state->handle = root;
+ SCM_REALLOW_INTS;
+ return root;
+}
+
+/* {call-with-dynamic-root}
+ *
+ * Suspending the current thread to evaluate a thunk on the
+ * same C stack but under a new root.
+ *
+ * Calls to call-with-dynamic-root return exactly once (unless
+ * the process is somehow exitted).
+ */
+
+/* Some questions about cwdr:
+
+ Couldn't the body just be a closure? Do we really need to pass
+ args through to it?
+
+ The semantics are a lot like catch's; in fact, we call
+ scm_internal_catch to take care of that part of things. Wouldn't
+ it be cleaner to say that uncaught throws just disappear into the
+ ether (or print a message to stderr), and let the caller use catch
+ themselves if they want to?
+
+ -JimB */
+
+#if 0
+SCM scm_exitval; /* INUM with return value */
+#endif
+static int n_dynamic_roots = 0;
+
+
+/* cwdr fills out one of these structures, and then passes a pointer
+ to it through scm_internal_catch to the cwdr_body function, to tell
+ it how to behave.
+
+ A cwdr is a lot like a catch, except there is no tag (all
+ exceptions are caught), and the body procedure takes the arguments
+ passed to cwdr as A1 and ARGS. */
+
+struct cwdr_body_data {
+
+ /* Arguments to pass to the cwdr body function. */
+ SCM a1, args;
+
+ /* Scheme procedure to use as body of cwdr. */
+ SCM body_proc;
+};
+
+
+/* Invoke the body of a cwdr, assuming that the throw handler has
+ already been set up. DATA points to a struct set up by cwdr that
+ says what proc to call, and what args to apply it to.
+
+ With a little thought, we could replace this with scm_body_thunk,
+ but I don't want to mess with that at the moment. */
+static SCM cwdr_body SCM_P ((void *, SCM));
+
+static SCM
+cwdr_body (void *data, SCM jmpbuf)
+{
+ struct cwdr_body_data *c = (struct cwdr_body_data *) data;
+
+ return scm_apply (c->body_proc, c->a1, c->args);
+}
+
+
+static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start));
+
+/* This is the basic code for new root creation.
+ *
+ * WARNING! The order of actions in this routine is in many ways
+ * critical. E. g., it is essential that an error doesn't leave Guile
+ * in a messed up state. */
+
+static SCM
+cwdr (proc, a1, args, handler, stack_start)
+ SCM proc;
+ SCM a1;
+ SCM args;
+ SCM handler;
+ SCM_STACKITEM *stack_start;
+{
+ int old_ints_disabled = scm_ints_disabled;
+ SCM old_rootcont, old_winds;
+ SCM answer;
+
+ /* Create a fresh root continuation.
+ */
+ {
+ SCM new_rootcont;
+ SCM_NEWCELL (new_rootcont);
+ SCM_REDEFER_INTS;
+ SCM_SETJMPBUF (new_rootcont,
+ scm_must_malloc ((long) sizeof (scm_contregs),
+ "inferior root continuation"));
+ SCM_SETCAR (new_rootcont, scm_tc7_contin);
+ SCM_DYNENV (new_rootcont) = SCM_EOL;
+ SCM_BASE (new_rootcont) = stack_start;
+ SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
+#ifdef DEBUG_EXTENSIONS
+ SCM_DFRAME (new_rootcont) = 0;
+#endif
+ old_rootcont = scm_rootcont;
+ scm_rootcont = new_rootcont;
+ SCM_REALLOW_INTS;
+ }
+
+ /* Exit caller's dynamic state.
+ */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
+#ifdef DEBUG_EXTENSIONS
+ SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
+ scm_last_debug_frame = 0;
+#endif
+
+ /* Catch all errors. */
+ {
+ struct cwdr_body_data c;
+
+ c.a1 = a1;
+ c.args = args;
+ c.body_proc = proc;
+
+ answer = scm_internal_catch (SCM_BOOL_T,
+ cwdr_body, &c,
+ scm_handle_by_proc, &handler);
+ }
+
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+ SCM_REDEFER_INTS;
+#ifdef DEBUG_EXTENSIONS
+ scm_last_debug_frame = SCM_DFRAME (old_rootcont);
+#endif
+ scm_rootcont = old_rootcont;
+ SCM_REALLOW_INTS;
+ scm_ints_disabled = old_ints_disabled;
+ return answer;
+}
+
+
+SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
+SCM
+scm_call_with_dynamic_root (thunk, handler)
+ SCM thunk;
+ SCM handler;
+{
+ SCM_STACKITEM stack_place;
+
+ return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
+}
+
+SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
+SCM
+scm_dynamic_root ()
+{
+ return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
+}
+
+SCM
+scm_apply_with_dynamic_root (proc, a1, args, handler)
+ SCM proc;
+ SCM a1;
+ SCM args;
+ SCM handler;
+{
+ SCM_STACKITEM stack_place;
+ return cwdr (proc, a1, args, handler, &stack_place);
+}
@@ -68,20 +332,20 @@ typedef long setjmp_type;
#endif
-#ifdef __STDC__
-SCM
-scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void * closure)
-#else
+
SCM
scm_call_catching_errors (thunk, err_filter, closure)
SCM (*thunk)();
SCM (*err_filter)();
- void * closure;
-#endif
+ void *closure;
{
SCM answer;
setjmp_type i;
+#ifdef DEBUG_EXTENSIONS
+ SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
+#endif
i = setjmp (SCM_JMPBUF (scm_rootcont));
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
if (!i)
{
scm_gc_heap_lock = 0;
@@ -95,7 +359,9 @@ scm_call_catching_errors (thunk, err_filter, closure)
return answer;
}
-
-
-
-
+void
+scm_init_root ()
+{
+ scm_tc16_root = scm_newsmob (&root_smob);
+#include "root.x"
+}
diff --git a/libguile/root.h b/libguile/root.h
index 370563dad..2602467ee 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -47,7 +47,8 @@
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/debug.h"
@@ -66,13 +67,24 @@
#define scm_object_whash scm_sys_protects[12]
#define scm_permobjs scm_sys_protects[13]
#define scm_asyncs scm_sys_protects[14]
-#define SCM_NUM_PROTECTS 15
+#define scm_protects scm_sys_protects[15]
+#ifdef DEBUG_EXTENSIONS
+#define scm_source_whash scm_sys_protects[16]
+#define SCM_NUM_PROTECTS 17
+#else
+#define SCM_NUM_PROTECTS 16
+#endif
extern SCM scm_sys_protects[];
-struct scm_root_state
+extern long scm_tc16_root;
+
+#define SCM_ROOTP(obj) (scm_tc16_root == SCM_TYP16 (obj))
+#define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_CDR (root))
+
+typedef struct scm_root_state
{
SCM_STACKITEM * stack_base;
jmp_buf save_regs_gc_mark;
@@ -82,7 +94,11 @@ struct scm_root_state
SCM dynwinds;
SCM continuation_stack;
SCM continuation_stack_ptr;
-
+#ifdef DEBUG_EXTENSIONS
+ /* It is very inefficient to have this variable in the root state. */
+ scm_debug_frame *last_debug_frame;
+#endif
+
SCM progargs; /* vestigial */
SCM exitval; /* vestigial */
@@ -94,8 +110,13 @@ struct scm_root_state
SCM def_errp;
SCM system_transformer;
- SCM top_level_lookup_thunk_var;
-};
+ SCM top_level_lookup_closure_var;
+
+ SCM the_last_stack_var;
+
+ SCM handle; /* The root object for this root state */
+ SCM parent; /* The parent root object */
+} scm_root_state;
#define scm_stack_base (scm_root->stack_base)
#define scm_save_regs_gc_mark (scm_root->save_regs_gc_mark)
@@ -106,6 +127,9 @@ struct scm_root_state
#define scm_continuation_stack (scm_root->continuation_stack)
#define scm_continuation_stack_ptr (scm_root->continuation_stack_ptr)
#define scm_progargs (scm_root->progargs)
+#ifdef USE_THREADS
+#define scm_last_debug_frame (scm_root->last_debug_frame)
+#endif
#define scm_exitval (scm_root->exitval)
#define scm_cur_inp (scm_root->cur_inp)
#define scm_cur_outp (scm_root->cur_outp)
@@ -113,26 +137,25 @@ struct scm_root_state
#define scm_def_inp (scm_root->def_inp)
#define scm_def_outp (scm_root->def_outp)
#define scm_def_errp (scm_root->def_errp)
-#define scm_top_level_lookup_thunk_var (scm_root->top_level_lookup_thunk_var)
+#define scm_top_level_lookup_closure_var \
+ (scm_root->top_level_lookup_closure_var)
#define scm_system_transformer (scm_root->system_transformer)
-
-
-extern struct scm_root_state * scm_root;
+#define scm_the_last_stack_var (scm_root->the_last_stack_var)
+
+#ifdef USE_THREADS
+#define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA)
+#define scm_set_root(new_root) SCM_SET_THREAD_LOCAL_DATA (new_root)
+#else /* USE_THREADS */
+extern struct scm_root_state *scm_root;
+#define scm_set_root(new_root) (scm_root = (new_root))
+#endif /* USE_THREADS */
-
-#ifdef __STDC__
-extern SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void * closure);
-
-#else /* STDC */
-extern SCM scm_call_catching_errors ();
-
-#endif /* STDC */
-
-
-
-
-
+extern SCM scm_make_root SCM_P ((SCM parent));
+extern SCM scm_call_with_dynamic_root SCM_P ((SCM thunk, SCM handler));
+extern SCM scm_apply_with_dynamic_root SCM_P ((SCM proc, SCM a1, SCM args, SCM handler));
+extern SCM scm_call_catching_errors SCM_P ((SCM (*thunk)(), SCM (*err_filter)(), void * closure));
+extern void scm_init_root SCM_P ((void));
#endif /* ROOTH */
diff --git a/libguile/scmconfig.h.in b/libguile/scmconfig.h.in
index af237dbdc..213a9a7d5 100644
--- a/libguile/scmconfig.h.in
+++ b/libguile/scmconfig.h.in
@@ -7,9 +7,16 @@
#undef _ALL_SOURCE
#endif
+/* Define if using alloca.c. */
+#undef C_ALLOCA
+
/* Define to empty if the keyword does not work. */
#undef const
+/* Define to one of _getb67, GETB67, getb67 for Cray-2 and Cray-YMP systems.
+ This function is required for alloca.c support on those systems. */
+#undef CRAY_STACKSEG_END
+
/* Define to the type of elements in the array set by `getgroups'.
Usually this is either `int' or `gid_t'. */
#undef GETGROUPS_T
@@ -17,6 +24,12 @@
/* Define to `int' if <sys/types.h> doesn't define. */
#undef gid_t
+/* Define if you have alloca, as a function or macro. */
+#undef HAVE_ALLOCA
+
+/* Define if you have <alloca.h> and it should be used (not on Ultrix). */
+#undef HAVE_ALLOCA_H
+
/* Define if your struct stat has st_blksize. */
#undef HAVE_ST_BLKSIZE
@@ -29,9 +42,19 @@
/* Define if you have <sys/wait.h> that is POSIX.1 compatible. */
#undef HAVE_SYS_WAIT_H
+/* Define if your struct tm has tm_zone. */
+#undef HAVE_TM_ZONE
+
+/* Define if you don't have tm_zone but do have the external array
+ tzname. */
+#undef HAVE_TZNAME
+
/* Define if on MINIX. */
#undef _MINIX
+/* Define to `int' if <sys/types.h> doesn't define. */
+#undef mode_t
+
/* Define if the system does not provide POSIX.1 features except
with this defined. */
#undef _POSIX_1_SOURCE
@@ -42,15 +65,102 @@
/* Define as the return type of signal handlers (int or void). */
#undef RETSIGTYPE
+/* If using the C implementation of alloca, define if you know the
+ direction of stack growth for your system; otherwise it will be
+ automatically deduced at run-time.
+ STACK_DIRECTION > 0 => grows toward higher addresses
+ STACK_DIRECTION < 0 => grows toward lower addresses
+ STACK_DIRECTION = 0 => direction of growth unknown
+ */
+#undef STACK_DIRECTION
+
/* Define if you have the ANSI C header files. */
#undef STDC_HEADERS
/* Define if you can safely include both <sys/time.h> and <time.h>. */
#undef TIME_WITH_SYS_TIME
+/* Define if your <sys/time.h> declares struct tm. */
+#undef TM_IN_SYS_TIME
+
/* Define to `int' if <sys/types.h> doesn't define. */
#undef uid_t
+/* Define these two if you want support for debugging of Scheme
+ programs. */
+#undef DEBUG_EXTENSIONS
+#undef READER_EXTENSIONS
+
+/* Define this if your system has a way to set a stdio stream's file
+ descriptor. */
+#undef FD_SETTER
+
+/* Set this to the name of a field in FILE which contains the number
+ of buffered characters waiting to be read. */
+#undef FILE_CNT_FIELD
+
+/* Define this if your stdio has _gptr and _egptr fields which can
+ be compared to give the number of buffered characters waiting to
+ be read. */
+#undef FILE_CNT_GPTR
+
+/* Define this if your stdio has _IO_read_ptr and _IO_read_end fields
+ which can be compared to give the number of buffered characters
+ waiting to be read. */
+#undef FILE_CNT_READPTR
+
+/* Define this if your system defines struct linger, for use with the
+ getsockopt and setsockopt system calls. */
+#undef HAVE_STRUCT_LINGER
+
+/* Define this if floats are the same size as longs. */
+#undef SCM_SINGLES
+
+/* Define this if a callee's stack frame has a higher address than the
+ caller's stack frame. On most machines, this is not the case. */
+#undef SCM_STACK_GROWS_UP
+
+/* Define this if <utime.h> doesn't define struct utimbuf unless
+ _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */
+#undef UTIMBUF_NEEDS_POSIX
+
+/* Define this if we should #include <libc.h> when we've already
+ #included <unistd.h>. On some systems, they conflict, and libc.h
+ should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in
+ aclocal.m4. */
+#undef LIBC_H_WITH_UNISTD_H
+
+/* Define these to indicate the current version of Guile. These
+ values are supposed to be supplied by the configuration system. */
+#undef GUILE_MAJOR_VERSION
+#undef GUILE_MINOR_VERSION
+#undef GUILE_VERSION
+
+/* Define this to include various undocumented functions used to debug
+ the Guile library itself. */
+#undef GUILE_DEBUG
+
+/* Define if using cooperative multithreading. */
+#undef USE_COOP_THREADS
+
+/* Define if using "FSU" pthreads. */
+#undef USE_FSU_PTHREADS
+
+/* Define if using MIT pthreads. */
+#undef USE_MIT_PTHREADS
+
+/* Define if using PCthreads pthreads. */
+#undef USE_PCTHREADS_PTHREADS
+
+/* Define if using any sort of threads. */
+#undef USE_THREADS
+
+/* Define if you want support for dynamic linking. */
+#undef DYNAMIC_LINKING
+
+/* Define if you have the ctermid function. */
+#undef HAVE_CTERMID
+
/* Define if you have the ftime function. */
#undef HAVE_FTIME
@@ -60,6 +170,12 @@
/* Define if you have the geteuid function. */
#undef HAVE_GETEUID
+/* Define if you have the gettimeofday function. */
+#undef HAVE_GETTIMEOFDAY
+
+/* Define if you have the inet_aton function. */
+#undef HAVE_INET_ATON
+
/* Define if you have the lstat function. */
#undef HAVE_LSTAT
@@ -87,9 +203,27 @@
/* Define if you have the select function. */
#undef HAVE_SELECT
+/* Define if you have the setegid function. */
+#undef HAVE_SETEGID
+
+/* Define if you have the seteuid function. */
+#undef HAVE_SETEUID
+
/* Define if you have the setlocale function. */
#undef HAVE_SETLOCALE
+/* Define if you have the setpgid function. */
+#undef HAVE_SETPGID
+
+/* Define if you have the setsid function. */
+#undef HAVE_SETSID
+
+/* Define if you have the shl_load function. */
+#undef HAVE_SHL_LOAD
+
+/* Define if you have the strerror function. */
+#undef HAVE_STRERROR
+
/* Define if you have the strftime function. */
#undef HAVE_STRFTIME
@@ -102,15 +236,27 @@
/* Define if you have the sync function. */
#undef HAVE_SYNC
+/* Define if you have the tcgetpgrp function. */
+#undef HAVE_TCGETPGRP
+
+/* Define if you have the tcsetpgrp function. */
+#undef HAVE_TCSETPGRP
+
/* Define if you have the times function. */
#undef HAVE_TIMES
/* Define if you have the uname function. */
#undef HAVE_UNAME
+/* Define if you have the waitpid function. */
+#undef HAVE_WAITPID
+
/* Define if you have the <dirent.h> header file. */
#undef HAVE_DIRENT_H
+/* Define if you have the <libc.h> header file. */
+#undef HAVE_LIBC_H
+
/* Define if you have the <limits.h> header file. */
#undef HAVE_LIMITS_H
@@ -129,6 +275,9 @@
/* Define if you have the <sys/dir.h> header file. */
#undef HAVE_SYS_DIR_H
+/* Define if you have the <sys/ioctl.h> header file. */
+#undef HAVE_SYS_IOCTL_H
+
/* Define if you have the <sys/ndir.h> header file. */
#undef HAVE_SYS_NDIR_H
@@ -147,13 +296,29 @@
/* Define if you have the <sys/types.h> header file. */
#undef HAVE_SYS_TYPES_H
+/* Define if you have the <sys/utime.h> header file. */
+#undef HAVE_SYS_UTIME_H
+
/* Define if you have the <time.h> header file. */
#undef HAVE_TIME_H
/* Define if you have the <unistd.h> header file. */
#undef HAVE_UNISTD_H
-#undef SCM_SINGLES
+/* Define if you have the <utime.h> header file. */
+#undef HAVE_UTIME_H
-#undef SCM_STACK_GROWS_UP
+/* Define if you have the dl library (-ldl). */
+#undef HAVE_LIBDL
+
+/* Define if you have the dld library (-ldld). */
+#undef HAVE_LIBDLD
+
+/* Define if you have the m library (-lm). */
+#undef HAVE_LIBM
+
+/* Define if you have the nsl library (-lnsl). */
+#undef HAVE_LIBNSL
+/* Define if you have the socket library (-lsocket). */
+#undef HAVE_LIBSOCKET
diff --git a/libguile/scmhob.h b/libguile/scmhob.h
index 127f4d5c1..6bd61489a 100644
--- a/libguile/scmhob.h
+++ b/libguile/scmhob.h
@@ -22,7 +22,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#include <stdio.h>
#include <ctype.h>
-#include "_scm.h"
+#include "libguile/_scm.h"
@@ -53,7 +53,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#define in2ex scm_inexact_to_exact
#define inexactp scm_inexact_p
#define input_portp scm_input_port_p
-#define intp scm_int_p
+#define intp scm_integer_p
#define length scm_length
#define leqp scm_leq_p
#define lessp scm_less_p
@@ -131,7 +131,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#define CHCI_LESSP(x,y) ((upcase[SCM_ICHR(x)] < upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHCI_LEQP(x,y) ((upcase[SCM_ICHR(x)] <= upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHAR_ALPHAP(chr) ((isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHAR_SCM_NUMP(chr) ((isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
+#define SCM_CHAR_NUMP(chr) ((isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHAR_WHITEP(chr) ((isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHAR_UPPERP(chr) ((isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHAR_LOWERP(chr) ((isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
@@ -139,9 +139,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#define INT2CHAR(n) SCM_MAKICHR(SCM_INUM(n))
#define CHAR_UPCASE(chr) SCM_MAKICHR(upcase[SCM_ICHR(chr)])
#define CHAR_DOWNCASE(chr) SCM_MAKICHR(downcase[SCM_ICHR(chr)])
-#define ST_SCM_LENGTH(str) SCM_MAKINUM(SCM_LENGTH(str))
+#define ST_LENGTH(str) SCM_MAKINUM(SCM_LENGTH(str))
#define ST_REF(str,k) SCM_MAKICHR(SCM_CHARS(str)[SCM_INUM(k)])
-#define VECTOR_SCM_LENGTH(v) SCM_MAKINUM(SCM_LENGTH(v))
+#define VECTOR_LENGTH(v) SCM_MAKINUM(SCM_LENGTH(v))
#ifdef SCM_FLOATS
#include <math.h>
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index bb7f740f9..7429a1598 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -44,6 +44,8 @@
#include <signal.h>
#include "_scm.h"
+#include "scmsigs.h"
+
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -55,6 +57,11 @@
#define signal ssignal /* Needed for TURBOC V1.0 */
#endif
+#ifdef USE_MIT_PTHREADS
+#undef signal
+#define signal pthread_signal
+#endif
+
/* SIGRETTYPE is the type that signal handlers return. See <signal.h>*/
@@ -134,14 +141,10 @@ FAKESIGFN(scm_tick_signal, SCM_TICK_SIGNAL)
SCM_PROC(s_alarm, "alarm", 1, 0, 0, scm_alarm);
-#ifdef __STDC__
-SCM
-scm_alarm (SCM i)
-#else
+
SCM
scm_alarm (i)
SCM i;
-#endif
{
unsigned int j;
SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_alarm);
@@ -151,27 +154,19 @@ scm_alarm (i)
SCM_PROC(s_pause, "pause", 0, 0, 0, scm_pause);
-#ifdef __STDC__
-SCM
-scm_pause (void)
-#else
+
SCM
scm_pause ()
-#endif
{
pause ();
return SCM_UNSPECIFIED;
}
SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep);
-#ifdef __STDC__
-SCM
-scm_sleep (SCM i)
-#else
+
SCM
scm_sleep (i)
SCM i;
-#endif
{
unsigned int j;
SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_sleep);
@@ -184,14 +179,10 @@ scm_sleep (i)
}
SCM_PROC(s_raise, "raise", 1, 0, 0, scm_raise);
-#ifdef __STDC__
-SCM
-scm_raise(SCM sig)
-#else
+
SCM
scm_raise(sig)
SCM sig;
-#endif
{
SCM_ASSERT(SCM_INUMP(sig), sig, SCM_ARG1, s_raise);
# ifdef vms
@@ -231,13 +222,9 @@ static SIGRETTYPE (*oldpipe) ();
#endif
-#ifdef __STDC__
-void
-scm_init_signals (void)
-#else
+
void
scm_init_signals ()
-#endif
{
#ifdef SIGINT
oldint = signal (SIGINT, scm_int_signal);
@@ -272,13 +259,9 @@ scm_init_signals ()
/* This is used in preparation for a possible fork(). Ignore all
signals before the fork so that child will catch only if it
establishes a handler */
-#ifdef __STDC__
-void
-scm_ignore_signals (void)
-#else
+
void
scm_ignore_signals ()
-#endif
{
#ifdef ultrix
siginterrupt (SIGINT, 0);
@@ -313,13 +296,9 @@ scm_ignore_signals ()
fflush (stderr);
}
-#ifdef __STDC__
-void
-scm_unignore_signals (void)
-#else
+
void
scm_unignore_signals ()
-#endif
{
signal (SIGINT, scm_int_signal);
#ifdef SIGHUP
@@ -346,13 +325,9 @@ scm_unignore_signals ()
}
SCM_PROC (s_restore_signals, "restore-signals", 0, 0, 0, scm_restore_signals);
-#ifdef __STDC__
-SCM
-scm_restore_signals (void)
-#else
+
SCM
scm_restore_signals ()
-#endif
{
#ifdef ultrix
siginterrupt (SIGINT, 0);
@@ -384,13 +359,9 @@ scm_restore_signals ()
}
-#ifdef __STDC__
-void
-scm_init_scmsigs (void)
-#else
+
void
scm_init_scmsigs ()
-#endif
{
#include "scmsigs.x"
}
diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h
index 484b15e9d..3b8bdc48c 100644
--- a/libguile/scmsigs.h
+++ b/libguile/scmsigs.h
@@ -43,37 +43,18 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_alarm (SCM i);
-extern SCM scm_pause (void);
-extern SCM scm_sleep (SCM i);
-extern SCM scm_raise(SCM sig);
-extern void scm_init_signals (void);
-extern void scm_ignore_signals (void);
-extern void scm_unignore_signals (void);
-extern SCM scm_restore_signals (void);
-extern void scm_init_scmsigs (void);
-
-#else /* STDC */
-extern SCM scm_alarm ();
-extern SCM scm_pause ();
-extern SCM scm_sleep ();
-extern SCM scm_raise();
-extern void scm_init_signals ();
-extern void scm_ignore_signals ();
-extern void scm_unignore_signals ();
-extern SCM scm_restore_signals ();
-extern void scm_init_scmsigs ();
-
-#endif /* STDC */
-
-
-
-
-
+extern SCM scm_alarm SCM_P ((SCM i));
+extern SCM scm_pause SCM_P ((void));
+extern SCM scm_sleep SCM_P ((SCM i));
+extern SCM scm_raise SCM_P ((SCM sig));
+extern void scm_init_signals SCM_P ((void));
+extern void scm_ignore_signals SCM_P ((void));
+extern void scm_unignore_signals SCM_P ((void));
+extern SCM scm_restore_signals SCM_P ((void));
+extern void scm_init_scmsigs SCM_P ((void));
#endif /* SCMSIGSH */
diff --git a/libguile/sequences.c b/libguile/sequences.c
index 6973f74dc..38c59e082 100644
--- a/libguile/sequences.c
+++ b/libguile/sequences.c
@@ -43,18 +43,15 @@
#include <stdio.h>
#include "_scm.h"
+#include "sequences.h"
-#ifdef __STDC__
-int
-scm_obj_length (SCM obj)
-#else
+
int
scm_obj_length (obj)
SCM obj;
-#endif
{
int i;
i = scm_ilength(obj);
@@ -75,14 +72,10 @@ scm_obj_length (obj)
SCM_PROC(s_length, "length", 1, 0, 0, scm_length);
-#ifdef __STDC__
-SCM
-scm_length(SCM x)
-#else
+
SCM
scm_length(x)
SCM x;
-#endif
{
int i;
i = scm_obj_length(x);
@@ -100,14 +93,10 @@ scm_length(x)
SCM_PROC (s_reverse, "reverse", 1, 0, 0, scm_reverse);
-#ifdef __STDC__
-SCM
-scm_reverse (SCM objs)
-#else
+
SCM
scm_reverse (objs)
SCM objs;
-#endif
{
return scm_list_reverse (objs);
}
@@ -115,13 +104,9 @@ scm_reverse (objs)
-#ifdef __STDC__
-void
-scm_init_sequences (void)
-#else
+
void
scm_init_sequences ()
-#endif
{
#include "sequences.x"
}
diff --git a/libguile/sequences.h b/libguile/sequences.h
index a508daa9b..6520457fc 100644
--- a/libguile/sequences.h
+++ b/libguile/sequences.h
@@ -43,28 +43,17 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern int scm_obj_length (SCM obj);
-extern SCM scm_length(SCM x);
-extern SCM scm_reverse (SCM objs);
-extern void scm_init_sequences (void);
-
-#else /* STDC */
-extern int scm_obj_length ();
-extern SCM scm_length();
-extern SCM scm_reverse ();
-extern void scm_init_sequences ();
-
-#endif /* STDC */
-
-
+extern int scm_obj_length SCM_P ((SCM obj));
+extern SCM scm_length SCM_P ((SCM x));
+extern SCM scm_reverse SCM_P ((SCM objs));
+extern void scm_init_sequences SCM_P ((void));
#endif /* SEQUENCESH */
diff --git a/libguile/simpos.c b/libguile/simpos.c
index f04e28cc5..8bbbaadd9 100644
--- a/libguile/simpos.c
+++ b/libguile/simpos.c
@@ -42,6 +42,13 @@
#include <stdio.h>
#include "_scm.h"
+
+#include "scmsigs.h"
+#include "simpos.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -52,14 +59,10 @@ extern int system();
#ifndef _Windows
SCM_PROC(s_system, "system", 1, 0, 0, scm_system);
-#ifdef __STDC__
-SCM
-scm_system(SCM cmd)
-#else
+
SCM
scm_system(cmd)
SCM cmd;
-#endif
{
SCM_ASSERT(SCM_NIMP(cmd) && SCM_ROSTRINGP(cmd), cmd, SCM_ARG1, s_system);
if (SCM_ROSTRINGP (cmd))
@@ -76,30 +79,34 @@ scm_system(cmd)
#endif
extern char *getenv();
-SCM_PROC (s_sys_getenv, "%getenv", 1, 0, 0, scm_sys_getenv);
-#ifdef __STDC__
-SCM
-scm_sys_getenv(SCM nam)
-#else
+SCM_PROC (s_getenv, "getenv", 1, 0, 0, scm_getenv);
+
SCM
-scm_sys_getenv(nam)
+scm_getenv(nam)
SCM nam;
-#endif
{
char *val;
- SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_sys_getenv);
+ SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_getenv);
if (SCM_ROSTRINGP (nam))
nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0);
val = getenv(SCM_CHARS(nam));
- if (!val)
- return SCM_BOOL_F;
- return scm_makfromstr(val, (scm_sizet)strlen(val), 0);
+ return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F;
}
+/* I have a feeling this whole arrangement below is a bad idea. One
+ should always test for the presence or absence of a particular
+ feature, instead of checking the system name. Older versions of a
+ system may lack features posessed by new ones, and a feature
+ appearing on one system will soon appear on others. And autoconf
+ provides the mechanisms for detecting features. -JimB */
+
+#ifdef _AIX
+# define SYSTNAME "AIX"
+#endif
#ifdef vms
# define SYSTNAME "VMS"
#endif
-#ifdef unix
+#if defined (unix) || defined (__unix)
# define SYSTNAME "UNIX"
#endif
#ifdef MWC
@@ -135,13 +142,9 @@ scm_sys_getenv(nam)
#endif
SCM_PROC(s_software_type, "software-type", 0, 0, 0, scm_software_type);
-#ifdef __STDC__
-SCM
-scm_software_type(void)
-#else
+
SCM
scm_software_type()
-#endif
{
#ifdef nosve
return SCM_CAR(scm_intern("nosve", 5));
@@ -150,13 +153,9 @@ scm_software_type()
#endif
}
-#ifdef __STDC__
-void
-scm_init_simpos (void)
-#else
+
void
scm_init_simpos ()
-#endif
{
#include "simpos.x"
}
diff --git a/libguile/simpos.h b/libguile/simpos.h
index 78cce68a5..023966ad1 100644
--- a/libguile/simpos.h
+++ b/libguile/simpos.h
@@ -1,7 +1,7 @@
/* classes: h_files */
-#ifndef SSCM_IMPOSH
-#define SSCM_IMPOSH
+#ifndef SIMPOSH
+#define SIMPOSH
/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
@@ -43,25 +43,13 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_system(SCM cmd);
-extern SCM scm_sys_getenv(SCM nam);
-extern SCM scm_software_type(void);
-extern void scm_init_simpos (void);
-
-#else /* STDC */
-extern SCM scm_system();
-extern SCM scm_sys_getenv();
-extern SCM scm_software_type();
-extern void scm_init_simpos ();
-
-#endif /* STDC */
-
-
-
+extern SCM scm_system SCM_P ((SCM cmd));
+extern SCM scm_getenv SCM_P ((SCM nam));
+extern SCM scm_software_type SCM_P ((void));
+extern void scm_init_simpos SCM_P ((void));
-#endif /* SSCM_IMPOSH */
+#endif /* SIMPOSH */
diff --git a/libguile/smob.c b/libguile/smob.c
index 4843d486f..90c27f6fe 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -42,6 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+
+#include "smob.h"
+
#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif
@@ -56,14 +59,10 @@
scm_sizet scm_numsmob;
scm_smobfuns *scm_smobs;
-#ifdef __STDC__
-long
-scm_newsmob (scm_smobfuns *smob)
-#else
+
long
scm_newsmob (smob)
scm_smobfuns *smob;
-#endif
{
char *tmp;
if (255 <= scm_numsmob)
@@ -114,13 +113,9 @@ static scm_smobfuns bigob =
-#ifdef __STDC__
-void
-scm_smob_prehistory (void)
-#else
+
void
scm_smob_prehistory ()
-#endif
{
scm_numsmob = 0;
scm_smobs = (scm_smobfuns *) malloc (7 * sizeof (scm_smobfuns));
diff --git a/libguile/smob.h b/libguile/smob.h
index a35cefc27..b009920ce 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -43,61 +43,35 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
-#include "params.h"
+#include "libguile/__scm.h"
-
-
-
typedef struct scm_smobfuns
{
SCM (*mark) SCM_P ((SCM));
scm_sizet (*free) SCM_P ((SCM));
- int (*print) SCM_P ((SCM exp, SCM port, int writing));
+ int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
SCM (*equalp) SCM_P ((SCM, SCM));
} scm_smobfuns;
-typedef struct scm_ptobfuns
-{
- SCM (*mark) ();
- int (*free) ();
- int (*print) ();
- SCM (*equalp) ();
- int (*fputc) ();
- int (*fputs) ();
- scm_sizet (*fwrite) ();
- int (*fflush) ();
- int (*fgetc) ();
- int (*fclose) ();
-
-
-
-} scm_ptobfuns;
-
-
-#define SCM_SMOBNUM(x) (0x0ff & (SCM_CAR(x)>>8));
-#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8));
+#define SCM_SMOBNUM(x) (0x0ff & (SCM_CAR(x)>>8))
extern scm_sizet scm_numsmob;
extern scm_smobfuns *scm_smobs;
-#ifdef __STDC__
-extern long scm_newsmob (scm_smobfuns *smob);
-extern void scm_smob_prehistory (void);
-
-#else /* STDC */
-extern long scm_newsmob ();
-extern void scm_smob_prehistory ();
-
-#endif /* STDC */
-
-
+/* Everyone who uses smobs needs to print. */
+#include "libguile/ports.h"
+#include "libguile/genio.h"
+/* ... and they all need to GC. */
+#include "libguile/markers.h"
+
+extern long scm_newsmob SCM_P ((scm_smobfuns *smob));
+extern void scm_smob_prehistory SCM_P ((void));
#endif /* SMOBH */
diff --git a/libguile/snarf.h b/libguile/snarf.h
new file mode 100644
index 000000000..9ed8c8e85
--- /dev/null
+++ b/libguile/snarf.h
@@ -0,0 +1,120 @@
+/* classes: h_files */
+
+/* Macros for snarfing initialization actions from C source. */
+
+#ifndef LIBGUILE_SNARF_H
+#define LIBGUILE_SNARF_H
+
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+
+#ifndef SCM_MAGIC_SNARFER
+#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
+ static char RANAME[]=STR
+#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
+ static char RANAME[]=STR
+#else
+#ifdef __cplusplus
+#if REQ == 0 && OPT == 0 && VAR == 0
+#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
+%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*) (void)) CFN)
+#else
+#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
+%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*) (SCM, ...)) CFN)
+#endif
+#if TYPE == scm_tc7_subr_0
+#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
+%%% scm_make_subr(RANAME, TYPE, (SCM (*)(void)) CFN)
+#else
+#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
+%%% scm_make_subr(RANAME, TYPE, (SCM (*)(...)) CFN)
+#endif
+#else /* __cplusplus */
+#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
+%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, CFN)
+#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
+%%% scm_make_subr(RANAME, TYPE, CFN)
+#endif /* __cplusplus */
+#endif
+
+#ifndef SCM_MAGIC_SNARFER
+#define SCM_SYMBOL(c_name, scheme_name) \
+ static SCM c_name = SCM_BOOL_F
+#else
+#define SCM_SYMBOL(C_NAME, SCHEME_NAME) \
+%%% C_NAME = scm_permanent_object (SCM_CAR (scm_intern0 (SCHEME_NAME)))
+#endif
+
+#ifndef SCM_MAGIC_SNARFER
+#define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
+ SCM c_name = SCM_BOOL_F
+#else
+#define SCM_GLOBAL_SYMBOL(C_NAME, SCHEME_NAME) \
+%%% C_NAME = scm_permanent_object (SCM_CAR (scm_intern0 (SCHEME_NAME)))
+#endif
+
+
+#ifndef SCM_MAGIC_SNARFER
+#define SCM_VCELL(c_name, scheme_name) \
+ static SCM c_name = SCM_BOOL_F
+#else
+#define SCM_VCELL(C_NAME, SCHEME_NAME) \
+%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, SCM_BOOL_F)
+#endif
+
+#ifndef SCM_MAGIC_SNARFER
+#define SCM_GLOBAL_VCELL(c_name, scheme_name) \
+ SCM c_name = SCM_BOOL_F
+#else
+#define SCM_GLOBAL_VCELL(C_NAME, SCHEME_NAME) \
+%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, SCM_BOOL_F)
+#endif
+
+
+#ifndef SCM_MAGIC_SNARFER
+#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \
+ static SCM C_NAME = SCM_BOOL_F
+#else
+#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \
+%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, scm_long2num (VALUE))
+#endif
+
+#endif /* LIBGUILE_SNARF_H */
diff --git a/libguile/socket.c b/libguile/socket.c
index 944609714..1dcccb3d6 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,15 +1,60 @@
-/* "socket.c" internet socket support for client/server in SCM
- Copyright (C) 1994 Aubrey Jaffer.
- Thanks to Hallvard.Tretteberg@si.sintef.no
- who credits NCSA httpd software by Rob McCool 3/21/93.
- Rewritten by Gary Houston to be a closer interface to the C
- socket library.
- */
+/* Copyright (C) 1996,1997 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
#include <stdio.h>
-#include <string.h>
+
#include "_scm.h"
+#include "unif.h"
+#include "feature.h"
+#include "fports.h"
+
+#include "socket.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/un.h>
@@ -19,390 +64,773 @@
-#ifndef STDC_HEADERS
-int close P ((int fd));
-#endif /* STDC_HEADERS */
+static SCM scm_sock_fd_to_port SCM_P ((int fd, char *proc));
-SCM_PROC (s_sys_inet_aton, "%inet-aton", 1, 0, 0, scm_sys_inet_aton);
-#ifdef __STDC__
-SCM
-scm_sys_inet_aton (SCM address)
-#else
-SCM
-scm_sys_inet_aton (address)
- SCM address;
-#endif
+static SCM
+scm_sock_fd_to_port (fd, proc)
+ int fd;
+ char *proc;
{
- struct in_addr soka;
- int rv;
- SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton);
- if (SCM_SUBSTRP (address))
- address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
- rv = inet_aton (SCM_ROCHARS (address), &soka);
- return rv ? scm_ulong2num (ntohl (soka.s_addr)) : SCM_BOOL_F;
+ SCM result;
+ FILE *f;
+
+ if (fd == -1)
+ scm_syserror (proc);
+ f = fdopen (fd, "r+");
+ if (!f)
+ {
+ SCM_SYSCALL (close (fd));
+ scm_syserror (proc);
+ }
+ SCM_NEWCELL (result);
+ {
+ struct scm_port_table *pt = scm_add_to_port_table (result);
+
+ SCM_SETPTAB_ENTRY (result, pt);
+ }
+ SCM_SETCAR (result, scm_tc16_fport | scm_mode_bits ("r+0"));
+ SCM_SETSTREAM (result, (SCM)f);
+ scm_setbuf0 (result);
+ return result;
}
+SCM_PROC (s_socket, "socket", 3, 0, 0, scm_socket);
-SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
-#ifdef __STDC__
-SCM
-scm_inet_ntoa (SCM inetid)
-#else
SCM
-scm_inet_ntoa (inetid)
- SCM inetid;
-#endif
+scm_socket (family, style, proto)
+ SCM family;
+ SCM style;
+ SCM proto;
{
- struct in_addr addr;
- char *s;
- SCM answer;
- addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
+ int fd;
+ SCM result;
+
+ SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socket);
+ SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socket);
+ SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socket);
SCM_DEFER_INTS;
- s = inet_ntoa (addr);
- answer = scm_makfromstr (s, strlen (s), 0);
+ fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto));
+ result = scm_sock_fd_to_port (fd, s_socket);
SCM_ALLOW_INTS;
- return answer;
+ return result;
}
-SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
-#ifdef __STDC__
-SCM
-scm_inet_netof (SCM address)
-#else
+
+
+SCM_PROC (s_socketpair, "socketpair", 3, 0, 0, scm_socketpair);
+
SCM
-scm_inet_netof (address)
- SCM address;
-#endif
+scm_socketpair (family, style, proto)
+ SCM family;
+ SCM style;
+ SCM proto;
{
- struct in_addr addr;
- addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
- return scm_ulong2num ((unsigned long) inet_netof (addr));
+ int fam;
+ int fd[2];
+ SCM a;
+ SCM b;
+
+ SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socketpair);
+ SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socketpair);
+ SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socketpair);
+
+ fam = SCM_INUM (family);
+
+ SCM_DEFER_INTS;
+ if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1)
+ scm_syserror (s_socketpair);
+
+ a = scm_sock_fd_to_port (fd[0], s_socketpair);
+ b = scm_sock_fd_to_port (fd[1], s_socketpair);
+ SCM_ALLOW_INTS;
+ return scm_cons (a, b);
}
-SCM_PROC (s_lnaof, "lnaof", 1, 0, 0, scm_lnaof);
-#ifdef __STDC__
-SCM
-scm_lnaof (SCM address)
+
+SCM_PROC (s_getsockopt, "getsockopt", 3, 0, 0, scm_getsockopt);
+
+SCM
+scm_getsockopt (sock, level, optname)
+ SCM sock;
+ SCM level;
+ SCM optname;
+{
+ int fd;
+ int optlen;
+#ifdef HAVE_STRUCT_LINGER
+ char optval[sizeof (struct linger)];
#else
-SCM
-scm_lnaof (address)
- SCM address;
+ char optval[sizeof (scm_sizet)];
#endif
-{
- struct in_addr addr;
- addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
- return scm_ulong2num ((unsigned long) inet_lnaof (addr));
-}
+ int ilevel;
+ int ioptname;
-
-SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
-#ifdef __STDC__
-SCM
-scm_inet_makeaddr (SCM net, SCM lna)
+#ifdef HAVE_STRUCT_LINGER
+ optlen = (int) sizeof (struct linger);
#else
-SCM
-scm_inet_makeaddr (net, lna)
- SCM net;
- SCM lna;
+ optlen = (int) sizeof (scm_sizet);
#endif
-{
- struct in_addr addr;
- unsigned long netnum;
- unsigned long lnanum;
-
- netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
- lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
- addr = inet_makeaddr (netnum, lnanum);
- return scm_ulong2num (ntohl (addr.s_addr));
-}
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
+ s_getsockopt);
+ SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_getsockopt);
+ SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_getsockopt);
-/* !!! Doesn't take address format.
- * Assumes hostent stream isn't reused.
- */
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ ilevel = SCM_INUM (level);
+ ioptname = SCM_INUM (optname);
+ if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
+ scm_syserror (s_getsockopt);
-SCM_PROC (s_sys_gethost, "%gethost", 0, 1, 0, scm_sys_gethost);
-#ifdef __STDC__
-SCM
-scm_sys_gethost (SCM name)
+#ifdef SO_LINGER
+ if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
+ {
+#ifdef HAVE_STRUCT_LINGER
+ struct linger *ling = (struct linger *) optval;
+ return scm_cons (SCM_MAKINUM (ling->l_onoff),
+ SCM_MAKINUM (ling->l_linger));
#else
-SCM
-scm_sys_gethost (name)
- SCM name;
+ scm_sizet *ling = (scm_sizet *) optval;
+ return scm_cons (SCM_MAKINUM (*ling),
+ SCM_MAKINUM (0));
#endif
-{
- SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F);
- SCM *ve = SCM_VELTS (ans);
- SCM lst = SCM_EOL;
- struct hostent *entry;
- struct in_addr inad;
- char **argv;
- int i = 0;
-#ifdef HAVE_GETHOSTENT
- if (SCM_UNBNDP (name))
- {
- SCM_DEFER_INTS;
- entry = gethostent ();
}
- else
#endif
- if (SCM_NIMP (name) && SCM_STRINGP (name))
- {
- SCM_DEFER_INTS;
- entry = gethostbyname (SCM_CHARS (name));
- }
- else
- {
- inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_sys_gethost));
- SCM_DEFER_INTS;
- entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
- }
- SCM_ALLOW_INTS;
- if (!entry)
- return SCM_BOOL_F;
- ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->h_aliases);
- ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
- ve[3] = SCM_MAKINUM (entry->h_length + 0L);
- if (sizeof (struct in_addr) != entry->h_length)
+#ifdef SO_SNDBUF
+ if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
{
- ve[4] = SCM_BOOL_F;
- return ans;
+ scm_sizet *bufsize = (scm_sizet *) optval;
+ return SCM_MAKINUM (*bufsize);
}
- for (argv = entry->h_addr_list; argv[i]; i++);
- while (i--)
+#endif
+#ifdef SO_RCVBUF
+ if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
{
- inad = *(struct in_addr *) argv[i];
- lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
+ scm_sizet *bufsize = (scm_sizet *) optval;
+ return SCM_MAKINUM (*bufsize);
}
- ve[4] = lst;
- return ans;
+#endif
+ return SCM_MAKINUM (*(int *) optval);
}
+SCM_PROC (s_setsockopt, "setsockopt", 4, 0, 0, scm_setsockopt);
-SCM_PROC (s_sys_getnet, "%getnet", 0, 1, 0, scm_sys_getnet);
-#ifdef __STDC__
-SCM
-scm_sys_getnet (SCM name)
+SCM
+scm_setsockopt (sock, level, optname, value)
+ SCM sock;
+ SCM level;
+ SCM optname;
+ SCM value;
+{
+ int fd;
+ int optlen;
+#ifdef HAVE_STRUCT_LINGER
+ char optval[sizeof (struct linger)]; /* Biggest option :-( */
#else
-SCM
-scm_sys_getnet (name)
- SCM name;
+ char optval[sizeof (scm_sizet)];
#endif
-{
- SCM ans;
- SCM *ve;
- struct netent *entry;
-
- ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (ans);
- if (SCM_UNBNDP (name))
+ int ilevel, ioptname;
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
+ s_setsockopt);
+ SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_setsockopt);
+ SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_setsockopt);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ ilevel = SCM_INUM (level);
+ ioptname = SCM_INUM (optname);
+ if (0);
+#ifdef SO_LINGER
+ else if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
{
- SCM_DEFER_INTS;
- entry = getnetent ();
+#ifdef HAVE_STRUCT_LINGER
+ struct linger ling;
+ SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
+ && SCM_INUMP (SCM_CAR (value))
+ && SCM_INUMP (SCM_CDR (value)),
+ value, SCM_ARG4, s_setsockopt);
+ ling.l_onoff = SCM_INUM (SCM_CAR (value));
+ ling.l_linger = SCM_INUM (SCM_CDR (value));
+ optlen = (int) sizeof (struct linger);
+ memcpy (optval, (void *) &ling, optlen);
+#else
+ scm_sizet ling;
+ SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
+ && SCM_INUMP (SCM_CAR (value))
+ && SCM_INUMP (SCM_CDR (value)),
+ value, SCM_ARG4, s_setsockopt);
+ ling = SCM_INUM (SCM_CAR (value));
+ optlen = (int) sizeof (scm_sizet);
+ (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
+#endif
+ }
+#endif
+#ifdef SO_SNDBUF
+ else if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
+ {
+ SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
+ optlen = (int) sizeof (scm_sizet);
+ (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
}
- else if (SCM_NIMP (name) && SCM_STRINGP (name))
+#endif
+#ifdef SO_RCVBUF
+ else if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
{
- SCM_DEFER_INTS;
- entry = getnetbyname (SCM_CHARS (name));
+ SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
+ optlen = (int) sizeof (scm_sizet);
+ (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
}
+#endif
else
{
- unsigned long netnum;
- netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getnet);
- SCM_DEFER_INTS;
- entry = getnetbyaddr (netnum, AF_INET);
+ /* Most options just take an int. */
+ SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
+ optlen = (int) sizeof (int);
+ (*(int *) optval) = (int) SCM_INUM (value);
}
- SCM_ALLOW_INTS;
- if (!entry)
- return SCM_BOOL_F;
- ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->n_aliases);
- ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
- ve[3] = scm_ulong2num (entry->n_net + 0L);
- return ans;
+ if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1)
+ scm_syserror (s_setsockopt);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_getproto, "%getproto", 0, 1, 0, scm_sys_getproto);
-#ifdef __STDC__
-SCM
-scm_sys_getproto (SCM name)
-#else
+SCM_PROC (s_shutdown, "shutdown", 2, 0, 0, scm_shutdown);
+
SCM
-scm_sys_getproto (name)
- SCM name;
-#endif
+scm_shutdown (sock, how)
+ SCM sock;
+ SCM how;
{
- SCM ans;
- SCM *ve;
- struct protoent *entry;
+ int fd;
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
+ s_shutdown);
+ SCM_ASSERT (SCM_INUMP (how) && 0 <= SCM_INUM (how) && 2 >= SCM_INUM (how),
+ how, SCM_ARG2, s_shutdown);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ if (shutdown (fd, SCM_INUM (how)) == -1)
+ scm_syserror (s_shutdown);
+ return SCM_UNSPECIFIED;
+}
- ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (ans);
- if (SCM_UNBNDP (name))
- {
- SCM_DEFER_INTS;
- entry = getprotoent ();
- }
- else if (SCM_NIMP (name) && SCM_STRINGP (name))
- {
- SCM_DEFER_INTS;
- entry = getprotobyname (SCM_CHARS (name));
- }
- else
+/* convert fam/address/args into a sockaddr of the appropriate type.
+ args is modified by removing the arguments actually used.
+ which_arg and proc are used when reporting errors:
+ which_arg is the position of address in the original argument list.
+ proc is the name of the original procedure.
+ size returns the size of the structure allocated. */
+
+
+static struct sockaddr * scm_fill_sockaddr SCM_P ((int fam, SCM address, SCM *args, int which_arg, char *proc, scm_sizet *size));
+
+static struct sockaddr *
+scm_fill_sockaddr (fam, address, args, which_arg, proc, size)
+ int fam;
+ SCM address;
+ SCM *args;
+ int which_arg;
+ char *proc;
+ scm_sizet *size;
+{
+ switch (fam)
{
- unsigned long protonum;
- protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getproto);
- SCM_DEFER_INTS;
- entry = getprotobynumber (protonum);
+ case AF_INET:
+ {
+ SCM isport;
+ struct sockaddr_in *soka;
+
+ soka = (struct sockaddr_in *)
+ scm_must_malloc (sizeof (struct sockaddr_in), proc);
+ soka->sin_family = AF_INET;
+ soka->sin_addr.s_addr =
+ htonl (scm_num2ulong (address, (char *) which_arg, proc));
+ SCM_ASSERT (SCM_NIMP (*args) && SCM_CONSP (*args), *args,
+ which_arg + 1, proc);
+ isport = SCM_CAR (*args);
+ *args = SCM_CDR (*args);
+ SCM_ASSERT (SCM_INUMP (isport), isport, which_arg + 1, proc);
+ soka->sin_port = htons (SCM_INUM (isport));
+ *size = sizeof (struct sockaddr_in);
+ return (struct sockaddr *) soka;
+ }
+ case AF_UNIX:
+ {
+ struct sockaddr_un *soka;
+
+ soka = (struct sockaddr_un *)
+ scm_must_malloc (sizeof (struct sockaddr_un), proc);
+ soka->sun_family = AF_UNIX;
+ SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address,
+ which_arg, proc);
+ memcpy (soka->sun_path, SCM_ROCHARS (address),
+ 1 + SCM_ROLENGTH (address));
+ *size = sizeof (struct sockaddr_un);
+ return (struct sockaddr *) soka;
+ }
+ default:
+ scm_out_of_range (proc, SCM_MAKINUM (fam));
}
- SCM_ALLOW_INTS;
- if (!entry)
- return SCM_BOOL_F;
- ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->p_aliases);
- ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
- return ans;
}
+
+SCM_PROC (s_connect, "connect", 3, 0, 1, scm_connect);
-#ifdef __STDC__
-static SCM
-scm_return_entry (struct servent *entry)
-#else
-static SCM
-scm_return_entry (entry)
- struct servent *entry;
-#endif
+SCM
+scm_connect (sock, fam, address, args)
+
+ SCM sock;
+ SCM fam;
+ SCM address;
+ SCM args;
{
- SCM ans;
- SCM *ve;
+ int fd;
+ struct sockaddr *soka;
+ scm_sizet size;
- ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (ans);
- if (!entry)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
- ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->s_aliases);
- ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
- ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_connect);
+ SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_connect);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ SCM_DEFER_INTS;
+ soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_connect, &size);
+ if (connect (fd, soka, size) == -1)
+ scm_syserror (s_connect);
+ scm_must_free ((char *) soka);
SCM_ALLOW_INTS;
- return ans;
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_getserv, "%getserv", 0, 2, 0, scm_sys_getserv);
-#ifdef __STDC__
+SCM_PROC (s_bind, "bind", 3, 0, 1, scm_bind);
+
SCM
-scm_sys_getserv (SCM name, SCM proto)
-#else
+scm_bind (sock, fam, address, args)
+ SCM sock;
+ SCM fam;
+ SCM address;
+ SCM args;
+{
+ int rv;
+ struct sockaddr *soka;
+ scm_sizet size;
+ int fd;
+
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_bind);
+ SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_bind);
+ soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_bind, &size);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ rv = bind (fd, soka, size);
+ if (rv == -1)
+ scm_syserror (s_bind);
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC (s_listen, "listen", 2, 0, 0, scm_listen);
+
SCM
-scm_sys_getserv (name, proto)
- SCM name;
- SCM proto;
-#endif
+scm_listen (sock, backlog)
+ SCM sock;
+ SCM backlog;
{
- struct servent *entry;
- if (SCM_UNBNDP (name))
+ int fd;
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_listen);
+ SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ if (listen (fd, SCM_INUM (backlog)) == -1)
+ scm_syserror (s_listen);
+ return SCM_UNSPECIFIED;
+}
+
+/* Put the components of a sockaddr into a new SCM vector. */
+
+static SCM scm_addr_vector SCM_P ((struct sockaddr *address, char *proc));
+
+static SCM
+scm_addr_vector (address, proc)
+ struct sockaddr *address;
+ char *proc;
+{
+ short int fam = address->sa_family;
+ SCM result;
+ SCM *ve;
+ if (fam == AF_UNIX)
{
- SCM_DEFER_INTS;
- entry = getservent ();
- return scm_return_entry (entry);
+ struct sockaddr_un *nad = (struct sockaddr_un *) address;
+ result = scm_make_vector (SCM_MAKINUM (2), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (result);
+ ve[0] = scm_ulong2num ((unsigned long) fam);
+ ve[1] = scm_makfromstr (nad->sun_path,
+ (scm_sizet) strlen (nad->sun_path), 0);
}
- SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv);
- if (SCM_NIMP (name) && SCM_STRINGP (name))
+ else if (fam == AF_INET)
{
- SCM_DEFER_INTS;
- entry = getservbyname (SCM_CHARS (name), SCM_CHARS (proto));
+ struct sockaddr_in *nad = (struct sockaddr_in *) address;
+ result = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (result);
+ ve[0] = scm_ulong2num ((unsigned long) fam);
+ ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr));
+ ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port));
}
else
- {
- SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_sys_getserv);
- SCM_DEFER_INTS;
- entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto));
- }
- return scm_return_entry (entry);
+ scm_misc_error (proc, "Unrecognised address family: %s",
+ scm_listify (SCM_MAKINUM (fam), SCM_UNSPECIFIED));
+
+ return result;
}
-SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
-#ifdef __STDC__
-SCM
-scm_sethost (SCM arg)
-#else
+/* Allocate a buffer large enough to hold any sockaddr type. */
+static char *scm_addr_buffer;
+static int scm_addr_buffer_size;
+
+static void scm_init_addr_buffer SCM_P ((void));
+
+static void
+scm_init_addr_buffer ()
+{
+ scm_addr_buffer_size = (int) sizeof (struct sockaddr_un);
+ if (sizeof (struct sockaddr_in) > scm_addr_buffer_size)
+ scm_addr_buffer_size = (int) sizeof (struct sockaddr_in);
+ scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer");
+}
+
+SCM_PROC (s_accept, "accept", 1, 0, 0, scm_accept);
+
SCM
-scm_sethost (arg)
- SCM arg;
-#endif
+scm_accept (sock)
+ SCM sock;
{
- if (SCM_UNBNDP (arg))
- endhostent ();
+ int fd;
+ int newfd;
+ SCM address;
+ SCM newsock;
+
+ int tmp_size;
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_accept);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ SCM_DEFER_INTS;
+ tmp_size = scm_addr_buffer_size;
+ newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size);
+ newsock = scm_sock_fd_to_port (newfd, s_accept);
+ if (tmp_size > 0)
+ address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_accept);
else
- sethostent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
+ address = SCM_BOOL_F;
+
+ SCM_ALLOW_INTS;
+ return scm_cons (newsock, address);
}
-SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
-#ifdef __STDC__
-SCM
-scm_setnet (SCM arg)
-#else
+SCM_PROC (s_getsockname, "getsockname", 1, 0, 0, scm_getsockname);
+
SCM
-scm_setnet (arg)
- SCM arg;
-#endif
+scm_getsockname (sock)
+ SCM sock;
{
- if (SCM_UNBNDP (arg))
- endnetent ();
+ int tmp_size;
+ int fd;
+ SCM result;
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getsockname);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ SCM_DEFER_INTS;
+ tmp_size = scm_addr_buffer_size;
+ if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
+ scm_syserror (s_getsockname);
+ if (tmp_size > 0)
+ result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname);
else
- setnetent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
+ result = SCM_BOOL_F;
+ SCM_ALLOW_INTS;
+ return result;
}
-SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
-#ifdef __STDC__
-SCM
-scm_setproto (SCM arg)
-#else
+SCM_PROC (s_getpeername, "getpeername", 1, 0, 0, scm_getpeername);
+
SCM
-scm_setproto (arg)
- SCM arg;
-#endif
+scm_getpeername (sock)
+ SCM sock;
{
- if (SCM_UNBNDP (arg))
- endprotoent ();
+ int tmp_size;
+ int fd;
+ SCM result;
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ SCM_DEFER_INTS;
+ tmp_size = scm_addr_buffer_size;
+ if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
+ scm_syserror (s_getpeername);
+ if (tmp_size > 0)
+ result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getpeername);
else
- setprotoent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
+ result = SCM_BOOL_F;
+ SCM_ALLOW_INTS;
+ return result;
}
-SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
-#ifdef __STDC__
-SCM
-scm_setserv (SCM arg)
-#else
-SCM
-scm_setserv (arg)
- SCM arg;
-#endif
+SCM_PROC (s_recv, "recv!", 2, 1, 0, scm_recv);
+
+SCM
+scm_recv (sock, buf, flags)
+ SCM sock;
+ SCM buf;
+ SCM flags;
{
- if (SCM_UNBNDP (arg))
- endservent ();
+ int rv;
+ int fd;
+ int flg;
+
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_recv);
+ SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+
+ if (SCM_UNBNDP (flags))
+ flg = 0;
else
- setservent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
+ flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recv);
+
+ SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg));
+ if (rv == -1)
+ scm_syserror (s_recv);
+
+ return SCM_MAKINUM (rv);
}
-#ifdef __STDC__
-void
-scm_init_socket (void)
-#else
-void
+SCM_PROC (s_send, "send", 2, 1, 0, scm_send);
+
+SCM
+scm_send (sock, message, flags)
+ SCM sock;
+ SCM message;
+ SCM flags;
+{
+ int rv;
+ int fd;
+ int flg;
+
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_send);
+ SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+
+ if (SCM_UNBNDP (flags))
+ flg = 0;
+ else
+ flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_send);
+
+ SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg));
+ if (rv == -1)
+ scm_syserror (s_send);
+ return SCM_MAKINUM (rv);
+}
+
+SCM_PROC (s_recvfrom, "recvfrom!", 2, 3, 0, scm_recvfrom);
+
+SCM
+scm_recvfrom (sock, buf, flags, start, end)
+ SCM sock;
+ SCM buf;
+ SCM flags;
+ SCM start;
+ SCM end;
+{
+ int rv;
+ int fd;
+ int flg;
+ int offset = 0;
+ int cend;
+ int tmp_size;
+ SCM address;
+
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
+ s_recvfrom);
+ SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recvfrom);
+ cend = SCM_LENGTH (buf);
+
+ if (SCM_UNBNDP (flags))
+ flg = 0;
+ else
+ {
+ flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recvfrom);
+
+ if (!SCM_UNBNDP (start))
+ {
+ offset = (int) scm_num2long (start,
+ (char *) SCM_ARG4, s_recvfrom);
+
+ if (offset < 0 || offset >= cend)
+ scm_out_of_range (s_recvfrom, start);
+
+ if (!SCM_UNBNDP (end))
+ {
+ int tend = (int) scm_num2long (end,
+ (char *) SCM_ARG5, s_recvfrom);
+
+ if (tend <= offset || tend > cend)
+ scm_out_of_range (s_recvfrom, end);
+
+ cend = tend;
+ }
+ }
+ }
+
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+
+ tmp_size = scm_addr_buffer_size;
+ SCM_SYSCALL (rv = recvfrom (fd, SCM_CHARS (buf) + offset,
+ cend - offset, flg,
+ (struct sockaddr *) scm_addr_buffer,
+ &tmp_size));
+ if (rv == -1)
+ scm_syserror (s_recvfrom);
+ if (tmp_size > 0)
+ address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_recvfrom);
+ else
+ address = SCM_BOOL_F;
+
+ return scm_cons (SCM_MAKINUM (rv), address);
+}
+
+SCM_PROC (s_sendto, "sendto", 4, 0, 1, scm_sendto);
+
+SCM
+scm_sendto (sock, message, fam, address, args_and_flags)
+ SCM sock;
+ SCM message;
+ SCM fam;
+ SCM address;
+ SCM args_and_flags;
+{
+ int rv;
+ int fd;
+ int flg;
+ struct sockaddr *soka;
+ scm_sizet size;
+
+ SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto);
+ SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message,
+ SCM_ARG2, s_sendto);
+ SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto);
+ fd = fileno ((FILE *)SCM_STREAM (sock));
+ SCM_DEFER_INTS;
+ soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
+ s_sendto, &size);
+ if (SCM_NULLP (args_and_flags))
+ flg = 0;
+ else
+ {
+ SCM_ASSERT (SCM_NIMP (args_and_flags) && SCM_CONSP (args_and_flags),
+ args_and_flags, SCM_ARG5, s_sendto);
+ flg = scm_num2ulong (SCM_CAR (args_and_flags), (char *) SCM_ARG5, s_sendto);
+ }
+ SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message),
+ flg, soka, size));
+ if (rv == -1)
+ scm_syserror (s_sendto);
+ scm_must_free ((char *) soka);
+ SCM_ALLOW_INTS;
+ return SCM_MAKINUM (rv);
+}
+
+
+
+void
scm_init_socket ()
-#endif
{
+ /* protocol families. */
+#ifdef AF_UNSPEC
+ scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC));
+#endif
+#ifdef AF_UNIX
+ scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX));
+#endif
+#ifdef AF_INET
+ scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET));
+#endif
+
+#ifdef PF_UNSPEC
+ scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC));
+#endif
+#ifdef PF_UNIX
+ scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX));
+#endif
+#ifdef PF_INET
+ scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET));
+#endif
+
+ /* socket types. */
+#ifdef SOCK_STREAM
+ scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM));
+#endif
+#ifdef SOCK_DGRAM
+ scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM));
+#endif
+#ifdef SOCK_RAW
+ scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW));
+#endif
+
+ /* setsockopt level. */
+#ifdef SOL_SOCKET
+ scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET));
+#endif
+#ifdef SOL_IP
+ scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP));
+#endif
+#ifdef SOL_TCP
+ scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP));
+#endif
+#ifdef SOL_UDP
+ scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP));
+#endif
+
+ /* setsockopt names. */
+#ifdef SO_DEBUG
+ scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG));
+#endif
+#ifdef SO_REUSEADDR
+ scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR));
+#endif
+#ifdef SO_STYLE
+ scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE));
+#endif
+#ifdef SO_TYPE
+ scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE));
+#endif
+#ifdef SO_ERROR
+ scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR));
+#endif
+#ifdef SO_DONTROUTE
+ scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE));
+#endif
+#ifdef SO_BROADCAST
+ scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST));
+#endif
+#ifdef SO_SNDBUF
+ scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF));
+#endif
+#ifdef SO_RCVBUF
+ scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF));
+#endif
+#ifdef SO_KEEPALIVE
+ scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE));
+#endif
+#ifdef SO_OOBINLINE
+ scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE));
+#endif
+#ifdef SO_NO_CHECK
+ scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK));
+#endif
+#ifdef SO_PRIORITY
+ scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY));
+#endif
+#ifdef SO_LINGER
+ scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER));
+#endif
+
+ /* recv/send options. */
+#ifdef MSG_OOB
+ scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB));
+#endif
+#ifdef MSG_PEEK
+ scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK));
+#endif
+#ifdef MSG_DONTROUTE
+ scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE));
+#endif
+
scm_add_feature ("socket");
+ scm_init_addr_buffer ();
+
#include "socket.x"
}
-
diff --git a/libguile/socket.h b/libguile/socket.h
index 28413a228..1d28b8171 100644
--- a/libguile/socket.h
+++ b/libguile/socket.h
@@ -2,7 +2,7 @@
#ifndef SOCKETH
#define SOCKETH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,76 +44,29 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
-#ifdef __STDC__
-extern SCM scm_sys_inet_aton (SCM address);
-extern SCM scm_inet_ntoa (SCM inetid);
-extern SCM scm_inet_netof (SCM address);
-extern SCM scm_lnaof (SCM address);
-extern SCM scm_inet_makeaddr (SCM net, SCM lna);
-extern SCM scm_sys_getnet (SCM name);
-extern SCM scm_sys_getproto (SCM name);
-extern SCM scm_sys_getserv (SCM name, SCM proto);
-extern SCM scm_sethost (SCM arg);
-extern SCM scm_setnet (SCM arg);
-extern SCM scm_setproto (SCM arg);
-extern SCM scm_setserv (SCM arg);
-extern SCM scm_sys_socket (SCM family, SCM style, SCM proto);
-extern SCM scm_sys_socketpair (SCM family, SCM style, SCM proto);
-
-extern SCM scm_sys_getsockopt (SCM port, SCM level, SCM optname);
-extern SCM scm_sys_setsockopt (SCM port, SCM level, SCM optname, SCM value);
-extern SCM scm_sys_shutdown (SCM port, SCM how);
-extern SCM scm_sys_connect (SCM sockpt, SCM fam, SCM address, SCM args);
-extern SCM scm_sys_bind (SCM sockpt, SCM fam, SCM address);
-extern SCM scm_sys_listen (SCM port, SCM backlog);
-extern void scm_init_addr_buffer (void);
-extern SCM scm_sys_accept (SCM sockpt);
-extern SCM scm_sys_getsockname (SCM sockpt);
-extern SCM scm_sys_getpeername (SCM sockpt);
-extern SCM scm_sys_recv (SCM sockpt, SCM buff_or_size, SCM flags);
-extern SCM scm_sys_send (SCM sockpt, SCM message, SCM flags);
-extern SCM scm_sys_recvfrom (SCM sockpt, SCM buff_or_size, SCM flags);
-extern SCM scm_sys_sendto (SCM sockpt, SCM message, SCM fam, SCM address, SCM args_and_flags);
-extern void scm_init_socket (void);
-#else /* STDC */
-extern SCM scm_sys_inet_aton ();
-extern SCM scm_inet_ntoa ();
-extern SCM scm_inet_netof ();
-extern SCM scm_lnaof ();
-extern SCM scm_inet_makeaddr ();
-extern SCM scm_sys_getnet ();
-extern SCM scm_sys_getproto ();
-extern SCM scm_sys_getserv ();
-extern SCM scm_sethost ();
-extern SCM scm_setnet ();
-extern SCM scm_setproto ();
-extern SCM scm_setserv ();
-extern SCM scm_sys_socket ();
-extern SCM scm_sys_socketpair ();
-extern SCM scm_sys_getsockopt ();
-extern SCM scm_sys_setsockopt ();
-extern SCM scm_sys_shutdown ();
-extern SCM scm_sys_connect ();
-extern SCM scm_sys_bind ();
-extern SCM scm_sys_listen ();
-extern void scm_init_addr_buffer ();
-extern SCM scm_sys_accept ();
-extern SCM scm_sys_getsockname ();
-extern SCM scm_sys_getpeername ();
-extern SCM scm_sys_recv ();
-extern SCM scm_sys_send ();
-extern SCM scm_sys_recvfrom ();
-extern SCM scm_sys_sendto ();
-extern void scm_init_socket ();
-
-#endif /* STDC */
+
+extern SCM scm_socket SCM_P ((SCM family, SCM style, SCM proto));
+extern SCM scm_socketpair SCM_P ((SCM family, SCM style, SCM proto));
+extern SCM scm_getsockopt SCM_P ((SCM sfd, SCM level, SCM optname));
+extern SCM scm_setsockopt SCM_P ((SCM sfd, SCM level, SCM optname, SCM value));
+extern SCM scm_shutdown SCM_P ((SCM sfd, SCM how));
+extern SCM scm_connect SCM_P ((SCM sockfd, SCM fam, SCM address, SCM args));
+extern SCM scm_bind SCM_P ((SCM sockfd, SCM fam, SCM address, SCM args));
+extern SCM scm_listen SCM_P ((SCM sfd, SCM backlog));
+extern SCM scm_accept SCM_P ((SCM sockfd));
+extern SCM scm_getsockname SCM_P ((SCM sockfd));
+extern SCM scm_getpeername SCM_P ((SCM sockfd));
+extern SCM scm_recv SCM_P ((SCM sockfd, SCM buff_or_size, SCM flags));
+extern SCM scm_send SCM_P ((SCM sockfd, SCM message, SCM flags));
+extern SCM scm_recvfrom SCM_P ((SCM sockfd, SCM buff_or_size, SCM flags, SCM offset, SCM length));
+extern SCM scm_sendto SCM_P ((SCM sockfd, SCM message, SCM fam, SCM address, SCM args_and_flags));
+extern void scm_init_socket SCM_P ((void));
#endif /* SOCKETH */
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
new file mode 100644
index 000000000..86705826f
--- /dev/null
+++ b/libguile/srcprop.c
@@ -0,0 +1,363 @@
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+#include "smob.h"
+#include "alist.h"
+#include "debug.h"
+#include "hashtab.h"
+#include "hash.h"
+#include "weaks.h"
+
+#include "srcprop.h"
+
+/* {Source Properties}
+ *
+ * Properties of source list expressions.
+ * Five of these have special meaning and optimized storage:
+ *
+ * filename string The name of the source file.
+ * copy list A copy of the list expression.
+ * line integer The source code line number.
+ * column integer The source code column number.
+ * breakpoint boolean Sets a breakpoint on this form.
+ *
+ * Most properties above can be set by the reader.
+ *
+ */
+
+SCM scm_i_filename;
+SCM scm_i_copy;
+SCM scm_i_line;
+SCM scm_i_column;
+SCM scm_i_breakpoint;
+
+long scm_tc16_srcprops;
+static scm_srcprops_chunk *srcprops_chunklist = 0;
+static scm_srcprops *srcprops_freelist = 0;
+
+
+static SCM marksrcprops SCM_P ((SCM obj));
+
+static SCM
+marksrcprops (obj)
+ SCM obj;
+{
+ SCM_SETGC8MARK (obj);
+ scm_gc_mark (SRCPROPFNAME (obj));
+ scm_gc_mark (SRCPROPCOPY (obj));
+ return SRCPROPPLIST (obj);
+}
+
+
+static scm_sizet freesrcprops SCM_P ((SCM obj));
+
+static scm_sizet
+freesrcprops (obj)
+ SCM obj;
+{
+ *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist;
+ srcprops_freelist = (scm_srcprops *) SCM_CDR (obj);
+ return 0; /* srcprops_chunks are not freed until leaving guile */
+}
+
+
+static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
+
+static int
+prinsrcprops (obj, port, pstate)
+ SCM obj;
+ SCM port;
+ scm_print_state *pstate;
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_gen_puts (scm_regular_string, "#<srcprops ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns srcpropssmob =
+{marksrcprops, freesrcprops, prinsrcprops, 0};
+
+
+SCM
+scm_make_srcprops (line, col, filename, copy, plist)
+ int line;
+ int col;
+ SCM filename;
+ SCM copy;
+ SCM plist;
+{
+ register SCM ans;
+ register scm_srcprops *ptr;
+ SCM_DEFER_INTS;
+ if ((ptr = srcprops_freelist) != NULL)
+ srcprops_freelist = *(scm_srcprops **)ptr;
+ else
+ {
+ int i;
+ scm_srcprops_chunk *mem;
+ scm_sizet n = sizeof (scm_srcprops_chunk)
+ + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
+ SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n));
+ SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops");
+ scm_mallocated += n;
+ mem->next = srcprops_chunklist;
+ srcprops_chunklist = mem;
+ ptr = &mem->srcprops[0];
+ for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
+ *(scm_srcprops **)&ptr[i] = &ptr[i + 1];
+ *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
+ srcprops_freelist = (scm_srcprops *) &ptr[1];
+ }
+ SCM_NEWCELL (ans);
+ SCM_SETCAR (ans, scm_tc16_srcprops);
+ ptr->pos = SRCPROPMAKPOS (line, col);
+ ptr->fname = filename;
+ ptr->copy = copy;
+ ptr->plist = plist;
+ SCM_SETCDR (ans, (SCM) ptr);
+ SCM_ALLOW_INTS;
+ return ans;
+}
+
+
+SCM
+scm_srcprops_to_plist (obj)
+ SCM obj;
+{
+ SCM plist = SRCPROPPLIST (obj);
+ if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
+ plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist);
+ if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
+ plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist);
+ plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist);
+ plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist);
+ plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist);
+ return plist;
+}
+
+SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties);
+
+SCM
+scm_source_properties (obj)
+ SCM obj;
+{
+ SCM p;
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+#ifndef SCM_RECKLESS
+ else if (SCM_NCONSP (obj))
+ scm_wrong_type_arg (s_source_properties, 1, obj);
+#endif
+ p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL);
+ if (p != (SCM) NULL && SRCPROPSP (p))
+ return scm_srcprops_to_plist (p);
+ return SCM_EOL;
+}
+
+/* Perhaps this procedure should look through an alist
+ and try to make a srcprops-object...? */
+SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x);
+
+SCM
+scm_set_source_properties_x (obj, plist)
+ SCM obj;
+ SCM plist;
+{
+ SCM handle;
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+#ifndef SCM_RECKLESS
+ else if (SCM_NCONSP (obj))
+ scm_wrong_type_arg (s_set_source_properties_x, 1, obj);
+#endif
+ handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
+ SCM_SETCDR (handle, plist);
+ return plist;
+}
+
+SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property);
+
+SCM
+scm_source_property (obj, key)
+ SCM obj;
+ SCM key;
+{
+ SCM p;
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+#ifndef SCM_RECKLESS
+ else if (SCM_NCONSP (obj))
+ scm_wrong_type_arg (s_source_property, 1, obj);
+#endif
+ p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ if (SCM_IMP (p) || !SRCPROPSP (p))
+ goto plist;
+ if (scm_i_breakpoint == key) p = SRCPROPBRK (p);
+ else if (scm_i_line == key) p = SCM_MAKINUM (SRCPROPLINE (p));
+ else if (scm_i_column == key) p = SCM_MAKINUM (SRCPROPCOL (p));
+ else if (scm_i_filename == key) p = SRCPROPFNAME (p);
+ else if (scm_i_copy == key) p = SRCPROPCOPY (p);
+ else
+ {
+ p = SRCPROPPLIST (p);
+ plist:
+ p = scm_assoc (key, p);
+ return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
+ }
+ return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
+}
+
+SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x);
+
+SCM
+scm_set_source_property_x (obj, key, datum)
+ SCM obj;
+ SCM key;
+ SCM datum;
+{
+ scm_whash_handle h;
+ SCM p;
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+#ifndef SCM_RECKLESS
+ else if (SCM_NCONSP (obj))
+ scm_wrong_type_arg (s_set_source_property_x, 1, obj);
+#endif
+ h = scm_whash_get_handle (scm_source_whash, obj);
+ if (SCM_WHASHFOUNDP (h))
+ p = SCM_WHASHREF (scm_source_whash, h);
+ else
+ {
+ h = scm_whash_create_handle (scm_source_whash, obj);
+ p = SCM_EOL;
+ }
+ if (scm_i_breakpoint == key)
+ if (SCM_FALSEP (datum))
+ CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
+ ? p
+ : SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED,
+ SCM_UNDEFINED, p)));
+ else
+ SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
+ ? p
+ : SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED,
+ SCM_UNDEFINED, p)));
+ else if (scm_i_line == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SETSRCPROPLINE (p, datum);
+ else
+ SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (datum, 0, SCM_UNDEFINED, SCM_UNDEFINED, p));
+ }
+ else if (scm_i_column == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SETSRCPROPCOL (p, datum);
+ else
+ SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (0, datum, SCM_UNDEFINED, SCM_UNDEFINED, p));
+ }
+ else if (scm_i_filename == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SRCPROPFNAME (p) = datum;
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
+ }
+ else if (scm_i_filename == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SRCPROPCOPY (p) = datum;
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
+ }
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
+ return SCM_UNSPECIFIED;
+}
+
+
+void
+scm_init_srcprop ()
+{
+ scm_tc16_srcprops = scm_newsmob (&srcpropssmob);
+ scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047));
+
+ scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED));
+ scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED));
+ scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED));
+ scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED));
+ scm_i_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED));
+
+ scm_sysintern ("source-whash", scm_source_whash);
+#include "srcprop.x"
+}
+
+void
+scm_finish_srcprop ()
+{
+ register scm_srcprops_chunk *ptr = srcprops_chunklist, *next;
+ while (ptr)
+ {
+ next = ptr->next;
+ free ((char *) ptr);
+ scm_mallocated -= sizeof (scm_srcprops_chunk)
+ + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
+ ptr = next;
+ }
+}
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
new file mode 100644
index 000000000..ae9358b0c
--- /dev/null
+++ b/libguile/srcprop.h
@@ -0,0 +1,134 @@
+/* classes: h_files */
+
+#ifndef SRCPROPH
+#define SRCPROPH
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+/* {The old whash table interface}
+ * *fixme* This is a temporary solution until weak hash table access
+ * has been optimized for speed (which is quite necessary, if they are
+ * used for recording of source code positions...)
+ */
+
+#define scm_whash_handle SCM
+
+#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0)
+#define SCM_WHASHFOUNDP(h) ((h) != SCM_BOOL_F)
+#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
+#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
+#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_insert(whash, key, obj) \
+{ \
+ register SCM w = (whash); \
+ SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \
+} \
+
+
+/* {Source properties}
+ */
+
+extern long scm_tc16_srcprops;
+
+typedef struct scm_srcprops
+{
+ unsigned long pos;
+ SCM fname;
+ SCM copy;
+ SCM plist;
+} scm_srcprops;
+
+#define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */
+typedef struct scm_srcprops_chunk
+{
+ struct scm_srcprops_chunk *next;
+ scm_srcprops srcprops[1];
+} scm_srcprops_chunk;
+
+#define SRCPROPSP(p) (SCM_TYP16 (p) == scm_tc16_srcprops)
+#define SRCPROPBRK(p) ((1L << 16) & SCM_CAR (p) ? SCM_BOOL_T : SCM_BOOL_F)
+#define SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos
+#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
+#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
+#define SRCPROPFNAME(p) ((scm_srcprops *) SCM_CDR (p))->fname
+#define SRCPROPCOPY(p) ((scm_srcprops *) SCM_CDR (p))->copy
+#define SRCPROPPLIST(p) ((scm_srcprops *) SCM_CDR (p))->plist
+#define SETSRCPROPBRK(p) (SCM_SETOR_CAR (p, (1L << 16)))
+#define CLEARSRCPROPBRK(p) SCM_SETAND_CAR (p, ~(1L << 16))
+#define SRCPROPMAKPOS(l,c) (((l) << 12) + (c))
+#define SETSRCPROPPOS(p,l,c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c))
+#define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
+#define SETSRCPROPCOL(p,c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
+
+#define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\
+ && SRCPROPSP (t.arg1)\
+ && (1L << 16) & SCM_CAR (t.arg1))
+
+#define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_i_trace))
+
+extern SCM scm_i_filename;
+extern SCM scm_i_copy;
+extern SCM scm_i_line;
+extern SCM scm_i_column;
+extern SCM scm_i_breakpoint;
+
+
+
+
+extern SCM scm_srcprops_to_plist SCM_P ((SCM obj));
+extern SCM scm_make_srcprops SCM_P ((int line, int col, SCM fname, SCM copy, SCM plist));
+extern SCM scm_source_property SCM_P ((SCM obj, SCM key));
+extern SCM scm_set_source_property_x SCM_P ((SCM obj, SCM key, SCM datum));
+extern SCM scm_source_properties SCM_P ((SCM obj));
+extern SCM scm_set_source_properties_x SCM_P ((SCM obj, SCM props));
+extern void scm_finish_srcprop SCM_P ((void));
+extern void scm_init_srcprop SCM_P ((void));
+
+#endif /* SRCPROPH */
diff --git a/libguile/stackchk.c b/libguile/stackchk.c
index 53a7556be..92846170f 100644
--- a/libguile/stackchk.c
+++ b/libguile/stackchk.c
@@ -42,31 +42,35 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "stackchk.h"
/* {Stack Checking}
*/
-#ifdef SCM_STACK_CHECK
-int scm_check_stack_p;
+#ifdef STACK_CHECKING
+int scm_stack_checking_enabled_p;
+
+SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
void
scm_report_stack_overflow ()
{
- scm_check_stack_p = 0;
- scm_wta (SCM_UNDEFINED, (char *) STACK_SCM_OVSCM_FLOW, NULL);
+ scm_stack_checking_enabled_p = 0;
+ scm_error (scm_stack_overflow_key,
+ NULL,
+ "Stack overflow",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
}
#endif
-#ifdef __STDC__
-long
-scm_stack_size (SCM_STACKITEM *start)
-#else
+
long
scm_stack_size (start)
SCM_STACKITEM *start;
-#endif
{
SCM_STACKITEM stack;
#ifdef SCM_STACK_GROWS_UP
@@ -76,13 +80,9 @@ scm_stack_size (start)
#endif /* def SCM_STACK_GROWS_UP */
}
-#ifdef __STDC__
-void
-scm_stack_report (void)
-#else
+
void
scm_stack_report ()
-#endif
{
SCM_STACKITEM stack;
scm_intprint (scm_stack_size (SCM_BASE (scm_rootcont)) * sizeof (SCM_STACKITEM),
@@ -96,17 +96,9 @@ scm_stack_report ()
-#ifdef __STDC__
-void
-scm_init_stackchk (void)
-#else
+
void
scm_init_stackchk ()
-#endif
{
-#ifdef SCM_STACK_CHECK
- scm_check_stack_p = 1;
-#endif
#include "stackchk.x"
}
-
diff --git a/libguile/stackchk.h b/libguile/stackchk.h
index eb3c436a2..6e6a358fc 100644
--- a/libguile/stackchk.h
+++ b/libguile/stackchk.h
@@ -43,48 +43,50 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/continuations.h"
+#ifdef DEBUG_EXTENSIONS
+#include "libguile/debug.h"
+#endif
-#ifdef SCM_STACK_LIMIT
-# define SCM_STACK_CHECK
+/* With debug extensions we have the possibility to use the debug options
+ * to disable stack checking.
+ */
+#ifdef DEBUG_EXTENSIONS
+#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT
+#else
+/* *fixme* This option should be settable also without debug extensions. */
+#define SCM_STACK_LIMIT 100000
+#define SCM_STACK_CHECKING_P 1
+#endif
+
+#ifdef STACK_CHECKING
# ifdef SCM_STACK_GROWS_UP
-# define SCM_STACK_OVERFLOW_P(s) (s - SCM_BASE (rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
+# define SCM_STACK_OVERFLOW_P(s)\
+ (s - SCM_BASE (scm_rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
# else
-# define SCM_STACK_OVERFLOW_P(s) (SCM_BASE (rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
+# define SCM_STACK_OVERFLOW_P(s)\
+ (SCM_BASE (scm_rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
# endif
# define SCM_CHECK_STACK\
{\
SCM_STACKITEM stack;\
- if (SCM_STACK_OVERFLOW_P (&stack) && scm_check_stack_p)\
+ if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\
scm_report_stack_overflow ();\
}
#else
# define SCM_CHECK_STACK /**/
-#endif /* def SCM_STACK_LIMIT */
+#endif /* STACK_CHECKING */
-
-extern int scm_check_stack_p;
+extern int scm_stack_checking_enabled_p;
-#ifdef __STDC__
-extern long scm_stack_size (SCM_STACKITEM *start);
-extern void scm_stack_report (void);
-extern void scm_init_stackchk (void);
-
-#else /* STDC */
-extern long scm_stack_size ();
-extern void scm_stack_report ();
-extern void scm_init_stackchk ();
-
-#endif /* STDC */
-
-
-
-
-
-
+extern void scm_report_stack_overflow SCM_P ((void));
+extern long scm_stack_size SCM_P ((SCM_STACKITEM *start));
+extern void scm_stack_report SCM_P ((void));
+extern void scm_init_stackchk SCM_P ((void));
#endif /* STACKCHKH */
diff --git a/libguile/stacks.c b/libguile/stacks.c
new file mode 100644
index 000000000..f17221ca7
--- /dev/null
+++ b/libguile/stacks.c
@@ -0,0 +1,698 @@
+/* Representation of stack frame debug information
+ * Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+#include "debug.h"
+#include "continuations.h"
+#include "struct.h"
+
+#include "stacks.h"
+
+
+/* {Frames and stacks}
+ *
+ * The debugging evaluator creates debug frames on the stack. These
+ * are linked from the innermost frame and outwards. The last frame
+ * created can always be accessed as SCM_LAST_DEBUG_FRAME.
+ * Continuations contain a pointer to the innermost debug frame on the
+ * continuation stack.
+ *
+ * Each debug frame contains a set of flags and information about one
+ * or more stack frames. The case of multiple frames occurs due to
+ * tail recursion. The maximal number of stack frames which can be
+ * recorded in one debug frame can be set dynamically with the debug
+ * option FRAMES.
+ *
+ * Stack frame information is of two types: eval information (the
+ * expression being evaluated and its environment) and apply
+ * information (the procedure being applied and its arguments). A
+ * stack frame normally corresponds to an eval/apply pair, but macros
+ * and special forms (which are implemented as macros in Guile) only
+ * have eval information and apply calls leads to apply only frames.
+ *
+ * Since we want to record the total stack information and later
+ * manipulate this data at the scheme level in the debugger, we need
+ * to transform it into a new representation. In the following code
+ * section you'll find the functions implementing this data type.
+ *
+ * Representation:
+ *
+ * The stack is represented as a struct with an id slot and a tail
+ * array of scm_info_frame structs.
+ *
+ * A frame is represented as a pair where the car contains a stack and
+ * the cdr an inum. The inum is an index to the first SCM value of
+ * the scm_info_frame struct.
+ *
+ * Stacks
+ * Constructor
+ * make-stack
+ * Selectors
+ * stack-id
+ * stack-ref
+ * Inspector
+ * stack-length
+ *
+ * Frames
+ * Constructor
+ * last-stack-frame
+ * Selectors
+ * frame-number
+ * frame-source
+ * frame-procedure
+ * frame-arguments
+ * frame-previous
+ * frame-next
+ * Predicates
+ * frame-real?
+ * frame-procedure?
+ * frame-evaluating-args?
+ * frame-overflow? */
+
+
+
+/* Some auxiliary functions for reading debug frames off the stack.
+ */
+
+/* Stacks often contain pointers to other items on the stack; for
+ example, each scm_debug_frame structure contains a pointer to the
+ next frame out. When we capture a continuation, we copy the stack
+ into the heap, and just leave all the pointers unchanged. This
+ makes it simple to restore the continuation --- just copy the stack
+ back! However, if we retrieve a pointer from the heap copy to
+ another item that was originally on the stack, we have to add an
+ offset to the pointer to discover the new referent.
+
+ If PTR is a pointer retrieved from a continuation, whose original
+ target was on the stack, and OFFSET is the appropriate offset from
+ the original stack to the continuation, then RELOC_MUMBLE (PTR,
+ OFFSET) is a pointer to the copy in the continuation of the
+ original referent, cast to an scm_debug_MUMBLE *. */
+#define RELOC_INFO(ptr, offset) \
+ ((scm_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
+#define RELOC_FRAME(ptr, offset) \
+ ((scm_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
+
+
+/* Count number of debug info frames on a stack, beginning with
+ * DFRAME. OFFSET is used for relocation of pointers when the stack
+ * is read from a continuation.
+ */
+static int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, SCM *id, int *maxp));
+static int
+stack_depth (dframe, offset, id, maxp)
+ scm_debug_frame *dframe;
+ long offset;
+ SCM *id;
+ int *maxp;
+{
+ int n, size;
+ int max_depth = SCM_BACKTRACE_MAXDEPTH;
+ scm_debug_info *info;
+ for (n = 0;
+ dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
+ dframe = RELOC_FRAME (dframe->prev, offset))
+ {
+ if (SCM_EVALFRAMEP (*dframe))
+ {
+ size = dframe->status & SCM_MAX_FRAME_SIZE;
+ info = RELOC_INFO (dframe->info, offset);
+ n += (info - dframe->vect) / 2 + 1;
+ /* Data in the apply part of an eval info frame comes from previous
+ stack frame if the scm_debug_info vector is overflowed. */
+ if ((((info - dframe->vect) & 1) == 0)
+ && SCM_OVERFLOWP (*dframe)
+ && !SCM_UNBNDP (info[1].a.proc))
+ ++n;
+ }
+ else
+ ++n;
+ }
+ if (dframe && SCM_VOIDFRAMEP (*dframe))
+ *id = dframe->vect[0].id;
+ else if (dframe)
+ *maxp = 1;
+ return n;
+}
+
+/* Read debug info from DFRAME into IFRAME.
+ */
+static void read_frame SCM_P ((scm_debug_frame *dframe, long offset, scm_info_frame *iframe));
+static void
+read_frame (dframe, offset, iframe)
+ scm_debug_frame *dframe;
+ long offset;
+ scm_info_frame *iframe;
+{
+ SCM flags = SCM_INUM0;
+ int size;
+ scm_debug_info *info;
+ if (SCM_EVALFRAMEP (*dframe))
+ {
+ size = dframe->status & SCM_MAX_FRAME_SIZE;
+ info = RELOC_INFO (dframe->info, offset);
+ if ((info - dframe->vect) & 1)
+ {
+ /* Debug.vect ends with apply info. */
+ --info;
+ if (info[1].a.proc != SCM_UNDEFINED)
+ {
+ flags |= SCM_FRAMEF_PROC;
+ iframe->proc = info[1].a.proc;
+ iframe->args = info[1].a.args;
+ if (!SCM_ARGS_READY_P (*dframe))
+ flags |= SCM_FRAMEF_EVAL_ARGS;
+ }
+ }
+ iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
+ }
+ else
+ {
+ flags |= SCM_FRAMEF_PROC;
+ iframe->proc = dframe->vect[0].a.proc;
+ iframe->args = dframe->vect[0].a.args;
+ }
+ iframe->flags = flags;
+}
+
+/* Fill the scm_info_frame vector IFRAME with data from N stack frames
+ * starting with the first stack frame represented by debug frame
+ * DFRAME.
+ */
+
+#define NEXT_FRAME(iframe, n, quit) \
+{ \
+ ++iframe; \
+ if (--n == 0) \
+ goto quit; \
+} \
+
+
+static void read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes));
+static void
+read_frames (dframe, offset, n, iframes)
+ scm_debug_frame *dframe;
+ long offset;
+ int n;
+ scm_info_frame *iframes;
+{
+ int size;
+ scm_info_frame *iframe = iframes;
+ scm_debug_info *info;
+
+ for (;
+ dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
+ dframe = RELOC_FRAME (dframe->prev, offset))
+ {
+ read_frame (dframe, offset, iframe);
+ if (SCM_EVALFRAMEP (*dframe))
+ {
+ size = dframe->status & SCM_MAX_FRAME_SIZE;
+ info = RELOC_INFO (dframe->info, offset);
+ if ((info - dframe->vect) & 1)
+ --info;
+ /* Data in the apply part of an eval info frame comes from
+ previous stack frame if the scm_debug_info vector is overflowed. */
+ else if (SCM_OVERFLOWP (*dframe)
+ && !SCM_UNBNDP (info[1].a.proc))
+ {
+ NEXT_FRAME (iframe, n, quit);
+ iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
+ iframe->proc = info[1].a.proc;
+ iframe->args = info[1].a.args;
+ }
+ if (SCM_OVERFLOWP (*dframe))
+ iframe->flags |= SCM_FRAMEF_OVERFLOW;
+ info -= 2;
+ NEXT_FRAME (iframe, n, quit);
+ while (info >= dframe->vect)
+ {
+ if (!SCM_UNBNDP (info[1].a.proc))
+ {
+ iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
+ iframe->proc = info[1].a.proc;
+ iframe->args = info[1].a.args;
+ }
+ else
+ iframe->flags = SCM_INUM0;
+ iframe->source = scm_make_memoized (info[0].e.exp,
+ info[0].e.env);
+ info -= 2;
+ NEXT_FRAME (iframe, n, quit);
+ }
+ }
+ else
+ {
+ NEXT_FRAME (iframe, n, quit);
+ }
+ quit:
+ if (iframe > iframes)
+ (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
+ }
+}
+
+static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key));
+
+static void
+narrow_stack (stack, inner, inner_key, outer, outer_key)
+ SCM stack;
+ int inner;
+ SCM inner_key;
+ int outer;
+ SCM outer_key;
+{
+ scm_stack *s = SCM_STACK (stack);
+ int i;
+ int n = s->length;
+
+ /* Cut inner part. */
+ for (i = 0; inner; --inner)
+ if (s->frames[i++].proc == inner_key)
+ break;
+ s->frames = &s->frames[i];
+ n -= i;
+
+ /* Cut outer part. */
+ for (; n && outer; --outer)
+ if (s->frames[--n].proc == outer_key)
+ break;
+
+ s->length = n;
+}
+
+
+
+/* Stacks
+ */
+
+SCM scm_stack_type;
+
+SCM_PROC (s_stack_p, "stack?", 1, 0, 0, scm_stack_p);
+SCM
+scm_stack_p (obj)
+ SCM obj;
+{
+ return SCM_NIMP (obj) && SCM_STACKP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC (s_make_stack, "make-stack", 0, 0, 1, scm_make_stack);
+SCM
+scm_make_stack (args)
+ SCM args;
+{
+ int n, maxp, size;
+ scm_debug_frame *dframe;
+ scm_info_frame *iframe;
+ long offset = 0;
+ SCM stack, id;
+ SCM obj, inner_cut, outer_cut;
+
+ SCM_ASSERT (SCM_NIMP (args) && SCM_CONSP (args), SCM_WNA, args, s_make_stack);
+ obj = SCM_CAR (args);
+ args = SCM_CDR (args);
+
+ /* Extract a pointer to the innermost frame of whatever object
+ scm_make_stack was given. */
+ if (obj == SCM_BOOL_T)
+ dframe = scm_last_debug_frame;
+ else
+ {
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_make_stack);
+ if (SCM_DEBUGOBJP (obj))
+ dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
+ else if (scm_tc7_contin == SCM_TYP7 (obj))
+ {
+ offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs))
+ - SCM_BASE (obj));
+#ifndef STACK_GROWS_UP
+ offset += SCM_LENGTH (obj);
+#endif
+ dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
+ }
+ else
+ {
+ scm_wta (obj, (char *) SCM_ARG1, s_make_stack);
+ abort ();
+ }
+ }
+
+ /* Count number of frames. Also get stack id tag and check whether
+ there are more stackframes than we want to record
+ (SCM_BACKTRACE_MAXDEPTH). */
+ id = SCM_BOOL_F;
+ maxp = 0;
+ n = stack_depth (dframe, offset, &id, &maxp);
+ size = n * SCM_FRAME_N_SLOTS;
+
+ /* Make the stack object. */
+ stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL);
+ SCM_STACK (stack) -> id = id;
+ SCM_STACK (stack) -> length = n;
+ iframe = &SCM_STACK (stack) -> tail[0];
+ SCM_STACK (stack) -> frames = iframe;
+
+ /* Translate the current chain of stack frames into debugging information. */
+ read_frames (RELOC_FRAME (dframe, offset), offset, n, iframe);
+
+ /* Narrow the stack according to the arguments given to scm_make_stack. */
+ while (n > 0 && SCM_NIMP (args) && SCM_CONSP (args))
+ {
+ inner_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ if (SCM_NIMP (args) && SCM_CONSP (args))
+ {
+ outer_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+ else
+ outer_cut = SCM_INUM0;
+
+ narrow_stack (stack,
+ SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n,
+ SCM_INUMP (inner_cut) ? 0 : inner_cut,
+ SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n,
+ SCM_INUMP (outer_cut) ? 0 : outer_cut);
+
+ n = SCM_STACK (stack) -> length;
+ }
+
+ if (n > 0)
+ {
+ if (maxp)
+ iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+ return stack;
+ }
+ else
+ return SCM_BOOL_F;
+}
+
+SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id);
+SCM
+scm_stack_id (stack)
+ SCM stack;
+{
+ scm_debug_frame *dframe;
+ long offset = 0;
+ if (stack == SCM_BOOL_T)
+ dframe = scm_last_debug_frame;
+ else
+ {
+ SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack);
+ if (SCM_DEBUGOBJP (stack))
+ dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
+ else if (scm_tc7_contin == SCM_TYP7 (stack))
+ {
+ offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs))
+ - SCM_BASE (stack));
+#ifndef STACK_GROWS_UP
+ offset += SCM_LENGTH (stack);
+#endif
+ dframe = RELOC_FRAME (SCM_DFRAME (stack), offset);
+ }
+ else if (SCM_STACKP (stack))
+ return SCM_STACK (stack) -> id;
+ else scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack);
+ }
+ while (dframe && !SCM_VOIDFRAMEP (*dframe))
+ dframe = RELOC_FRAME (dframe->prev, offset);
+ if (dframe && SCM_VOIDFRAMEP (*dframe))
+ return dframe->vect[0].id;
+ return SCM_BOOL_F;
+}
+
+SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref);
+SCM
+scm_stack_ref (stack, i)
+ SCM stack;
+ SCM i;
+{
+ SCM_ASSERT (SCM_NIMP (stack)
+ && SCM_STACKP (stack),
+ stack,
+ SCM_ARG1,
+ s_stack_ref);
+ SCM_ASSERT (SCM_INUMP (i), i, SCM_ARG2, s_stack_ref);
+ SCM_ASSERT (SCM_INUM (i) >= 0
+ && SCM_INUM (i) < SCM_STACK_LENGTH (stack),
+ i,
+ SCM_OUTOFRANGE,
+ s_stack_ref);
+ return scm_cons (stack, i);
+}
+
+SCM_PROC(s_stack_length, "stack-length", 1, 0, 0, scm_stack_length);
+SCM
+scm_stack_length (stack)
+ SCM stack;
+{
+ SCM_ASSERT (SCM_NIMP (stack)
+ && SCM_STACKP (stack),
+ stack,
+ SCM_ARG1,
+ s_stack_length);
+ return SCM_MAKINUM (SCM_STACK_LENGTH (stack));
+}
+
+/* Frames
+ */
+
+SCM_PROC (s_frame_p, "frame?", 1, 0, 0, scm_frame_p);
+SCM
+scm_frame_p (obj)
+ SCM obj;
+{
+ return SCM_NIMP (obj) && SCM_FRAMEP (obj);
+}
+
+SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame);
+SCM
+scm_last_stack_frame (obj)
+ SCM obj;
+{
+ scm_debug_frame *dframe;
+ long offset = 0;
+ SCM stack;
+
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
+ if (SCM_DEBUGOBJP (obj))
+ dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
+ else if (scm_tc7_contin == SCM_TYP7 (obj))
+ {
+ offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs))
+ - SCM_BASE (obj));
+#ifndef STACK_GROWS_UP
+ offset += SCM_LENGTH (obj);
+#endif
+ dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
+ }
+ else
+ {
+ scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
+ abort ();
+ }
+
+ if (!dframe || SCM_VOIDFRAMEP (*dframe))
+ return SCM_BOOL_F;
+
+ stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS),
+ SCM_EOL);
+ SCM_STACK (stack) -> length = 1;
+ SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
+ read_frame (dframe, offset,
+ (scm_info_frame *) &SCM_STACK (stack) -> frames[0]);
+
+ return scm_cons (stack, SCM_INUM0);;
+}
+
+SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number);
+SCM
+scm_frame_number (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_number);
+ return SCM_MAKINUM (SCM_FRAME_NUMBER (frame));
+}
+
+SCM_PROC(s_frame_source, "frame-source", 1, 0, 0, scm_frame_source);
+SCM
+scm_frame_source (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_source);
+ return SCM_FRAME_SOURCE (frame);
+}
+
+SCM_PROC(s_frame_procedure, "frame-procedure", 1, 0, 0, scm_frame_procedure);
+SCM
+scm_frame_procedure (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_procedure);
+ return (SCM_FRAME_PROC_P (frame)
+ ? SCM_BOOL_F
+ : SCM_FRAME_PROC (frame));
+}
+
+SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments);
+SCM
+scm_frame_arguments (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_arguments);
+ return SCM_FRAME_ARGS (frame);
+}
+
+SCM_PROC(s_frame_previous, "frame-previous", 1, 0, 0, scm_frame_previous);
+SCM
+scm_frame_previous (frame)
+ SCM frame;
+{
+ int n;
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_previous);
+ n = SCM_INUM (SCM_CDR (frame)) + 1;
+ if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
+ return SCM_BOOL_F;
+ else
+ return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
+}
+
+SCM_PROC(s_frame_next, "frame-next", 1, 0, 0, scm_frame_next);
+SCM
+scm_frame_next (frame)
+ SCM frame;
+{
+ int n;
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_next);
+ n = SCM_INUM (SCM_CDR (frame)) - 1;
+ if (n < 0)
+ return SCM_BOOL_F;
+ else
+ return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
+}
+
+SCM_PROC(s_frame_real_p, "frame-real?", 1, 0, 0, scm_frame_real_p);
+SCM
+scm_frame_real_p (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_real_p);
+ return SCM_FRAME_REAL_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC(s_frame_procedure_p, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p);
+SCM
+scm_frame_procedure_p (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_procedure_p);
+ return SCM_FRAME_PROC_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC(s_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p);
+SCM
+scm_frame_evaluating_args_p (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_evaluating_args_p);
+ return SCM_FRAME_EVAL_ARGS_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC(s_frame_overflow_p, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p);
+SCM
+scm_frame_overflow_p (frame)
+ SCM frame;
+{
+ SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
+ frame,
+ SCM_ARG1,
+ s_frame_overflow_p);
+ return SCM_FRAME_OVERFLOW_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+
+
+void
+scm_init_stacks ()
+{
+ SCM vtable;
+ SCM vtable_layout = scm_make_struct_layout (scm_nullstr);
+ SCM stack_layout
+ = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT));
+ vtable = scm_make_vtable_vtable (vtable_layout, SCM_INUM0, SCM_EOL);
+ scm_stack_type
+ = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0,
+ scm_cons (stack_layout,
+ SCM_EOL)));
+#include "stacks.x"
+}
diff --git a/libguile/stacks.h b/libguile/stacks.h
new file mode 100644
index 000000000..3cbcb28be
--- /dev/null
+++ b/libguile/stacks.h
@@ -0,0 +1,135 @@
+/* classes: h_files */
+
+#ifndef STACKSH
+#define STACKSH
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+/* {Frames and stacks}
+ */
+
+typedef struct scm_info_frame {
+ SCM flags;
+ SCM source;
+ SCM proc;
+ SCM args;
+} scm_info_frame;
+#define SCM_FRAME_N_SLOTS (sizeof (scm_info_frame) / sizeof (SCM))
+
+#define SCM_STACK(obj) ((scm_stack *) SCM_STRUCT_DATA (obj))
+#define SCM_STACK_LAYOUT "pwuourpW"
+typedef struct scm_stack {
+ SCM id; /* Stack id */
+ scm_info_frame *frames; /* Info frames */
+ unsigned int length; /* Stack length */
+ unsigned int tail_length;
+ scm_info_frame tail[1];
+} scm_stack;
+
+extern SCM scm_stack_type;
+
+#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE (obj) == scm_stack_type)
+#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length)
+
+#define SCM_FRAMEP(obj) (SCM_CONSP (obj) \
+ && SCM_NIMP (SCM_CAR (obj)) \
+ && SCM_STACKP (SCM_CAR (obj)) \
+ && SCM_INUMP (SCM_CDR (obj))) \
+
+
+#define SCM_FRAME_REF(frame, slot) \
+(SCM_STACK (SCM_CAR (frame)) -> frames[SCM_INUM (SCM_CDR (frame))].slot) \
+
+#define SCM_FRAME_NUMBER(frame) \
+(SCM_BACKWARDS_P \
+ ? SCM_INUM (SCM_CDR (frame)) \
+ : (SCM_STACK_LENGTH (SCM_CAR (frame)) \
+ - SCM_INUM (SCM_CDR (frame)) \
+ - 1)) \
+
+#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags)
+#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source)
+#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc)
+#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args)
+#define SCM_FRAME_PREV(frame) scm_frame_previous (frame)
+#define SCM_FRAME_NEXT(frame) scm_frame_next (frame)
+
+#define SCM_FRAMEF_VOID (1L << 2)
+#define SCM_FRAMEF_REAL (1L << 3)
+#define SCM_FRAMEF_PROC (1L << 4)
+#define SCM_FRAMEF_EVAL_ARGS (1L << 5)
+#define SCM_FRAMEF_OVERFLOW (1L << 6)
+
+#define SCM_FRAME_VOID_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_VOID)
+#define SCM_FRAME_REAL_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_REAL)
+#define SCM_FRAME_PROC_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_PROC)
+#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_EVAL_ARGS)
+#define SCM_FRAME_OVERFLOW_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_OVERFLOW)
+
+
+
+SCM scm_stack_p SCM_P ((SCM obj));
+SCM scm_make_stack SCM_P ((SCM args));
+SCM scm_stack_ref SCM_P ((SCM stack, SCM i));
+SCM scm_stack_length SCM_P ((SCM stack));
+
+SCM scm_frame_p SCM_P ((SCM obj));
+SCM scm_last_stack_frame SCM_P ((SCM obj));
+SCM scm_frame_number SCM_P ((SCM frame));
+SCM scm_frame_source SCM_P ((SCM frame));
+SCM scm_frame_procedure SCM_P ((SCM frame));
+SCM scm_frame_arguments SCM_P ((SCM frame));
+SCM scm_frame_previous SCM_P ((SCM frame));
+SCM scm_frame_next SCM_P ((SCM frame));
+SCM scm_frame_real_p SCM_P ((SCM frame));
+SCM scm_frame_procedure_p SCM_P ((SCM frame));
+SCM scm_frame_evaluating_args_p SCM_P ((SCM frame));
+SCM scm_frame_overflow_p SCM_P ((SCM frame));
+
+void scm_init_stacks SCM_P ((void));
+
+#endif /* STACKSH */
diff --git a/libguile/stamp-h.in b/libguile/stamp-h.in
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/libguile/stamp-h.in
diff --git a/libguile/stime.c b/libguile/stime.c
index 77ead9a7a..2847c04aa 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -42,6 +42,11 @@
#include <stdio.h>
#include "_scm.h"
+#include "feature.h"
+#include "sequences.h"
+
+#include "stime.h"
+
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -72,10 +77,17 @@
# endif
# endif
+#ifndef tzname /* For SGI. */
+extern char *tzname[]; /* RS6000 and others reject char **tzname. */
+#endif
+
+char *strptime ();
+
+/* This should be figured out by autoconf. */
#ifdef CLK_TCK
# define CLKTCK CLK_TCK
# ifdef CLOCKS_PER_SEC
-# ifdef unix
+# if defined (unix) || defined (__unix)
# ifndef ARM_ULIB
# include <sys/times.h>
# endif
@@ -106,13 +118,8 @@
#endif
#ifdef HAVE_TIMES
-#ifdef __STDC__
-static
-long mytime(void)
-#else
static
long mytime()
-#endif
{
struct tms time_buffer;
times(&time_buffer);
@@ -126,19 +133,16 @@ long mytime()
# endif
#endif
-
+extern int errno;
#ifdef HAVE_FTIME
+extern int ftime (struct timeb *);
+
struct timeb scm_your_base = {0};
SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
-#ifdef __STDC__
-SCM
-scm_get_internal_real_time(void)
-#else
SCM
scm_get_internal_real_time()
-#endif
{
struct timeb time_buffer;
long tmp;
@@ -148,22 +152,17 @@ scm_get_internal_real_time()
tmp = time_buffer.time*1000L + tmp;
tmp *= CLKTCK;
tmp /= 1000;
- return SCM_MAKINUM(tmp);
+ return scm_long2num (tmp);
}
#else
timet scm_your_base = 0;
SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
-#ifdef __STDC__
-SCM
-scm_get_internal_real_time(void)
-#else
SCM
scm_get_internal_real_time()
-#endif
{
- return SCM_MAKINUM((time((timet*)0) - scm_your_base) * (int)CLKTCK);
+ return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
}
#endif
@@ -172,56 +171,372 @@ scm_get_internal_real_time()
static long scm_my_base = 0;
SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time);
-#ifdef __STDC__
-SCM
-scm_get_internal_run_time(void)
-#else
SCM
scm_get_internal_run_time()
-#endif
{
- return SCM_MAKINUM(mytime()-scm_my_base);
+ return scm_long2num(mytime()-scm_my_base);
}
SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time);
-#ifdef __STDC__
SCM
-scm_current_time(void)
+scm_current_time()
+{
+ timet timv;
+
+ SCM_DEFER_INTS;
+ if ((timv = time (0)) == -1)
+ scm_syserror (s_current_time);
+ SCM_ALLOW_INTS;
+ return scm_long2num((long) timv);
+}
+
+SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday);
+SCM
+scm_gettimeofday (void)
+{
+#ifdef HAVE_GETTIMEOFDAY
+ struct timeval time;
+
+ SCM_DEFER_INTS;
+ if (gettimeofday (&time, NULL) == -1)
+ scm_syserror (s_gettimeofday);
+ SCM_ALLOW_INTS;
+ return scm_cons (scm_long2num ((long) time.tv_sec),
+ scm_long2num ((long) time.tv_usec));
#else
+# ifdef HAVE_FTIME
+ struct timeb time;
+
+ ftime(&time);
+ return scm_cons (scm_long2num ((long) time.time),
+ SCM_MAKINUM (time.millitm * 1000));
+# else
+ timet timv;
+
+ SCM_DEFER_INTS;
+ if ((timv = time (0)) == -1)
+ scm_syserror (s_gettimeofday);
+ SCM_ALLOW_INTS;
+ return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
+# endif
+#endif
+}
+
+static SCM
+filltime (struct tm *bd_time, int zoff, char *zname)
+{
+ SCM result = scm_make_vector(SCM_MAKINUM(11), SCM_UNDEFINED, SCM_UNDEFINED);
+
+ SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
+ SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
+ SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
+ SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
+ SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
+ SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
+ SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
+ SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
+ SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
+ SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
+ SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
+ return result;
+}
+
+static char *
+setzone (SCM zone, int pos, char *subr)
+{
+ char *oldtz = 0;
+
+ if (!SCM_UNBNDP (zone))
+ {
+ char *buf;
+
+ /* if zone was supplied, set the environment variable TZ temporarily. */
+ SCM_ASSERT (SCM_NIMP (zone) && SCM_STRINGP (zone), zone, pos, subr);
+ buf = malloc (SCM_LENGTH (zone) + 4);
+ if (buf == 0)
+ scm_memory_error (subr);
+ oldtz = getenv ("TZ");
+ if (oldtz != NULL)
+ oldtz = oldtz - 3;
+ sprintf (buf, "TZ=%s", SCM_CHARS (zone));
+ if (putenv (buf) < 0)
+ scm_syserror (subr);
+ tzset();
+ }
+ return oldtz;
+}
+
+static void
+restorezone (SCM zone, char *oldzone)
+{
+ if (!SCM_UNBNDP (zone))
+ {
+ int rv;
+
+ if (oldzone)
+ rv = putenv (oldzone);
+ else
+ rv = putenv ("TZ");
+ if (rv < 0)
+ scm_syserror ("restorezone");
+ tzset();
+ }
+}
+
+
+SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime);
SCM
-scm_current_time()
+scm_localtime (SCM time, SCM zone)
+{
+ timet itime;
+ struct tm *lt, *utc;
+ SCM result;
+ int zoff;
+ char *zname = 0;
+ char *oldtz;
+ int err;
+
+ itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime);
+ SCM_DEFER_INTS;
+ oldtz = setzone (zone, SCM_ARG2, s_localtime);
+ lt = localtime (&itime);
+ err = errno;
+ utc = gmtime (&itime);
+ if (utc == NULL)
+ err = errno;
+ if (lt)
+ {
+#ifdef HAVE_TM_ZONE
+ zname = lt->tm_zone;
+#else
+# ifdef HAVE_TZNAME
+ /* must be copied before calling tzset again. */
+ char *ptr = tzname[ (lt->tm_isdst == 1) ? 1 : 0 ];
+
+ zname = scm_must_malloc (strlen (ptr) + 1, s_localtime);
+ strcpy (zname, ptr);
+#endif
#endif
+ }
+ restorezone (zone, oldtz);
+ /* delayed until zone has been restored. */
+ errno = err;
+ if (utc == NULL || lt == NULL)
+ scm_syserror (s_localtime);
+
+ /* calculate timezone offset in seconds west of UTC. */
+ zoff = (utc->tm_hour - lt->tm_hour) * 3600 + (utc->tm_min - lt->tm_min) * 60
+ + utc->tm_sec - lt->tm_sec;
+ if (utc->tm_year < lt->tm_year)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_year > lt->tm_year)
+ zoff += 24 * 60 * 60;
+ else if (utc->tm_yday < lt->tm_yday)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_yday > lt->tm_yday)
+ zoff += 24 * 60 * 60;
+
+ result = filltime (lt, zoff, zname);
+ SCM_ALLOW_INTS;
+ return result;
+}
+
+SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime);
+SCM
+scm_gmtime (SCM time)
{
- timet timv = time((timet*)0);
- SCM ans;
- ans = scm_ulong2num(timv);
- return SCM_BOOL_F==ans ? SCM_MAKINUM(timv) : ans;
+ timet itime;
+ struct tm *bd_time;
+ SCM result;
+
+ itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime);
+ SCM_DEFER_INTS;
+ bd_time = gmtime (&itime);
+ if (bd_time == NULL)
+ scm_syserror (s_gmtime);
+ result = filltime (bd_time, 0, "GMT");
+ SCM_ALLOW_INTS;
+ return result;
}
-#ifdef __STDC__
-long
-scm_time_in_msec(long x)
+/* copy time components from a Scheme object to a struct tm. */
+static void
+bdtime2c (SCM sbd_time, struct tm *lt, int pos, char *subr)
+{
+ SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time)
+ && scm_obj_length (sbd_time) == 11
+ && SCM_INUMP (SCM_VELTS (sbd_time)[0])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[1])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[2])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[3])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[4])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[5])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[6])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[7])
+ && SCM_INUMP (SCM_VELTS (sbd_time)[8]),
+ sbd_time, pos, subr);
+ lt->tm_sec = SCM_INUM (SCM_VELTS (sbd_time)[0]);
+ lt->tm_min = SCM_INUM (SCM_VELTS (sbd_time)[1]);
+ lt->tm_hour = SCM_INUM (SCM_VELTS (sbd_time)[2]);
+ lt->tm_mday = SCM_INUM (SCM_VELTS (sbd_time)[3]);
+ lt->tm_mon = SCM_INUM (SCM_VELTS (sbd_time)[4]);
+ lt->tm_year = SCM_INUM (SCM_VELTS (sbd_time)[5]);
+ lt->tm_wday = SCM_INUM (SCM_VELTS (sbd_time)[6]);
+ lt->tm_yday = SCM_INUM (SCM_VELTS (sbd_time)[7]);
+ lt->tm_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]);
+}
+
+SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime);
+SCM
+scm_mktime (SCM sbd_time, SCM zone)
+{
+ timet itime;
+ struct tm lt, *utc;
+ SCM result;
+ int zoff;
+ char *zname = 0;
+ char *oldtz = 0;
+ int err;
+
+ SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time), sbd_time,
+ SCM_ARG1, s_mktime);
+ bdtime2c (sbd_time, &lt, SCM_ARG1, s_mktime);
+
+ SCM_DEFER_INTS;
+ oldtz = setzone (zone, SCM_ARG2, s_mktime);
+ itime = mktime (&lt);
+ err = errno;
+
+ /* timezone offset in seconds west of UTC. */
+ utc = gmtime (&itime);
+ if (utc == NULL)
+ err = errno;
+
+ if (itime != -1)
+ {
+#ifdef HAVE_TM_ZONE
+ zname = lt.tm_zone;
#else
-long
-scm_time_in_msec(x)
- long x;
+# ifdef HAVE_TZNAME
+ /* must be copied before calling tzset again. */
+ char *ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
+
+ zname = scm_must_malloc (strlen (ptr) + 1, s_mktime);
+ strcpy (zname, ptr);
+#endif
#endif
+ }
+ restorezone (zone, oldtz);
+ /* delayed until zone has been restored. */
+ errno = err;
+ if (utc == NULL || itime == -1)
+ scm_syserror (s_mktime);
+
+ zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
+ + utc->tm_sec - lt.tm_sec;
+ if (utc->tm_year < lt.tm_year)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_year > lt.tm_year)
+ zoff += 24 * 60 * 60;
+ else if (utc->tm_yday < lt.tm_yday)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_yday > lt.tm_yday)
+ zoff += 24 * 60 * 60;
+
+ result = scm_cons (scm_long2num ((long) itime),
+ filltime (&lt, zoff, zname));
+ SCM_ALLOW_INTS;
+ return result;
+}
+
+SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
+SCM
+scm_tzset (void)
{
- if (CLKTCK==60) return (x*50)/3;
- else
- return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK);
+ tzset();
+ return SCM_UNSPECIFIED;
}
-#ifdef __STDC__
-void
-scm_init_stime(void)
+SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
+
+SCM
+scm_strftime (format, stime)
+ SCM format;
+ SCM stime;
+{
+ struct tm t;
+
+ char *tbuf;
+ int size = 50;
+ char *fmt;
+ int len;
+
+ SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1,
+ s_strftime);
+ bdtime2c (stime, &t, SCM_ARG2, s_strftime);
+
+ fmt = SCM_ROCHARS (format);
+ len = SCM_ROLENGTH (format);
+
+ tbuf = scm_must_malloc (size, s_strftime);
+ while ((len = strftime (tbuf, size, fmt, &t)) == size)
+ {
+ scm_must_free (tbuf);
+ size *= 2;
+ tbuf = scm_must_malloc (size, s_strftime);
+ }
+ return scm_makfromstr (tbuf, len, 0);
+}
+
+SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime);
+
+SCM
+scm_strptime (format, string)
+ SCM format;
+ SCM string;
+{
+#ifdef HAVE_STRPTIME
+ struct tm t;
+ char *fmt, *str, *rest;
+
+ SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
+ s_strptime);
+ SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2,
+ s_strptime);
+
+ fmt = SCM_ROCHARS (format);
+ str = SCM_ROCHARS (string);
+
+ /* initialize the struct tm */
+#define tm_init(field) t.field = 0
+ tm_init (tm_sec);
+ tm_init (tm_min);
+ tm_init (tm_hour);
+ tm_init (tm_mday);
+ tm_init (tm_mon);
+ tm_init (tm_year);
+ tm_init (tm_wday);
+ tm_init (tm_yday);
+#undef tm_init
+
+ t.tm_isdst = -1;
+ SCM_DEFER_INTS;
+ if ((rest = strptime (str, fmt, &t)) == NULL)
+ scm_syserror (s_strptime);
+
+ SCM_ALLOW_INTS;
+ return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str));
+
#else
+ scm_sysmissing (s_strptime);
+#endif
+}
+
void
scm_init_stime()
-#endif
{
scm_sysintern("internal-time-units-per-second",
- SCM_MAKINUM((long)CLKTCK));
+ scm_long2num((long)CLKTCK));
#ifdef HAVE_FTIME
if (!scm_your_base.time) ftime(&scm_your_base);
@@ -231,6 +546,7 @@ scm_init_stime()
if (!scm_my_base) scm_my_base = mytime();
+ scm_add_feature ("current-time");
#include "stime.x"
}
diff --git a/libguile/stime.h b/libguile/stime.h
index c492d40fe..d25f8378b 100644
--- a/libguile/stime.h
+++ b/libguile/stime.h
@@ -2,7 +2,7 @@
#ifndef TIMEH
#define TIMEH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,32 +44,19 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_get_internal_real_time(void);
-extern SCM scm_get_internal_real_time(void);
-extern SCM scm_get_internal_real_time(void);
-extern SCM scm_get_internal_run_time(void);
-extern SCM scm_current_time(void);
-extern long scm_time_in_msec(long x);
-extern void scm_init_stime(void);
-
-#else /* STDC */
-extern SCM scm_get_internal_real_time();
-extern SCM scm_get_internal_real_time();
-extern SCM scm_get_internal_real_time();
-extern SCM scm_get_internal_run_time();
-extern SCM scm_current_time();
-extern long scm_time_in_msec();
-extern void scm_init_stime();
-
-#endif /* STDC */
-
-
-
-
-
+extern SCM scm_get_internal_real_time SCM_P ((void));
+extern SCM scm_get_internal_run_time SCM_P ((void));
+extern SCM scm_current_time SCM_P ((void));
+extern SCM scm_gettimeofday (void);
+extern SCM scm_localtime (SCM time, SCM zone);
+extern SCM scm_gmtime (SCM time);
+extern SCM scm_mktime (SCM sbd_time, SCM zone);
+extern SCM scm_tzset (void);
+extern SCM scm_strftime SCM_P ((SCM format, SCM stime));
+extern SCM scm_strptime SCM_P ((SCM format, SCM string));
+extern void scm_init_stime SCM_P ((void));
#endif /* TIMEH */
diff --git a/libguile/strerror.c b/libguile/strerror.c
new file mode 100644
index 000000000..4723d04e8
--- /dev/null
+++ b/libguile/strerror.c
@@ -0,0 +1,32 @@
+/* Turning errno values into English error messages.
+ Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs 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.
+
+GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+
+char *
+strerror (errnum)
+ int errnum;
+{
+ extern char *sys_errlist[];
+ extern int sys_nerr;
+
+ if (errnum >= 0 && errnum < sys_nerr)
+ return sys_errlist[errnum];
+ return (char *) "Unknown error";
+}
diff --git a/libguile/strings.c b/libguile/strings.c
index ea96e8c30..e3c24406b 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -42,21 +42,19 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "strings.h"
/* {Strings}
*/
SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p);
-#ifdef __STDC__
-SCM
-scm_string_p (SCM x)
-#else
+
SCM
scm_string_p (x)
SCM x;
-#endif
{
if (SCM_IMP (x))
return SCM_BOOL_F;
@@ -64,14 +62,10 @@ scm_string_p (x)
}
SCM_PROC(s_read_only_string_p, "read-only-string?", 1, 0, 0, scm_read_only_string_p);
-#ifdef __STDC__
-SCM
-scm_read_only_string_p (SCM x)
-#else
+
SCM
scm_read_only_string_p (x)
SCM x;
-#endif
{
if (SCM_IMP (x))
return SCM_BOOL_F;
@@ -80,17 +74,13 @@ scm_read_only_string_p (x)
SCM_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string);
SCM_PROC(s_string, "string", 0, 0, 1, scm_string);
-#ifdef __STDC__
-SCM
-scm_string (SCM chrs)
-#else
+
SCM
scm_string (chrs)
SCM chrs;
-#endif
{
SCM res;
- register char *data;
+ register unsigned char *data;
long i;
long len;
SCM_DEFER_INTS;
@@ -116,7 +106,7 @@ scm_string (chrs)
}
}
res = scm_makstr (len, 0);
- data = SCM_CHARS (res);
+ data = SCM_UCHARS (res);
for (;SCM_NNULLP (chrs);chrs = SCM_CDR (chrs))
{
if (SCM_ICHRP (SCM_CAR (chrs)))
@@ -126,7 +116,7 @@ scm_string (chrs)
int l;
char * c;
l = SCM_ROLENGTH (SCM_CAR (chrs));
- c = SCM_ROCHARS (SCM_CAR (chrs));
+ c = SCM_ROUCHARS (SCM_CAR (chrs));
while (l)
{
--l;
@@ -138,15 +128,11 @@ scm_string (chrs)
return res;
}
-#ifdef __STDC__
-SCM
-scm_makstr (long len, int slots)
-#else
+
SCM
scm_makstr (len, slots)
long len;
int slots;
-#endif
{
SCM s;
SCM * mem;
@@ -171,15 +157,11 @@ scm_makstr (len, slots)
/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array is assumed. */
-#ifdef __STDC__
-SCM
-scm_makfromstrs (int argc, char **argv)
-#else
+
SCM
scm_makfromstrs (argc, argv)
int argc;
char **argv;
-#endif
{
int i = argc;
SCM lst = SCM_EOL;
@@ -191,14 +173,10 @@ scm_makfromstrs (argc, argv)
}
-#ifdef __STDC__
-SCM
-scm_take0str (char * it)
-#else
+
SCM
scm_take0str (it)
char * it;
-#endif
{
SCM answer;
SCM_NEWCELL (answer);
@@ -209,16 +187,12 @@ scm_take0str (it)
return answer;
}
-#ifdef __STDC__
-SCM
-scm_makfromstr (const char *src, scm_sizet len, int slots)
-#else
+
SCM
scm_makfromstr (src, len, slots)
const char *src;
scm_sizet len;
int slots;
-#endif
{
SCM s;
register char *dst;
@@ -230,27 +204,19 @@ scm_makfromstr (src, len, slots)
}
-#ifdef __STDC__
-SCM
-scm_makfrom0str (char *src)
-#else
+
SCM
scm_makfrom0str (src)
- char *src;
-#endif
+ const char *src;
{
if (!src) return SCM_BOOL_F;
return scm_makfromstr (src, (scm_sizet) strlen (src), 0);
}
-#ifdef __STDC__
-SCM
-scm_makfrom0str_opt (char *src)
-#else
+
SCM
scm_makfrom0str_opt (src)
- char *src;
-#endif
+ const char *src;
{
return scm_makfrom0str (src);
}
@@ -259,23 +225,19 @@ scm_makfrom0str_opt (src)
SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string);
-#ifdef __STDC__
-SCM
-scm_make_string (SCM k, SCM chr)
-#else
+
SCM
scm_make_string (k, chr)
SCM k;
SCM chr;
-#endif
{
SCM res;
- register char *dst;
+ register unsigned char *dst;
register long i;
SCM_ASSERT (SCM_INUMP (k) && (k >= 0), k, SCM_ARG1, s_make_string);
i = SCM_INUM (k);
res = scm_makstr (i, 0);
- dst = SCM_CHARS (res);
+ dst = SCM_UCHARS (res);
if SCM_ICHRP (chr)
{
char c = SCM_ICHR (chr);
@@ -288,71 +250,55 @@ scm_make_string (k, chr)
}
SCM_PROC(s_string_length, "string-length", 1, 0, 0, scm_string_length);
-#ifdef __STDC__
-SCM
-scm_string_length (SCM str)
-#else
+
SCM
scm_string_length (str)
SCM str;
-#endif
{
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_length);
return SCM_MAKINUM (SCM_ROLENGTH (str));
}
SCM_PROC(s_string_ref, "string-ref", 1, 1, 0, scm_string_ref);
-#ifdef __STDC__
-SCM
-scm_string_ref (SCM str, SCM k)
-#else
+
SCM
scm_string_ref (str, k)
SCM str;
SCM k;
-#endif
{
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_ref);
if (k == SCM_UNDEFINED)
k = SCM_MAKINUM (0);
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_ref);
SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_ref);
- return SCM_MAKICHR (SCM_ROCHARS (str)[SCM_INUM (k)]);
+ return SCM_MAKICHR (SCM_ROUCHARS (str)[SCM_INUM (k)]);
}
SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x);
-#ifdef __STDC__
-SCM
-scm_string_set_x (SCM str, SCM k, SCM chr)
-#else
+
SCM
scm_string_set_x (str, k, chr)
SCM str;
SCM k;
SCM chr;
-#endif
{
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_set_x);
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_set_x);
SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG3, s_string_set_x);
SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_set_x);
- SCM_CHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr);
+ SCM_UCHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr);
return SCM_UNSPECIFIED;
}
SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring);
-#ifdef __STDC__
-SCM
-scm_substring (SCM str, SCM start, SCM end)
-#else
+
SCM
scm_substring (str, start, end)
SCM str;
SCM start;
SCM end;
-#endif
{
long l;
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str),
@@ -369,19 +315,15 @@ scm_substring (str, start, end)
}
SCM_PROC(s_string_append, "string-append", 0, 0, 1, scm_string_append);
-#ifdef __STDC__
-SCM
-scm_string_append (SCM args)
-#else
+
SCM
scm_string_append (args)
SCM args;
-#endif
{
SCM res;
register long i = 0;
register SCM l, s;
- register char *data;
+ register unsigned char *data;
for (l = args;SCM_NIMP (l);) {
SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, s_string_append);
s = SCM_CAR (l);
@@ -392,25 +334,21 @@ scm_string_append (args)
}
SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, s_string_append);
res = scm_makstr (i, 0);
- data = SCM_CHARS (res);
+ data = SCM_UCHARS (res);
for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
s = SCM_CAR (l);
- for (i = 0;i<SCM_ROLENGTH (s);i++) *data++ = SCM_ROCHARS (s)[i];
+ for (i = 0;i<SCM_ROLENGTH (s);i++) *data++ = SCM_ROUCHARS (s)[i];
}
return res;
}
SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring);
-#ifdef __STDC__
-SCM
-scm_make_shared_substring (SCM str, SCM frm, SCM to)
-#else
+
SCM
scm_make_shared_substring (str, frm, to)
SCM str;
SCM frm;
SCM to;
-#endif
{
long f;
long t;
@@ -460,13 +398,9 @@ scm_make_shared_substring (str, frm, to)
return answer;
}
-#ifdef __STDC__
-void
-scm_init_strings (void)
-#else
+
void
scm_init_strings ()
-#endif
{
#include "strings.x"
}
diff --git a/libguile/strings.h b/libguile/strings.h
index 6615e2330..93f5a6e43 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -44,7 +44,11 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -53,57 +57,23 @@
-#ifdef __STDC__
-extern SCM scm_string_p (SCM x);
-extern SCM scm_read_only_string_p (SCM x);
-extern SCM scm_string (SCM chrs);
-extern SCM scm_makstr (long len, int slots);
-extern SCM scm_makfromstrs (int argc, char **argv);
-extern SCM scm_take0str (char * it);
-extern SCM scm_makfromstr (const char *src, scm_sizet len, int slots);
-extern SCM scm_makfrom0str (char *src);
-extern SCM scm_makfrom0str_opt (char *src);
-extern SCM scm_make_string (SCM k, SCM chr);
-extern SCM scm_string_length (SCM str);
-extern SCM scm_string_ref (SCM str, SCM k);
-extern SCM scm_string_set_x (SCM str, SCM k, SCM chr);
-extern SCM scm_substring (SCM str, SCM start, SCM end);
-extern SCM scm_string_append (SCM args);
-extern SCM scm_make_shared_substring (SCM str, SCM frm, SCM to);
-extern void scm_init_strings (void);
-
-#else /* STDC */
-extern SCM scm_string_p ();
-extern SCM scm_read_only_string_p ();
-extern SCM scm_string ();
-extern SCM scm_makstr ();
-extern SCM scm_makfromstrs ();
-extern SCM scm_take0str ();
-extern SCM scm_makfromstr ();
-extern SCM scm_makfrom0str ();
-extern SCM scm_makfrom0str_opt ();
-extern SCM scm_make_string ();
-extern SCM scm_string_length ();
-extern SCM scm_string_ref ();
-extern SCM scm_string_set_x ();
-extern SCM scm_substring ();
-extern SCM scm_string_append ();
-extern SCM scm_make_shared_substring ();
-extern void scm_init_strings ();
-
-#endif /* STDC */
-
-
-
-
-
-
-
-
-
-
-
-
+extern SCM scm_string_p SCM_P ((SCM x));
+extern SCM scm_read_only_string_p SCM_P ((SCM x));
+extern SCM scm_string SCM_P ((SCM chrs));
+extern SCM scm_makstr SCM_P ((long len, int slots));
+extern SCM scm_makfromstrs SCM_P ((int argc, char **argv));
+extern SCM scm_take0str SCM_P ((char * it));
+extern SCM scm_makfromstr SCM_P ((const char *src, scm_sizet len, int slots));
+extern SCM scm_makfrom0str SCM_P ((const char *src));
+extern SCM scm_makfrom0str_opt SCM_P ((const char *src));
+extern SCM scm_make_string SCM_P ((SCM k, SCM chr));
+extern SCM scm_string_length SCM_P ((SCM str));
+extern SCM scm_string_ref SCM_P ((SCM str, SCM k));
+extern SCM scm_string_set_x SCM_P ((SCM str, SCM k, SCM chr));
+extern SCM scm_substring SCM_P ((SCM str, SCM start, SCM end));
+extern SCM scm_string_append SCM_P ((SCM args));
+extern SCM scm_make_shared_substring SCM_P ((SCM str, SCM frm, SCM to));
+extern void scm_init_strings SCM_P ((void));
#endif /* STRINGSH */
diff --git a/libguile/strop.c b/libguile/strop.c
index 366d249da..4adfed975 100644
--- a/libguile/strop.c
+++ b/libguile/strop.c
@@ -1,6 +1,6 @@
/* classes: src_files */
-/* Copyright (C) 1994 Free Software Foundation, Inc.
+/* Copyright (C) 1994, 1996, 1997 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
@@ -20,69 +20,21 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "strop.h"
-#ifdef __STDC__
-int
-scm_i_index (SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why)
-#else
-int
-scm_i_index (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why)
- SCM * str;
- SCM chr;
- SCM sub_start;
- SCM sub_end;
- int pos;
- int pos2;
- int pos3;
- int pos4;
- char * why;
-#endif
-{
- unsigned char * p;
- int x;
- int bound;
- int ch;
-
- SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why);
- SCM_ASSERT (SCM_ICHRP (chr), chr, pos2, why);
- if (sub_start == SCM_BOOL_F)
- sub_start = SCM_MAKINUM (0);
- else
- SCM_ASSERT ( SCM_INUMP (sub_start)
- && (0 <= SCM_INUM (sub_start))
- && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)),
- sub_start, pos3, why);
-
- if (sub_end == SCM_BOOL_F)
- sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str));
- else
- SCM_ASSERT ( SCM_INUMP (sub_end)
- && (SCM_INUM (sub_start) <= SCM_INUM (sub_end))
- && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)),
- sub_end, pos4, why);
-
- p = (unsigned char *)SCM_ROCHARS (*str) + SCM_INUM (sub_start);
- bound = SCM_INUM (sub_end);
- ch = SCM_ICHR (chr);
+static int scm_i_index SCM_P ((SCM * str, SCM chr, int direction, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why));
- for (x = SCM_INUM (sub_start); x < bound; ++x, ++p)
- if (*p == ch)
- return x;
-
- return -1;
-}
-
-#ifdef __STDC__
-int
-scm_i_rindex (SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why)
-#else
-int
-scm_i_rindex (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why)
+/* implements index if direction > 0 otherwise rindex. */
+static int
+scm_i_index (str, chr, direction, sub_start, sub_end, pos, pos2, pos3, pos4,
+ why)
SCM * str;
SCM chr;
+ int direction;
SCM sub_start;
SCM sub_end;
int pos;
@@ -90,12 +42,11 @@ scm_i_rindex (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why)
int pos3;
int pos4;
char * why;
-#endif
{
unsigned char * p;
int x;
- int upper_bound;
- int lower_bound;
+ int lower;
+ int upper;
int ch;
SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why);
@@ -103,44 +54,51 @@ scm_i_rindex (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why)
if (sub_start == SCM_BOOL_F)
sub_start = SCM_MAKINUM (0);
- else
- SCM_ASSERT ( SCM_INUMP (sub_start)
- && (0 <= SCM_INUM (sub_start))
- && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)),
- sub_start, pos3, why);
+
+ SCM_ASSERT (SCM_INUMP (sub_start), sub_start, pos3, why);
+ lower = SCM_INUM (sub_start);
+ if (lower < 0
+ || lower > SCM_ROLENGTH (*str))
+ scm_out_of_range (why, sub_start);
if (sub_end == SCM_BOOL_F)
sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str));
+
+ SCM_ASSERT (SCM_INUMP (sub_end), sub_end, pos4, why);
+ upper = SCM_INUM (sub_end);
+ if (upper < SCM_INUM (sub_start)
+ || upper > SCM_ROLENGTH (*str))
+ scm_out_of_range (why, sub_end);
+
+ if (direction > 0)
+ {
+ p = (unsigned char *)SCM_ROCHARS (*str) + lower;
+ ch = SCM_ICHR (chr);
+
+ for (x = SCM_INUM (sub_start); x < upper; ++x, ++p)
+ if (*p == ch)
+ return x;
+ }
else
- SCM_ASSERT ( SCM_INUMP (sub_end)
- && (SCM_INUM (sub_start) <= SCM_INUM (sub_end))
- && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)),
- sub_end, pos4, why);
-
- upper_bound = SCM_INUM (sub_end);
- lower_bound = SCM_INUM (sub_start);
- p = upper_bound - 1 + (unsigned char *)SCM_ROCHARS (*str);
- ch = SCM_ICHR (chr);
- for (x = upper_bound - 1; x >= lower_bound; --x, --p)
- if (*p == ch)
- return x;
+ {
+ p = upper - 1 + (unsigned char *)SCM_ROCHARS (*str);
+ ch = SCM_ICHR (chr);
+ for (x = upper - 1; x >= lower; --x, --p)
+ if (*p == ch)
+ return x;
+ }
return -1;
}
-
SCM_PROC(s_string_index, "string-index", 2, 2, 0, scm_string_index);
-#ifdef __STDC__
-SCM
-scm_string_index (SCM str, SCM chr, SCM frm, SCM to)
-#else
+
SCM
scm_string_index (str, chr, frm, to)
SCM str;
SCM chr;
SCM frm;
SCM to;
-#endif
{
int pos;
@@ -148,24 +106,20 @@ scm_string_index (str, chr, frm, to)
frm = SCM_BOOL_F;
if (to == SCM_UNDEFINED)
to = SCM_BOOL_F;
- pos = scm_i_index (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index);
+ pos = scm_i_index (&str, chr, 1, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index);
return (pos < 0
? SCM_BOOL_F
: SCM_MAKINUM (pos));
}
SCM_PROC(s_string_rindex, "string-rindex", 2, 2, 0, scm_string_rindex);
-#ifdef __STDC__
-SCM
-scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to)
-#else
+
SCM
scm_string_rindex (str, chr, frm, to)
SCM str;
SCM chr;
SCM frm;
SCM to;
-#endif
{
int pos;
@@ -173,7 +127,7 @@ scm_string_rindex (str, chr, frm, to)
frm = SCM_BOOL_F;
if (to == SCM_UNDEFINED)
to = SCM_BOOL_F;
- pos = scm_i_rindex (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index);
+ pos = scm_i_index (&str, chr, -1, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index);
return (pos < 0
? SCM_BOOL_F
: SCM_MAKINUM (pos));
@@ -185,20 +139,17 @@ scm_string_rindex (str, chr, frm, to)
SCM_PROC(s_substring_move_left_x, "substring-move-left!", 2, 0, 1, scm_substring_move_left_x);
-#ifdef __STDC__
-SCM
-scm_substring_move_left_x (SCM str1, SCM start1, SCM args)
-#else
+
SCM
scm_substring_move_left_x (str1, start1, args)
SCM str1;
SCM start1;
SCM args;
-#endif
{
SCM end1, str2, start2;
long i, j, e;
- SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_left_x);
+ SCM_ASSERT (3==scm_ilength (args), scm_makfrom0str (s_substring_move_left_x),
+ SCM_WNA, NULL);
end1 = SCM_CAR (args); args = SCM_CDR (args);
str2 = SCM_CAR (args); args = SCM_CDR (args);
start2 = SCM_CAR (args);
@@ -218,20 +169,17 @@ scm_substring_move_left_x (str1, start1, args)
SCM_PROC(s_substring_move_right_x, "substring-move-right!", 2, 0, 1, scm_substring_move_right_x);
-#ifdef __STDC__
-SCM
-scm_substring_move_right_x (SCM str1, SCM start1, SCM args)
-#else
+
SCM
scm_substring_move_right_x (str1, start1, args)
SCM str1;
SCM start1;
SCM args;
-#endif
{
SCM end1, str2, start2;
long i, j, e;
- SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_right_x);
+ SCM_ASSERT (3==scm_ilength (args),
+ scm_makfrom0str (s_substring_move_right_x), SCM_WNA, NULL);
end1 = SCM_CAR (args); args = SCM_CDR (args);
str2 = SCM_CAR (args); args = SCM_CDR (args);
start2 = SCM_CAR (args);
@@ -251,21 +199,18 @@ scm_substring_move_right_x (str1, start1, args)
SCM_PROC(s_substring_fill_x, "substring-fill!", 2, 0, 1, scm_substring_fill_x);
-#ifdef __STDC__
-SCM
-scm_substring_fill_x (SCM str, SCM start, SCM args)
-#else
+
SCM
scm_substring_fill_x (str, start, args)
SCM str;
SCM start;
SCM args;
-#endif
{
SCM end, fill;
long i, e;
char c;
- SCM_ASSERT (2==scm_ilength (args), args, SCM_WNA, s_substring_fill_x);
+ SCM_ASSERT (2==scm_ilength (args), scm_makfrom0str (s_substring_fill_x),
+ SCM_WNA, NULL);
end = SCM_CAR (args); args = SCM_CDR (args);
fill = SCM_CAR (args);
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x);
@@ -281,14 +226,10 @@ scm_substring_fill_x (str, start, args)
SCM_PROC(s_string_null_p, "string-null?", 1, 0, 0, scm_string_null_p);
-#ifdef __STDC__
-SCM
-scm_string_null_p (SCM str)
-#else
+
SCM
scm_string_null_p (str)
SCM str;
-#endif
{
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_null_p);
return (SCM_ROLENGTH (str)
@@ -298,14 +239,10 @@ scm_string_null_p (str)
SCM_PROC(s_string_to_list, "string->list", 1, 0, 0, scm_string_to_list);
-#ifdef __STDC__
-SCM
-scm_string_to_list (SCM str)
-#else
+
SCM
scm_string_to_list (str)
SCM str;
-#endif
{
long i;
SCM res = SCM_EOL;
@@ -319,30 +256,24 @@ scm_string_to_list (str)
SCM_PROC(s_string_copy, "string-copy", 1, 0, 0, scm_string_copy);
-#ifdef __STDC__
-SCM
-scm_string_copy (SCM str)
-#else
+
SCM
scm_string_copy (str)
SCM str;
-#endif
{
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_copy);
- return scm_makfromstr (SCM_CHARS (str), (scm_sizet)SCM_LENGTH (str), 0);
+ /* doesn't handle multibyte strings. */
+ SCM_ASSERT (SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP (str)),
+ str, SCM_ARG1, s_string_copy);
+ return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0);
}
SCM_PROC(s_string_fill_x, "string-fill!", 2, 0, 0, scm_string_fill_x);
-#ifdef __STDC__
-SCM
-scm_string_fill_x (SCM str, SCM chr)
-#else
+
SCM
scm_string_fill_x (str, chr)
SCM str;
SCM chr;
-#endif
{
register char *dst, c;
register long k;
@@ -354,14 +285,57 @@ scm_string_fill_x (str, chr)
return SCM_UNSPECIFIED;
}
+SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x);
+
+SCM
+scm_string_upcase_x (v)
+ SCM v;
+{
+ register long k;
+ register unsigned char *cs;
+ SCM_ASRTGO (SCM_NIMP (v), badarg1);
+ k = SCM_LENGTH (v);
+ switch SCM_TYP7
+ (v)
+ {
+ case scm_tc7_string:
+ cs = SCM_UCHARS (v);
+ while (k--)
+ cs[k] = scm_upcase(cs[k]);
+ break;
+ default:
+ badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x);
+ }
+ return v;
+}
+
+SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x);
+
+SCM
+scm_string_downcase_x (v)
+ SCM v;
+{
+ register long k;
+ register unsigned char *cs;
+ SCM_ASRTGO (SCM_NIMP (v), badarg1);
+ k = SCM_LENGTH (v);
+ switch SCM_TYP7
+ (v)
+ {
+ case scm_tc7_string:
+ cs = SCM_UCHARS (v);
+ while (k--)
+ cs[k] = scm_downcase(cs[k]);
+ break;
+ default:
+ badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x);
+ }
+ return v;
+}
+
-#ifdef __STDC__
-void
-scm_init_strop (void)
-#else
void
scm_init_strop ()
-#endif
{
#include "strop.x"
}
diff --git a/libguile/strop.h b/libguile/strop.h
index d2b9a9c00..a91812df2 100644
--- a/libguile/strop.h
+++ b/libguile/strop.h
@@ -2,7 +2,7 @@
#ifndef STROPH
#define STROPH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,46 +44,22 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern int scm_i_index (SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why);
-extern int scm_i_rindex (SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why);
-extern SCM scm_string_index (SCM str, SCM chr, SCM frm, SCM to);
-extern SCM scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to);
-extern SCM scm_substring_move_left_x (SCM str1, SCM start1, SCM args);
-extern SCM scm_substring_move_right_x (SCM str1, SCM start1, SCM args);
-extern SCM scm_substring_fill_x (SCM str, SCM start, SCM args);
-extern SCM scm_string_null_p (SCM str);
-extern SCM scm_string_to_list (SCM str);
-extern SCM scm_string_copy (SCM str);
-extern SCM scm_string_fill_x (SCM str, SCM chr);
-extern void scm_init_strop (void);
-
-#else /* STDC */
-extern int scm_i_index ();
-extern int scm_i_rindex ();
-extern SCM scm_string_index ();
-extern SCM scm_string_rindex ();
-extern SCM scm_substring_move_left_x ();
-extern SCM scm_substring_move_right_x ();
-extern SCM scm_substring_fill_x ();
-extern SCM scm_string_null_p ();
-extern SCM scm_string_to_list ();
-extern SCM scm_string_copy ();
-extern SCM scm_string_fill_x ();
-extern void scm_init_strop ();
-
-#endif /* STDC */
-
-
-
-
-
-
-
+extern SCM scm_string_index SCM_P ((SCM str, SCM chr, SCM frm, SCM to));
+extern SCM scm_string_rindex SCM_P ((SCM str, SCM chr, SCM frm, SCM to));
+extern SCM scm_substring_move_left_x SCM_P ((SCM str1, SCM start1, SCM args));
+extern SCM scm_substring_move_right_x SCM_P ((SCM str1, SCM start1, SCM args));
+extern SCM scm_substring_fill_x SCM_P ((SCM str, SCM start, SCM args));
+extern SCM scm_string_null_p SCM_P ((SCM str));
+extern SCM scm_string_to_list SCM_P ((SCM str));
+extern SCM scm_string_copy SCM_P ((SCM str));
+extern SCM scm_string_fill_x SCM_P ((SCM str, SCM chr));
+extern void scm_init_strop SCM_P ((void));
+extern SCM scm_string_upcase_x SCM_P ((SCM v));
+extern SCM scm_string_downcase_x SCM_P ((SCM v));
#endif /* STROPH */
diff --git a/libguile/strorder.c b/libguile/strorder.c
index 5e1a15a26..a4fe03daa 100644
--- a/libguile/strorder.c
+++ b/libguile/strorder.c
@@ -42,22 +42,20 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "strorder.h"
SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p);
-#ifdef __STDC__
-SCM
-scm_string_equal_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_equal_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
register scm_sizet i;
- register char *c1, *c2;
+ register unsigned char *c1, *c2;
SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_equal_p);
SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_equal_p);
@@ -66,8 +64,8 @@ scm_string_equal_p (s1, s2)
{
return SCM_BOOL_F;
}
- c1 = SCM_ROCHARS (s1);
- c2 = SCM_ROCHARS (s2);
+ c1 = SCM_ROUCHARS (s1);
+ c2 = SCM_ROUCHARS (s2);
while (0 != i--)
if (*c1++ != *c2++)
return SCM_BOOL_F;
@@ -75,15 +73,11 @@ scm_string_equal_p (s1, s2)
}
SCM_PROC1 (s_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, scm_string_ci_equal_p);
-#ifdef __STDC__
-SCM
-scm_string_ci_equal_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_ci_equal_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
register scm_sizet i;
register unsigned char *c1, *c2;
@@ -103,15 +97,11 @@ scm_string_ci_equal_p (s1, s2)
}
SCM_PROC1 (s_string_less_p, "string<?", scm_tc7_rpsubr, scm_string_less_p);
-#ifdef __STDC__
-SCM
-scm_string_less_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_less_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
register scm_sizet i, len, s2len;
register unsigned char *c1, *c2;
@@ -140,57 +130,41 @@ scm_string_less_p (s1, s2)
}
SCM_PROC1 (s_string_leq_p, "string<=?", scm_tc7_rpsubr, scm_string_leq_p);
-#ifdef __STDC__
-SCM
-scm_string_leq_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_leq_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
return SCM_BOOL_NOT (scm_string_less_p (s2, s1));
}
SCM_PROC1 (s_string_gr_p, "string>?", scm_tc7_rpsubr, scm_string_gr_p);
-#ifdef __STDC__
-SCM
-scm_string_gr_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_gr_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
return scm_string_less_p (s2, s1);
}
SCM_PROC1 (s_string_geq_p, "string>=?", scm_tc7_rpsubr, scm_string_geq_p);
-#ifdef __STDC__
-SCM
-scm_string_geq_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_geq_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
return SCM_BOOL_NOT (scm_string_less_p (s1, s2));
}
SCM_PROC1 (s_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr, scm_string_ci_less_p);
-#ifdef __STDC__
-SCM
-scm_string_ci_less_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_ci_less_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
register scm_sizet i, len, s2len;
register unsigned char *c1, *c2;
@@ -211,55 +185,39 @@ scm_string_ci_less_p (s1, s2)
}
SCM_PROC1 (s_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, scm_string_ci_leq_p);
-#ifdef __STDC__
-SCM
-scm_string_ci_leq_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_ci_leq_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
return SCM_BOOL_NOT (scm_string_ci_less_p (s2, s1));
}
SCM_PROC1 (s_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, scm_string_ci_gr_p);
-#ifdef __STDC__
-SCM
-scm_string_ci_gr_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_ci_gr_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
return scm_string_ci_less_p (s2, s1);
}
SCM_PROC1 (s_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, scm_string_ci_geq_p);
-#ifdef __STDC__
-SCM
-scm_string_ci_geq_p (SCM s1, SCM s2)
-#else
+
SCM
scm_string_ci_geq_p (s1, s2)
SCM s1;
SCM s2;
-#endif
{
return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2));
}
-#ifdef __STDC__
-void
-scm_init_strorder (void)
-#else
+
void
scm_init_strorder ()
-#endif
{
#include "strorder.x"
}
diff --git a/libguile/strorder.h b/libguile/strorder.h
index ebc4a8de8..2263a1c7f 100644
--- a/libguile/strorder.h
+++ b/libguile/strorder.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -52,34 +52,17 @@
-#ifdef __STDC__
-extern SCM scm_string_equal_p (SCM s1, SCM s2);
-extern SCM scm_string_ci_equal_p (SCM s1, SCM s2);
-extern SCM scm_string_less_p (SCM s1, SCM s2);
-extern SCM scm_string_leq_p (SCM s1, SCM s2);
-extern SCM scm_string_gr_p (SCM s1, SCM s2);
-extern SCM scm_string_geq_p (SCM s1, SCM s2);
-extern SCM scm_string_ci_less_p (SCM s1, SCM s2);
-extern SCM scm_string_ci_leq_p (SCM s1, SCM s2);
-extern SCM scm_string_ci_gr_p (SCM s1, SCM s2);
-extern SCM scm_string_ci_geq_p (SCM s1, SCM s2);
-extern void scm_init_strorder (void);
-
-#else /* STDC */
-extern SCM scm_string_equal_p ();
-extern SCM scm_string_ci_equal_p ();
-extern SCM scm_string_less_p ();
-extern SCM scm_string_leq_p ();
-extern SCM scm_string_gr_p ();
-extern SCM scm_string_geq_p ();
-extern SCM scm_string_ci_less_p ();
-extern SCM scm_string_ci_leq_p ();
-extern SCM scm_string_ci_gr_p ();
-extern SCM scm_string_ci_geq_p ();
-extern void scm_init_strorder ();
-
-#endif /* STDC */
-
+extern SCM scm_string_equal_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_ci_equal_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_less_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_leq_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_gr_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_geq_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_ci_less_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_ci_leq_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_ci_gr_p SCM_P ((SCM s1, SCM s2));
+extern SCM scm_string_ci_geq_p SCM_P ((SCM s1, SCM s2));
+extern void scm_init_strorder SCM_P ((void));
#endif /* STRORDERH */
diff --git a/libguile/strports.c b/libguile/strports.c
index 1ba808a51..34485f0b3 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -42,6 +42,15 @@
#include <stdio.h>
#include "_scm.h"
+#include "unif.h"
+#include "eval.h"
+#include "read.h"
+
+#include "strports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -49,30 +58,26 @@
*
*/
-#ifdef __STDC__
-static int
-prinstpt (SCM exp, SCM port, int writing)
-#else
+
+static int prinstpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinstpt (exp, port, writing)
+prinstpt (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_prinport (exp, port, "string");
return !0;
}
-#ifdef __STDC__
-static int
-stputc (int c, SCM p)
-#else
+
+static int stputc SCM_P ((int c, SCM p));
+
static int
stputc (c, p)
int c;
SCM p;
-#endif
{
scm_sizet ind = SCM_INUM (SCM_CAR (p));
SCM_DEFER_INTS;
@@ -80,21 +85,19 @@ stputc (c, p)
scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1)));
SCM_ALLOW_INTS;
SCM_CHARS (SCM_CDR (p))[ind] = c;
- SCM_CAR (p) = SCM_MAKINUM (ind + 1);
+ SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
return c;
}
-#ifdef __STDC__
-static scm_sizet
-stwrite (char *str, scm_sizet siz, scm_sizet num, SCM p)
-#else
+
+static scm_sizet stwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p));
+
static scm_sizet
stwrite (str, siz, num, p)
char *str;
scm_sizet siz;
scm_sizet num;
SCM p;
-#endif
{
scm_sizet ind = SCM_INUM (SCM_CAR (p));
scm_sizet len = siz * num;
@@ -106,51 +109,43 @@ stwrite (str, siz, num, p)
dst = &(SCM_CHARS (SCM_CDR (p))[ind]);
while (len--)
dst[len] = str[len];
- SCM_CAR (p) = SCM_MAKINUM (ind + siz * num);
+ SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num));
return num;
}
-#ifdef __STDC__
-static int
-stputs (char *s, SCM p)
-#else
+
+static int stputs SCM_P ((char *s, SCM p));
+
static int
stputs (s, p)
char *s;
SCM p;
-#endif
{
stwrite (s, 1, strlen (s), p);
return 0;
}
-#ifdef __STDC__
-static int
-stgetc (SCM p)
-#else
+
+static int stgetc SCM_P ((SCM p));
+
static int
stgetc (p)
SCM p;
-#endif
{
scm_sizet ind = SCM_INUM (SCM_CAR (p));
if (ind >= SCM_ROLENGTH (SCM_CDR (p)))
return EOF;
- SCM_CAR (p) = SCM_MAKINUM (ind + 1);
+ SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
return SCM_ROUCHARS (SCM_CDR (p))[ind];
}
-#ifdef __STDC__
-SCM
-scm_mkstrport (SCM pos, SCM str, long modes, char * caller)
-#else
+
SCM
scm_mkstrport (pos, str, modes, caller)
SCM pos;
SCM str;
long modes;
char * caller;
-#endif
{
SCM z;
SCM stream;
@@ -162,7 +157,7 @@ scm_mkstrport (pos, str, modes, caller)
SCM_NEWCELL (z);
SCM_DEFER_INTS;
pt = scm_add_to_port_table (z);
- SCM_CAR (z) = scm_tc16_strport | modes;
+ SCM_SETCAR (z, scm_tc16_strport | modes);
SCM_SETPTAB_ENTRY (z, pt);
SCM_SETSTREAM (z, stream);
SCM_ALLOW_INTS;
@@ -170,14 +165,10 @@ scm_mkstrport (pos, str, modes, caller)
}
SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string);
-#ifdef __STDC__
-SCM
-scm_call_with_output_string (SCM proc)
-#else
+
SCM
scm_call_with_output_string (proc)
SCM proc;
-#endif
{
SCM p;
p = scm_mkstrport(SCM_INUM0, scm_make_string(SCM_MAKINUM(30), SCM_UNDEFINED),
@@ -200,21 +191,17 @@ scm_call_with_output_string (proc)
/* Return a Scheme string obtained by printing a given object.
*/
-#ifdef __STDC__
-SCM
-scm_strprint_obj (SCM obj)
-#else
+
SCM
scm_strprint_obj (obj)
SCM obj;
-#endif
{
SCM str;
SCM port;
str = scm_makstr (64, 0);
port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj");
- scm_iprin1 (obj, port, 1);
+ scm_prin1 (obj, port, 1);
{
SCM answer;
SCM_DEFER_INTS;
@@ -230,28 +217,64 @@ scm_strprint_obj (obj)
SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string);
-#ifdef __STDC__
-SCM
-scm_call_with_input_string (SCM str, SCM proc)
-#else
+
SCM
scm_call_with_input_string (str, proc)
SCM str;
SCM proc;
-#endif
{
SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string);
return scm_apply (proc, p, scm_listofnull);
}
-#ifdef __STDC__
-static int
-noop0 (FILE *stream)
-#else
+
+
+/* Given a null-terminated string EXPR containing a Scheme expression
+ read it, and return it as an SCM value. */
+SCM
+scm_read_0str (expr)
+ char *expr;
+{
+ SCM port = scm_mkstrport (SCM_MAKINUM (0),
+ scm_makfrom0str (expr),
+ SCM_OPN | SCM_RDNG,
+ "scm_eval_0str");
+ SCM form;
+
+ /* Read expressions from that port; ignore the values. */
+ form = scm_read (port);
+
+ scm_close_port (port);
+ return form;
+}
+
+/* Given a null-terminated string EXPR containing Scheme program text,
+ evaluate it, and return the result of the last expression evaluated. */
+SCM
+scm_eval_0str (expr)
+ char *expr;
+{
+ SCM port = scm_mkstrport (SCM_MAKINUM (0),
+ scm_makfrom0str (expr),
+ SCM_OPN | SCM_RDNG,
+ "scm_eval_0str");
+ SCM form;
+ SCM ans = SCM_EOL;
+
+ /* Read expressions from that port; ignore the values. */
+ while ((form = scm_read (port)) != SCM_EOF_VAL)
+ ans = scm_eval_x (form);
+
+ scm_close_port (port);
+ return ans;
+}
+
+
+static int noop0 SCM_P ((SCM stream));
+
static int
noop0 (stream)
- FILE *stream;
-#endif
+ SCM stream;
{
return 0;
}
@@ -272,13 +295,9 @@ scm_ptobfuns scm_stptob =
};
-#ifdef __STDC__
-void
-scm_init_strports (void)
-#else
+
void
scm_init_strports ()
-#endif
{
#include "strports.x"
}
diff --git a/libguile/strports.h b/libguile/strports.h
index 2eb01961e..fc0a1ed9f 100644
--- a/libguile/strports.h
+++ b/libguile/strports.h
@@ -44,32 +44,18 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
extern scm_ptobfuns scm_stptob;
-#ifdef __STDC__
-extern SCM scm_mkstrport (SCM pos, SCM str, long modes, char * caller);
-extern SCM scm_call_with_output_string (SCM proc);
-extern SCM scm_strprint_obj (SCM obj);
-extern SCM scm_call_with_input_string (SCM str, SCM proc);
-extern void scm_init_strports (void);
-
-#else /* STDC */
-extern SCM scm_mkstrport ();
-extern SCM scm_call_with_output_string ();
-extern SCM scm_strprint_obj ();
-extern SCM scm_call_with_input_string ();
-extern void scm_init_strports ();
-
-#endif /* STDC */
-
-
-
-
-
-
+extern SCM scm_mkstrport SCM_P ((SCM pos, SCM str, long modes, char * caller));
+extern SCM scm_call_with_output_string SCM_P ((SCM proc));
+extern SCM scm_strprint_obj SCM_P ((SCM obj));
+extern SCM scm_call_with_input_string SCM_P ((SCM str, SCM proc));
+extern SCM scm_read_0str SCM_P ((char *expr));
+extern SCM scm_eval_0str SCM_P ((char *expr));
+extern void scm_init_strports SCM_P ((void));
#endif /* STRPORTSH */
diff --git a/libguile/struct.c b/libguile/struct.c
index 265c7d4fd..51f934e07 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -42,6 +42,13 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+
+#include "struct.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -50,14 +57,10 @@ static int struct_num = 0;
SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
-#ifdef __STDC__
-SCM
-scm_make_struct_layout (SCM fields)
-#else
+
SCM
scm_make_struct_layout (fields)
SCM fields;
-#endif
{
SCM new_sym;
SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
@@ -91,12 +94,22 @@ scm_make_struct_layout (fields)
switch (field_desc[x + 1])
{
case 'w':
- SCM_ASSERT ((field_desc[x] != 's'), SCM_MAKICHR (field_desc[x + 1]),
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
"self fields not writable", s_struct_make_layout);
case 'r':
case 'o':
break;
+ case 'R':
+ case 'W':
+ case 'O':
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
+ "self fields not allowed in tail array",
+ s_struct_make_layout);
+ SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
+ "tail array field must be last field in layout",
+ s_struct_make_layout);
+ break;
default:
SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
}
@@ -117,36 +130,50 @@ scm_make_struct_layout (fields)
-#ifdef __STDC__
-static void
-init_struct (SCM handle, SCM tail_elts, SCM inits)
-#else
+
+static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits));
+
static void
init_struct (handle, tail_elts, inits)
SCM handle;
- SCM tail_elts;
+ int tail_elts;
SCM inits;
-#endif
{
SCM layout;
SCM * data;
unsigned char * fields_desc;
+ unsigned char prot = 0;
int n_fields;
SCM * mem;
-
+ int tailp = 0;
+
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
- fields_desc = (unsigned char *)SCM_CHARS (layout);
+ fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
n_fields = SCM_LENGTH (layout) / 2;
mem = SCM_STRUCT_DATA (handle);
while (n_fields)
{
+ if (!tailp)
+ {
+ fields_desc += 2;
+ prot = fields_desc[1];
+ if (SCM_LAYOUT_TAILP (prot))
+ {
+ tailp = 1;
+ prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
+ *mem++ = tail_elts;
+ n_fields += tail_elts - 1;
+ if (n_fields == 0)
+ break;
+ }
+ }
+
switch (*fields_desc)
{
#if 0
case 'i':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = 0;
else
{
@@ -157,8 +184,7 @@ init_struct (handle, tail_elts, inits)
#endif
case 'u':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = 0;
else
{
@@ -168,8 +194,7 @@ init_struct (handle, tail_elts, inits)
break;
case 'p':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || (inits == SCM_EOL))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = SCM_EOL;
else
{
@@ -181,8 +206,7 @@ init_struct (handle, tail_elts, inits)
#if 0
case 'd':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*((double *)mem) = 0.0;
else
{
@@ -198,7 +222,6 @@ init_struct (handle, tail_elts, inits)
break;
}
- fields_desc += 2;
n_fields--;
mem++;
}
@@ -206,14 +229,10 @@ init_struct (handle, tail_elts, inits)
SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
-#ifdef __STDC__
-SCM
-scm_struct_p (SCM x)
-#else
+
SCM
scm_struct_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && SCM_STRUCTP (x))
? SCM_BOOL_T
@@ -221,14 +240,10 @@ scm_struct_p (x)
}
SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
-#ifdef __STDC__
-SCM
-scm_struct_vtable_p (SCM x)
-#else
+
SCM
scm_struct_vtable_p (x)
SCM x;
-#endif
{
SCM layout;
SCM * mem;
@@ -261,17 +276,72 @@ scm_struct_vtable_p (x)
: SCM_BOOL_F);
}
+
+/* All struct data must be allocated at an address whose bottom three
+ bits are zero. This is because the tag for a struct lives in the
+ bottom three bits of the struct's car, and the upper bits point to
+ the data of its vtable, which is a struct itself. Thus, if the
+ address of that data doesn't end in three zeros, tagging it will
+ destroy the pointer.
+
+ This function allocates a block of memory, and returns a pointer at
+ least scm_struct_n_extra_words words into the block. Furthermore,
+ it guarantees that that pointer's least three significant bits are
+ all zero.
+
+ The argument n_words should be the number of words that should
+ appear after the returned address. (That is, it shouldn't include
+ scm_struct_n_extra_words.)
+
+ This function initializes the following fields of the struct:
+
+ scm_struct_i_ptr --- the actual stort of the block of memory; the
+ address you should pass to 'free' to dispose of the block.
+ This field allows us to both guarantee that the returned
+ address is divisible by eight, and allow the GC to free the
+ block.
+
+ scm_struct_i_n_words --- the number of words allocated to the
+ block, including the extra fields. This is used by the GC.
+
+ scm_struct_i_tag --- a unique tag assigned to this struct,
+ allocated according to struct_num.
+
+ Ugh. */
+
+
+static SCM *alloc_struct SCM_P ((int n_words, char *who));
+
+static SCM *
+alloc_struct (n_words, who)
+ int n_words;
+ char *who;
+{
+ int size = sizeof (SCM) * (n_words + scm_struct_n_extra_words) + 7;
+ SCM *block = (SCM *) scm_must_malloc (size, who);
+
+ /* Adjust the pointer to hide the extra words. */
+ SCM *p = block + scm_struct_n_extra_words;
+
+ /* Adjust it even further so it's aligned on an eight-byte boundary. */
+ p = (SCM *) (((SCM) p + 7) & ~7);
+
+ /* Initialize a few fields as described above. */
+ p[scm_struct_i_ptr] = (SCM) block;
+ p[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words + n_words);
+ p[scm_struct_i_tag] = struct_num++;
+
+ return p;
+}
+
+
SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
-#ifdef __STDC__
-SCM
-scm_make_struct (SCM vtable, SCM tail_array_size, SCM init)
-#else
+
SCM
scm_make_struct (vtable, tail_array_size, init)
SCM vtable;
SCM tail_array_size;
SCM init;
-#endif
{
SCM layout;
int basic_size;
@@ -281,19 +351,17 @@ scm_make_struct (vtable, tail_array_size, init)
SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
vtable, SCM_ARG1, s_make_struct);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, s_make_struct);
+ SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
+ s_make_struct);
layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
basic_size = SCM_LENGTH (layout) / 2;
tail_elts = SCM_INUM (tail_array_size);
SCM_NEWCELL (handle);
SCM_DEFER_INTS;
- data = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure");
- *data = (SCM)(2 + basic_size + tail_elts);
- data[1] = struct_num++;
- data += 2;
+ data = alloc_struct (basic_size + tail_elts, "make-struct");
SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1);
+ SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
init_struct (handle, tail_elts, init);
SCM_ALLOW_INTS;
return handle;
@@ -302,16 +370,12 @@ scm_make_struct (vtable, tail_array_size, init)
SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
-#ifdef __STDC__
-SCM
-scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init)
-#else
+
SCM
scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM extra_fields;
SCM tail_array_size;
SCM init;
-#endif
{
SCM fields;
SCM layout;
@@ -322,8 +386,8 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
extra_fields, SCM_ARG1, s_make_vtable_vtable);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG3, s_make_vtable_vtable);
-
+ SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
+ s_make_vtable_vtable);
fields = scm_string_append (scm_listify (required_vtable_fields,
extra_fields,
@@ -333,12 +397,9 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
tail_elts = SCM_INUM (tail_array_size);
SCM_NEWCELL (handle);
SCM_DEFER_INTS;
- data = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure");
- *data = (SCM)(2 + basic_size + tail_elts);
- data[1] = struct_num++;
- data += 2;
+ data = alloc_struct (basic_size + tail_elts, "make-vtable-vtable");
SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)data) + 1);
+ SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
SCM_STRUCT_LAYOUT (handle) = layout;
init_struct (handle, tail_elts, scm_cons (layout, init));
SCM_ALLOW_INTS;
@@ -349,17 +410,13 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
-#ifdef __STDC__
-SCM
-scm_struct_ref (SCM handle, SCM pos)
-#else
+
SCM
scm_struct_ref (handle, pos)
SCM handle;
SCM pos;
-#endif
{
- SCM answer;
+ SCM answer = SCM_UNDEFINED;
SCM * data;
SCM layout;
int p;
@@ -377,22 +434,31 @@ scm_struct_ref (handle, pos)
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = SCM_LENGTH (layout) / 2;
-
- SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
+ n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
+
+ SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
- field_type = fields_desc[p * 2];
- {
- unsigned char ref;
- ref = fields_desc [p * 2 + 1];
- if ((ref != 'r') && (ref != 'w'))
- {
- if ((ref == 'R') || (ref == 'W'))
- field_type = 'u';
- else
- SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
- }
- }
+ if (p * 2 < SCM_LENGTH (layout))
+ {
+ unsigned char ref;
+ field_type = fields_desc[p * 2];
+ ref = fields_desc[p * 2 + 1];
+ if ((ref != 'r') && (ref != 'w'))
+ {
+ if ((ref == 'R') || (ref == 'W'))
+ field_type = 'u';
+ else
+ SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ }
+ }
+ else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
+ field_type = fields_desc[SCM_LENGTH (layout) - 2];
+ else
+ {
+ SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ abort ();
+ }
+
switch (field_type)
{
case 'u':
@@ -425,16 +491,12 @@ scm_struct_ref (handle, pos)
SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
-#ifdef __STDC__
-SCM
-scm_struct_set_x (SCM handle, SCM pos, SCM val)
-#else
+
SCM
scm_struct_set_x (handle, pos, val)
SCM handle;
SCM pos;
SCM val;
-#endif
{
SCM * data;
SCM layout;
@@ -454,17 +516,26 @@ scm_struct_set_x (handle, pos, val)
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = SCM_LENGTH (layout) / 2;
+ n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
- SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
+ SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
- field_type = fields_desc[p * 2];
- {
- unsigned char set_x;
- set_x = fields_desc [p * 2 + 1];
- if (set_x != 'w')
- SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
- }
+ if (p * 2 < SCM_LENGTH (layout))
+ {
+ unsigned char set_x;
+ field_type = fields_desc[p * 2];
+ set_x = fields_desc [p * 2 + 1];
+ if (set_x != 'w')
+ SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
+ }
+ else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
+ field_type = fields_desc[SCM_LENGTH (layout) - 2];
+ else
+ {
+ SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
+ abort ();
+ }
+
switch (field_type)
{
case 'u':
@@ -499,14 +570,10 @@ scm_struct_set_x (handle, pos, val)
SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
-#ifdef __STDC__
-SCM
-scm_struct_vtable (SCM handle)
-#else
+
SCM
scm_struct_vtable (handle)
SCM handle;
-#endif
{
SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
SCM_ARG1, s_struct_vtable);
@@ -515,14 +582,10 @@ scm_struct_vtable (handle)
SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
-#ifdef __STDC__
-SCM
-scm_struct_vtable_tag (SCM handle)
-#else
+
SCM
scm_struct_vtable_tag (handle)
SCM handle;
-#endif
{
SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
handle, SCM_ARG1, s_struct_vtable_tag);
@@ -532,13 +595,9 @@ scm_struct_vtable_tag (handle)
-#ifdef __STDC__
-void
-scm_init_struct (void)
-#else
+
void
scm_init_struct ()
-#endif
{
required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
scm_permanent_object (required_vtable_fields);
diff --git a/libguile/struct.h b/libguile/struct.h
index b444e282b..e076a8aee 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -44,11 +44,15 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+/* Number of words with negative index */
+#define scm_struct_n_extra_words 3
+
/* These are how the initial words of a vtable are allocated. */
+#define scm_struct_i_ptr -3 /* start of block (see alloc_struct) */
#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */
#define scm_struct_i_tag -1 /* A unique tag for this type.. */
#define scm_struct_i_layout 0 /* A symbol describing the physical arrangement of this type. */
@@ -62,40 +66,21 @@
#define SCM_STRUCT_VTABLE_DATA(X) ((SCM *)(SCM_CAR(X) - 1))
#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_layout])
#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_vtable])
+/* Efficiency is important in the following macro, since it's used in GC */
+#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
-#ifdef __STDC__
-extern SCM scm_make_struct_layout (SCM fields);
-extern SCM scm_struct_p (SCM x);
-extern SCM scm_struct_vtable_p (SCM x);
-extern SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
-extern SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
-extern SCM scm_struct_ref (SCM handle, SCM pos);
-extern SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
-extern SCM scm_struct_vtable (SCM handle);
-extern SCM scm_struct_vtable_tag (SCM handle);
-extern void scm_init_struct (void);
-
-#else /* STDC */
-extern SCM scm_make_struct_layout ();
-extern SCM scm_struct_p ();
-extern SCM scm_struct_vtable_p ();
-extern SCM scm_make_struct ();
-extern SCM scm_make_vtable_vtable ();
-extern SCM scm_struct_ref ();
-extern SCM scm_struct_set_x ();
-extern SCM scm_struct_vtable ();
-extern SCM scm_struct_vtable_tag ();
-extern void scm_init_struct ();
-
-#endif /* STDC */
-
-
-
-
-
-
+extern SCM scm_make_struct_layout SCM_P ((SCM fields));
+extern SCM scm_struct_p SCM_P ((SCM x));
+extern SCM scm_struct_vtable_p SCM_P ((SCM x));
+extern SCM scm_make_struct SCM_P ((SCM vtable, SCM tail_array_size, SCM init));
+extern SCM scm_make_vtable_vtable SCM_P ((SCM extra_fields, SCM tail_array_size, SCM init));
+extern SCM scm_struct_ref SCM_P ((SCM handle, SCM pos));
+extern SCM scm_struct_set_x SCM_P ((SCM handle, SCM pos, SCM val));
+extern SCM scm_struct_vtable SCM_P ((SCM handle));
+extern SCM scm_struct_vtable_tag SCM_P ((SCM handle));
+extern void scm_init_struct SCM_P ((void));
#endif /* STRUCTH */
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 4a6dd6065..da00cd267 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -42,6 +42,18 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "eval.h"
+#include "variable.h"
+#include "alist.h"
+#include "mbstrings.h"
+#include "weaks.h"
+
+#include "symbols.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -56,23 +68,19 @@
/* {Symbols}
*/
-#ifdef __STDC__
-unsigned long
-scm_strhash (unsigned char *str, scm_sizet len, unsigned long n)
-#else
+
unsigned long
scm_strhash (str, len, n)
unsigned char *str;
scm_sizet len;
unsigned long n;
-#endif
{
if (len > 5)
{
scm_sizet i = 5;
unsigned long h = 264 % n;
while (i--)
- h = ((h << 8) + ((unsigned) (scm_downcase[str[h % len]]))) % n;
+ h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n;
return h;
}
else
@@ -80,7 +88,7 @@ scm_strhash (str, len, n)
scm_sizet i = len;
unsigned long h = 0;
while (i)
- h = ((h << 8) + ((unsigned) (scm_downcase[str[--i]]))) % n;
+ h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n;
return h;
}
}
@@ -91,16 +99,12 @@ int scm_symhash_dim = NUM_HASH_BUCKETS;
/* scm_sym2vcell
* looks up the symbol in the symhash table.
*/
-#ifdef __STDC__
-SCM
-scm_sym2vcell (SCM sym, SCM thunk, SCM definep)
-#else
+
SCM
scm_sym2vcell (sym, thunk, definep)
SCM sym;
SCM thunk;
SCM definep;
-#endif
{
if (SCM_NIMP(thunk))
{
@@ -136,13 +140,14 @@ scm_sym2vcell (sym, thunk, definep)
for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[scm_hash]);
SCM_NIMP (lsym);
- lsym = *(lsymp = &SCM_CDR (lsym)))
+ lsym = *(lsymp = SCM_CDRLOC (lsym)))
{
z = SCM_CAR (lsym);
if (SCM_CAR (z) == sym)
{
- if (definep)
+ if (SCM_NFALSEP (definep))
{
+ /* Move handle from scm_weak_symhash to scm_symhash. */
*lsymp = SCM_CDR (lsym);
SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[scm_hash]);
SCM_VELTS(scm_symhash)[scm_hash] = lsym;
@@ -157,17 +162,13 @@ scm_sym2vcell (sym, thunk, definep)
}
/* scm_sym2ovcell
- * looks up the symbol in an arbitrary obarray (defaulting to scm_symhash).
+ * looks up the symbol in an arbitrary obarray.
*/
-#ifdef __STDC__
-SCM
-scm_sym2ovcell_soft (SCM sym, SCM obarray)
-#else
+
SCM
scm_sym2ovcell_soft (sym, obarray)
SCM sym;
SCM obarray;
-#endif
{
SCM lsym, z;
scm_sizet scm_hash;
@@ -191,15 +192,11 @@ scm_sym2ovcell_soft (sym, obarray)
return SCM_BOOL_F;
}
-#ifdef __STDC__
-SCM
-scm_sym2ovcell (SCM sym, SCM obarray)
-#else
+
SCM
scm_sym2ovcell (sym, obarray)
SCM sym;
SCM obarray;
-#endif
{
SCM answer;
answer = scm_sym2ovcell_soft (sym, obarray);
@@ -209,17 +206,35 @@ scm_sym2ovcell (sym, obarray)
return SCM_UNSPECIFIED; /* not reached */
}
-#ifdef __STDC__
-SCM
-scm_intern_obarray_soft (char *name, scm_sizet len, SCM obarray, int softness)
-#else
+/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
+
+ OBARRAY should be a vector of lists, indexed by the name's hash
+ value, modulo OBARRAY's length. Each list has the form
+ ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
+ value associated with that symbol (in the current module? in the
+ system module?)
+
+ To "intern" a symbol means: if OBARRAY already contains a symbol by
+ that name, return its (SYMBOL . VALUE) pair; otherwise, create a
+ new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
+ appropriate list of the OBARRAY, and return the pair.
+
+ If softness is non-zero, don't create a symbol if it isn't already
+ in OBARRAY; instead, just return #f.
+
+ If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
+ return (SYMBOL . SCM_UNDEFINED).
+
+ If OBARRAY is scm_symhash, and that doesn't contain the symbol,
+ check scm_weak_symhash instead. */
+
+
SCM
scm_intern_obarray_soft (name, len, obarray, softness)
char *name;
scm_sizet len;
SCM obarray;
int softness;
-#endif
{
SCM lsym;
SCM z;
@@ -240,8 +255,12 @@ scm_intern_obarray_soft (name, len, obarray, softness)
scm_hash = scm_strhash (tmp, i, SCM_LENGTH(obarray));
+ /* softness == -1 used to mean that it was known that the symbol
+ wasn't already in the obarray. I don't think there are any
+ callers that use that case any more, but just in case...
+ -- JimB, Oct 1996 */
if (softness == -1)
- goto mustintern_symbol;
+ abort ();
retry_new_obarray:
for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
@@ -276,20 +295,20 @@ scm_intern_obarray_soft (name, len, obarray, softness)
return SCM_BOOL_F;
}
- mustintern_symbol:
lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS);
SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol);
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (lsym) = SCM_BOOL_F;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (lsym) = SCM_BOOL_F;
SCM_SYMBOL_HASH (lsym) = scm_hash;
+ SCM_SYMBOL_PROPS (lsym) = SCM_EOL;
if (obarray == SCM_BOOL_F)
{
SCM answer;
SCM_REALLOW_INTS;
SCM_NEWCELL (answer);
SCM_DEFER_INTS;
- SCM_CAR (answer) = lsym;
- SCM_CDR (answer) = SCM_UNDEFINED;
+ SCM_SETCAR (answer, lsym);
+ SCM_SETCDR (answer, SCM_UNDEFINED);
SCM_REALLOW_INTS;
return answer;
}
@@ -310,63 +329,44 @@ scm_intern_obarray_soft (name, len, obarray, softness)
}
}
-#ifdef __STDC__
-SCM
-scm_intern_obarray (char *name, scm_sizet len, SCM obarray)
-#else
+
SCM
scm_intern_obarray (name, len, obarray)
char *name;
scm_sizet len;
SCM obarray;
-#endif
{
return scm_intern_obarray_soft (name, len, obarray, 0);
}
-#ifdef __STDC__
-SCM
-scm_intern (char *name, scm_sizet len)
-#else
SCM
scm_intern (name, len)
char *name;
scm_sizet len;
-#endif
{
return scm_intern_obarray (name, len, scm_symhash);
}
-#ifdef __STDC__
-SCM
-scm_intern0 (char * name)
-#else
+
SCM
scm_intern0 (name)
char * name;
-#endif
{
return scm_intern (name, strlen (name));
}
-#ifdef __STDC__
-SCM
-scm_sysintern (char *name, SCM val)
-#else
+/* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
SCM
-scm_sysintern (name, val)
+scm_sysintern0_no_module_lookup (name)
char *name;
- SCM val;
-#endif
{
SCM easy_answer;
SCM_DEFER_INTS;
easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1);
if (SCM_NIMP (easy_answer))
{
- SCM_CDR (easy_answer) = val;
SCM_ALLOW_INTS;
return easy_answer;
}
@@ -379,7 +379,7 @@ scm_sysintern (name, val)
SCM_NEWCELL (lsym);
SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol);
SCM_SETCHARS (lsym, name);
- lsym = scm_cons (lsym, val);
+ lsym = scm_cons (lsym, SCM_UNDEFINED);
SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]);
SCM_ALLOW_INTS;
return lsym;
@@ -387,44 +387,86 @@ scm_sysintern (name, val)
}
-SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
-#ifdef __STDC__
+/* Is it safe to access SCM_TOP_LEVEL_LOOKUP_CLOSURE_VAR?
+ */
+int scm_can_use_top_level_lookup_closure_var;
+
+/* Intern the symbol named NAME in scm_symhash, and give it the value
+ VAL. NAME is null-terminated. Use the current top_level lookup
+ closure to give NAME its value.
+ */
SCM
-scm_symbol_p(SCM x)
-#else
+scm_sysintern (name, val)
+ char *name;
+ SCM val;
+{
+ SCM vcell = scm_sysintern0 (name);
+ SCM_SETCDR (vcell, val);
+ return vcell;
+}
+
+SCM
+scm_sysintern0 (name)
+ char *name;
+{
+ SCM lookup_proc;
+ if (scm_can_use_top_level_lookup_closure_var &&
+ SCM_NIMP (lookup_proc = SCM_CDR (scm_top_level_lookup_closure_var)))
+ {
+ SCM sym = SCM_CAR (scm_intern0 (name));
+ SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T);
+ if (vcell == SCM_BOOL_F)
+ scm_misc_error ("sysintern", "can't define variable", sym);
+ return vcell;
+ }
+ else
+ return scm_sysintern0_no_module_lookup (name);
+}
+
+/* Lookup the value of the symbol named by the nul-terminated string
+ NAME in the current module. */
+SCM
+scm_symbol_value0 (name)
+ char *name;
+{
+ /* This looks silly - we look up the symbol twice. But it is in
+ fact necessary given the current module system because the module
+ lookup closures are written in scheme which needs real symbols. */
+ SCM symbol = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 0);
+ SCM vcell = scm_sym2vcell (SCM_CAR (symbol),
+ SCM_CDR (scm_top_level_lookup_closure_var),
+ SCM_BOOL_F);
+ if (SCM_FALSEP (vcell))
+ return SCM_UNDEFINED;
+ return SCM_CDR (vcell);
+}
+
+SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
+
SCM
scm_symbol_p(x)
SCM x;
-#endif
{
- if SCM_IMP(x) return SCM_BOOL_F;
- return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
+ if SCM_IMP(x) return SCM_BOOL_F;
+ return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string);
-#ifdef __STDC__
-SCM
-scm_symbol_to_string(SCM s)
-#else
+
SCM
scm_symbol_to_string(s)
SCM s;
-#endif
{
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string);
- return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
+ SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string);
+ return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
}
SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol);
-#ifdef __STDC__
-SCM
-scm_string_to_symbol(SCM s)
-#else
+
SCM
scm_string_to_symbol(s)
SCM s;
-#endif
{
SCM vcell;
SCM answer;
@@ -435,33 +477,34 @@ scm_string_to_symbol(s)
if (SCM_TYP7 (answer) == scm_tc7_msymbol)
{
if (SCM_REGULAR_STRINGP (s))
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_F;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
else
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_T;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
}
return answer;
}
SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol);
-#ifdef __STDC__
-SCM
-scm_string_to_obarray_symbol(SCM o, SCM s, SCM softp)
-#else
+
SCM
scm_string_to_obarray_symbol(o, s, softp)
SCM o;
SCM s;
SCM softp;
-#endif
{
SCM vcell;
SCM answer;
int softness;
- SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2, s_string_to_obarray_symbol);
- SCM_ASSERT((o == SCM_BOOL_F) || (o == SCM_BOOL_T) || (SCM_NIMP(o) && SCM_VECTORP(o)),
- o, SCM_ARG1, s_string_to_obarray_symbol);
+ SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2,
+ s_string_to_obarray_symbol);
+ SCM_ASSERT((o == SCM_BOOL_F)
+ || (o == SCM_BOOL_T)
+ || (SCM_NIMP(o) && SCM_VECTORP(o)),
+ o,
+ SCM_ARG1,
+ s_string_to_obarray_symbol);
softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
/* iron out some screwy calling conventions */
@@ -470,113 +513,104 @@ scm_string_to_obarray_symbol(o, s, softp)
else if (o == SCM_BOOL_T)
o = SCM_BOOL_F;
- vcell = scm_intern_obarray_soft (SCM_ROCHARS(s), (scm_sizet)SCM_ROLENGTH(s), o, softness);
+ vcell = scm_intern_obarray_soft (SCM_ROCHARS(s),
+ (scm_sizet)SCM_ROLENGTH(s),
+ o,
+ softness);
if (vcell == SCM_BOOL_F)
return vcell;
answer = SCM_CAR (vcell);
if (SCM_TYP7 (s) == scm_tc7_msymbol)
{
if (SCM_REGULAR_STRINGP (s))
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_F;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
else
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_T;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
}
return answer;
}
SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol);
-#ifdef __STDC__
-SCM
-scm_intern_symbol(SCM o, SCM s)
-#else
+
SCM
scm_intern_symbol(o, s)
SCM o;
SCM s;
-#endif
{
- scm_sizet hval;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol);
- hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
- /* If the symbol is already interned, simply return. */
- SCM_REDEFER_INTS;
- {
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VELTS (o)[hval];
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (SCM_CAR (sym) == s)
- {
- SCM_REALLOW_INTS;
- return SCM_UNSPECIFIED;
- }
- }
- SCM_VELTS (o)[hval] =
- scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
- }
- SCM_REALLOW_INTS;
- return SCM_UNSPECIFIED;
+ scm_sizet hval;
+ SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol);
+ if (o == SCM_BOOL_F)
+ o = scm_symhash;
+ SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol);
+ hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
+ /* If the symbol is already interned, simply return. */
+ SCM_REDEFER_INTS;
+ {
+ SCM lsym;
+ SCM sym;
+ for (lsym = SCM_VELTS (o)[hval];
+ SCM_NIMP (lsym);
+ lsym = SCM_CDR (lsym))
+ {
+ sym = SCM_CAR (lsym);
+ if (SCM_CAR (sym) == s)
+ {
+ SCM_REALLOW_INTS;
+ return SCM_UNSPECIFIED;
+ }
+ }
+ SCM_VELTS (o)[hval] =
+ scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
+ }
+ SCM_REALLOW_INTS;
+ return SCM_UNSPECIFIED;
}
SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol);
-#ifdef __STDC__
-SCM
-scm_unintern_symbol(SCM o, SCM s)
-#else
+
SCM
scm_unintern_symbol(o, s)
SCM o;
SCM s;
-#endif
{
- scm_sizet hval;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol);
- hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
- SCM_DEFER_INTS;
- {
- SCM lsym_follow;
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
- SCM_NIMP (lsym);
- lsym_follow = lsym, lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (SCM_CAR (sym) == s)
- {
- /* Found the symbol to unintern. */
- if (lsym_follow == SCM_BOOL_F)
- SCM_VELTS(o)[hval] = lsym;
- else
- SCM_CDR(lsym_follow) = SCM_CDR(lsym);
- SCM_ALLOW_INTS;
- return SCM_BOOL_T;
- }
- }
- }
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ scm_sizet hval;
+ SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol);
+ if (o == SCM_BOOL_F)
+ o = scm_symhash;
+ SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol);
+ hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
+ SCM_DEFER_INTS;
+ {
+ SCM lsym_follow;
+ SCM lsym;
+ SCM sym;
+ for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
+ SCM_NIMP (lsym);
+ lsym_follow = lsym, lsym = SCM_CDR (lsym))
+ {
+ sym = SCM_CAR (lsym);
+ if (SCM_CAR (sym) == s)
+ {
+ /* Found the symbol to unintern. */
+ if (lsym_follow == SCM_BOOL_F)
+ SCM_VELTS(o)[hval] = lsym;
+ else
+ SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
+ SCM_ALLOW_INTS;
+ return SCM_BOOL_T;
+ }
+ }
+ }
+ SCM_ALLOW_INTS;
+ return SCM_BOOL_F;
}
SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding);
-#ifdef __STDC__
-SCM
-scm_symbol_binding (SCM o, SCM s)
-#else
+
SCM
scm_symbol_binding (o, s)
SCM o;
SCM s;
-#endif
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding);
@@ -589,15 +623,11 @@ scm_symbol_binding (o, s)
SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p);
-#ifdef __STDC__
-SCM
-scm_symbol_interned_p (SCM o, SCM s)
-#else
+
SCM
scm_symbol_interned_p (o, s)
SCM o;
SCM s;
-#endif
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p);
@@ -614,15 +644,11 @@ scm_symbol_interned_p (o, s)
SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p);
-#ifdef __STDC__
-SCM
-scm_symbol_bound_p (SCM o, SCM s)
-#else
+
SCM
scm_symbol_bound_p (o, s)
SCM o;
SCM s;
-#endif
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p);
@@ -638,16 +664,12 @@ scm_symbol_bound_p (o, s)
SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x);
-#ifdef __STDC__
-SCM
-scm_symbol_set_x (SCM o, SCM s, SCM v)
-#else
+
SCM
scm_symbol_set_x (o, s, v)
SCM o;
SCM s;
SCM v;
-#endif
{
SCM vcell;
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x);
@@ -655,7 +677,7 @@ scm_symbol_set_x (o, s, v)
o = scm_symhash;
SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x);
vcell = scm_sym2ovcell (s, o);
- SCM_CDR(vcell) = v;
+ SCM_SETCDR (vcell, v);
return SCM_UNSPECIFIED;
}
@@ -667,21 +689,22 @@ msymbolize (s)
string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
SCM_SETCHARS (s, SCM_CHARS (string));
SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (s) = SCM_BOOL_F;
- SCM_CDR (string) = SCM_EOL;
- SCM_CAR (string) = SCM_EOL;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F;
+ SCM_SETCDR (string, SCM_EOL);
+ SCM_SETCAR (string, SCM_EOL);
+ SCM_SYMBOL_PROPS (s) = SCM_EOL;
+ /* If it's a tc7_ssymbol, it comes from scm_symhash */
+ SCM_SYMBOL_HASH (s) = scm_strhash (SCM_UCHARS (s),
+ (scm_sizet) SCM_LENGTH (s),
+ SCM_LENGTH (scm_symhash));
}
SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref);
-#ifdef __STDC__
-SCM
-scm_symbol_fref (SCM s)
-#else
+
SCM
scm_symbol_fref (s)
SCM s;
-#endif
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref);
SCM_DEFER_INTS;
@@ -693,14 +716,10 @@ scm_symbol_fref (s)
SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref);
-#ifdef __STDC__
-SCM
-scm_symbol_pref (SCM s)
-#else
+
SCM
scm_symbol_pref (s)
SCM s;
-#endif
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref);
SCM_DEFER_INTS;
@@ -712,15 +731,11 @@ scm_symbol_pref (s)
SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x);
-#ifdef __STDC__
-SCM
-scm_symbol_fset_x (SCM s, SCM val)
-#else
+
SCM
scm_symbol_fset_x (s, val)
SCM s;
SCM val;
-#endif
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x);
SCM_DEFER_INTS;
@@ -733,15 +748,11 @@ scm_symbol_fset_x (s, val)
SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x);
-#ifdef __STDC__
-SCM
-scm_symbol_pset_x (SCM s, SCM val)
-#else
+
SCM
scm_symbol_pset_x (s, val)
SCM s;
SCM val;
-#endif
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x);
SCM_DEFER_INTS;
@@ -754,27 +765,74 @@ scm_symbol_pset_x (s, val)
SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash);
-#ifdef __STDC__
-SCM
-scm_symbol_hash (SCM s)
-#else
+
SCM
scm_symbol_hash (s)
SCM s;
-#endif
{
SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash);
+ if (SCM_TYP7(s) == scm_tc7_ssymbol)
+ msymbolize (s);
return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
}
-#ifdef __STDC__
-void
-scm_init_symbols (void)
-#else
+static void copy_and_prune_obarray SCM_P ((SCM from, SCM to));
+
+static void
+copy_and_prune_obarray (from, to)
+ SCM from;
+ SCM to;
+{
+ int i;
+ int length = SCM_LENGTH (from);
+ for (i = 0; i < length; ++i)
+ {
+ SCM head = SCM_VELTS (from)[i]; /* GC protection */
+ SCM ls = head;
+ SCM res = SCM_EOL;
+ SCM *lloc = &res;
+ while (SCM_NIMP (ls))
+ {
+ if (!SCM_UNBNDP (SCM_CDAR (ls)))
+ {
+ *lloc = scm_cons (SCM_CAR (ls), SCM_EOL);
+ lloc = SCM_CDRLOC (*lloc);
+ }
+ ls = SCM_CDR (ls);
+ }
+ SCM_VELTS (to)[i] = res;
+ }
+}
+
+
+SCM_PROC(s_builtin_bindings, "builtin-bindings", 0, 0, 0, scm_builtin_bindings);
+
+SCM
+scm_builtin_bindings ()
+{
+ int length = SCM_LENGTH (scm_symhash);
+ SCM obarray = scm_make_vector (SCM_MAKINUM (length), SCM_EOL, SCM_UNDEFINED);
+ copy_and_prune_obarray (scm_symhash, obarray);
+ return obarray;
+}
+
+
+SCM_PROC(s_builtin_weak_bindings, "builtin-weak-bindings", 0, 0, 0, scm_builtin_weak_bindings);
+
+SCM
+scm_builtin_weak_bindings ()
+{
+ int length = SCM_LENGTH (scm_weak_symhash);
+ SCM obarray = scm_make_doubly_weak_hash_table (SCM_MAKINUM (length));
+ copy_and_prune_obarray (scm_weak_symhash, obarray);
+ return obarray;
+}
+
+
+
void
scm_init_symbols ()
-#endif
{
#include "symbols.x"
}
diff --git a/libguile/symbols.h b/libguile/symbols.h
index b1486ce7a..d4808dc8b 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -2,7 +2,7 @@
#ifndef SYMBOLSH
#define SYMBOLSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,15 +44,40 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
extern int scm_symhash_dim;
+/* SCM_LENGTH(SYM) is the length of SYM's name in characters, and
+ SCM_CHARS(SYM) is the address of the first character of SYM's name.
+
+ Beyond that, there are two kinds of symbols: ssymbols and msymbols,
+ distinguished by the 'S' bit in the type.
+
+ Ssymbols are just uniquified strings. They have a length, chars,
+ and that's it. They use the scm_tc7_ssymbol tag (S bit clear).
+
+ Msymbols are symbols with extra slots. These slots hold a property
+ list and a function value (for Emacs Lisp compatibility), a hash
+ code, and a flag to indicate whether their name contains multibyte
+ characters. They use the scm_tc7_msymbol tag.
+
+ We'd like SCM_CHARS to work on msymbols just as it does on
+ ssymbols, so we'll have it point to the symbol's name as usual, and
+ store a pointer to the slots just before the name in memory. Thus,
+ you have to do some casting and pointer arithmetic to find the
+ slots; see the SCM_SLOTS macro.
+
+ In practice, the slots always live just before the pointer to them.
+ So why not ditch the pointer, and use negative indices to refer to
+ the slots? That's a good question; ask the author. I think it was
+ the cognac. */
+
#define SCM_SYMBOLP(x) (SCM_TYP7S(x)==scm_tc7_ssymbol)
#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8)
#define SCM_LENGTH_MAX (0xffffffL)
-#define SCM_SETLENGTH(x, v, t) SCM_CAR(x) = ((v)<<8)+(t)
+#define SCM_SETLENGTH(x, v, t) SCM_SETCAR((x), ((v)<<8)+(t))
#define SCM_SETCHARS SCM_SETCDR
#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
#define SCM_UCHARS(x) ((unsigned char *)(SCM_CDR(x)))
@@ -61,7 +86,7 @@ extern int scm_symhash_dim;
#define SCM_SYMBOL_FUNC(X) (SCM_SLOTS(X)[0])
#define SCM_SYMBOL_PROPS(X) (SCM_SLOTS(X)[1])
#define SCM_SYMBOL_HASH(X) (*(unsigned long*)(&SCM_SLOTS(X)[2]))
-#define SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP(X) (*(unsigned long*)(&SCM_SLOTS(X)[3]))
+#define SCM_SYMBOL_MULTI_BYTE_STRINGP(X) (*(unsigned long*)(&SCM_SLOTS(X)[3]))
#define SCM_ROSTRINGP(x) ((SCM_TYP7SD(x)==scm_tc7_string) || (SCM_TYP7S(x) == scm_tc7_ssymbol))
#define SCM_ROCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \
@@ -77,65 +102,35 @@ extern int scm_symhash_dim;
-#ifdef __STDC__
-extern unsigned long scm_strhash (unsigned char *str, scm_sizet len, unsigned long n);
-extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep);
-extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
-extern SCM scm_sym2ovcell (SCM sym, SCM obarray);
-extern SCM scm_intern_obarray_soft (char *name, scm_sizet len, SCM obarray, int softness);
-extern SCM scm_intern_obarray (char *name, scm_sizet len, SCM obarray);
-extern SCM scm_intern (char *name, scm_sizet len);
-extern SCM scm_intern0 (char * name);
-extern SCM scm_sysintern (char *name, SCM val);
-extern SCM scm_symbol_p(SCM x);
-extern SCM scm_symbol_to_string(SCM s);
-extern SCM scm_string_to_symbol(SCM s);
-extern SCM scm_string_to_obarray_symbol(SCM o, SCM s, SCM softp);
-extern SCM scm_intern_symbol(SCM o, SCM s);
-extern SCM scm_unintern_symbol(SCM o, SCM s);
-extern SCM scm_symbol_binding (SCM o, SCM s);
-extern SCM scm_symbol_interned_p (SCM o, SCM s);
-extern SCM scm_symbol_bound_p (SCM o, SCM s);
-extern SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
-extern SCM scm_symbol_fref (SCM s);
-extern SCM scm_symbol_pref (SCM s);
-extern SCM scm_symbol_fset_x (SCM s, SCM val);
-extern SCM scm_symbol_pset_x (SCM s, SCM val);
-extern SCM scm_symbol_hash (SCM s);
-extern void scm_init_symbols (void);
-
-#else /* STDC */
-extern unsigned long scm_strhash ();
-extern SCM scm_sym2vcell ();
-extern SCM scm_sym2ovcell_soft ();
-extern SCM scm_sym2ovcell ();
-extern SCM scm_intern_obarray_soft ();
-extern SCM scm_intern_obarray ();
-extern SCM scm_intern ();
-extern SCM scm_intern0 ();
-extern SCM scm_sysintern ();
-extern SCM scm_symbol_p();
-extern SCM scm_symbol_to_string();
-extern SCM scm_string_to_symbol();
-extern SCM scm_string_to_obarray_symbol();
-extern SCM scm_intern_symbol();
-extern SCM scm_unintern_symbol();
-extern SCM scm_symbol_binding ();
-extern SCM scm_symbol_interned_p ();
-extern SCM scm_symbol_bound_p ();
-extern SCM scm_symbol_set_x ();
-extern SCM scm_symbol_fref ();
-extern SCM scm_symbol_pref ();
-extern SCM scm_symbol_fset_x ();
-extern SCM scm_symbol_pset_x ();
-extern SCM scm_symbol_hash ();
-extern void scm_init_symbols ();
-
-#endif /* STDC */
-
-
-
+extern unsigned long scm_strhash SCM_P ((unsigned char *str, scm_sizet len, unsigned long n));
+extern SCM scm_sym2vcell SCM_P ((SCM sym, SCM thunk, SCM definep));
+extern SCM scm_sym2ovcell_soft SCM_P ((SCM sym, SCM obarray));
+extern SCM scm_sym2ovcell SCM_P ((SCM sym, SCM obarray));
+extern SCM scm_intern_obarray_soft SCM_P ((char *name, scm_sizet len, SCM obarray, int softness));
+extern SCM scm_intern_obarray SCM_P ((char *name, scm_sizet len, SCM obarray));
+extern SCM scm_intern SCM_P ((char *name, scm_sizet len));
+extern SCM scm_intern0 SCM_P ((char * name));
+extern SCM scm_sysintern SCM_P ((char *name, SCM val));
+extern SCM scm_sysintern0 SCM_P ((char *name));
+extern SCM scm_symbol_value0 SCM_P ((char *name));
+extern SCM scm_symbol_p SCM_P ((SCM x));
+extern SCM scm_symbol_to_string SCM_P ((SCM s));
+extern SCM scm_string_to_symbol SCM_P ((SCM s));
+extern SCM scm_string_to_obarray_symbol SCM_P ((SCM o, SCM s, SCM softp));
+extern SCM scm_intern_symbol SCM_P ((SCM o, SCM s));
+extern SCM scm_unintern_symbol SCM_P ((SCM o, SCM s));
+extern SCM scm_symbol_binding SCM_P ((SCM o, SCM s));
+extern SCM scm_symbol_interned_p SCM_P ((SCM o, SCM s));
+extern SCM scm_symbol_bound_p SCM_P ((SCM o, SCM s));
+extern SCM scm_symbol_set_x SCM_P ((SCM o, SCM s, SCM v));
+extern SCM scm_symbol_fref SCM_P ((SCM s));
+extern SCM scm_symbol_pref SCM_P ((SCM s));
+extern SCM scm_symbol_fset_x SCM_P ((SCM s, SCM val));
+extern SCM scm_symbol_pset_x SCM_P ((SCM s, SCM val));
+extern SCM scm_symbol_hash SCM_P ((SCM s));
+extern void scm_init_symbols SCM_P ((void));
+extern int scm_can_use_top_level_lookup_closure_var;
#endif /* SYMBOLSH */
diff --git a/libguile/tag.c b/libguile/tag.c
index a305d70b2..09f0effe5 100644
--- a/libguile/tag.c
+++ b/libguile/tag.c
@@ -41,7 +41,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "struct.h"
+#include "tag.h"
SCM_CONST_LONG (scm_utag_immediate_integer, "utag_immediate_integer", 0);
@@ -81,14 +84,10 @@ SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255);
SCM_PROC (s_tag, "tag", 1, 0, 0, scm_tag);
-#ifdef __STDC__
-SCM
-scm_tag (SCM x)
-#else
+
SCM
scm_tag (x)
SCM x;
-#endif
{
switch (SCM_ITAG3 (x))
{
@@ -207,13 +206,9 @@ scm_tag (x)
-#ifdef __STDC__
-void
-scm_init_tag (void)
-#else
+
void
scm_init_tag ()
-#endif
{
#include "tag.x"
}
diff --git a/libguile/tag.h b/libguile/tag.h
index a7d1ab761..9c4952bdf 100644
--- a/libguile/tag.h
+++ b/libguile/tag.h
@@ -44,20 +44,15 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-#ifdef __STDC__
-extern SCM scm_tag (SCM x);
-extern void scm_init_tag (void);
-#else /* STDC */
-extern SCM scm_tag ();
-extern void scm_init_tag ();
+extern SCM scm_tag SCM_P ((SCM x));
+extern void scm_init_tag SCM_P ((void));
-#endif /* STDC */
#endif /* TAGH */
diff --git a/libguile/tags.h b/libguile/tags.h
index 1469a90f6..72610f7e0 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,17 +3,17 @@
#ifndef TAGSH
#define TAGSH
/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
+ *
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
- *
+ *
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
- *
+ *
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
@@ -40,11 +40,11 @@
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
+ * If you do not wish that, delete this exception notice.
*/
-/** This file defines the format of SCM values and cons pairs.
+/** This file defines the format of SCM values and cons pairs.
** It is here that tag bits are assigned for various purposes.
**/
@@ -80,37 +80,37 @@ typedef long SCM;
*
* Immediates -- meaning that the variable contains an entire Scheme object.
*
- * Non-immediates -- meaning that the variable holds a (possibly tagged) pointer
- * into the cons pair heap.
+ * Non-immediates -- meaning that the variable holds a (possibly
+ * tagged) pointer into the cons pair heap.
*
- * Non-objects are distinguished from other values by careful coding only (i.e.,
- * programmers must keep track of any SCM variables they create that don't contain
- * ordinary scheme values).
+ * Non-objects are distinguished from other values by careful coding
+ * only (i.e., programmers must keep track of any SCM variables they
+ * create that don't contain ordinary scheme values).
*
- * All immediates and non-immediates must have a 0 in bit 0. Only non-object
- * values can have a 1 in bit 0. In some cases, bit 0 of a word in the heap
- * is used for the GC tag so during garbage collection, that bit might be 1
- * even in an immediate or non-immediate value. In other cases, bit 0 of a word
- * in the heap is used to tag a pointer to a GLOC (VM global variable address)
- * or the header of a struct. But whenever an SCM variable holds a normal Scheme
- * value, bit 0 is 0.
+ * All immediates and non-immediates must have a 0 in bit 0. Only
+ * non-object values can have a 1 in bit 0. In some cases, bit 0 of a
+ * word in the heap is used for the GC tag so during garbage
+ * collection, that bit might be 1 even in an immediate or
+ * non-immediate value. In other cases, bit 0 of a word in the heap
+ * is used to tag a pointer to a GLOC (VM global variable address) or
+ * the header of a struct. But whenever an SCM variable holds a
+ * normal Scheme value, bit 0 is 0.
*
* Immediates and non-immediates are distinguished by bits two and four.
* Immediate values must have a 1 in at least one of those bits. Does
- * this (or any other detail of tagging) seem arbitrary? Try chaning it!
+ * this (or any other detail of tagging) seem arbitrary? Try changing it!
* (Not always impossible but it is fair to say that many details of tags
- * are mutually dependent).
- */
+ * are mutually dependent). */
#define SCM_IMP(x) (6 & (int)(x))
#define SCM_NIMP(x) (!SCM_IMP(x))
/* Here is a summary of tagging in SCM values as they might occur in
- * SCM variables or in the heap.
+ * SCM variables or in the heap.
*
* low bits meaning
*
- *
+ *
* 0 Most objects except...
* 1 ...glocs and structs (this tag valid only in a SCM_CAR or
* in the header of a struct's data).
@@ -134,7 +134,7 @@ typedef long SCM;
* 100 --- IMMEDIATES
*
* Looking at the seven final bits of an immediate:
- *
+ *
* 0000-100 short instruction
* 0001-100 short instruction
* 0010-100 short instruction
@@ -152,7 +152,7 @@ typedef long SCM;
* 1110-100 immediate characters
* 1111-100 ilocs
*
- * Some of the 0110100 immediates are long instructions (they dispatch
+ * Some of the 0110100 immediates are long instructions (they dispatch
* in two steps compared to one step for a short instruction).
* The two steps are, (1) dispatch on 7 bits to the long instruction
* handler, (2) dispatch on 7 additional bits.
@@ -196,8 +196,13 @@ typedef long SCM;
*
* 101 & 111 --- tc7_ types
*
- * tc7_tags are 7 bit tags ending in 1x1. These tags occur
- * only in the CAR of heap cells.
+ * tc7_tags are 7 bit tags ending in 1x1. These tags
+ * occur only in the CAR of heap cells, and have the
+ * handy property that all bits of the CAR above the
+ * bottom eight can be used to store a length, thus
+ * saving a word in the body itself. Thus, we use them
+ * for strings, symbols, and vectors (among other
+ * things).
*
* SCM_LENGTH returns the bits in "length" (see the diagram).
* SCM_CHARS returns the data cast to "char *"
@@ -208,25 +213,36 @@ typedef long SCM;
* that applies to a particular type, see the header file
* for that type.
*
+ * Sometimes we choose the bottom seven bits carefully,
+ * so that the 4- and 1-valued bits (called the D and S
+ * bits) can be masked off to reveal a common type.
+ *
* TYP7S(X) returns TYP7, but masking out the option bit S.
* TYP7D(X) returns TYP7, but masking out the option bit D.
* TYP7SD(X) masks out both option bits.
*
+ * For example, all strings have 001 in the 'xxx' bits in
+ * the diagram above, the D bit says whether it's a
+ * substring, and the S bit says whether it's a multibyte
+ * character string.
+ *
* for example:
* D S
- * scm_tc7_string = Gxxx0101
- * scm_tc7_mb_string = Gxxx0111
- * scm_tc7_substring = Gxxx1101
- * scm_tc7_mb_substring = Gxxx1111
+ * scm_tc7_string = G0010101
+ * scm_tc7_mb_string = G0010111
+ * scm_tc7_substring = G0011101
+ * scm_tc7_mb_substring = G0011111
+ *
+ * TYP7DS turns all string tags into tc7_string; thus,
+ * testing TYP7DS against tc7_string is a quick way to
+ * test for any kind of string.
*
- * TYP7S turns tc7_mb_string into tc7_string and
+ * TYP7S turns tc7_mb_string into tc7_string and
* tc7_mb_substring into tc7_substring.
*
- * TYP7D turns tc7_mb_substring into tc7_mb_string and
+ * TYP7D turns tc7_mb_substring into tc7_mb_string and
* tc7_substring into tc7_string.
*
- * TYP7DS turns all string tags into tc7_string.
- *
* Some TC7 types are subdivided into 256 subtypes giving
* rise to the macros:
*
@@ -237,8 +253,7 @@ typedef long SCM;
* TYP16S functions similarly wrt to TYP16 as TYP7S to TYP7,
* but a different option bit is used (bit 2 for TYP7S,
* bit 8 for TYP16S).
- *
- */
+ * */
@@ -249,7 +264,7 @@ typedef long SCM;
* figure out Xs type. X may be a cons pair, in which case the
* value SCM_CAR (x) will be either an immediate or non-immediate value.
* X may be something other than a cons pair, in which case the value SCM_CAR (x)
- * will be a non-object value.
+ * will be a non-object value.
*
* All immediates and non-immediates have a 0 in bit 0. We additionally preserve
* the invariant that all non-object values stored in the SCM_CAR of a non-immediate
@@ -260,19 +275,22 @@ typedef long SCM;
#define SCM_CONSP(x) (!SCM_NCONSP(x))
-/* ECONSP is historical and, in fact, slightly buggy.
- * There are two places to fix where structures and glocs can be confused.
- * !!!
+/* SCM_ECONSP should be used instead of SCM_CONSP at places where GLOCS
+ * can be expected to occur.
*/
-#define SCM_ECONSP(x) (SCM_CONSP(x) || (1==SCM_TYP3(x)))
-#define SCM_NECONSP(x) (SCM_NCONSP(x) && (1 != SCM_TYP3(x)))
+#define SCM_ECONSP(x) (SCM_CONSP (x) \
+ || (SCM_TYP3(x) == 1 \
+ && SCM_CDR (SCM_CAR (x) - 1) != 0))
+#define SCM_NECONSP(x) (SCM_NCONSP(x) \
+ && (SCM_TYP3(x) != 1 \
+ || SCM_CDR (SCM_CAR (x) - 1) == 0))
#define SCM_CELLP(x) (!SCM_NCELLP(x))
#define SCM_NCELLP(x) ((sizeof(scm_cell)-1) & (int)(x))
-/* See numbers.h for macros relating to immediate integers.
+/* See numbers.h for macros relating to immediate integers.
*/
#define SCM_ITAG3(x) (7 & (int)x)
@@ -308,10 +326,10 @@ typedef long SCM;
*/
#define SCM_GCMARKP(x) (1 & (int)SCM_CDR(x))
#define SCM_GC8MARKP(x) (0x80 & (int)SCM_CAR(x))
-#define SCM_SETGCMARK(x) (SCM_CDR(x) |= 1)
-#define SCM_CLRGCMARK(x) (SCM_CDR(x) &= ~1L)
-#define SCM_SETGC8MARK(x) (SCM_CAR(x) |= 0x80)
-#define SCM_CLRGC8MARK(x) (SCM_CAR(x) &= ~0x80L)
+#define SCM_SETGCMARK(x) SCM_SETOR_CDR (x,1)
+#define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L)
+#define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80)
+#define SCM_CLRGC8MARK(x) SCM_SETAND_CAR (x, ~0x80L)
@@ -400,20 +418,20 @@ typedef long SCM;
#define scm_tc_dblc (scm_tc16_flo|SCM_REAL_PART|SCM_IMAG_PART)
-/* Smob types 2 and 3:
+/* Smob types 2 and 3:
*/
#define scm_tc16_bigpos 0x027f
#define scm_tc16_bigneg 0x037f
-/* {Immediate Values}
+/* {Immediate Values}
*/
enum scm_tags
{
scm_tc8_char = 0xf4,
- scm_tc8_iloc = 0xfc,
+ scm_tc8_iloc = 0xfc
};
#define SCM_ITAG8(X) ((int)(X) & 0xff)
@@ -431,12 +449,12 @@ enum scm_tags
/* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */
#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4)
#define SCM_ISYMNUM(n) ((int)((n)>>9))
-#define SCM_ISYMSCM_CHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
+#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
#define SCM_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
#define SCM_MAKISYM(n) (((n)<<9)+0x74L)
#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L)
-/* This table must agree with the declarations
+/* This table must agree with the declarations
* in repl.c: {Names of immediate symbols}.
*
* These are used only in eval but their values
@@ -464,7 +482,7 @@ enum scm_tags
#define SCM_BOOL_T SCM_MAKIFLAG(17)
#define SCM_UNDEFINED SCM_MAKIFLAG(18)
#define SCM_EOF_VAL SCM_MAKIFLAG(19)
-#define SCM_UNUSED_NIL_VALUE SCM_MAKIFLAG(20)
+#define SCM_EOL SCM_MAKIFLAG(20)
#define SCM_UNSPECIFIED SCM_MAKIFLAG(21)
@@ -476,7 +494,7 @@ enum scm_tags
*/
-/* For cons pairs with immediate values in the CAR
+/* For cons pairs with immediate values in the CAR
*/
#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\
@@ -521,12 +539,4 @@ enum scm_tags
#define scm_tcs_bignums scm_tc16_bigpos:case scm_tc16_bigneg
-
-#ifdef __STDC__
-
-#else /* STDC */
-
-#endif /* STDC */
-
-
#endif /* TAGSH */
diff --git a/libguile/threads.c b/libguile/threads.c
new file mode 100644
index 000000000..f1c826f2a
--- /dev/null
+++ b/libguile/threads.c
@@ -0,0 +1,161 @@
+/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+#include "dynwind.h"
+#include "smob.h"
+
+#include "threads.h"
+
+
+
+long scm_tc16_thread;
+
+long scm_tc16_mutex;
+
+long scm_tc16_condvar;
+
+
+/* Scheme-visible thread functions. */
+
+#ifdef USE_COOP_THREADS
+SCM_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p);
+#endif
+SCM_PROC(s_yield, "yield", 0, 0, 0, scm_yield);
+SCM_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread);
+SCM_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread);
+SCM_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex);
+SCM_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex);
+SCM_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex);
+SCM_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable);
+SCM_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 0, 0, scm_wait_condition_variable);
+SCM_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable);
+
+
+
+#ifdef USE_MIT_PTHREADS
+#include "mit-pthreads.c"
+#endif
+
+#ifdef USE_COOP_THREADS
+#include "coop-threads.c"
+#endif
+
+static int
+print_thread (exp, port, pstate)
+ SCM exp;
+ SCM port;
+ scm_print_state *pstate;
+{
+ scm_gen_puts (scm_regular_string, "#<thread ", port);
+ scm_intprint (SCM_CDR (exp), 16, port);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns thread_smob =
+{
+ scm_mark0,
+ scm_threads_free_thread,
+ print_thread,
+ 0
+};
+
+static int
+print_mutex (exp, port, pstate)
+ SCM exp;
+ SCM port;
+ scm_print_state *pstate;
+{
+ scm_gen_puts (scm_regular_string, "#<mutex ", port);
+ scm_intprint (SCM_CDR (exp), 16, port);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns mutex_smob =
+{
+ scm_mark0,
+ scm_threads_free_mutex,
+ print_mutex,
+ 0
+};
+
+static int
+print_condvar (exp, port, pstate)
+ SCM exp;
+ SCM port;
+ scm_print_state *pstate;
+{
+ scm_gen_puts (scm_regular_string, "#<condition-variable ", port);
+ scm_intprint (SCM_CDR (exp), 16, port);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns condvar_smob =
+{
+ scm_mark0,
+ scm_threads_free_condvar,
+ print_condvar,
+ 0
+};
+
+
+
+#ifdef __STDC__
+void
+scm_init_threads (SCM_STACKITEM *i)
+#else
+void
+scm_init_threads (i)
+ SCM_STACKITEM *i;
+#endif
+{
+ scm_tc16_thread = scm_newsmob (&thread_smob);
+ scm_tc16_mutex = scm_newsmob (&mutex_smob);
+ scm_tc16_condvar = scm_newsmob (&condvar_smob);
+#include "threads.x"
+ /* Initialize implementation specific details of the threads support */
+ scm_threads_init (i);
+}
diff --git a/libguile/threads.h b/libguile/threads.h
new file mode 100644
index 000000000..cebd28827
--- /dev/null
+++ b/libguile/threads.h
@@ -0,0 +1,91 @@
+/* classes: h_files */
+
+#ifndef THREADSH
+#define THREADSH
+
+/* Copyright (C) 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include "libguile/__scm.h"
+#include "libguile/procs.h"
+
+/* smob tags for the thread datatypes */
+extern long scm_tc16_thread;
+extern long scm_tc16_mutex;
+extern long scm_tc16_condvar;
+
+#define SCM_THREADP(obj) (scm_tc16_thread == SCM_TYP16 (obj))
+#define SCM_THREAD_DATA(obj) ((void *) SCM_CDR (obj))
+
+#define SCM_MUTEXP(obj) (scm_tc16_mutex == SCM_TYP16 (obj))
+#define SCM_MUTEX_DATA(obj) ((void *) SCM_CDR (obj))
+
+#define SCM_CONDVARP(obj) (scm_tc16_condvar == SCM_TYP16 (obj))
+#define SCM_CONDVAR_DATA(obj) ((void *) SCM_CDR (obj))
+
+/* Initialize implementation specific details of the threads support */
+void scm_threads_init SCM_P ((SCM_STACKITEM *));
+void scm_threads_mark_stacks SCM_P ((void));
+void scm_init_threads SCM_P ((SCM_STACKITEM *));
+
+/* */
+SCM scm_threads_make_mutex SCM_P ((void));
+SCM scm_threads_lock_mutex SCM_P ((SCM));
+SCM scm_threads_unlock_mutex SCM_P ((SCM));
+SCM scm_threads_monitor SCM_P ((void));
+
+#if 0
+/* These don't work any more. */
+#ifdef USE_MIT_PTHREADS
+#include "mit-pthreads.h"
+#endif
+
+#ifdef USE_FSU_PTHREADS
+#include "fsu-pthreads.h"
+#endif
+#endif
+
+#ifdef USE_COOP_THREADS
+#include "libguile/coop-defs.h"
+#endif
+
+#endif /* THREADSH */
diff --git a/libguile/throw.c b/libguile/throw.c
index a84d7e92e..60e0c13e7 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -42,41 +42,56 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "smob.h"
+#include "alist.h"
+#include "eval.h"
+#include "eq.h"
+#include "dynwind.h"
+#include "backtrace.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif
+#include "continuations.h"
+#include "stackchk.h"
-
-
+#include "throw.h"
-/* {Catch and Throw}
- */
+
+/* the jump buffer data structure */
static int scm_tc16_jmpbuffer;
-SCM scm_bad_throw_vcell;
-
#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
-#define ACTIVATEJB(O) (SCM_CAR (O) |= (1L << 16L))
-#define DEACTIVATEJB(O) (SCM_CAR (O) &= ~(1L << 16L))
+#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
+#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
-#ifdef DEBUG_EXTENSIONS
-#define JBSCM_DFRAME(O) ((debug_frame*)SCM_CAR (SCM_CDR (O)) )
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
-#define SETJBSCM_DFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X)
-#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
-#else
+#ifndef DEBUG_EXTENSIONS
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
#define SETJBJMPBUF SCM_SETCDR
+#else
+#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
+#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
+#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
+#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
+
+static scm_sizet freejb SCM_P ((SCM jbsmob));
+
+static scm_sizet
+freejb (jbsmob)
+ SCM jbsmob;
+{
+ scm_must_free ((char *) SCM_CDR (jbsmob));
+ return sizeof (scm_cell);
+}
#endif
-#ifdef __STDC__
-static int
-printjb (SCM exp, SCM port, int writing)
-#else
+static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
-printjb (exp, port, writing)
+printjb (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
@@ -85,34 +100,39 @@ printjb (exp, port, writing)
return 1 ;
}
-/* !!! The mark function needs to be different for
- * debugging support. A. Green
- */
-static scm_smobfuns jbsmob = {scm_mark0, scm_free0, printjb, 0};
-
-#ifdef __STDC__
-static SCM
-make_jmpbuf (void)
+static scm_smobfuns jbsmob = {
+ scm_mark0,
+#ifdef DEBUG_EXTENSIONS
+ freejb,
#else
+ scm_free0,
+#endif
+ printjb,
+ 0
+};
+
+static SCM make_jmpbuf SCM_P ((void));
static SCM
make_jmpbuf ()
-#endif
{
SCM answer;
SCM_NEWCELL (answer);
+ SCM_REDEFER_INTS;
+ {
#ifdef DEBUG_EXTENSIONS
- SCM_NEWCELL (SCM_CDR (answer));
+ char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
+ SCM_SETCDR (answer, (SCM) mem);
#endif
- SCM_DEFER_INTS;
- {
- SCM_CAR(answer) = scm_tc16_jmpbuffer;
+ SCM_SETCAR (answer, scm_tc16_jmpbuffer);
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
}
- SCM_ALLOW_INTS;
+ SCM_REALLOW_INTS;
return answer;
}
+
+/* scm_internal_catch (the guts of catch) */
struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
{
@@ -121,72 +141,402 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
SCM retval;
};
-SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
-#ifdef __STDC__
-SCM
-scm_catch (SCM tag, SCM thunk, SCM handler)
-#else
+
+/* scm_internal_catch is the guts of catch. It handles all the
+ mechanics of setting up a catch target, invoking the catch body,
+ and perhaps invoking the handler if the body does a throw.
+
+ The function is designed to be usable from C code, but is general
+ enough to implement all the semantics Guile Scheme expects from
+ throw.
+
+ TAG is the catch tag. Typically, this is a symbol, but this
+ function doesn't actually care about that.
+
+ BODY is a pointer to a C function which runs the body of the catch;
+ this is the code you can throw from. We call it like this:
+ BODY (BODY_DATA, JMPBUF)
+ where:
+ BODY_DATA is just the BODY_DATA argument we received; we pass it
+ through to BODY as its first argument. The caller can make
+ BODY_DATA point to anything useful that BODY might need.
+ JMPBUF is the Scheme jmpbuf object corresponding to this catch,
+ which we have just created and initialized.
+
+ HANDLER is a pointer to a C function to deal with a throw to TAG,
+ should one occur. We call it like this:
+ HANDLER (HANDLER_DATA, TAG, THROW_ARGS)
+ where
+ HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
+ same idea as BODY_DATA above.
+ TAG is the tag that the user threw to; usually this is TAG, but
+ it could be something else if TAG was #t (i.e., a catch-all),
+ or the user threw to a jmpbuf.
+ THROW_ARGS is the list of arguments the user passed to the THROW
+ function.
+
+ BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
+ is just a pointer we pass through to HANDLER. We don't actually
+ use either of those pointers otherwise ourselves. The idea is
+ that, if our caller wants to communicate something to BODY or
+ HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
+ HANDLER can then use. Think of it as a way to make BODY and
+ HANDLER closures, not just functions; MUMBLE_DATA points to the
+ enclosed variables.
+
+ Of course, it's up to the caller to make sure that any data a
+ MUMBLE_DATA needs is protected from GC. A common way to do this is
+ to make MUMBLE_DATA a pointer to data stored in an automatic
+ structure variable; since the collector must scan the stack for
+ references anyway, this assures that any references in MUMBLE_DATA
+ will be found. */
+
SCM
-scm_catch (tag, thunk, handler)
+scm_internal_catch (tag, body, body_data, handler, handler_data)
SCM tag;
- SCM thunk;
- SCM handler;
-#endif
+ scm_catch_body_t body;
+ void *body_data;
+ scm_catch_handler_t handler;
+ void *handler_data;
{
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
SCM answer;
- SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_catch);
jmpbuf = make_jmpbuf ();
answer = SCM_EOL;
scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
SETJBJMPBUF(jmpbuf, &jbr.buf);
#ifdef DEBUG_EXTENSIONS
- SETJBSCM_DFRAME(jmpbuf, last_debug_info_frame);
+ SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
#endif
if (setjmp (jbr.buf))
{
SCM throw_tag;
SCM throw_args;
- SCM_DEFER_INTS;
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
+ SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_ALLOW_INTS;
+ SCM_REALLOW_INTS;
throw_args = jbr.retval;
throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL;
jbr.retval = SCM_EOL;
- answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL);
+ answer = handler (handler_data, throw_tag, throw_args);
}
else
{
ACTIVATEJB (jmpbuf);
- answer = scm_apply (thunk,
- ((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL),
- SCM_EOL);
- SCM_DEFER_INTS;
+ answer = body (body_data, jmpbuf);
+ SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_ALLOW_INTS;
+ SCM_REALLOW_INTS;
}
return answer;
}
-static char s_throw[];
-#ifdef __STDC__
+
+/* scm_internal_lazy_catch (the guts of lazy catching) */
+
+/* The smob tag for lazy_catch smobs. */
+static long tc16_lazy_catch;
+
+/* This is the structure we put on the wind list for a lazy catch. It
+ stores the handler function to call, and the data pointer to pass
+ through to it. It's not a Scheme closure, but it is a function
+ with data, so the term "closure" is appropriate in its broader
+ sense.
+
+ (We don't need anything like this in the "eager" catch code,
+ because the same C frame runs both the body and the handler.) */
+struct lazy_catch {
+ scm_catch_handler_t handler;
+ void *handler_data;
+};
+
+/* Strictly speaking, we could just pass a zero for our print
+ function, because we don't need to print them. They should never
+ appear in normal data structures, only in the wind list. However,
+ it might be nice for debugging someday... */
+static int
+print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate)
+{
+ struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (closure);
+ char buf[200];
+
+ sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
+ (long) c->handler, (long) c->handler_data);
+ scm_gen_puts (scm_regular_string, buf, port);
+
+ return 1;
+}
+
+static scm_smobfuns lazy_catch_funs = {
+ scm_mark0, scm_free0, print_lazy_catch, 0
+};
+
+
+/* Given a pointer to a lazy catch structure, return a smob for it,
+ suitable for inclusion in the wind list. ("Ah yes, a Château
+ Gollombiere '72, non?"). */
+static SCM
+make_lazy_catch (struct lazy_catch *c)
+{
+ SCM smob;
+
+ SCM_NEWCELL (smob);
+ SCM_SETCDR (smob, c);
+ SCM_SETCAR (smob, tc16_lazy_catch);
+
+ return smob;
+}
+
+#define SCM_LAZY_CATCH_P(obj) \
+ (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch))
+
+
+/* Exactly like scm_internal_catch, except:
+ - It does not unwind the stack (this is the major difference).
+ - If handler returns, its value is returned from the throw.
+ - BODY always receives #f as its JMPBUF argument (since there's no
+ jmpbuf associated with a lazy catch, because we don't unwind the
+ stack.) */
+SCM
+scm_internal_lazy_catch (tag, body, body_data, handler, handler_data)
+ SCM tag;
+ scm_catch_body_t body;
+ void *body_data;
+ scm_catch_handler_t handler;
+ void *handler_data;
+{
+ SCM lazy_catch, answer;
+ struct lazy_catch c;
+
+ c.handler = handler;
+ c.handler_data = handler_data;
+ lazy_catch = make_lazy_catch (&c);
+
+ SCM_REDEFER_INTS;
+ scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
+ SCM_REALLOW_INTS;
+
+ answer = (*body) (body_data, SCM_BOOL_F);
+
+ SCM_REDEFER_INTS;
+ scm_dynwinds = SCM_CDR (scm_dynwinds);
+ SCM_REALLOW_INTS;
+
+ return answer;
+}
+
+
+
+/* body and handler functions for use with either of the above */
+
+/* This is a body function you can pass to scm_internal_catch if you
+ want the body to be like Scheme's `catch' --- a thunk, or a
+ function of one argument if the tag is #f.
+
+ BODY_DATA is a pointer to a scm_body_thunk_data structure, which
+ contains the Scheme procedure to invoke as the body, and the tag
+ we're catching. If the tag is #f, then we pass JMPBUF (created by
+ scm_internal_catch) to the body procedure; otherwise, the body gets
+ no arguments. */
+
SCM
-scm_ithrow (SCM key, SCM args, int noreturn)
-#else
+scm_body_thunk (body_data, jmpbuf)
+ void *body_data;
+ SCM jmpbuf;
+{
+ struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
+
+ if (c->tag == SCM_BOOL_F)
+ return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL);
+ else
+ return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
+}
+
+
+/* This is a handler function you can pass to scm_internal_catch if
+ you want the handler to act like Scheme's catch --- call a
+ procedure with the tag and the throw arguments.
+
+ If the user does a throw to this catch, this function runs a
+ handler procedure written in Scheme. HANDLER_DATA is a pointer to
+ an SCM variable holding the Scheme procedure object to invoke. It
+ ought to be a pointer to an automatic variable (i.e., one living on
+ the stack), or the procedure object should be otherwise protected
+ from GC. */
+SCM
+scm_handle_by_proc (handler_data, tag, throw_args)
+ void *handler_data;
+ SCM tag;
+ SCM throw_args;
+{
+ SCM *handler_proc_p = (SCM *) handler_data;
+
+ return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
+}
+
+
+/* This is a handler function to use if you want scheme to print a
+ message and die. Useful for dealing with throws to uncaught keys
+ at the top level.
+
+ At boot time, we establish a catch-all that uses this as its handler.
+ 1) If the user wants something different, they can use (catch #t
+ ...) to do what they like.
+ 2) Outside the context of a read-eval-print loop, there isn't
+ anything else good to do; libguile should not assume the existence
+ of a read-eval-print loop.
+ 3) Given that we shouldn't do anything complex, it's much more
+ robust to do it in C code.
+
+ HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
+ message header to print; if zero, we use "guile" instead. That
+ text is followed by a colon, then the message described by ARGS. */
+
+SCM
+scm_handle_by_message (handler_data, tag, args)
+ void *handler_data;
+ SCM tag;
+ SCM args;
+{
+ char *prog_name = (char *) handler_data;
+ SCM p = scm_def_errp;
+
+ if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit")))))
+ exit (scm_exit_status (args));
+
+ if (! prog_name)
+ prog_name = "guile";
+
+ scm_gen_puts (scm_regular_string, prog_name, p);
+ scm_gen_puts (scm_regular_string, ": ", p);
+
+ if (scm_ilength (args) >= 3)
+ {
+ SCM message = SCM_CADR (args);
+ SCM parts = SCM_CADDR (args);
+
+ scm_display_error_message (message, parts, p);
+ }
+ else
+ {
+ scm_gen_puts (scm_regular_string, "uncaught throw to ", p);
+ scm_prin1 (tag, p, 0);
+ scm_gen_puts (scm_regular_string, ": ", p);
+ scm_prin1 (args, p, 1);
+ scm_gen_putc ('\n', p);
+ }
+
+ exit (2);
+}
+
+
+/* Derive the an exit status from the arguments to (quit ...). */
+int
+scm_exit_status (args)
+ SCM args;
+{
+ if (SCM_NNULLP (args))
+ {
+ SCM cqa = SCM_CAR (args);
+
+ if (SCM_INUMP (cqa))
+ return (SCM_INUM (cqa));
+ else if (SCM_FALSEP (cqa))
+ return 1;
+ }
+ return 0;
+}
+
+
+
+
+/* the Scheme-visible CATCH and LAZY-CATCH functions */
+
+SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
+SCM
+scm_catch (tag, thunk, handler)
+ SCM tag;
+ SCM thunk;
+ SCM handler;
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT ((tag == SCM_BOOL_F)
+ || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
+ || (tag == SCM_BOOL_T),
+ tag, SCM_ARG1, s_catch);
+
+ c.tag = tag;
+ c.body_proc = thunk;
+
+ /* scm_internal_catch takes care of all the mechanics of setting up
+ a catch tag; we tell it to call scm_body_thunk to run the body,
+ and scm_handle_by_proc to deal with any throws to this catch.
+ The former receives a pointer to c, telling it how to behave.
+ The latter receives a pointer to HANDLER, so it knows who to call. */
+ return scm_internal_catch (tag,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler);
+}
+
+
+SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
+SCM
+scm_lazy_catch (tag, thunk, handler)
+ SCM tag;
+ SCM thunk;
+ SCM handler;
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
+ || (tag == SCM_BOOL_T),
+ tag, SCM_ARG1, s_lazy_catch);
+
+ c.tag = tag;
+ c.body_proc = thunk;
+
+ /* scm_internal_lazy_catch takes care of all the mechanics of
+ setting up a lazy catch tag; we tell it to call scm_body_thunk to
+ run the body, and scm_handle_by_proc to deal with any throws to
+ this catch. The former receives a pointer to c, telling it how
+ to behave. The latter receives a pointer to HANDLER, so it knows
+ who to call. */
+ return scm_internal_lazy_catch (tag,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler);
+}
+
+
+
+/* throwing */
+
+SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
+SCM
+scm_throw (key, args)
+ SCM key;
+ SCM args;
+{
+ /* May return if handled by lazy catch. */
+ return scm_ithrow (key, args, 1);
+}
+
+
SCM
scm_ithrow (key, args, noreturn)
SCM key;
SCM args;
int noreturn;
-#endif
{
SCM jmpbuf;
SCM wind_goal;
@@ -205,28 +555,43 @@ scm_ithrow (key, args, noreturn)
}
else
{
- SCM dynpair;
- SCM hook;
+ SCM dynpair = SCM_UNDEFINED;
+ SCM winds;
if (noreturn)
{
- SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_throw);
+ SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1,
+ s_throw);
}
else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key)))
return SCM_UNSPECIFIED;
- dynpair = scm_sloppy_assq (key, scm_dynwinds);
+ /* Search the wind list for an appropriate catch.
+ "Waiter, please bring us the wind list." */
+ for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds))
+ {
+ if (! SCM_CONSP (winds))
+ abort ();
- if (dynpair == SCM_BOOL_F)
- dynpair = scm_sloppy_assq (SCM_BOOL_T, scm_dynwinds);
+ dynpair = SCM_CAR (winds);
+ if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair))
+ {
+ SCM this_key = SCM_CAR (dynpair);
- hook = SCM_CDR (scm_bad_throw_vcell);
- if ((dynpair == SCM_BOOL_F)
- && (SCM_BOOL_T == scm_procedure_p (hook)))
- {
- SCM answer;
- answer = scm_apply (hook, scm_cons (key, args), SCM_EOL);
+ if (this_key == SCM_BOOL_T || this_key == key)
+ break;
+ }
}
+
+ /* If we didn't find anything, abort. scm_boot_guile should
+ have established a catch-all, but obviously things are
+ thoroughly screwed up. */
+ if (winds == SCM_EOL)
+ abort ();
+
+ /* If the wind list is malformed, bail. */
+ if (SCM_IMP (winds) || SCM_NCONSP (winds))
+ abort ();
if (dynpair != SCM_BOOL_F)
jmpbuf = SCM_CDR (dynpair);
@@ -238,54 +603,67 @@ scm_ithrow (key, args, noreturn)
{
scm_exitval = scm_cons (key, args);
scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
+#ifdef DEBUG_EXTENSIONS
+ scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
+#endif
longjmp (SCM_JMPBUF (scm_rootcont), 1);
}
}
}
-#ifdef DEBUG_EXTENSIONS
- last_debug_info_frame = JBSCM_DFRAME (jmpbuf);
-#endif
for (wind_goal = scm_dynwinds;
SCM_CDAR (wind_goal) != jmpbuf;
wind_goal = SCM_CDR (wind_goal))
;
- {
- struct jmp_buf_and_retval * jbr;
- jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
- jbr->throw_tag = key;
- jbr->retval = args;
- }
- scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
- longjmp (*JBJMPBUF (jmpbuf), 1);
-}
+ /* Is a lazy catch? In wind list entries for lazy catches, the key
+ is bound to a lazy_catch smob, not a jmpbuf. */
+ if (SCM_LAZY_CATCH_P (jmpbuf))
+ {
+ struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (jmpbuf);
+ SCM oldwinds = scm_dynwinds;
+ SCM handle, answer;
+ scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
+ - scm_ilength (wind_goal)));
+ SCM_REDEFER_INTS;
+ handle = scm_dynwinds;
+ scm_dynwinds = SCM_CDR (scm_dynwinds);
+ SCM_REALLOW_INTS;
+ answer = (c->handler) (c->handler_data, key, args);
+ SCM_REDEFER_INTS;
+ SCM_SETCDR (handle, scm_dynwinds);
+ scm_dynwinds = handle;
+ SCM_REALLOW_INTS;
+ scm_dowinds (oldwinds, (scm_ilength (scm_dynwinds)
+ - scm_ilength (oldwinds)));
+ return answer;
+ }
-SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
-#ifdef __STDC__
-SCM
-scm_throw (SCM key, SCM args)
-#else
-SCM
-scm_throw (key, args)
- SCM key;
- SCM args;
+ /* Otherwise, it's a normal catch. */
+ else if (SCM_JMPBUFP (jmpbuf))
+ {
+ struct jmp_buf_and_retval * jbr;
+ scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
+ - scm_ilength (wind_goal)));
+ jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
+ jbr->throw_tag = key;
+ jbr->retval = args;
+ }
+
+ /* Otherwise, it's some random piece of junk. */
+ else
+ abort ();
+
+#ifdef DEBUG_EXTENSIONS
+ scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
#endif
-{
- scm_ithrow (key, args, 1);
- return SCM_BOOL_F; /* never really returns */
+ longjmp (*JBJMPBUF (jmpbuf), 1);
}
-#ifdef __STDC__
-void
-scm_init_throw (void)
-#else
void
scm_init_throw ()
-#endif
{
scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
- scm_bad_throw_vcell = scm_sysintern ("%%bad-throw", SCM_BOOL_F);
+ tc16_lazy_catch = scm_newsmob (&lazy_catch_funs);
#include "throw.x"
}
-
diff --git a/libguile/throw.h b/libguile/throw.h
index f6aca5b24..99d8ff692 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -44,24 +44,51 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-
-#ifdef __STDC__
-extern SCM scm_catch (SCM tag, SCM thunk, SCM handler);
-extern SCM scm_ithrow (SCM key, SCM args, int noreturn);
-extern SCM scm_throw (SCM key, SCM args);
-extern void scm_init_throw (void);
+typedef SCM (*scm_catch_body_t) SCM_P ((void *data, SCM jmpbuf));
+typedef SCM (*scm_catch_handler_t) SCM_P ((void *data,
+ SCM tag, SCM throw_args));
+
+extern SCM scm_internal_catch SCM_P ((SCM tag,
+ scm_catch_body_t body,
+ void *body_data,
+ scm_catch_handler_t handler,
+ void *handler_data));
+
+extern SCM scm_internal_lazy_catch SCM_P ((SCM tag,
+ scm_catch_body_t body,
+ void *body_data,
+ scm_catch_handler_t handler,
+ void *handler_data));
+
+/* The first argument to scm_body_thunk should be a pointer to one of
+ these. See the implementation of catch in throw.c. */
+struct scm_body_thunk_data
+{
+ /* The tag being caught. We only use it to figure out what
+ arguments to pass to the body procedure; see scm_catch_thunk_body for
+ details. */
+ SCM tag;
+
+ /* The Scheme procedure object constituting the catch body.
+ scm_body_by_proc invokes this. */
+ SCM body_proc;
+};
+
+extern SCM scm_body_thunk SCM_P ((void *, SCM));
-#else /* STDC */
-extern SCM scm_catch ();
-extern SCM scm_ithrow ();
-extern SCM scm_throw ();
-extern void scm_init_throw ();
-#endif /* STDC */
+extern SCM scm_handle_by_proc SCM_P ((void *, SCM, SCM));
+extern SCM scm_handle_by_message SCM_P ((void *, SCM, SCM));
+extern int scm_exit_status SCM_P ((SCM args));
+extern SCM scm_catch SCM_P ((SCM tag, SCM thunk, SCM handler));
+extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler));
+extern SCM scm_ithrow SCM_P ((SCM key, SCM args, int noreturn));
+extern SCM scm_throw SCM_P ((SCM key, SCM args));
+extern void scm_init_throw SCM_P ((void));
#endif /* THROWH */
diff --git a/libguile/unif.c b/libguile/unif.c
index ed0e17c5c..fc9879a89 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -42,6 +42,20 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "eval.h"
+#include "genio.h"
+#include "smob.h"
+#include "sequences.h"
+#include "strop.h"
+#include "feature.h"
+
+#include "unif.h"
+#include "ramap.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
/* The set of uniform scm_vector types is:
@@ -69,15 +83,11 @@ long scm_tc16_array;
*/
static char s_vector_set_length_x[] = "vector-set-length!";
-#ifdef __STDC__
-SCM
-scm_vector_set_length_x (SCM vect, SCM len)
-#else
+
SCM
scm_vector_set_length_x (vect, len)
SCM vect;
SCM len;
-#endif
{
long l;
scm_sizet siz;
@@ -166,21 +176,16 @@ scm_vector_set_length_x (vect, len)
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
-#ifdef __STDC__
+
SCM
scm_makflo (float x)
-#else
-SCM
-scm_makflo (x)
- float x;
-#endif
{
SCM z;
if (x == 0.0)
return scm_flo0;
SCM_NEWCELL (z);
SCM_DEFER_INTS;
- SCM_CAR (z) = scm_tc_flo;
+ SCM_SETCAR (z, scm_tc_flo);
SCM_FLO (z) = x;
SCM_ALLOW_INTS;
return z;
@@ -188,15 +193,11 @@ scm_makflo (x)
#endif
#endif
-#ifdef __STDC__
-SCM
-scm_make_uve (long k, SCM prot)
-#else
+
SCM
scm_make_uve (k, prot)
long k;
SCM prot;
-#endif
{
SCM v;
long i, type;
@@ -285,14 +286,10 @@ scm_make_uve (k, prot)
}
SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length);
-#ifdef __STDC__
-SCM
-scm_uniform_vector_length (SCM v)
-#else
+
SCM
scm_uniform_vector_length (v)
SCM v;
-#endif
{
SCM_ASRTGO (SCM_NIMP (v), badarg1);
switch SCM_TYP7
@@ -318,15 +315,11 @@ scm_uniform_vector_length (v)
}
SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p);
-#ifdef __STDC__
-SCM
-scm_array_p (SCM v, SCM prot)
-#else
+
SCM
scm_array_p (v, prot)
SCM v;
SCM prot;
-#endif
{
int nprot;
int enclosed;
@@ -389,14 +382,10 @@ loop:
SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank);
-#ifdef __STDC__
-SCM
-scm_array_rank (SCM ra)
-#else
+
SCM
scm_array_rank (ra)
SCM ra;
-#endif
{
if (SCM_IMP (ra))
return SCM_INUM0;
@@ -426,14 +415,10 @@ scm_array_rank (ra)
SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions);
-#ifdef __STDC__
-SCM
-scm_array_dimensions (SCM ra)
-#else
+
SCM
scm_array_dimensions (ra)
SCM ra;
-#endif
{
SCM res = SCM_EOL;
scm_sizet k;
@@ -474,16 +459,12 @@ scm_array_dimensions (ra)
static char s_bad_ind[] = "Bad scm_array index";
-#ifdef __STDC__
-long
-scm_aind (SCM ra, SCM args, char *what)
-#else
+
long
scm_aind (ra, args, what)
- SCM ra,
+ SCM ra;
SCM args;
char *what;
-#endif
{
SCM ind;
register long j;
@@ -491,9 +472,8 @@ scm_aind (ra, args, what)
register scm_sizet k = SCM_ARRAY_NDIM (ra);
scm_array_dim *s = SCM_ARRAY_DIMS (ra);
if (SCM_INUMP (args))
-
{
- SCM_ASSERT (1 == k, SCM_UNDEFINED, SCM_WNA, what);
+ SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL);
return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
}
while (k && SCM_NIMP (args))
@@ -507,26 +487,23 @@ scm_aind (ra, args, what)
k--;
s++;
}
- SCM_ASSERT (0 == k && SCM_NULLP (args), SCM_UNDEFINED, SCM_WNA, what);
+ SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA,
+ NULL);
return pos;
}
-#ifdef __STDC__
-SCM
-scm_make_ra (int ndim)
-#else
+
SCM
scm_make_ra (ndim)
int ndim;
-#endif
{
SCM ra;
SCM_NEWCELL (ra);
SCM_DEFER_INTS;
SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
"array"));
- SCM_CAR (ra) = ((long) ndim << 17) + scm_tc16_array;
+ SCM_SETCAR (ra, ((long) ndim << 17) + scm_tc16_array);
SCM_ARRAY_V (ra) = scm_nullvect;
SCM_ALLOW_INTS;
return ra;
@@ -535,15 +512,11 @@ scm_make_ra (ndim)
static char s_bad_spec[] = "Bad scm_array dimension";
/* Increments will still need to be set. */
-#ifdef __STDC__
-SCM
-scm_shap2ra (SCM args, char *what)
-#else
+
SCM
scm_shap2ra (args, what)
SCM args;
char *what;
-#endif
{
scm_array_dim *s;
SCM ra, spec, sp;
@@ -578,16 +551,12 @@ scm_shap2ra (args, what)
}
SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array);
-#ifdef __STDC__
-SCM
-scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill)
-#else
+
SCM
scm_dimensions_to_uniform_array (dims, prot, fill)
SCM dims;
SCM prot;
SCM fill;
-#endif
{
scm_sizet k, vlen = 1;
long rlen = 1;
@@ -600,7 +569,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
answer = scm_make_uve (SCM_INUM (dims), prot);
if (SCM_NNULLP (fill))
{
- SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array);
+ SCM_ASSERT (1 == scm_ilength (fill),
+ scm_makfrom0str (s_dimensions_to_uniform_array),
+ SCM_WNA, NULL);
scm_array_fill_x (answer, SCM_CAR (fill));
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
@@ -614,7 +585,7 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)),
dims, SCM_ARG1, s_dimensions_to_uniform_array);
ra = scm_shap2ra (dims, s_dimensions_to_uniform_array);
- SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS;
+ SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
s = SCM_ARRAY_DIMS (ra);
k = SCM_ARRAY_NDIM (ra);
while (k--)
@@ -656,7 +627,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
}
if (SCM_NNULLP (fill))
{
- SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array);
+ SCM_ASSERT (1 == scm_ilength (fill),
+ scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
+ NULL);
scm_array_fill_x (ra, SCM_CAR (fill));
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
@@ -669,43 +642,37 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
return ra;
}
-#ifdef __STDC__
-void
-scm_ra_set_contp (SCM ra)
-#else
+
void
scm_ra_set_contp (ra)
SCM ra;
-#endif
{
scm_sizet k = SCM_ARRAY_NDIM (ra);
- long inc;
if (k)
- inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
{
- if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
+ long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
+ while (k--)
{
- SCM_CAR (ra) &= ~SCM_ARRAY_CONTIGUOUS;
- return;
+ if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
+ {
+ SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS);
+ return;
+ }
+ inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd
+ - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
}
- inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
}
- SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS;
+ SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
}
SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array);
-#ifdef __STDC__
-SCM
-scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims)
-#else
+
SCM
scm_make_shared_array (oldra, mapfunc, dims)
SCM oldra;
SCM mapfunc;
SCM dims;
-#endif
{
SCM ra;
SCM inds, indptr;
@@ -771,7 +738,7 @@ scm_make_shared_array (oldra, mapfunc, dims)
{
if (s[k].ubnd > s[k].lbnd)
{
- SCM_CAR (indptr) = SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1);
+ SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1));
imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
if (SCM_ARRAYP (oldra))
@@ -814,26 +781,23 @@ scm_make_shared_array (oldra, mapfunc, dims)
/* args are RA . DIMS */
SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array);
-#ifdef __STDC__
-SCM
-scm_transpose_array (SCM args)
-#else
+
SCM
scm_transpose_array (args)
SCM args;
-#endif
{
SCM ra, res, vargs, *ve = &vargs;
scm_array_dim *s, *r;
int ndim, i, k;
- SCM_ASSERT (SCM_NIMP (args), SCM_UNDEFINED, SCM_WNA, s_transpose_array);
+ SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array),
+ SCM_WNA, NULL);
ra = SCM_CAR (args);
+ SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array);
args = SCM_CDR (args);
- switch SCM_TYP7
- (ra)
+ switch (SCM_TYP7 (ra))
{
default:
- badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array);
+ badarg:scm_wta (ra, (char *) SCM_ARGn, s_transpose_array);
case scm_tc7_bvect:
case scm_tc7_string:
case scm_tc7_byvect:
@@ -846,14 +810,19 @@ scm_transpose_array (args)
#ifdef LONGLONGS
case scm_tc7_llvect:
#endif
- SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), SCM_UNDEFINED, SCM_WNA, s_transpose_array);
- SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_ARG1, s_transpose_array);
+ SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
+ scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2,
+ s_transpose_array);
+ SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE,
+ s_transpose_array);
return ra;
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
vargs = scm_vector (args);
- SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), SCM_UNDEFINED, SCM_WNA, s_transpose_array);
- ve = SCM_VELTS (vargs);
+ SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
+ scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ ve = SCM_VELTS (vargs);
ndim = 0;
for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
{
@@ -904,19 +873,16 @@ scm_transpose_array (args)
/* args are RA . AXES */
SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array);
-#ifdef __STDC__
-SCM
-scm_enclose_array (SCM axes)
-#else
+
SCM
scm_enclose_array (axes)
SCM axes;
-#endif
{
SCM axv, ra, res, ra_inr;
scm_array_dim vdim, *s = &vdim;
int ndim, j, k, ninr, noutr;
- SCM_ASSERT (SCM_NIMP (axes), SCM_UNDEFINED, SCM_WNA, s_enclose_array);
+ SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA,
+ NULL);
ra = SCM_CAR (axes);
axes = SCM_CDR (axes);
if (SCM_NULLP (axes))
@@ -960,7 +926,8 @@ scm_enclose_array (axes)
}
noutr = ndim - ninr;
axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0));
- SCM_ASSERT (0 <= noutr && 0 <= ninr, SCM_UNDEFINED, SCM_WNA, s_enclose_array);
+ SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array),
+ SCM_WNA, NULL);
res = scm_make_ra (noutr);
SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
SCM_ARRAY_V (res) = ra_inr;
@@ -989,21 +956,18 @@ scm_enclose_array (axes)
SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p);
-#ifdef __STDC__
-SCM
-scm_array_in_bounds_p (SCM args)
-#else
+
SCM
scm_array_in_bounds_p (args)
SCM args;
-#endif
{
SCM v, ind = SCM_EOL;
long pos = 0;
register scm_sizet k;
register long j;
scm_array_dim *s;
- SCM_ASSERT (SCM_NIMP (args), args, SCM_WNA, s_array_in_bounds_p);
+ SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p),
+ SCM_WNA, NULL);
v = SCM_CAR (args);
args = SCM_CDR (args);
SCM_ASRTGO (SCM_NIMP (v), badarg1);
@@ -1021,7 +985,7 @@ tail:
{
default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p);
- wna:scm_wta (args, (char *) SCM_WNA, s_array_in_bounds_p);
+ wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p));
case scm_tc7_smob:
k = SCM_ARRAY_NDIM (v);
s = SCM_ARRAY_DIMS (v);
@@ -1072,25 +1036,20 @@ tail:
SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref);
-#ifdef __STDC__
-SCM
-scm_uniform_vector_ref (SCM v, SCM args)
-#else
+
SCM
scm_uniform_vector_ref (v, args)
SCM v;
SCM args;
-#endif
{
long pos;
- if (SCM_IMP (v))
+ if (SCM_IMP (v))
{
SCM_ASRTGO (SCM_NULLP (args), badarg);
return v;
}
else if (SCM_ARRAYP (v))
-
{
pos = scm_aind (v, args, s_uniform_vector_ref);
v = SCM_ARRAY_V (v);
@@ -1117,9 +1076,11 @@ scm_uniform_vector_ref (v, args)
default:
if (SCM_NULLP (args))
return v;
- badarg:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
- outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_uniform_vector_ref);
- wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_uniform_vector_ref);
+ badarg:
+ scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
+ abort ();
+ outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos));
+ wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref));
case scm_tc7_smob:
{ /* enclosed */
int k = SCM_ARRAY_NDIM (v);
@@ -1179,16 +1140,12 @@ scm_uniform_vector_ref (v, args)
/* Internal version of scm_uniform_vector_ref for uves that does no error checking and
tries to recycle conses. (Make *sure* you want them recycled.) */
-#ifdef __STDC__
-SCM
-scm_cvref (SCM v, scm_sizet pos, SCM last)
-#else
+
SCM
scm_cvref (v, pos, last)
SCM v;
scm_sizet pos;
SCM last;
-#endif
{
switch SCM_TYP7
(v)
@@ -1272,21 +1229,18 @@ scm_cvref (v, pos, last)
SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x);
-#ifdef __STDC__
-SCM
-scm_array_set_x (SCM v, SCM obj, SCM args)
-#else
+
+/* Note that args may be a list or an immediate object, depending which
+ PROC is used (and it's called from C too). */
SCM
scm_array_set_x (v, obj, args)
SCM v;
SCM obj;
SCM args;
-#endif
{
long pos;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
if (SCM_ARRAYP (v))
-
{
pos = scm_aind (v, args, s_array_set_x);
v = SCM_ARRAY_V (v);
@@ -1294,25 +1248,26 @@ scm_array_set_x (v, obj, args)
else
{
if (SCM_NIMP (args))
-
{
- SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_array_set_x);
- pos = SCM_INUM (SCM_CAR (args));
+ SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
+ SCM_ARG3, s_array_set_x);
SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
+ pos = SCM_INUM (SCM_CAR (args));
}
else
{
- SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x);
+ SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, s_array_set_x);
pos = SCM_INUM (args);
}
SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
}
switch (SCM_TYP7 (v))
{
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
- outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_array_set_x);
- wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_array_set_x);
+ default: badarg1:
+ scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
+ abort ();
+ outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
+ wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
case scm_tc7_smob: /* enclosed */
goto badarg1;
case scm_tc7_bvect:
@@ -1321,38 +1276,38 @@ scm_array_set_x (v, obj, args)
else if (SCM_BOOL_T == obj)
SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT));
else
- badarg3:scm_wta (obj, (char *) SCM_ARG3, s_array_set_x);
+ badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x);
break;
case scm_tc7_string:
- SCM_ASRTGO (SCM_ICHRP (obj), badarg3);
+ SCM_ASRTGO (SCM_ICHRP (obj), badobj);
SCM_CHARS (v)[pos] = SCM_ICHR (obj);
break;
case scm_tc7_byvect:
if (SCM_ICHRP (obj))
- obj = SCM_MAKINUM (SCM_ICHR (obj));
- SCM_ASRTGO (SCM_INUMP (obj), badarg3);
+ obj = SCM_MAKINUM ((char) SCM_ICHR (obj));
+ SCM_ASRTGO (SCM_INUMP (obj), badobj);
((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj);
break;
# ifdef SCM_INUMS_ONLY
case scm_tc7_uvect:
- SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3);
+ SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj);
case scm_tc7_ivect:
- SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
+ SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
# else
case scm_tc7_uvect:
- SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG3, s_array_set_x); break;
+ SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break;
case scm_tc7_ivect:
- SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break;
+ SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG2, s_array_set_x); break;
# endif
break;
case scm_tc7_svect:
- SCM_ASRTGO (SCM_INUMP (obj), badarg3);
+ SCM_ASRTGO (SCM_INUMP (obj), badobj);
((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
break;
#ifdef LONGLONGS
case scm_tc7_llvect:
- ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG3, s_array_set_x);
+ ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x);
break;
#endif
@@ -1360,16 +1315,16 @@ scm_array_set_x (v, obj, args)
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3);
+ SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
break;
#endif
case scm_tc7_dvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3);
+ SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
break;
case scm_tc7_cvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3);
+ SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj);
((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj);
((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0;
break;
@@ -1382,15 +1337,11 @@ scm_array_set_x (v, obj, args)
}
SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);
-#ifdef __STDC__
-SCM
-scm_array_contents (SCM ra, SCM strict)
-#else
+
SCM
scm_array_contents (ra, strict)
SCM ra;
SCM strict;
-#endif
{
SCM sra;
if (SCM_IMP (ra))
@@ -1448,15 +1399,11 @@ scm_array_contents (ra, strict)
}
}
-#ifdef __STDC__
-SCM
-scm_ra2contig (SCM ra, int copy)
-#else
+
SCM
scm_ra2contig (ra, copy)
SCM ra;
int copy;
-#endif
{
SCM ret;
long inc = 1;
@@ -1490,37 +1437,40 @@ scm_ra2contig (ra, copy)
-SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 1, 0, scm_uniform_array_read_x);
-#ifdef __STDC__
-SCM
-scm_uniform_array_read_x (SCM ra, SCM port)
-#else
+SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x);
+
SCM
-scm_uniform_array_read_x (ra, port)
+scm_uniform_array_read_x (ra, port_or_fd, start, end)
SCM ra;
- SCM port;
-#endif
+ SCM port_or_fd;
+ SCM start;
+ SCM end;
{
- SCM cra, v = ra;
- long sz, len, ans;
- long start = 0;
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINFPORTP (port), port, SCM_ARG2, s_uniform_array_read_x);
+ SCM cra = SCM_UNDEFINED, v = ra;
+ long sz, vlen, ans;
+ long cstart = 0;
+ long cend;
+ long offset = 0;
+
SCM_ASRTGO (SCM_NIMP (v), badarg1);
- len = SCM_LENGTH (v);
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_cur_inp;
+ else
+ SCM_ASSERT (SCM_INUMP (port_or_fd)
+ || (SCM_NIMP (port_or_fd) && SCM_OPINFPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, s_uniform_array_read_x);
+ vlen = SCM_LENGTH (v);
+
loop:
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x);
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
cra = scm_ra2contig (ra, 0);
- start = SCM_ARRAY_BASE (cra);
- len = SCM_ARRAY_DIMS (cra)->inc *
+ cstart += SCM_ARRAY_BASE (cra);
+ vlen = SCM_ARRAY_DIMS (cra)->inc *
(SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
v = SCM_ARRAY_V (cra);
goto loop;
@@ -1529,8 +1479,8 @@ loop:
sz = sizeof (char);
break;
case scm_tc7_bvect:
- len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- start /= SCM_LONG_BIT;
+ vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ cstart /= SCM_LONG_BIT;
case scm_tc7_uvect:
case scm_tc7_ivect:
sz = sizeof (long);
@@ -1557,61 +1507,102 @@ loop:
break;
#endif
}
- /* An ungetc before an fread will not work on some systems if setbuf(0).
- do #define NOSETBUF in scmfig.h to fix this. */
- if (SCM_CRDYP (port))
+
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ offset =
+ scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x);
+
+ if (offset < 0 || offset >= cend)
+ scm_out_of_range (s_uniform_array_read_x, start);
+
+ if (!SCM_UNBNDP (end))
+ {
+ long tend =
+ scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x);
+
+ if (tend <= offset || tend > cend)
+ scm_out_of_range (s_uniform_array_read_x, end);
+ cend = tend;
+ }
+ }
- { /* UGGH!!! */
- ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port));
- SCM_CLRDY (port); /* Clear ungetted char */
+ if (SCM_NIMP (port_or_fd))
+ {
+ /* if we have stored a character from the port in our own buffer,
+ push it back onto the stream. */
+ /* An ungetc before an fread will not work on some systems if
+ setbuf(0). do #define NOSETBUF in scmfig.h to fix this. */
+ if (SCM_CRDYP (port_or_fd))
+ {
+ ungetc (SCM_CGETUN (port_or_fd), (FILE *)SCM_STREAM (port_or_fd));
+ SCM_CLRDY (port_or_fd); /* Clear ungetted char */
+ }
+ SCM_SYSCALL (ans = fread (SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) sz, (scm_sizet) (cend - offset),
+ (FILE *)SCM_STREAM (port_or_fd)));
+ }
+ else /* file descriptor. */
+ {
+ SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
+ SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) (sz * (cend - offset))));
+ if (ans == -1)
+ scm_syserror (s_uniform_array_read_x);
}
- SCM_SYSCALL (ans = fread (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port)));
if (SCM_TYP7 (v) == scm_tc7_bvect)
ans *= SCM_LONG_BIT;
+
if (v != ra && cra != ra)
scm_array_copy_x (cra, ra);
+
return SCM_MAKINUM (ans);
}
-SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 1, 0, scm_uniform_array_write);
-#ifdef __STDC__
-SCM
-scm_uniform_array_write (SCM v, SCM port)
-#else
+SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write);
+
SCM
-scm_uniform_array_write (v, port)
+scm_uniform_array_write (v, port_or_fd, start, end)
SCM v;
- SCM port;
-#endif
+ SCM port_or_fd;
+ SCM start;
+ SCM end;
{
- long sz, len, ans;
- long start = 0;
- if (SCM_UNBNDP (port))
- port = scm_cur_outp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTFPORTP (port), port, SCM_ARG2, s_uniform_array_write);
+ long sz, vlen, ans;
+ long offset = 0;
+ long cstart = 0;
+ long cend;
+
SCM_ASRTGO (SCM_NIMP (v), badarg1);
- len = SCM_LENGTH (v);
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_cur_outp;
+ else
+ SCM_ASSERT (SCM_INUMP (port_or_fd)
+ || (SCM_NIMP (port_or_fd) && SCM_OPOUTFPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, s_uniform_array_write);
+ vlen = SCM_LENGTH (v);
+
loop:
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write);
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
v = scm_ra2contig (v, 1);
- start = SCM_ARRAY_BASE (v);
- len = SCM_ARRAY_DIMS (v)->inc * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
+ cstart = SCM_ARRAY_BASE (v);
+ vlen = SCM_ARRAY_DIMS (v)->inc
+ * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
v = SCM_ARRAY_V (v);
goto loop;
- case scm_tc7_byvect:
case scm_tc7_string:
+ case scm_tc7_byvect:
sz = sizeof (char);
break;
case scm_tc7_bvect:
- len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- start /= SCM_LONG_BIT;
+ vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ cstart /= SCM_LONG_BIT;
case scm_tc7_uvect:
case scm_tc7_ivect:
sz = sizeof (long);
@@ -1638,9 +1629,44 @@ loop:
break;
#endif
}
- SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port)));
+
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ offset =
+ scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write);
+
+ if (offset < 0 || offset >= cend)
+ scm_out_of_range (s_uniform_array_write, start);
+
+ if (!SCM_UNBNDP (end))
+ {
+ long tend =
+ scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write);
+
+ if (tend <= offset || tend > cend)
+ scm_out_of_range (s_uniform_array_write, end);
+ cend = tend;
+ }
+ }
+
+ if (SCM_NIMP (port_or_fd))
+ {
+ SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) sz, (scm_sizet) (cend - offset),
+ (FILE *)SCM_STREAM (port_or_fd)));
+ }
+ else /* file descriptor. */
+ {
+ SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
+ SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) (sz * (cend - offset))));
+ if (ans == -1)
+ scm_syserror (s_uniform_array_write);
+ }
if (SCM_TYP7 (v) == scm_tc7_bvect)
ans *= SCM_LONG_BIT;
+
return SCM_MAKINUM (ans);
}
@@ -1649,15 +1675,11 @@ static char cnt_tab[16] =
{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count);
-#ifdef __STDC__
-SCM
-scm_bit_count (SCM item, SCM seq)
-#else
+
SCM
scm_bit_count (item, seq)
SCM item;
SCM seq;
-#endif
{
long i;
register unsigned long cnt = 0, w;
@@ -1690,16 +1712,12 @@ scm_bit_count (item, seq)
SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position);
-#ifdef __STDC__
-SCM
-scm_bit_position (SCM item, SCM v, SCM k)
-#else
+
SCM
scm_bit_position (item, v, k)
SCM item;
SCM v;
SCM k;
-#endif
{
long i, lenw, xbits, pos = SCM_INUM (k);
register unsigned long w;
@@ -1763,16 +1781,12 @@ scm_bit_position (item, v, k)
SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x);
-#ifdef __STDC__
-SCM
-scm_bit_set_star_x (SCM v, SCM kv, SCM obj)
-#else
+
SCM
scm_bit_set_star_x (v, kv, obj)
SCM v;
SCM kv;
SCM obj;
-#endif
{
register long i, k, vlen;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
@@ -1825,16 +1839,12 @@ scm_bit_set_star_x (v, kv, obj)
SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star);
-#ifdef __STDC__
-SCM
-scm_bit_count_star (SCM v, SCM kv, SCM obj)
-#else
+
SCM
scm_bit_count_star (v, kv, obj)
SCM v;
SCM kv;
SCM obj;
-#endif
{
register long i, vlen, count = 0;
register unsigned long k;
@@ -1896,14 +1906,10 @@ scm_bit_count_star (v, kv, obj)
SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x);
-#ifdef __STDC__
-SCM
-scm_bit_invert_x (SCM v)
-#else
+
SCM
scm_bit_invert_x (v)
SCM v;
-#endif
{
register long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
@@ -1922,72 +1928,10 @@ scm_bit_invert_x (v)
}
-SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x);
-#ifdef __STDC__
-SCM
-scm_string_upcase_x (SCM v)
-#else
-SCM
-scm_string_upcase_x (v)
- SCM v;
-#endif
-{
- register long k;
- register unsigned char *cs;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- k = SCM_LENGTH (v);
- switch SCM_TYP7
- (v)
- {
- case scm_tc7_string:
- cs = SCM_UCHARS (v);
- while (k--)
- cs[k] = scm_upcase(cs[k]);
- break;
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x);
- }
- return v;
-}
-
-SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x);
-#ifdef __STDC__
-SCM
-scm_string_downcase_x (SCM v)
-#else
-SCM
-scm_string_downcase_x (v)
- SCM v;
-#endif
-{
- register long k;
- register unsigned char *cs;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- k = SCM_LENGTH (v);
- switch SCM_TYP7
- (v)
- {
- case scm_tc7_string:
- cs = SCM_UCHARS (v);
- while (k--)
- cs[k] = scm_downcase(cs[k]);
- break;
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x);
- }
- return v;
-}
-
-
-#ifdef __STDC__
-SCM
-scm_istr2bve (char *str, long len)
-#else
SCM
scm_istr2bve (str, len)
char *str;
long len;
-#endif
{
SCM v = scm_make_uve (len, SCM_BOOL_T);
long *data = (long *) SCM_VELTS (v);
@@ -2016,16 +1960,14 @@ scm_istr2bve (str, len)
}
-#ifdef __STDC__
-static SCM
-ra2l (SCM ra, scm_sizet base, scm_sizet k)
-#else
+
+static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k));
+
static SCM
ra2l (ra, base, k)
SCM ra;
scm_sizet base;
scm_sizet k;
-#endif
{
register SCM res = SCM_EOL;
register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
@@ -2054,14 +1996,10 @@ ra2l (ra, base, k)
SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list);
-#ifdef __STDC__
-SCM
-scm_array_to_list (SCM v)
-#else
+
SCM
scm_array_to_list (v)
SCM v;
-#endif
{
SCM res = SCM_EOL;
register long k;
@@ -2160,19 +2098,16 @@ scm_array_to_list (v)
static char s_bad_ralst[] = "Bad scm_array contents scm_list";
-static int l2ra ();
+
+static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k));
SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array);
-#ifdef __STDC__
-SCM
-scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst)
-#else
+
SCM
scm_list_to_uniform_array (ndim, prot, lst)
SCM ndim;
SCM prot;
SCM lst;
-#endif
{
SCM shp = SCM_EOL;
SCM row = lst;
@@ -2184,7 +2119,7 @@ scm_list_to_uniform_array (ndim, prot, lst)
while (k--)
{
n = scm_ilength (row);
- SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array);
+ SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array);
shp = scm_cons (SCM_MAKINUM (n), shp);
if (SCM_NIMP (row))
row = SCM_CAR (row);
@@ -2210,18 +2145,12 @@ scm_list_to_uniform_array (ndim, prot, lst)
return SCM_BOOL_F;
}
-
-#ifdef __STDC__
-static int
-l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k)
-#else
static int
l2ra (lst, ra, base, k)
SCM lst;
SCM ra;
scm_sizet base;
scm_sizet k;
-#endif
{
register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
@@ -2257,18 +2186,16 @@ l2ra (lst, ra, base, k)
return ok;
}
-#ifdef __STDC__
-static void
-rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, int writing)
-#else
+
+static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate));
+
static void
-rapr1 (ra, j, k, port, writing)
+rapr1 (ra, j, k, port, pstate)
SCM ra;
scm_sizet j;
scm_sizet k;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
long inc = 1;
long n = SCM_LENGTH (ra);
@@ -2282,12 +2209,12 @@ tail:
{
SCM_ARRAY_BASE (ra) = j;
if (n-- > 0)
- scm_iprin1 (ra, port, writing);
+ scm_iprin1 (ra, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_ARRAY_BASE (ra) = j;
- scm_iprin1 (ra, port, writing);
+ scm_iprin1 (ra, port, pstate);
}
break;
}
@@ -2298,14 +2225,14 @@ tail:
for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
{
scm_gen_putc ('(', port);
- rapr1 (ra, j, k + 1, port, writing);
+ rapr1 (ra, j, k + 1, port, pstate);
scm_gen_puts (scm_regular_string, ") ", port);
j += inc;
}
if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
{ /* could be zero size. */
scm_gen_putc ('(', port);
- rapr1 (ra, j, k + 1, port, writing);
+ rapr1 (ra, j, k + 1, port, pstate);
scm_gen_putc (')', port);
}
break;
@@ -2322,21 +2249,21 @@ tail:
goto tail;
default:
if (n-- > 0)
- scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, writing);
+ scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
- scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing);
+ scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
}
break;
case scm_tc7_string:
if (n-- > 0)
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
- if (writing)
+ scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
+ if (SCM_WRITINGP (pstate))
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
+ scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
}
else
for (j += inc; n-- > 0; j += inc)
@@ -2380,12 +2307,12 @@ tail:
{
SCM z = scm_makflo (1.0);
SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
}
}
break;
@@ -2395,12 +2322,12 @@ tail:
{
SCM z = scm_makdbl (1.0 / 3.0, 0.0);
SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
}
}
break;
@@ -2410,13 +2337,13 @@ tail:
SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]);
SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, writing);
+ scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, writing);
+ scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
}
}
break;
@@ -2425,16 +2352,12 @@ tail:
}
-#ifdef __STDC__
-int
-scm_raprin1 (SCM exp, SCM port, int writing)
-#else
+
int
-scm_raprin1 (exp, port, writing)
+scm_raprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
SCM v = exp;
scm_sizet base = 0;
@@ -2452,7 +2375,7 @@ tail:
{
scm_gen_puts (scm_regular_string, "<enclosed-array ", port);
- rapr1 (exp, base, 0, port, writing);
+ rapr1 (exp, base, 0, port, pstate);
scm_gen_putc ('>', port);
return 1;
}
@@ -2526,20 +2449,16 @@ tail:
#endif /*SCM_FLOATS*/
}
scm_gen_putc ('(', port);
- rapr1 (exp, base, 0, port, writing);
+ rapr1 (exp, base, 0, port, pstate);
scm_gen_putc (')', port);
return 1;
}
SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype);
-#ifdef __STDC__
-SCM
-scm_array_prototype (SCM ra)
-#else
+
SCM
scm_array_prototype (ra)
SCM ra;
-#endif
{
int enclosed = 0;
SCM_ASRTGO (SCM_NIMP (ra), badarg);
@@ -2586,14 +2505,12 @@ loop:
}
}
-#ifdef __STDC__
-static SCM
-markra (SCM ptr)
-#else
+
+static SCM markra SCM_P ((SCM ptr));
+
static SCM
markra (ptr)
SCM ptr;
-#endif
{
if SCM_GC8MARKP
(ptr) return SCM_BOOL_F;
@@ -2601,14 +2518,12 @@ markra (ptr)
return SCM_ARRAY_V (ptr);
}
-#ifdef __STDC__
-static scm_sizet
-freera (SCM ptr)
-#else
+
+static scm_sizet freera SCM_P ((SCM ptr));
+
static scm_sizet
freera (ptr)
SCM ptr;
-#endif
{
scm_must_free (SCM_CHARS (ptr));
return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
@@ -2619,13 +2534,9 @@ static scm_smobfuns rasmob =
/* This must be done after scm_init_scl() */
-#ifdef __STDC__
-void
-scm_init_unif (void)
-#else
+
void
scm_init_unif ()
-#endif
{
#include "unif.x"
scm_tc16_array = scm_newsmob (&rasmob);
@@ -2634,42 +2545,21 @@ scm_init_unif ()
#else /* ARRAYS */
-#ifdef __STDC__
-int
-scm_raprin1 (SCM exp, SCM port, int writing)
-#else
+
int
-scm_raprin1 (exp, port, writing)
+scm_raprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
return 0;
}
-#ifdef __STDC__
-SCM
-scm_istr2bve (char *str, long len)
-#else
+
SCM
scm_istr2bve (str, len)
char *str;
long len;
-#endif
-{
- return SCM_BOOL_F;
-}
-
-#ifdef __STDC__
-SCM
-scm_array_equal_p (SCM ra0, SCM ra1)
-#else
-SCM
-scm_array_equal_p (ra0, ra1)
- SCM ra0;
- SCM ra1;
-#endif
{
return SCM_BOOL_F;
}
@@ -2677,11 +2567,8 @@ scm_array_equal_p (ra0, ra1)
void
scm_init_unif ()
{
+#include "unif.x"
scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
}
#endif /* ARRAYS */
-
-
-
-
diff --git a/libguile/unif.h b/libguile/unif.h
index 077621c6f..a63da0cee 100644
--- a/libguile/unif.h
+++ b/libguile/unif.h
@@ -2,7 +2,7 @@
#ifndef UNIFH
#define UNIFH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
typedef struct scm_array
@@ -73,92 +73,40 @@ extern long scm_tc16_array;
#define SCM_HUGE_LENGTH(x) (SCM_LENGTH_MAX==SCM_LENGTH(x) ? *((long *)SCM_VELTS(x)) : SCM_LENGTH(x))
-#ifdef __STDC__
-extern SCM scm_vector_set_length_x (SCM vect, SCM len);
-extern SCM scm_makflo (float x);
-extern SCM scm_make_uve (long k, SCM prot);
-extern SCM scm_uniform_vector_length (SCM v);
-extern SCM scm_array_p (SCM v, SCM prot);
-extern SCM scm_array_rank (SCM ra);
-extern SCM scm_array_dimensions (SCM ra);
-extern long scm_aind (SCM ra, SCM args, char *what);
-extern SCM scm_make_ra (int ndim);
-extern SCM scm_shap2ra (SCM args, char *what);
-extern SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill);
-extern void scm_ra_set_contp (SCM ra);
-extern SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
-extern SCM scm_transpose_array (SCM args);
-extern SCM scm_enclose_array (SCM axes);
-extern SCM scm_array_in_bounds_p (SCM args);
-extern SCM scm_uniform_vector_ref (SCM v, SCM args);
-extern SCM scm_cvref (SCM v, scm_sizet pos, SCM last);
-extern SCM scm_array_set_x (SCM v, SCM obj, SCM args);
-extern SCM scm_array_contents (SCM ra, SCM strict);
-extern SCM scm_ra2contig (SCM ra, int copy);
-extern SCM scm_uniform_array_read_x (SCM ra, SCM port);
-extern SCM scm_uniform_array_write (SCM v, SCM port);
-extern SCM scm_bit_count (SCM item, SCM seq);
-extern SCM scm_bit_position (SCM item, SCM v, SCM k);
-extern SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
-extern SCM scm_bit_count_star (SCM v, SCM kv, SCM obj);
-extern SCM scm_bit_invert_x (SCM v);
-extern SCM scm_string_upcase_x (SCM v);
-extern SCM scm_string_downcase_x (SCM v);
-extern SCM scm_istr2bve (char *str, long len);
-extern SCM scm_array_to_list (SCM v);
-extern SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst);
-extern int scm_raprin1 (SCM exp, SCM port, int writing);
-extern SCM scm_array_prototype (SCM ra);
-extern void scm_init_unif (void);
-extern int scm_raprin1 (SCM exp, SCM port, int writing);
-extern SCM scm_istr2bve (char *str, long len);
-extern SCM scm_array_equal_p (SCM ra0, SCM ra1);
-
-#else /* STDC */
-extern SCM scm_vector_set_length_x ();
-extern SCM scm_makflo ();
-extern SCM scm_make_uve ();
-extern SCM scm_uniform_vector_length ();
-extern SCM scm_array_p ();
-extern SCM scm_array_rank ();
-extern SCM scm_array_dimensions ();
-extern long scm_aind ();
-extern SCM scm_make_ra ();
-extern SCM scm_shap2ra ();
-extern SCM scm_dimensions_to_uniform_array ();
-extern void scm_ra_set_contp ();
-extern SCM scm_make_shared_array ();
-extern SCM scm_transpose_array ();
-extern SCM scm_enclose_array ();
-extern SCM scm_array_in_bounds_p ();
-extern SCM scm_uniform_vector_ref ();
-extern SCM scm_cvref ();
-extern SCM scm_array_set_x ();
-extern SCM scm_array_contents ();
-extern SCM scm_ra2contig ();
-extern SCM scm_uniform_array_read_x ();
-extern SCM scm_uniform_array_write ();
-extern SCM scm_bit_count ();
-extern SCM scm_bit_position ();
-extern SCM scm_bit_set_star_x ();
-extern SCM scm_bit_count_star ();
-extern SCM scm_bit_invert_x ();
-extern SCM scm_string_upcase_x ();
-extern SCM scm_string_downcase_x ();
-extern SCM scm_istr2bve ();
-extern SCM scm_array_to_list ();
-extern SCM scm_list_to_uniform_array ();
-extern int scm_raprin1 ();
-extern SCM scm_array_prototype ();
-extern void scm_init_unif ();
-extern int scm_raprin1 ();
-extern SCM scm_istr2bve ();
-extern SCM scm_array_equal_p ();
-
-#endif /* STDC */
-
-
-
+extern SCM scm_vector_set_length_x SCM_P ((SCM vect, SCM len));
+extern SCM scm_makflo SCM_P ((float x));
+extern SCM scm_make_uve SCM_P ((long k, SCM prot));
+extern SCM scm_uniform_vector_length SCM_P ((SCM v));
+extern SCM scm_array_p SCM_P ((SCM v, SCM prot));
+extern SCM scm_array_rank SCM_P ((SCM ra));
+extern SCM scm_array_dimensions SCM_P ((SCM ra));
+extern long scm_aind SCM_P ((SCM ra, SCM args, char *what));
+extern SCM scm_make_ra SCM_P ((int ndim));
+extern SCM scm_shap2ra SCM_P ((SCM args, char *what));
+extern SCM scm_dimensions_to_uniform_array SCM_P ((SCM dims, SCM prot, SCM fill));
+extern void scm_ra_set_contp SCM_P ((SCM ra));
+extern SCM scm_make_shared_array SCM_P ((SCM oldra, SCM mapfunc, SCM dims));
+extern SCM scm_transpose_array SCM_P ((SCM args));
+extern SCM scm_enclose_array SCM_P ((SCM axes));
+extern SCM scm_array_in_bounds_p SCM_P ((SCM args));
+extern SCM scm_uniform_vector_ref SCM_P ((SCM v, SCM args));
+extern SCM scm_cvref SCM_P ((SCM v, scm_sizet pos, SCM last));
+extern SCM scm_array_set_x SCM_P ((SCM v, SCM obj, SCM args));
+extern SCM scm_array_contents SCM_P ((SCM ra, SCM strict));
+extern SCM scm_ra2contig SCM_P ((SCM ra, int copy));
+extern SCM scm_uniform_array_read_x SCM_P ((SCM ra, SCM port_or_fd, SCM start, SCM end));
+extern SCM scm_uniform_array_write SCM_P ((SCM v, SCM port_or_fd, SCM start, SCM end));
+extern SCM scm_bit_count SCM_P ((SCM item, SCM seq));
+extern SCM scm_bit_position SCM_P ((SCM item, SCM v, SCM k));
+extern SCM scm_bit_set_star_x SCM_P ((SCM v, SCM kv, SCM obj));
+extern SCM scm_bit_count_star SCM_P ((SCM v, SCM kv, SCM obj));
+extern SCM scm_bit_invert_x SCM_P ((SCM v));
+extern SCM scm_istr2bve SCM_P ((char *str, long len));
+extern SCM scm_array_to_list SCM_P ((SCM v));
+extern SCM scm_list_to_uniform_array SCM_P ((SCM ndim, SCM prot, SCM lst));
+extern int scm_raprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+extern SCM scm_array_prototype SCM_P ((SCM ra));
+extern void scm_init_unif SCM_P ((void));
#endif /* UNIFH */
diff --git a/libguile/variable.c b/libguile/variable.c
index 984de26db..f87887f1f 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -42,31 +42,31 @@
#include <stdio.h>
#include "_scm.h"
+#include "eq.h"
+#include "genio.h"
+#include "smob.h"
+#include "variable.h"
-#ifdef __STDC__
-static scm_sizet
-free_var (SCM obj)
-#else
+
+static scm_sizet free_var SCM_P ((SCM obj));
+
static scm_sizet
free_var (obj)
SCM obj;
-#endif
{
return 0;
}
-#ifdef __STDC__
-static int
-prin_var (SCM exp, SCM port, int writing)
-#else
+
+static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prin_var (exp, port, writing)
+prin_var (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_gen_puts (scm_regular_string, "#<variable ", port);
scm_intprint(exp, 16, port);
@@ -76,23 +76,21 @@ prin_var (exp, port, writing)
if (SCM_CAR (val_cell) != SCM_UNDEFINED)
{
scm_gen_puts (scm_regular_string, " name: ", port);
- scm_iprin1 (SCM_CAR (val_cell), port, writing);
+ scm_iprin1 (SCM_CAR (val_cell), port, pstate);
}
scm_gen_puts (scm_regular_string, " binding: ", port);
- scm_iprin1 (SCM_CDR (val_cell), port, writing);
+ scm_iprin1 (SCM_CDR (val_cell), port, pstate);
}
scm_gen_putc('>', port);
return 1;
}
-#ifdef __STDC__
-static SCM
-scm_markvar (SCM ptr)
-#else
+
+static SCM scm_markvar SCM_P ((SCM ptr));
+
static SCM
scm_markvar (ptr)
SCM ptr;
-#endif
{
if (SCM_GC8MARKP (ptr))
return SCM_BOOL_F;
@@ -100,84 +98,84 @@ scm_markvar (ptr)
return SCM_CDR (ptr);
}
+static SCM var_equal SCM_P ((SCM var1, SCM var2));
+
+static SCM
+var_equal (var1, var2)
+ SCM var1;
+ SCM var2;
+{
+ return scm_equal_p (SCM_CDR (var1), SCM_CDR (var2));
+}
+
int scm_tc16_variable;
-static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, 0};
+static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, var_equal};
-static SCM variable_sym;
+static SCM anonymous_variable_sym;
+
+
+static SCM make_vcell_variable SCM_P ((SCM vcell));
-#ifdef __STDC__
-static SCM
-make_vcell_variable (SCM vcell)
-#else
static SCM
make_vcell_variable (vcell)
SCM vcell;
-#endif
{
SCM answer;
SCM_NEWCELL(answer);
SCM_REDEFER_INTS;
- SCM_CAR(answer) = scm_tc16_variable;
- SCM_CDR(answer) = vcell;
+ SCM_SETCAR (answer, scm_tc16_variable);
+ SCM_SETCDR (answer, vcell);
SCM_REALLOW_INTS;
return answer;
}
-SCM_PROC(s_make_variable, "make-variable", 2, 0, 0, scm_make_variable);
-#ifdef __STDC__
-SCM
-scm_make_variable (SCM init, SCM name_hint)
-#else
+SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable);
+
SCM
scm_make_variable (init, name_hint)
SCM init;
SCM name_hint;
-#endif
{
SCM val_cell;
+
+ if (name_hint == SCM_UNDEFINED)
+ name_hint = anonymous_variable_sym;
+
SCM_NEWCELL(val_cell);
SCM_DEFER_INTS;
- SCM_CAR(val_cell) = name_hint;
- SCM_CDR(val_cell) = init;
+ SCM_SETCAR (val_cell, name_hint);
+ SCM_SETCDR (val_cell, init);
SCM_ALLOW_INTS;
return make_vcell_variable (val_cell);
}
SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable);
-#ifdef __STDC__
-SCM
-scm_make_undefined_variable (SCM name_hint)
-#else
+
SCM
scm_make_undefined_variable (name_hint)
SCM name_hint;
-#endif
{
SCM vcell;
if (name_hint == SCM_UNDEFINED)
- name_hint = variable_sym;
+ name_hint = anonymous_variable_sym;
SCM_NEWCELL (vcell);
SCM_DEFER_INTS;
- SCM_CAR (vcell) = name_hint;
- SCM_CDR (vcell) = SCM_UNDEFINED;
+ SCM_SETCAR (vcell, name_hint);
+ SCM_SETCDR (vcell, SCM_UNDEFINED);
SCM_ALLOW_INTS;
return make_vcell_variable (vcell);
}
SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p);
-#ifdef __STDC__
-SCM
-scm_variable_p (SCM obj)
-#else
+
SCM
scm_variable_p (obj)
SCM obj;
-#endif
{
return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj))
? SCM_BOOL_T
@@ -186,14 +184,10 @@ scm_variable_p (obj)
SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref);
-#ifdef __STDC__
-SCM
-scm_variable_ref (SCM var)
-#else
+
SCM
scm_variable_ref (var)
SCM var;
-#endif
{
SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref);
return SCM_CDR (SCM_CDR (var));
@@ -202,31 +196,23 @@ scm_variable_ref (var)
SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x);
-#ifdef __STDC__
-SCM
-scm_variable_set_x (SCM var, SCM val)
-#else
+
SCM
scm_variable_set_x (var, val)
SCM var;
SCM val;
-#endif
{
SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x);
- SCM_CDR (SCM_CDR (var)) = val;
+ SCM_SETCDR (SCM_CDR (var), val);
return SCM_UNSPECIFIED;
}
SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable);
-#ifdef __STDC__
-SCM
-scm_builtin_variable (SCM name)
-#else
+
SCM
scm_builtin_variable (name)
SCM name;
-#endif
{
SCM vcell;
SCM var_slot;
@@ -242,7 +228,7 @@ scm_builtin_variable (name)
SCM_DEFER_INTS;
if ( SCM_IMP (SCM_CDR (var_slot))
|| (SCM_VARVCELL (var_slot) != vcell))
- SCM_CDR (var_slot) = make_vcell_variable (vcell);
+ SCM_SETCDR (var_slot, make_vcell_variable (vcell));
SCM_ALLOW_INTS;
return SCM_CDR (var_slot);
@@ -250,14 +236,10 @@ scm_builtin_variable (name)
SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p);
-#ifdef __STDC__
-SCM
-scm_variable_bound_p (SCM var)
-#else
+
SCM
scm_variable_bound_p (var)
SCM var;
-#endif
{
SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p);
return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))
@@ -267,16 +249,12 @@ scm_variable_bound_p (var)
-#ifdef __STDC__
-void
-scm_init_variable (void)
-#else
+
void
scm_init_variable ()
-#endif
{
scm_tc16_variable = scm_newsmob (&variable_smob);
- variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
+ anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
#include "variable.x"
}
diff --git a/libguile/variable.h b/libguile/variable.h
index b9d84fd8c..9bced2936 100644
--- a/libguile/variable.h
+++ b/libguile/variable.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -54,34 +54,18 @@ extern int scm_tc16_variable;
#define SCM_VARVCELL(V) SCM_CDR(V)
#define SCM_VARIABLEP(X) (scm_tc16_variable == SCM_CAR(X))
-#define SCM_UDSCM_VARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
-#define SCM_DEFSCM_VARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
+#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
+#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
-#ifdef __STDC__
-extern SCM scm_make_variable (SCM init, SCM name_hint);
-extern SCM scm_make_udvariable (SCM name_hint);
-extern SCM scm_variable_p (SCM obj);
-extern SCM scm_variable_ref (SCM var);
-extern SCM scm_variable_set_x (SCM var, SCM val);
-extern SCM scm_builtin_variable (SCM name);
-extern SCM scm_variable_bound_p (SCM var);
-extern void scm_init_variable (void);
-
-#else /* STDC */
-extern SCM scm_make_variable ();
-extern SCM scm_make_udvariable ();
-extern SCM scm_variable_p ();
-extern SCM scm_variable_ref ();
-extern SCM scm_variable_set_x ();
-extern SCM scm_builtin_variable ();
-extern SCM scm_variable_bound_p ();
-extern void scm_init_variable ();
-
-#endif /* STDC */
-
-
-
+extern SCM scm_make_variable SCM_P ((SCM init, SCM name_hint));
+extern SCM scm_make_undefined_variable SCM_P ((SCM name_hint));
+extern SCM scm_variable_p SCM_P ((SCM obj));
+extern SCM scm_variable_ref SCM_P ((SCM var));
+extern SCM scm_variable_set_x SCM_P ((SCM var, SCM val));
+extern SCM scm_builtin_variable SCM_P ((SCM name));
+extern SCM scm_variable_bound_p SCM_P ((SCM var));
+extern void scm_init_variable SCM_P ((void));
#endif /* VARIABLEH */
diff --git a/libguile/vectors.c b/libguile/vectors.c
index c30a8590a..4484bf841 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -42,33 +42,27 @@
#include <stdio.h>
#include "_scm.h"
+#include "eq.h"
+#include "vectors.h"
SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p);
-#ifdef __STDC__
-SCM
-scm_vector_p(SCM x)
-#else
+
SCM
scm_vector_p(x)
SCM x;
-#endif
{
if SCM_IMP(x) return SCM_BOOL_F;
return SCM_VECTORP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC(s_vector_length, "vector-length", 1, 0, 0, scm_vector_length);
-#ifdef __STDC__
-SCM
-scm_vector_length(SCM v)
-#else
+
SCM
scm_vector_length(v)
SCM v;
-#endif
{
SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_length);
return SCM_MAKINUM(SCM_LENGTH(v));
@@ -76,14 +70,10 @@ scm_vector_length(v)
SCM_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
SCM_PROC(s_vector, "vector", 0, 0, 1, scm_vector);
-#ifdef __STDC__
-SCM
-scm_vector(SCM l)
-#else
+
SCM
scm_vector(l)
SCM l;
-#endif
{
SCM res;
register SCM *data;
@@ -97,15 +87,11 @@ scm_vector(l)
}
SCM_PROC(s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref);
-#ifdef __STDC__
-SCM
-scm_vector_ref(SCM v, SCM k)
-#else
+
SCM
scm_vector_ref(v, k)
SCM v;
SCM k;
-#endif
{
SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_ref);
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_ref);
@@ -115,16 +101,12 @@ scm_vector_ref(v, k)
SCM_PROC(s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x);
-#ifdef __STDC__
-SCM
-scm_vector_set_x(SCM v, SCM k, SCM obj)
-#else
+
SCM
scm_vector_set_x(v, k, obj)
SCM v;
SCM k;
SCM obj;
-#endif
{
SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_set_x);
SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_set_x);
@@ -135,16 +117,12 @@ scm_vector_set_x(v, k, obj)
SCM_PROC(s_make_vector, "make-vector", 1, 2, 0, scm_make_vector);
-#ifdef __STDC__
-SCM
-scm_make_vector(SCM k, SCM fill, SCM multip)
-#else
+
SCM
scm_make_vector(k, fill, multip)
SCM k;
SCM fill;
SCM multip;
-#endif
{
SCM v;
int multi;
@@ -154,7 +132,7 @@ scm_make_vector(k, fill, multip)
SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector);
if (SCM_UNBNDP(fill))
- fill = SCM_EOL;
+ fill = SCM_UNSPECIFIED;
multi = !(SCM_UNBNDP(multip) || SCM_FALSEP(multip));
i = SCM_INUM(k);
SCM_NEWCELL(v);
@@ -178,14 +156,10 @@ scm_make_vector(k, fill, multip)
SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list);
-#ifdef __STDC__
-SCM
-scm_vector_to_list(SCM v)
-#else
+
SCM
scm_vector_to_list(v)
SCM v;
-#endif
{
SCM res = SCM_EOL;
long i;
@@ -198,15 +172,11 @@ scm_vector_to_list(v)
SCM_PROC(s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x);
-#ifdef __STDC__
-SCM
-scm_vector_fill_x(SCM v, SCM fill_x)
-#else
+
SCM
scm_vector_fill_x(v, fill_x)
SCM v;
SCM fill_x;
-#endif
{
register long i;
register SCM *data;
@@ -217,15 +187,11 @@ scm_vector_fill_x(v, fill_x)
}
-#ifdef __STDC__
-SCM
-scm_vector_equal_p(SCM x, SCM y)
-#else
+
SCM
scm_vector_equal_p(x, y)
SCM x;
SCM y;
-#endif
{
long i;
for(i = SCM_LENGTH(x)-1;i >= 0;i--)
@@ -236,10 +202,7 @@ scm_vector_equal_p(x, y)
SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x);
-#ifdef __STDC__
-SCM
-scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2)
-#else
+
SCM
scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
SCM vec1;
@@ -247,7 +210,6 @@ scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
SCM end1;
SCM vec2;
SCM start2;
-#endif
{
long i;
long j;
@@ -270,10 +232,7 @@ scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
}
SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x);
-#ifdef __STDC__
-SCM
-scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2)
-#else
+
SCM
scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
SCM vec1;
@@ -281,7 +240,6 @@ scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
SCM end1;
SCM vec2;
SCM start2;
-#endif
{
long i;
long j;
@@ -304,13 +262,9 @@ scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
}
-#ifdef __STDC__
-void
-scm_init_vectors (void)
-#else
+
void
scm_init_vectors ()
-#endif
{
#include "vectors.x"
}
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 3cf5c6478..5b98afbcc 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -54,29 +54,20 @@
#define SCM_SETVELTS SCM_SETCDR
-#ifdef __STDC__
-extern SCM scm_vector_p(SCM x);
-extern SCM scm_vector_length(SCM v);
-extern SCM scm_vector(SCM l);
-extern SCM scm_vector_ref(SCM v, SCM k);
-extern SCM scm_vector_set_x(SCM v, SCM k, SCM obj);
-extern SCM scm_make_vector(SCM k, SCM fill, SCM multi);
-extern SCM scm_vector_to_list(SCM v);
-extern SCM scm_vector_fill_x(SCM v, SCM fill_x);
-extern SCM scm_vector_equal_p(SCM x, SCM y);
-extern void scm_init_vectors (void);
-#else /* STDC */
-extern SCM scm_vector_p();
-extern SCM scm_vector_length();
-extern SCM scm_vector();
-extern SCM scm_vector_ref();
-extern SCM scm_vector_set_x();
-extern SCM scm_make_vector();
-extern SCM scm_vector_to_list();
-extern SCM scm_vector_fill_x();
-extern SCM scm_vector_equal_p();
-extern void scm_init_vectors ();
+extern SCM scm_vector_p SCM_P ((SCM x));
+extern SCM scm_vector_length SCM_P ((SCM v));
+extern SCM scm_vector SCM_P ((SCM l));
+extern SCM scm_vector_ref SCM_P ((SCM v, SCM k));
+extern SCM scm_vector_set_x SCM_P ((SCM v, SCM k, SCM obj));
+extern SCM scm_make_vector SCM_P ((SCM k, SCM fill, SCM multi));
+extern SCM scm_vector_to_list SCM_P ((SCM v));
+extern SCM scm_vector_fill_x SCM_P ((SCM v, SCM fill_x));
+extern SCM scm_vector_equal_p SCM_P ((SCM x, SCM y));
+extern SCM scm_vector_move_left_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM
+ vec2, SCM start2));
+extern SCM scm_vector_move_right_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM
+ vec2, SCM start2));
+extern void scm_init_vectors SCM_P ((void));
-#endif /* STDC */
#endif /* VECTORSH */
diff --git a/libguile/version.c b/libguile/version.c
new file mode 100644
index 000000000..889b08efc
--- /dev/null
+++ b/libguile/version.c
@@ -0,0 +1,85 @@
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include "_scm.h"
+
+#include "version.h"
+
+
+/* Return a Scheme string containing Guile's major version number. */
+
+SCM_PROC(s_major_version, "major-version", 0, 0, 0, scm_major_version);
+
+SCM
+scm_major_version ()
+{
+ return scm_makfrom0str (GUILE_MAJOR_VERSION);
+}
+
+/* Return a Scheme string containing Guile's minor version number. */
+
+SCM_PROC(s_minor_version, "minor-version", 0, 0, 0, scm_minor_version);
+
+SCM
+scm_minor_version ()
+{
+ return scm_makfrom0str (GUILE_MINOR_VERSION);
+}
+
+/* Return a Scheme string containing Guile's complete version. */
+
+SCM_PROC(s_version, "version", 0, 0, 0, scm_version);
+
+SCM
+scm_version ()
+{
+ return scm_makfrom0str (GUILE_VERSION);
+}
+
+
+
+
+void
+scm_init_version ()
+{
+#include "version.x"
+}
diff --git a/libguile/version.h b/libguile/version.h
new file mode 100644
index 000000000..ff48cf231
--- /dev/null
+++ b/libguile/version.h
@@ -0,0 +1,56 @@
+/* classes: h_files */
+
+#ifndef VERSIONH
+#define VERSIONH
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+extern SCM scm_major_version SCM_P ((void));
+extern SCM scm_minor_version SCM_P ((void));
+extern SCM scm_version SCM_P ((void));
+extern void scm_init_version SCM_P ((void));
+
+#endif /* VERSIONH */
diff --git a/libguile/vports.c b/libguile/vports.c
index dbb67cbfe..89e398e98 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -42,6 +42,15 @@
#include <stdio.h>
#include "_scm.h"
+#include "eval.h"
+#include "chars.h"
+#include "fports.h"
+
+#include "vports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -50,16 +59,14 @@
*/
-#ifdef __STDC__
-static int
-prinsfpt (SCM exp, SCM port, int writing)
-#else
+
+static int prinsfpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinsfpt (exp, port, writing)
+prinsfpt (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_prinport (exp, port, "soft");
return !0;
@@ -73,32 +80,28 @@ prinsfpt (exp, port, writing)
* before returning.
*/
-#ifdef __STDC__
-static int
-sfputc (int c, SCM p)
-#else
+
+static int sfputc SCM_P ((int c, SCM p));
+
static int
sfputc (c, p)
int c;
SCM p;
-#endif
{
scm_apply (SCM_VELTS (p)[0], SCM_MAKICHR (c), scm_listofnull);
errno = 0;
return c;
}
-#ifdef __STDC__
-static scm_sizet
-sfwrite (char *str, scm_sizet siz, scm_sizet num, SCM p)
-#else
+
+static scm_sizet sfwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p));
+
static scm_sizet
sfwrite (str, siz, num, p)
char *str;
scm_sizet siz;
scm_sizet num;
SCM p;
-#endif
{
SCM sstr;
sstr = scm_makfromstr (str, siz * num, 0);
@@ -107,28 +110,24 @@ sfwrite (str, siz, num, p)
return num;
}
-#ifdef __STDC__
-static int
-sfputs (char *s, SCM p)
-#else
+
+static int sfputs SCM_P ((char *s, SCM p));
+
static int
sfputs (s, p)
char *s;
SCM p;
-#endif
{
sfwrite (s, 1, strlen (s), p);
return 0;
}
-#ifdef __STDC__
-static int
-sfflush (SCM stream)
-#else
+
+static int sfflush SCM_P ((SCM stream));
+
static int
sfflush (stream)
SCM stream;
-#endif
{
SCM f = SCM_VELTS (stream)[2];
if (SCM_BOOL_F == f)
@@ -138,14 +137,12 @@ sfflush (stream)
return SCM_BOOL_F == f ? EOF : 0;
}
-#ifdef __STDC__
-static int
-sfgetc (SCM p)
-#else
+
+static int sfgetc SCM_P ((SCM p));
+
static int
sfgetc (p)
SCM p;
-#endif
{
SCM ans;
ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL);
@@ -156,14 +153,12 @@ sfgetc (p)
return SCM_ICHR (ans);
}
-#ifdef __STDC__
-static int
-sfclose (SCM p)
-#else
+
+static int sfclose SCM_P ((SCM p));
+
static int
sfclose (p)
SCM p;
-#endif
{
SCM f = SCM_VELTS (p)[4];
if (SCM_BOOL_F == f)
@@ -176,15 +171,11 @@ sfclose (p)
SCM_PROC(s_make_soft_port, "make-soft-port", 2, 0, 0, scm_make_soft_port);
-#ifdef __STDC__
-SCM
-scm_make_soft_port (SCM pv, SCM modes)
-#else
+
SCM
scm_make_soft_port (pv, modes)
SCM pv;
SCM modes;
-#endif
{
struct scm_port_table * pt;
SCM z;
@@ -193,21 +184,19 @@ scm_make_soft_port (pv, modes)
SCM_NEWCELL (z);
SCM_DEFER_INTS;
pt = scm_add_to_port_table (z);
- SCM_CAR (z) = scm_tc16_sfport | scm_mode_bits (SCM_CHARS (modes));
+ SCM_SETCAR (z, scm_tc16_sfport | scm_mode_bits (SCM_CHARS (modes)));
SCM_SETPTAB_ENTRY (z, pt);
SCM_SETSTREAM (z, pv);
SCM_ALLOW_INTS;
return z;
}
-#ifdef __STDC__
-static int
-noop0 (FILE *stream)
-#else
+
+static int noop0 SCM_P ((SCM stream));
+
static int
noop0 (stream)
- FILE *stream;
-#endif
+ SCM stream;
{
return 0;
}
@@ -228,13 +217,9 @@ scm_ptobfuns scm_sfptob =
};
-#ifdef __STDC__
-void
-scm_init_vports (void)
-#else
+
void
scm_init_vports ()
-#endif
{
#include "vports.x"
}
diff --git a/libguile/vports.h b/libguile/vports.h
index 17a50fa57..27b14a3d6 100644
--- a/libguile/vports.h
+++ b/libguile/vports.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
extern scm_ptobfuns scm_sfptob;
@@ -52,19 +52,8 @@ extern scm_ptobfuns scm_sfptob;
-#ifdef __STDC__
-extern SCM scm_make_soft_port (SCM pv, SCM modes);
-extern void scm_init_vports (void);
-
-#else /* STDC */
-extern SCM scm_make_soft_port ();
-extern void scm_init_vports ();
-
-#endif /* STDC */
-
-
-
-
+extern SCM scm_make_soft_port SCM_P ((SCM pv, SCM modes));
+extern void scm_init_vports SCM_P ((void));
#endif /* VPORTSH */
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 8479d76f5..cb2912970 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -42,6 +42,7 @@
#include <stdio.h>
#include "_scm.h"
+#include "weaks.h"
@@ -50,15 +51,11 @@
SCM_PROC(s_make_weak_vector, "make-weak-vector", 1, 1, 0, scm_make_weak_vector);
-#ifdef __STDC__
-SCM
-scm_make_weak_vector (SCM k, SCM fill)
-#else
+
SCM
scm_make_weak_vector (k, fill)
SCM k;
SCM fill;
-#endif
{
SCM v;
v = scm_make_vector (scm_sum (k, SCM_MAKINUM (1)), fill, SCM_UNDEFINED);
@@ -73,14 +70,10 @@ scm_make_weak_vector (k, fill)
SCM_PROC(s_weak_vector, "weak-vector", 0, 0, 1, scm_weak_vector);
SCM_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
-#ifdef __STDC__
-SCM
-scm_weak_vector (SCM l)
-#else
+
SCM
scm_weak_vector (l)
SCM l;
-#endif
{
SCM res;
register SCM *data;
@@ -99,14 +92,10 @@ scm_weak_vector (l)
SCM_PROC(s_weak_vector_p, "weak-vector?", 1, 0, 0, scm_weak_vector_p);
-#ifdef __STDC__
-SCM
-scm_weak_vector_p (SCM x)
-#else
+
SCM
scm_weak_vector_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x))
? SCM_BOOL_T
@@ -119,18 +108,14 @@ scm_weak_vector_p (x)
-SCM_PROC(s_make_weak_hash_table, "make-weak-hash-table", 1, 0, 0, scm_make_weak_hash_table);
-#ifdef __STDC__
-SCM
-scm_make_weak_hash_table (SCM k)
-#else
+SCM_PROC(s_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, scm_make_weak_key_hash_table);
+
SCM
-scm_make_weak_hash_table (k)
+scm_make_weak_key_hash_table (k)
SCM k;
-#endif
{
SCM v;
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_hash_table);
+ SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_key_hash_table);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 1;
@@ -140,14 +125,10 @@ scm_make_weak_hash_table (k)
SCM_PROC (s_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, scm_make_weak_value_hash_table);
-#ifdef __STDC__
-SCM
-scm_make_weak_value_hash_table (SCM k)
-#else
+
SCM
scm_make_weak_value_hash_table (k)
SCM k;
-#endif
{
SCM v;
SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table);
@@ -161,17 +142,13 @@ scm_make_weak_value_hash_table (k)
SCM_PROC (s_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, scm_make_doubly_weak_hash_table);
-#ifdef __STDC__
-SCM
-scm_make_doubly_weak_hash_table (SCM k)
-#else
+
SCM
scm_make_doubly_weak_hash_table (k)
SCM k;
-#endif
{
SCM v;
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table);
+ SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_doubly_weak_hash_table);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 3;
@@ -179,15 +156,11 @@ scm_make_doubly_weak_hash_table (k)
return v;
}
-SCM_PROC(s_weak_hash_table_p, "weak-hash-table?", 1, 0, 0, scm_weak_hash_table_p);
-#ifdef __STDC__
-SCM
-scm_weak_hash_table_p (SCM x)
-#else
+SCM_PROC(s_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, scm_weak_key_hash_table_p);
+
SCM
-scm_weak_hash_table_p (x)
+scm_weak_key_hash_table_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x))
? SCM_BOOL_T
@@ -196,14 +169,10 @@ scm_weak_hash_table_p (x)
SCM_PROC (s_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, scm_weak_value_hash_table_p);
-#ifdef __STDC__
-SCM
-scm_weak_value_hash_table_p (SCM x)
-#else
+
SCM
scm_weak_value_hash_table_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x))
? SCM_BOOL_T
@@ -212,14 +181,10 @@ scm_weak_value_hash_table_p (x)
SCM_PROC (s_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, scm_doubly_weak_hash_table_p);
-#ifdef __STDC__
-SCM
-scm_doubly_weak_hash_table_p (SCM x)
-#else
+
SCM
scm_doubly_weak_hash_table_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x))
? SCM_BOOL_T
@@ -229,13 +194,9 @@ scm_doubly_weak_hash_table_p (x)
-#ifdef __STDC__
-void
-scm_init_weaks (void)
-#else
+
void
scm_init_weaks ()
-#endif
{
#include "weaks.x"
}
diff --git a/libguile/weaks.h b/libguile/weaks.h
index 98e1cb698..8a6eb467d 100644
--- a/libguile/weaks.h
+++ b/libguile/weaks.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -56,31 +56,16 @@
#define SCM_IS_WHVEC_ANY(X) (SCM_VELTS(X)[-1])
-#ifdef __STDC__
-extern SCM scm_make_weak_vector (SCM k, SCM fill);
-extern SCM scm_weak_vector (SCM l);
-extern SCM scm_weak_vector_p (SCM x);
-extern SCM scm_make_weak_hash_table (SCM k);
-extern SCM scm_make_weak_value_hash_table (SCM k);
-extern SCM scm_make_doubly_weak_hash_table (SCM k);
-extern SCM scm_weak_hash_table_p (SCM x);
-extern SCM scm_weak_value_hash_table_p (SCM x);
-extern SCM scm_doubly_weak_hash_table_p (SCM x);
-extern void scm_init_weaks (void);
-
-#else /* STDC */
-extern SCM scm_make_weak_vector ();
-extern SCM scm_weak_vector ();
-extern SCM scm_weak_vector_p ();
-extern SCM scm_make_weak_hash_table ();
-extern SCM scm_make_weak_value_hash_table ();
-extern SCM scm_make_doubly_weak_hash_table ();
-extern SCM scm_weak_hash_table_p ();
-extern SCM scm_weak_value_hash_table_p ();
-extern SCM scm_doubly_weak_hash_table_p ();
-extern void scm_init_weaks ();
-
-#endif /* STDC */
+extern SCM scm_make_weak_vector SCM_P ((SCM k, SCM fill));
+extern SCM scm_weak_vector SCM_P ((SCM l));
+extern SCM scm_weak_vector_p SCM_P ((SCM x));
+extern SCM scm_make_weak_key_hash_table SCM_P ((SCM k));
+extern SCM scm_make_weak_value_hash_table SCM_P ((SCM k));
+extern SCM scm_make_doubly_weak_hash_table SCM_P ((SCM k));
+extern SCM scm_weak_key_hash_table_p SCM_P ((SCM x));
+extern SCM scm_weak_value_hash_table_p SCM_P ((SCM x));
+extern SCM scm_doubly_weak_hash_table_p SCM_P ((SCM x));
+extern void scm_init_weaks SCM_P ((void));
#endif /* WEAKSH */
diff --git a/ltconfig b/ltconfig
new file mode 100755
index 000000000..8bf0a14d1
--- /dev/null
+++ b/ltconfig
@@ -0,0 +1,945 @@
+#! /bin/sh
+
+# ltconfig - Create a system-specific libtool.
+# When updating this script, search for LINENUM and fix line number refs.
+# Generated automatically from ltconfig.in by configure.
+# Copyright (C) 1996, 1997, Free Software Foundation, Inc.
+# Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
+#
+# This file 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.
+#
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+# A lot of this script is taken from autoconf-2.10.
+
+# The name of this program.
+progname=`echo "$0" | sed 's%^.*/%%'`
+
+# Constants:
+PROGRAM=ltconfig
+PACKAGE=libtool
+VERSION=0.9d
+ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.c 1>&5'
+rm="rm -f"
+
+help="Try \`$progname --help' for more information."
+
+# Global variables:
+can_build_shared=yes
+enable_shared=yes
+# All known linkers require a `.a' archive for static linking.
+enable_static=yes
+ltmain=NONE
+silent=
+srcdir=
+ac_config_guess=
+ac_config_sub=
+host=NONE
+nonopt=NONE
+verify_host=yes
+with_gcc=no
+
+old_AR="$AR"
+old_CC="$CC"
+old_CFLAGS="$CFLAGS"
+old_CPPFLAGS="$CPPFLAGS"
+old_LD="$LD"
+old_RANLIB="$RANLIB"
+
+test -z "$AR" && AR=ar
+
+# Parse the command line options.
+args=
+prev=
+for option
+do
+ case "$option" in
+ -*=*) optarg=`echo "$option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
+ *) optarg= ;;
+ esac
+
+ # If the previous option needs an argument, assign it.
+ if test -n "$prev"; then
+ eval "$prev=\$option"
+ prev=
+ continue
+ fi
+
+ case "$option" in
+ --help) cat <<EOM
+Usage: $progname [OPTION]... LTMAIN [HOST]
+
+Generate a system-specific libtool script.
+
+ --disable-shared do not build shared libraries
+ --help display this help and exit
+ --no-verify do not verify that HOST is a valid host type
+ --quiet same as \`--silent'
+ --silent don't print informational messages
+ --srcdir=DIR find \`config.guess' in DIR
+ --version output version information and exit
+ --with-gcc assume that the GNU C compiler will be used
+
+LTMAIN is the \`ltmain.sh' shell script fragment that provides basic libtool
+functionality.
+
+HOST is the canonical host system name [default=guessed].
+EOM
+ exit 0
+ ;;
+
+ --disable-shared) enable_shared=no ;;
+
+ --quiet | --silent) silent=yes ;;
+
+ --srcdir) prev=srcdir ;;
+ --srcdir=*) srcdir="$optarg" ;;
+
+ --no-verify) verify_host=no ;;
+
+ --version) echo "$PROGRAM (GNU $PACKAGE) $VERSION"; exit 0 ;;
+
+ --with-gcc) with_gcc=yes ;;
+
+ -*)
+ echo "$progname: unrecognized option \`$option'" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ ;;
+
+ *)
+ if test "$ltmain" = NONE; then
+ ltmain="$option"
+ elif test "$host" = NONE; then
+# FIXME This generates an unnecessary warning for sparc-sun-solaris4.1.3_U1
+# if test -n "`echo $option| sed 's/[-a-z0-9.]//g'`"; then
+# echo "$progname: warning \`$option' is not a valid host type" 1>&2
+# fi
+ host="$option"
+ else
+ echo "$progname: too many arguments" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi ;;
+ esac
+done
+
+if test "$ltmain" = NONE; then
+ echo "$progname: you must specify a LTMAIN file" 1>&2
+ echo "$help" 1>&2
+ exit 1
+fi
+
+if test -f "$ltmain"; then :
+else
+ echo "$progname: warning: \`$ltmain' does not exist" 1>&2
+fi
+
+# Quote any args containing shell metacharacters.
+ltconfig_args=
+for arg
+do
+ case "$arg" in
+ *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
+ ltconfig_args="$ltconfig_args '$arg'" ;;
+ *) ltconfig_args="$ltconfig_args $arg" ;;
+ esac
+done
+
+# A relevant subset of AC_INIT.
+
+# File descriptor usage:
+# 0 standard input
+# 1 file creation
+# 2 errors and warnings
+# 3 some systems may open it to /dev/tty
+# 4 used on the Kubota Titan
+# 5 compiler messages saved in config.log
+# 6 checking for... messages and results
+if test "$silent" = yes; then
+ exec 6>/dev/null
+else
+ exec 6>&1
+fi
+exec 5>>./config.log
+
+# NLS nuisances.
+# Only set LANG and LC_ALL to C if already set.
+# These must not be set unconditionally because not all systems understand
+# e.g. LANG=C (notably SCO).
+if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+if test "${LANG+set}" = set; then LANG=C; export LANG; fi
+
+if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
+ # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
+ if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
+ ac_n= ac_c='
+' ac_t=' '
+ else
+ ac_n=-n ac_c= ac_t=
+ fi
+else
+ ac_n= ac_c='\c' ac_t=
+fi
+
+if test -z "$srcdir"; then
+ # Assume the source directory is the same one as the path to ltmain.sh.
+ srcdir=`echo "$ltmain" | sed 's%/[^/]*$%%'`
+ test "$srcdir" = "$ltmain" && srcdir=.
+fi
+
+if test "$verify_host" = yes; then
+ # Check for config.guess and config.sub.
+ ac_aux_dir=
+ for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
+ if test -f $ac_dir/config.guess; then
+ ac_aux_dir=$ac_dir
+ break
+ fi
+ done
+ if test -z "$ac_aux_dir"; then
+ echo "$progname: cannot find config.guess in $srcdir $srcdir/.. $srcdir/../.." 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+ ac_config_guess=$ac_aux_dir/config.guess
+ ac_config_sub=$ac_aux_dir/config.sub
+
+ # Make sure we can run config.sub.
+ if $ac_config_sub sun4 >/dev/null 2>&1; then :
+ else
+ echo "$progname: cannot run $ac_config_sub" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ echo $ac_n "checking host system type""... $ac_c" 1>&6
+
+ host_alias=$host
+ case "$host_alias" in
+ NONE)
+ if host_alias=`$ac_config_guess`; then :
+ else
+ echo "$progname: cannot guess host type; you must specify one" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi ;;
+ esac
+ host=`$ac_config_sub $host_alias`
+ echo "$ac_t""$host" 1>&6
+
+ # Transform *-*-linux* to *-*-linux-gnu*, to support old configure scripts.
+ case "$host" in
+ *-*-linux-gnu*) ;;
+ *-*-linux*) host=`echo $host | sed 's/^\(.*-.*-linux\)\(.*\)$/\1-gnu\2/'`
+ esac
+
+elif test "$host" = NONE; then
+ echo "$progname: you must specify a host type if you use \`--no-verify'" 1>&2
+ echo "$help" 1>&2
+ exit 1
+else
+ host_alias=$host
+fi
+
+# Transform *-*-linux* to *-*-linux-gnu*, to support old configure scripts.
+case "$host" in
+*-*-linux-gnu*) ;;
+*-*-linux*) host=`echo $host | sed 's/^\(.*-.*-linux\)\(.*\)$/\1-gnu\2/'`
+esac
+
+host_cpu=`echo $host | sed 's/^\(.*\)-\(.*\)-\(.*\)$/\1/'`
+host_vendor=`echo $host | sed 's/^\(.*\)-\(.*\)-\(.*\)$/\2/'`
+host_os=`echo $host | sed 's/^\(.*\)-\(.*\)-\(.*\)$/\3/'`
+
+# Determine commands to create old-style static archives.
+old_archive_cmds='$AR cru $oldlib$oldobjs'
+old_postinstall_cmds='chmod 644 $oldlib'
+
+# If RANLIB is not set, then run the test.
+if test "${RANLIB+set}" != "set"; then
+ result=no
+
+ echo $ac_n "checking for ranlib... $ac_c" 1>&6
+ if test "$result" = no; then
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:"
+ for dir in $PATH; do
+ test -z "$dir" && dir=.
+ if test -f $dir/ranlib; then
+ RANLIB="ranlib"
+ result="ranlib"
+ break
+ fi
+ done
+ IFS="$save_ifs"
+ fi
+
+ echo $ac_t "$result" 1>&6
+fi
+
+if test -n "$RANLIB"; then
+ old_archive_cmds="$old_archive_cmds;\$RANLIB \$oldlib"
+ old_postinstall_cmds="$old_postinstall_cmds;\$RANLIB \$oldlib"
+fi
+
+# Check to see if we are using GCC.
+if test "$with_gcc" = no; then
+ # If CC is not set, then try to find GCC or a usable CC.
+ if test -z "$CC"; then
+ echo $ac_n "checking for gcc... $ac_c" 1>&6
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:"
+ for dir in $PATH; do
+ IFS="$save_ifs"
+ test -z "$dir" && dir=.
+ if test -f $dir/gcc; then
+ CC="gcc"
+ break
+ fi
+ done
+ IFS="$save_ifs"
+
+ if test -n "$CC"; then
+ echo "$ac_t""$CC" 1>&6
+ else
+ echo "$ac_t""no" 1>&6
+ fi
+ fi
+
+ # Not "gcc", so try "cc", rejecting "/usr/ucb/cc".
+ if test -z "$CC"; then
+ echo $ac_n "checking for cc... $ac_c" 1>&6
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:"
+ cc_rejected=no
+ for dir in $PATH; do
+ test -z "$dir" && dir=.
+ if test -f $dir/cc; then
+ if test "$dir/cc" = "/usr/ucb/cc"; then
+ cc_rejected=yes
+ continue
+ fi
+ CC="cc"
+ break
+ fi
+ done
+ IFS="$save_ifs"
+ if test $cc_rejected = yes; then
+ # We found a bogon in the path, so make sure we never use it.
+ set dummy $CC
+ shift
+ if test $# -gt 0; then
+ # We chose a different compiler from the bogus one.
+ # However, it has the same name, so the bogon will be chosen
+ # first if we set CC to just the name; use the full file name.
+ shift
+ set dummy "$dir/cc" "$@"
+ shift
+ CC="$@"
+ fi
+ fi
+
+ if test -n "$CC"; then
+ echo "$ac_t""$CC" 1>&6
+ else
+ echo "$ac_t""no" 1>&6
+ fi
+
+ if test -z "$CC"; then
+ echo "$progname: error: no acceptable cc found in \$PATH" 1>&2
+ exit 1
+ fi
+ fi
+
+ # Now see if the compiler is really GCC.
+ with_gcc=no
+ echo $ac_n "checking whether we are using GNU C... $ac_c" 1>&6
+
+ trap "$rm conftest.c; exit 1" 1 2 15
+ $rm conftest.c
+ cat > conftest.c <<EOF
+#ifdef __GNUC__
+ yes;
+#endif
+EOF
+ # LINENUM
+ if { ac_try='${CC-cc} -E conftest.c'; { (eval echo $progname:364: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+ with_gcc=yes
+ fi
+ $rm conftest.c
+ echo $ac_t "$with_gcc" 1>&6
+fi
+
+# Allow CC to be a program name with arguments.
+set dummy $CC
+compiler="$2"
+
+echo $ac_n "checking for $compiler option to produce PIC... $ac_c" 1>&6
+pic_flag=
+profile_flag_pattern=
+special_shlib_compile_flags=
+wl=
+link_static_flag=
+
+if test "$with_gcc" = yes; then
+ pic_flag='-fPIC'
+ profile_flag_pattern='-pg?'
+ wl='-Wl,'
+ link_static_flag='-static'
+else
+ # PORTME Check for PIC flags for the system compiler.
+ case "$host" in
+ *-*-aix3* | *-*-aix4*)
+ # FIXME All rs/6000 code is PIC, but is there any non-rs/6000 AIX platform?
+ pic_flag=
+ link_static_flag='-bnso -bI:/lib/syscalls.exp'
+ ;;
+
+ *-*-hpux9* | *-*-hpux10*)
+ # FIXME is there a better link_static_flag that works with the bundled CC?
+ wl='-Wl,'
+ link_static_flag='${wl}-a ${wl}archive'
+ pic_flag='+Z'
+ ;;
+
+ *-*-irix5* | *-*-irix6*)
+ wl='-Wl,'
+ link_static_flag='-non_shared'
+ # PIC (with -KPIC) is the default.
+ pic_flag=
+ ;;
+
+ *-*-osf3* | *-*-osf4*)
+ # FIXME - pic_flag is probably required for hppa*-osf* and i860-osf*
+ wl='-Wl,'
+ link_static_flag='-non_shared'
+ ;;
+
+ *-*-sco3.2v5*)
+ pic_flag='-Kpic'
+ link_static_flag='-dn'
+ special_shlib_compile_flags='-belf'
+ ;;
+
+ *-*-solaris2*)
+ pic_flag='-KPIC'
+ link_static_flag='-Bstatic'
+ ;;
+
+ *-*-sunos4*)
+ pic_flag='-PIC'
+ link_static_flag='-Bstatic'
+ wl='-Qoption ld '
+ ;;
+
+ *)
+ can_build_shared=no
+ ;;
+ esac
+fi
+
+case "$host" in
+rs6000-*-* | powerpc-*-* | powerpcle-*-*)
+ # Yippee! All RS/6000 and PowerPC code is position-independent.
+ pic_flag=
+ ;;
+esac
+
+if test -n "$pic_flag"; then
+ echo $ac_t "$pic_flag" 1>&6
+ pic_flag=" $pic_flag"
+else
+ echo $ac_t none 1>&6
+fi
+
+# Check for any special shared library compilation flags.
+if test -n "$special_shlib_compile_flags"; then
+ echo "$progname: warning: \`$CC' requires \`$special_shlib_compile_flags' to build shared libraries" 1>&2
+ if echo "$old_CC $old_CFLAGS " | egrep -e "[ ]$special_shlib_compile_flags[ ]" >/dev/null; then :
+ else
+ echo "$progname: add \`$special_shlib_compile_flags' to the CC or CFLAGS env variable and reconfigure" 1>&2
+ can_build_shared=no
+ fi
+fi
+
+echo $ac_n "checking for $compiler option to statically link programs... $ac_c" 1>&6
+if test -n "$link_static_flag"; then
+ echo $ac_t "$link_static_flag" 1>&6
+else
+ echo $ac_t none 1>&6
+fi
+
+# See if we're really using GNU ld.
+test -z "$LD" && LD="ld"
+with_gnu_ld=no
+# Allow LD to be a program name with arguments.
+set dummy $LD
+linker="$2"
+echo $ac_n "checking if $LD is GNU ld... $ac_c" 1>&6
+if $LD --version 2>&1 | egrep '(GNU ld|with BFD)' > /dev/null; then
+ with_gnu_ld=yes
+ linker="GNU ld"
+fi
+echo $ac_t "$with_gnu_ld" 1>&6
+
+# See if the linker supports building shared libraries.
+echo $ac_n "checking if $linker supports shared libraries... $ac_c" 1>&6
+
+archive_cmds=
+export_dynamic_flag=
+hardcode_libdir_flag_spec=
+hardcode_libdir_separator=
+hardcode_direct=no
+hardcode_minus_L=no
+hardcode_shlibpath_var=unsupported
+
+ld_shlibs=yes
+if test "$with_gnu_ld" = yes; then
+ # See if GNU ld supports shared libraries.
+
+ case "$host" in
+ *-*-sunos4*)
+ ld_shlibs=yes
+ hardcode_direct=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ *)
+ if $LD --help 2>&1 | egrep ': supported targets:.* elf' > /dev/null; then
+ ld_shlibs=yes
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+
+ if test "$ld_shlibs" = yes; then
+ archive_cmds='$cc -shared ${wl}-soname $wl$soname -o $lib$libobjs$deplibs'
+ hardcode_libdir_flag_spec='${wl}-rpath $wl$libdir'
+ export_dynamic_flag='${wl}-export-dynamic'
+ fi
+else
+ # PORTME fill in a description of your system's linker (not GNU ld)
+ case "$host" in
+ *-*-aix3*)
+ archive_cmds='/usr/ucb/nm$libobjs | egrep \" [BD] \" | sed \"s/^.* //\" > $lib.exp;$LD -o $objdir/$soname$libobjs -bE:$lib.exp -T512 -H512 -bM:SRE -lc$deplibs;$AR cru $lib $objdir/$soname'
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ hardcode_minus_L=yes
+ ;;
+
+ *-*-aix4*)
+ archive_cmds='/bin/nm -B$libobjs | egrep \" [BD] \" | sed \"s/^.* //\" > $lib.exp;$cc -o $objdir/$soname$libobjs ${wl}-bE:$lib.exp ${wl}-bM:SRE ${wl}-bnoentry$deplibs;$AR cru $lib $objdir/$soname'
+ hardcode_minus_L=yes
+ ;;
+
+ *-*-freebsd*)
+ archive_cmds='$LD -Bshareable -o $lib$libobjs$deplibs'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ *-*-hpux9*)
+ archive_cmds='$rm $objdir/$soname;$LD -b +s +b $install_libdir -o $objdir/$soname$libobjs$deplibs;mv $objdir/$soname $lib'
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+
+ *-*-hpux10*)
+ archive_cmds='$LD -b +h $soname +s +b $install_libdir -o $lib$libobjs$deplibs'
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+
+ *-*-irix5* | *-*-irix6*)
+ archive_cmds='$LD -shared -o $lib -soname $soname -set_version $verstring$libobjs -lc$deplibs'
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ ;;
+
+ *-*-netbsd*)
+ # Tested with NetBSD 1.2 ld
+ archive_cmds='$LD -Bshareable -o $lib$libobjs$deplibs'
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ *-*-osf3* | *-*-osf4*)
+ archive_cmds='$LD -shared -o $lib -soname $soname -set_version $verstring$libobjs -lc$deplibs'
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+
+ *-*-sco3.2v5*)
+ archive_cmds='$LD -G -o $lib$libobjs$deplibs'
+ hardcode_direct=yes
+ ;;
+
+ *-*-solaris2*)
+ archive_cmds='$LD -G -z text -h $soname -o $lib$libobjs$deplibs'
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_shlibpath_var=no
+ ;;
+
+ *-*-sunos4*)
+ archive_cmds='$LD -assert pure-text -Bstatic -o $lib$libobjs'
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ hardcode_shlibpath_var=no
+ ;;
+
+ *)
+ ld_shlibs=no
+ can_build_shared=no
+ ;;
+ esac
+fi
+echo $ac_t "$ld_shlibs" 1>&6
+
+# Check hardcoding attributes.
+echo $ac_n "checking how to hardcode library paths into programs... $ac_c" 1>&6
+hardcode_action=
+if test -n "$hardcode_libdir_flag_spec"; then
+ # We can hardcode non-existant directories.
+ if test "$hardcode_direct" != no &&
+ test "$hardcode_minus_L" != no &&
+ test "$hardcode_shlibpath_var" != no; then
+
+ # Can't link without hardcoding.
+ hardcode_action=relink
+ else
+ hardcode_action=immediate
+ fi
+elif test "$hardcode_direct" = yes ||
+ test "$hardcode_minus_L" = yes ||
+ test "$hardcode_shlibpath_var" = yes; then
+
+ # We can't hardcode non-existant directories, but we can existing ones.
+ hardcode_action=immediate
+else
+ # We can't hardcode anything.
+ hardcode_action=unsupported
+fi
+echo $ac_t "$hardcode_action" 1>&6
+test "$hardcode_action" = unsupported && can_build_shared=no
+
+
+reload_flag=
+reload_cmds='$LD$reload_flag -o $output$reload_objs'
+echo $ac_n "checking for $linker option to reload object files... $ac_c" 1>&6
+# PORTME Some linker may need a different reload flag.
+reload_flag='-r'
+echo $ac_t "$reload_flag"
+test -n "$reload_flag" && reload_flag=" $reload_flag"
+
+# PORTME Fill in your ld.so characteristics
+library_names_spec=
+soname_spec=
+postinstall_cmds=
+finish_cmds=
+shlibpath_var=
+version_type=none
+dynamic_linker="$host_os ld.so"
+
+echo $ac_n "checking dynamic linker characteristics... $ac_c" 1>&6
+case "$host" in
+*-*-aix3* | *-*-aix4*)
+ version_type=linux
+ library_names_spec='$libname.so.$versuffix $libname.a'
+ shlibpath_var=LIBPATH
+
+ # AIX has no versioning support, so we append a major version to the name.
+ soname_spec='$libname.so.$major'
+ ;;
+
+*-*-freebsd*)
+ version_type=sunos
+ library_names_spec='$libname.so.$versuffix $libname.so'
+ finish_cmds='ldconfig -m $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+# *-*-gnu* needs to come after *-*-linux-gnu*.
+
+*-*-hpux9* | *-*-hpux10*)
+ # Give a soname corresponding to the major version so that dld.sl refuses to
+ # link against other versions.
+ dynamic_linker="$host_os dld.sl"
+ version_type=sunos
+ shlibpath_var=SHLIB_PATH
+ library_names_spec='$libname.sl.$versuffix $libname.sl.$major $libname.sl'
+ soname_spec='$libname.sl.$major'
+ # HP-UX runs *really* slowly unless shared libraries are mode 555.
+ postinstall_cmds='chmod 555 $lib'
+ ;;
+
+*-*-irix5* | *-*-irix6*)
+ version_type=osf
+ soname_spec='$libname.so'
+ library_names_spec='$libname.so.$versuffix $libname.so'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+# No shared lib support for Linux oldld, aout, or coff.
+*-*-linux-gnuoldld* | *-*-linux-gnuaout* | *-*-linux-gnucoff*)
+ dynamic_linker=no
+ can_build_shared=no
+ ;;
+
+# This must be Linux ELF.
+*-*-linux-gnu*)
+ version_type=linux
+ library_names_spec='$libname.so.$versuffix $libname.so.$major $libname.so'
+ soname_spec='$libname.so.$major'
+ finish_cmds='ldconfig -n $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*-*-gnu*)
+ version_type=sunos
+ library_names_spec='$libname.so.$versuffix'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*-*-netbsd*)
+ version_type=sunos
+ library_names_spec='$libname.so.$versuffix'
+ finish_cmds='ldconfig -m $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*-*-osf3* | *-*-osf4*)
+ version_type=osf
+ soname_spec='$libname.so'
+ library_names_spec='$libname.so.$versuffix $libname.so'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*-*-sco3.2v5*)
+ version_type=osf
+ soname_spec='$libname.so.$major'
+ library_names_spec='$libname.so.$versuffix $libname.so.$major $libname.so'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*-*-solaris2*)
+ version_type=linux
+ library_names_spec='$libname.so.$versuffix $libname.so.$major $libname.so'
+ soname_spec='$libname.so.$major'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*-*-sunos4*)
+ version_type=sunos
+ library_names_spec='$libname.so.$versuffix'
+ finish_cmds='ldconfig $libdir'
+ shlibpath_var=LD_LIBRARY_PATH
+ ;;
+
+*)
+ dynamic_linker=no
+ can_build_shared=no
+ ;;
+esac
+echo "$ac_t""$dynamic_linker"
+
+
+# FIXME need to add library stripping features
+# strip -x works for most platforms, though not for static libraries on NetBSD
+# HP-UX requires "-r" for library stripping
+striplib=
+old_striplib=
+
+#echo $ac_n "checking for static library strip program... $ac_c" 1>&6
+#if test -n "$old_striplib"; then
+# echo $ac_t "$old_striplib" 1>&6
+#else
+# echo $ac_t none 1>&6
+#fi
+
+#if test "$can_build_shared" = yes; then
+# echo $ac_n "checking for shared library strip program... $ac_c" 1>&6
+#
+# if test -n "$striplib"; then
+# echo $ac_t "$striplib" 1>&6
+# else
+# echo $ac_t none 1>&6
+# fi
+#fi
+
+# Report the consequences.
+echo "checking if libtool supports shared libraries... $can_build_shared" 1>&6
+
+echo $ac_n "checking whether to build shared libraries... $ac_c" 1>&6
+test "$can_build_shared" = "no" && enable_shared=no
+
+# On AIX, shared libraries and static libraries use the same namespace.
+case "$host_os" in
+aix*)
+ test "$enable_shared" = yes && enable_static=no
+ if test -n "$RANLIB"; then
+ archive_cmds="$archive_cmds;\$RANLIB \$lib"
+ postinstall_cmds='$RANLIB $lib'
+ fi
+ ;;
+esac
+
+echo "$ac_t""$enable_shared" 1>&6
+
+# Make sure either enable_shared or enable_static is yes.
+test "$enable_shared" = yes || enable_static=yes
+
+ofile=libtool
+trap "$rm $ofile; exit 1" 1 2 15
+echo creating $ofile
+rm -fr $ofile
+cat <<EOF > $ofile
+#! /bin/sh
+
+# libtool - Provide generalized library-building support services.
+#
+# Generated automatically by $PROGRAM - GNU $PACKAGE $VERSION
+# This program was configured as follows,
+# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
+#
+# CC="$old_CC" CFLAGS="$old_CFLAGS" LD="$old_LD" RANLIB="$old_RANLIB" \\
+# $0$ltconfig_args
+#
+# Compiler and other test output produced by $progname, useful for
+# debugging $progname, is in ./config.log if it exists.
+
+# The version of $progname that generated this script.
+LTCONFIG_VERSION="$VERSION"
+
+# Whether or not to build libtool libraries.
+build_libtool_libs=$enable_shared
+
+# Whether or not to build old-style libraries.
+build_old_libs=$enable_static
+
+# The host system.
+host_alias="$host_alias"
+host="$host"
+
+# The archiver.
+AR='$AR'
+
+# The linker used to build libraries.
+LD='$LD'
+
+# How to create reloadable object files.
+reload_flag='$reload_flag'
+reload_cmds='$reload_cmds'
+
+# How to pass a linker flag through the compiler.
+wl='$wl'
+
+# Additional compiler flags for building library objects.
+pic_flag='$pic_flag'
+
+# Compiler flag to prevent dynamic linking.
+link_static_flag='$link_static_flag'
+
+# Compiler flag to allow reflexive dlopens.
+export_dynamic_flag='$export_dynamic_flag'
+
+# Pattern to match compiler flags for creating libNAME_p libraries:
+profile_flag_pattern='$profile_flag_pattern'
+
+# Library versioning type.
+version_type=$version_type
+
+# List of archive names. First name is the real one, the rest are links.
+# The last name is the one that the linker finds with -lNAME.
+library_names_spec='$library_names_spec'
+
+# The coded name of the library, if different from the real name.
+soname_spec='$soname_spec'
+
+# Commands used to build and install an old-style archive.
+RANLIB='$RANLIB'
+old_archive_cmds='$old_archive_cmds'
+old_postinstall_cmds='$old_postinstall_cmds'
+
+# Commands used to build and install a shared archive.
+archive_cmds='$archive_cmds'
+postinstall_cmds='$postinstall_cmds'
+
+# Commands used to finish a libtool library installation in a directory.
+finish_cmds='$finish_cmds'
+
+# How to strip a library file.
+striplib='$striplib'
+old_striplib='$old_striplib'
+
+# This is the shared library path variable.
+shlibpath_var=$shlibpath_var
+
+# How to hardcode a shared library path into an executable.
+hardcode_action=$hardcode_action
+
+# Flag to hardcode \$libdir into a binary during linking.
+# This must work even if \$libdir does not exist.
+hardcode_libdir_flag_spec='$hardcode_libdir_flag_spec'
+
+# Whether we need a single -rpath flag with a separated argument.
+hardcode_libdir_separator='$hardcode_libdir_separator'
+
+# Set to yes if using DIR/libNAME.so during linking hardcodes DIR into the
+# resulting binary.
+hardcode_direct=$hardcode_direct
+
+# Set to yes if using the -LDIR flag during linking hardcodes DIR into the
+# resulting binary.
+hardcode_minus_L=$hardcode_minus_L
+
+# Set to yes if using SHLIBPATH_VAR=DIR during linking hardcodes DIR into the
+# the resulting binary.
+hardcode_shlibpath_var=$hardcode_shlibpath_var
+
+EOF
+
+# Detect if we are using a relative or absolute path to ltmain.sh.
+case "$ltmain" in
+/*) cat <<EOF2 >> $ofile
+# Execute the libtool backend.
+. $ltmain
+EOF2
+ ;;
+*) cat <<EOF3 >> $ofile
+# Find the path to this script.
+thisdir=\`echo "\$0" | sed -e 's%/[^/]*\$%%'\`
+test "X\$0" = "X\$thisdir" && thisdir=.
+
+# Execute the libtool backend.
+. \$thisdir/$ltmain
+EOF3
+ ;;
+esac
+
+echo 'exit 1' >> $ofile
+
+chmod +x $ofile
+exit 0
+
+# Local Variables:
+# mode:shell-script
+# sh-indentation:2
+# End:
diff --git a/ltmain.sh b/ltmain.sh
new file mode 100644
index 000000000..d38fae1a9
--- /dev/null
+++ b/ltmain.sh
@@ -0,0 +1,1748 @@
+# ltmain.sh - Provide generalized library-building support services.
+# Generated automatically from ltmain.sh.in by configure.
+# Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+# Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
+#
+# 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.
+#
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+# The name of this program.
+progname=`echo "$0" | sed 's%^.*/%%'`
+
+# Constants.
+PROGRAM=ltmain.sh
+PACKAGE=libtool
+VERSION=0.9d
+
+default_mode=NONE
+help="Try \`$progname --help' for more information."
+ln_s="ln -s"
+cp_p="cp -p"
+magic="%%%MAGIC variable%%%"
+mkdir="mkdir"
+mv="mv -f"
+objdir=.libs
+rm="rm -f"
+
+if test "$LTCONFIG_VERSION" != "$VERSION"; then
+ echo "$progname: ltconfig version \`$LTCONFIG_VERSION' does not match $PROGRAM version \`$VERSION'" 1>&2
+ echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2
+ exit 1
+fi
+
+#
+if test "$build_libtool_libs" != yes && test "$build_old_libs" != yes; then
+ echo "$progname: not configured to build any kind of library" 1>&2
+ echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2
+ exit 1
+fi
+
+# Global variables.
+mode=$default_mode
+nonopt=
+prev=
+prevopt=
+run=
+show=echo
+show_help=
+
+# Parse our command line options once, thoroughly.
+while test -n "$1"
+do
+ arg="$1"
+ shift
+
+ case "$arg" in
+ -*=*) optarg=`echo "$arg" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
+ *) optarg= ;;
+ esac
+
+ # If the previous option needs an argument, assign it.
+ if test -n "$prev"; then
+ eval "$prev=\$arg"
+ prev=
+ prevopt=
+ continue
+ fi
+
+ # Have we seen a non-optional argument yet?
+ case "$arg" in
+ --help)
+ show_help=yes
+ ;;
+
+ --version)
+ echo "$PROGRAM (GNU $PACKAGE) $VERSION"
+ exit 0
+ ;;
+
+ --dry-run | -n)
+ run=:
+ ;;
+
+ --features)
+ echo "host: $host"
+ if test "$build_libtool_libs" = yes; then
+ echo "enable shared libraries"
+ else
+ echo "disable shared libraries"
+ fi
+ if test "$build_old_libs" = yes; then
+ echo "enable static libraries"
+ else
+ echo "disable static libraries"
+ fi
+ exit 0
+ ;;
+
+ --finish) mode="finish" ;;
+
+ --mode) prevopt="--mode" prev=mode ;;
+ --mode=*) mode="$optarg" ;;
+
+ -*)
+ echo "$progname: unrecognized option \`$arg'" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ ;;
+
+ *)
+ nonopt="$arg"
+ break
+ ;;
+ esac
+done
+
+
+if test -n "$prevopt"; then
+ echo "$progname: option \`$prevopt' requires an argument" 1>&2
+ echo "$help" 1>&2
+ exit 1
+fi
+
+
+if test -z "$show_help"; then
+
+ # Infer the operation mode.
+ if test "$mode" = NONE; then
+ case "$nonopt" in
+ *cc)
+ if echo " $@ " | egrep "[ ]-c[ ]" > /dev/null 2>&1; then
+ mode=compile
+ else
+ mode=link
+ fi
+ ;;
+ *install*|cp)
+ mode=install
+ ;;
+ *rm)
+ mode=uninstall
+ ;;
+ *.la)
+ mode=dlname
+ ;;
+ *)
+ # Just use the default operation mode.
+ if test "$mode" = NONE; then
+ if test -n "$nonopt"; then
+ echo "$progname: warning: cannot infer operation mode from \`$nonopt'" 1>&2
+ else
+ echo "$progname: warning: cannot infer operation mode without MODE-ARGS" 1>&2
+ fi
+ fi
+ ;;
+ esac
+ fi
+
+ # Change the help message to a mode-specific one.
+ generic_help="$help"
+ help="Try \`$progname --help --mode=$mode' for more information."
+
+ # These modes are in order of execution frequency so that they run quickly.
+ case "$mode" in
+ # libtool compile mode
+ compile)
+ progname="$progname: compile"
+ # Get the compilation command and the source file.
+ base_compile="$nonopt"
+ lastarg=
+ srcfile=
+
+ for arg
+ do
+ # Quote any args containing shell metacharacters.
+ case "$arg" in
+ *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*|*\"*)
+ quote_arg="'$arg'" ;;
+ *) quote_arg="$arg" ;;
+ esac
+
+ base_compile="$base_compile$lastarg"
+ srcfile="$quote_arg"
+ lastarg=" $srcfile"
+ done
+
+ # Get the name of the library object.
+ libobj=`echo "$srcfile" | sed -e 's%^.*/%%'`
+
+ # Recognize several different file suffixes.
+ xform='[cCFSf]'
+ case "$libobj" in
+ *.c++) xform='c++' ;;
+ *.cc) xform=cc ;;
+ *.cpp) xform=cpp ;;
+ *.cxx) xform=cxx ;;
+ *.f90) xform=f90 ;;
+ *.for) xform='for' ;;
+ esac
+
+ libobj=`echo "$libobj" | sed -e "s/\.$xform$/.lo/"`
+
+ case "$libobj" in
+ *.lo) obj=`echo "$libobj" | sed -e 's/\.lo$/.o/'` ;;
+ *)
+ echo "$progname: cannot determine name of library object from \`$srcfile'" 1>&2
+ exit 1
+ ;;
+ esac
+
+ if test -z "$base_compile"; then
+ echo "$progname: you must specify a compilation command" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ # Delete any old library objects.
+ $run $rm $obj $libobj
+ trap "$run $rm $obj $libobj; exit 1" 1 2 15
+
+ # Only build a PIC object if we are building libtool libraries.
+ if test "$build_libtool_libs" = yes; then
+ # All platforms use -DPIC, to notify preprocessed assembler code.
+ $show "$base_compile$pic_flag -DPIC $srcfile"
+ if eval "$run $base_compile$pic_flag -DPIC $srcfile"; then :
+ else
+ $run $rm $obj
+ exit 1
+ fi
+
+ # If we have no pic_flag, then copy the object into place and finish.
+ if test -z "$pic_flag"; then
+ $show "$ln_s $obj $libobj"
+ $run $ln_s $obj $libobj || $run $cp_p $obj $libobj
+ exit $?
+ fi
+
+ # Just move the object, then go on to compile the next one
+ $show "$mv $obj $libobj"
+ $run $mv $obj $libobj || exit 1
+ fi
+
+ # Compile the position-dependent object.
+ $show "$base_compile $srcfile"
+ if eval "$run $base_compile $srcfile"; then :
+ else
+ $run $rm $obj $libobj
+ exit 1
+ fi
+
+ # Symlink or copy the object file into library object, if no PIC.
+ if test "$build_libtool_libs" != yes; then
+ $show "$ln_s $obj $libobj"
+ $run $ln_s $obj $libobj || $run $cp_p $obj $libobj
+ exit $?
+ fi
+
+ exit 0
+ ;;
+
+ # libtool link mode
+ link)
+ progname="$progname: link"
+ # Go through the arguments, transforming them on the way.
+ cc="$nonopt"
+ args="$cc"
+ compile_command="$cc"
+ finalize_command="$cc"
+ compile_shlibpath=
+ finalize_shlibpath=
+ deplibs=
+ export_dynamic=no
+ hardcode_libdirs=
+ install_libdir=
+ libobjs=
+ link_against_libtool_libs=
+ link_static=
+ ltlibs=
+ objs=
+ output=
+ prev=
+ prevarg=
+ temp_rpath=
+ vinfo=
+ whole_archive=no
+
+ # We need to know -static, to get the right output filenames.
+ case " $@ " in
+ *" -static "*) build_libtool_libs=no build_old_libs=yes ;;
+ esac
+
+ for arg
+ do
+ # If the previous option needs an argument, assign it.
+ if test -n "$prev"; then
+ case "$prev" in
+ output)
+ compile_command="$compile_command @OUTPUT@"
+ finalize_command="$finalize_command @OUTPUT@"
+ args="$args $arg"
+ ;;
+ esac
+
+ eval "$prev=\$arg"
+ prev=
+
+ continue
+ fi
+
+ args="$args $arg"
+ prevarg="$arg"
+
+ case "$arg" in
+ -export-dynamic)
+ export_dynamic=yes
+ compile_command="$compile_command $export_dynamic_flag"
+ finalize_command="$finalize_command $export_dynamic_flag"
+ continue
+ ;;
+
+ -L*)
+ dir=`echo "$arg" | sed 's%^-L\(.*\)$%\1%'`
+ case "$dir" in
+ /*)
+ ;;
+ *)
+ echo "$progname: \`-L$dir' cannot specify a relative directory" 1>&2
+ exit 1
+ ;;
+ esac
+ deplibs="$deplibs $arg"
+ ;;
+
+ -l*) deplibs="$deplibs $arg" ;;
+
+ -no-whole-archive) whole_archive=no ;;
+
+ -o) prev=output ;;
+
+ -rpath)
+ prev=install_libdir
+ continue
+ ;;
+
+ -static)
+ link_static="`eval echo \"$link_static_flag\"`"
+ compile_command="$compile_command $link_static"
+ continue
+ ;;
+
+ -version-file)
+ echo "$progname: \`-version-file' has been replaced by \`-version-info'" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ ;;
+
+ -version-info)
+ prev=vinfo
+ continue
+ ;;
+
+ -whole-archive) whole_archive=yes ;;
+
+ -*) cc="$cc $arg" ;; # Some other compiler flag.
+
+ *.o)
+ # A standard object.
+ objs="$objs $arg"
+ ;;
+
+ *.a)
+ # Find the relevant object directory and library name.
+ file=`echo "$arg" | sed 's%^.*/%%'`
+ dir=`echo "$arg" | sed 's%/[^/]*$%/%'`
+ test "$dir" = "$arg" && dir=
+
+ # If -whole-archive was specified, we need to link all the members.
+ if test "$whole_archive" = yes; then
+ if test -f $arg; then :
+ else
+ echo "$progname: \`$arg' does not exist" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ # Get the names of the members of the archive.
+ members=`$AR t $arg 2>/dev/null`
+ for m in $members; do
+ case "$m" in
+ *.lo) libobjs="$libobjs $dir$m" ;;
+ *.o)
+ if test "$build_libtool_libs" = yes; then
+ objs="$objs $dir$m"
+ else
+ libobjs="$libobjs $dir$m"
+ fi
+ ;;
+ esac
+ done
+ elif test -f "$dir$objdir/$file"; then
+ # .libs/libfoo.a exists, so this is an archive of libobjects.
+ libobjs="$libobjs $arg"
+ else
+ # Standard archive.
+ objs="$objs $arg"
+ fi
+ ;;
+
+ *.lo)
+ # A library object.
+ libobjs="$libobjs $arg"
+ ;;
+
+ *.la)
+ # A libtool-controlled library.
+
+ libdir=
+ library_names=
+ old_library=
+
+ # Check to see that this really is a libtool archive.
+ if egrep "^# Generated by $PROGRAM" $arg >/dev/null 2>&1; then :
+ else
+ echo "$progname: \`$arg' is not a valid libtool archive" 1>&2
+ exit 1
+ fi
+
+ # If there is no directory component, then add one.
+ case "$arg" in
+ */*) . $arg ;;
+ *) . ./$arg ;;
+ esac
+
+ if test -z "$libdir"; then
+ echo "$progname: \`$arg' contains no -rpath information" 1>&2
+ exit 1
+ fi
+
+ # Get the name of the library we link against.
+ linklib=
+ for l in $old_library $library_names; do
+ linklib="$l"
+ done
+
+ if test -z "$linklib"; then
+ echo "$progname: cannot find name of link library for \`$arg'" 1>&2
+ exit 1
+ fi
+
+ # Find the relevant object directory and library name.
+ name=`echo "$arg" | sed 's%^.*/%%; s/\.la$//; s/^lib//'`
+ dir=`echo "$arg" | sed 's%/[^/]*$%%'`
+ if test "$dir" = "$arg"; then
+ dir="$objdir"
+ else
+ dir="$dir/$objdir"
+ fi
+
+ link_against_libtool_libs="$link_against_libtool_libs $arg"
+
+ if test "$build_libtool_libs" = yes; then
+ if test -n "$shlibpath_var"; then
+ # Make sure the rpath contains only unique directories.
+ case "$temp_rpath " in
+ "* $dir *") ;;
+ *) temp_rpath="$temp_rpath $dir" ;;
+ esac
+ fi
+
+ if test -n "$hardcode_libdir_flag_spec"; then
+ if test -n "$hardcode_libdir_separator"; then
+ if test -z "$hardcode_libdirs"; then
+ # Put the magic libdir with the hardcode flag.
+ hardcode_libdirs="$libdir"
+ libdir="@HARDCODE_LIBDIRS@"
+ else
+ # Just accumulate the libdirs.
+ hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir"
+ libdir=
+ fi
+ fi
+
+ if test -n "$libdir"; then
+ hardcode_libdir_flag=`eval echo \"$hardcode_libdir_flag_spec\"`
+ compile_command="$compile_command $hardcode_libdir_flag"
+ finalize_command="$finalize_command $hardcode_libdir_flag"
+ fi
+ fi
+
+ case "$hardcode_action" in
+ immediate)
+ if test "$hardcode_direct" = no; then
+ compile_command="$compile_command $dir/$linklib"
+ elif test "$hardcode_minus_L" = no; then
+ compile_command="$compile_command -L$dir -l$name"
+ elif test "$hardcode_shlibpath_var" = no; then
+ compile_shlibpath="$compile_shlibpath$dir:"
+ compile_command="$compile_command -l$name"
+ fi
+ ;;
+
+ relink)
+ # We need an absolute path.
+ case "$dir" in
+ /*) ;;
+ *)
+ absdir=`cd "$dir" && pwd`
+ if test -z "$absdir"; then
+ echo "$progname: cannot determine absolute directory name of \`$dir'" 1>&2
+ exit 1
+ fi
+ dir="$absdir"
+ ;;
+ esac
+
+ if test "$hardcode_direct" = yes; then
+ compile_command="$compile_command $dir/$linklib"
+ elif test "$hardcode_minus_L" = yes; then
+ compile_command="$compile_command -L$dir -l$name"
+ elif test "$hardcode_shlibpath_var" = yes; then
+ compile_shlibpath="$compile_shlibpath$dir:"
+ compile_command="$compile_command -l$name"
+ fi
+ ;;
+
+ *)
+ echo "$progname: \`$hardcode_action' is an unknown hardcode action" 1>&2
+ exit 1
+ ;;
+ esac
+
+ # Finalize command for both is simple: just hardcode it.
+ if test "$hardcode_direct" = yes; then
+ finalize_command="$finalize_command $libdir/$linklib"
+ elif test "$hardcode_minus_L" = yes; then
+ finalize_command="$finalize_command -L$libdir -l$name"
+ elif test "$hardcode_shlibpath_var" = yes; then
+ finalize_shlibpath="$finalize_shlibpath$libdir:"
+ finalize_command="$finalize_command -l$name"
+ else
+ # We can't seem to hardcode it, guess we'll fake it.
+ finalize_command="$finalize_command -L$libdir -l$name"
+ fi
+ else
+ # Transform directly to old archives if we don't build new libraries.
+ test -z "$old_library" || linklib="$old_library"
+ compile_command="$compile_command $dir/$linklib"
+ finalize_command="$finalize_command $dir/$linklib"
+ fi
+ continue
+ ;;
+
+ *)
+ echo "$progname: unknown file suffix for \`$arg'" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ ;;
+ esac
+
+ compile_command="$compile_command $arg"
+ finalize_command="$finalize_command $arg"
+ done
+
+ if test -n "$prev"; then
+ echo "$progname: the \`$prevarg' option requires an argument" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ # Substitute the hardcoded libdirs into the compile commands.
+ if test "$hardcode_libdir_colon_separated" = yes; then
+ compile_command=`echo "$compile_command" | sed "s%@HARDCODE_LIBDIRS@%$hardcode_libdirs%g"`
+ finalize_command=`echo "$finalize_command" | sed "s%@HARDCODE_LIBDIRS@%$hardcode_libdirs%g"`
+ fi
+
+ oldlib=
+ oldobjs=
+ case "$output" in
+ "")
+ echo "$progname: you must specify an output file" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ ;;
+
+ */*)
+ echo "$progname: output file \`$output' must have no directory components" 1>&2
+ exit 1
+ ;;
+
+ *.a)
+ # Old archive.
+ libname=`echo "$output" | sed 's/\.a$//'`
+ build_old_libs=yes
+
+ if test -n "$install_libdir"; then
+ echo "$progname: warning: \`-rpath' is ignored while linking old-style libraries" 1>&2
+ fi
+
+ if test -n "$vinfo"; then
+ echo "$progname: warning: \`-version-info' is ignored while linking old-style libraries" 1>&2
+ fi
+ ;;
+
+ *.la)
+ libname=`echo "$output" | sed 's/\.la$//'`
+
+ # All the library-specific variables (install_libdir is set above).
+ library_names=
+ old_library=
+ dlname=
+ current=0
+ revision=0
+ age=0
+
+ if test -n "$objs"; then
+ echo "$progname: cannot build libtool library \`$output' from non-libtool objects:$objs" 2>&1
+ exit 1
+ fi
+
+ # How the heck are we supposed to write a wrapper for a shared library?
+ if test -n "$link_against_libtool_libs"; then
+ echo "$progname: libtool library \`$output' may not depend on uninstalled libraries:$link_against_libtool_libs" 1>&2
+ exit 1
+ fi
+
+ if test -z "$install_libdir"; then
+ echo "$progname: you must specify an installation directory with \`-rpath'" 1>&2
+ exit 1
+ fi
+
+ # Parse the version information argument.
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=':'
+ set dummy $vinfo
+ IFS="$save_ifs"
+
+ if test -n "$5"; then
+ echo "$progname: too many parameters to \`-version-info'" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ test -n "$2" && current="$2"
+ test -n "$3" && revision="$3"
+ test -n "$4" && age="$4"
+
+ # Check that each of the things are valid numbers.
+ case "$current" in
+ 0 | [1-9] | [1-9][0-9]*) ;;
+ *)
+ echo "$progname: CURRENT \`$current' is not a nonnegative integer" 1>&2
+ echo "$progname: \`$vinfo' is not valid version information" 1>&2
+ exit 1
+ ;;
+ esac
+
+ case "$revision" in
+ 0 | [1-9] | [1-9][0-9]*) ;;
+ *)
+ echo "$progname: REVISION \`$revision' is not a nonnegative integer" 1>&2
+ echo "$progname: \`$vinfo' is not valid version information" 1>&2
+ exit 1
+ ;;
+ esac
+
+ case "$age" in
+ 0 | [1-9] | [1-9][0-9]*) ;;
+ *)
+ echo "$progname: AGE \`$age' is not a nonnegative integer" 1>&2
+ echo "$progname: \`$vinfo' is not valid version information" 1>&2
+ exit 1
+ ;;
+ esac
+
+ if test $age -gt $current; then
+ echo "$progname: AGE \`$age' is greater than the current interface number \`$current'" 1>&2
+ echo "$progname: \`$vinfo' is not valid version information" 1>&2
+ exit 1
+ fi
+
+ # Calculate the version variables.
+ version_vars="version_type current age revision"
+ case "$version_type" in
+ none) ;;
+
+ linux)
+ version_vars="$version_vars major versuffix"
+ major=`expr $current - $age`
+ versuffix="$major.$age.$revision"
+ ;;
+
+ osf)
+ version_vars="$version_vars versuffix verstring"
+ major=`expr $current - $age`
+ versuffix="$current.$age.$revision"
+ verstring="$versuffix"
+
+ # Add in all the interfaces that we are compatible with.
+ loop=$age
+ while test $loop != 0; do
+ iface=`expr $current - $loop`
+ loop=`expr $loop - 1`
+ verstring="$verstring:${iface}.0"
+ done
+
+ # Make executables depend on our current version.
+ verstring="$verstring:${current}.0"
+ ;;
+
+ sunos)
+ version_vars="$version_vars major versuffix"
+ major="$current"
+ versuffix="$current.$revision"
+ ;;
+
+ *)
+ echo "$progname: unknown library version type \`$version_type'" 1>&2
+ echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2
+ exit 1
+ ;;
+ esac
+
+ # Create the output directory, or remove our outputs if we need to.
+ if test -d $objdir; then
+ $show "$rm $objdir/$libname.*"
+ $run $rm $objdir/$libname.*
+ else
+ $show "$mkdir $objdir"
+ $run $mkdir $objdir || exit $?
+ fi
+
+ if test "$build_libtool_libs" = yes; then
+ # Get the real and link names of the library.
+ library_names=`eval echo \"$library_names_spec\"`
+ set dummy $library_names
+ realname="$2"
+ shift; shift
+
+ if test -n "$soname_spec"; then
+ soname=`eval echo \"$soname_spec\"`
+ else
+ soname="$realname"
+ fi
+
+ lib="$objdir/$realname"
+ linknames=
+ for link
+ do
+ linknames="$linknames $objdir/$link"
+ done
+
+ # Use standard objects if they are PIC.
+ test -z "$pic_flag" && libobjs=`echo "$libobjs " | sed 's/\.lo /.o /g; s/ $//g'`
+
+ # Do each of the archive commands.
+ cmds=`eval echo \"$archive_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd" || exit $?
+ done
+ IFS="$save_ifs"
+
+ # Create links to the real library.
+ for link in $linknames; do
+ $show "$ln_s $realname $link"
+ $run $ln_s $realname $link || exit $?
+ done
+
+ # If -export-dynamic was specified, set the dlname.
+ if test "$export_dynamic" = yes; then
+ # On all known operating systems, these are identical.
+ dlname="$soname"
+ fi
+ fi
+ ;;
+
+ *.lo | *.o)
+ if test -n "$link_against_libtool_libs"; then
+ echo "$progname: error: cannot link libtool libraries into reloadable objects" 1>&2
+ exit 1
+ fi
+
+ if test -n "$deplibs"; then
+ echo "$progname: warning: \`-l' and \`-L' are ignored while creating objects" 1>&2
+ fi
+
+ if test -n "$install_libdir"; then
+ echo "$progname: warning: \`-rpath' is ignored while creating objects" 1>&2
+ fi
+
+ if test -n "$vinfo"; then
+ echo "$progname: warning: \`-version-info' is ignored while creating objects" 1>&2
+ fi
+
+ case "$output" in
+ *.lo)
+ if test -n "$objs"; then
+ echo "$progname: cannot build library object \`$output' from non-libtool objects" 1>&2
+ exit 1
+ fi
+ libobj="$output"
+ obj=`echo "$output" | sed 's/\.lo$/.o/'`
+ ;;
+ *)
+ libobj=
+ obj="$output"
+ ;;
+ esac
+
+ # Delete the old objects.
+ $run $rm $obj $libobj
+
+ # Create the old-style object (skipping any convenience libraries).
+ # FIXME: skipping them is simplistic. We should determine which members
+ # are actually needed to resolve symbols.
+ reload_objs="$objs"`echo "$libobjs " | sed 's/[^ ]*\.a //g; s/\.lo /.o /g; s/ $//g'`
+
+ output="$obj"
+ cmds=`eval echo \"$reload_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd" || exit $?
+ done
+ IFS="$save_ifs"
+
+ # Exit if we aren't doing a library object file.
+ test -z "$libobj" && exit 0
+
+ if test "$build_libtool_libs" = yes && test -n "$pic_flag"; then
+ # Only do commands if we really have different PIC objects.
+ reload_objs="$libobjs"
+ output="$libobj"
+ cmds=`eval echo \"$reload_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd" || exit $?
+ done
+ IFS="$save_ifs"
+ else
+ # Just create a symlink.
+ $show "$ln_s $obj $libobj"
+ $run $ln_s $obj $libobj || $run $cp_p $obj $libobj || exit 1
+ fi
+
+ exit 0
+ ;;
+
+ *)
+ if test -n "$install_libdir"; then
+ echo "$progname: warning: \`-rpath' is ignored while linking programs" 1>&2
+ fi
+
+ if test -n "$vinfo"; then
+ echo "$progname: warning: \`-version-info' is ignored while linking programs" 1>&2
+ fi
+
+ if test -n "$libobjs"; then
+ # Transform all the library objects into standard objects.
+ compile_command=`echo "$compile_command " | sed 's/\.lo /.o /g; s/ $//'`
+ fi
+
+ if test -z "$link_against_libtool_libs" || test "$build_libtool_libs" != yes; then
+ # Replace the output file specification.
+ compile_command=`echo "$compile_command" | sed 's%@OUTPUT@%'"$output"'%g'`
+ finalize_command=`echo "$finalize_command" | sed 's%@OUTPUT@%'"$output"'%g'`
+
+ # We have no uninstalled library dependencies, so finalize right now.
+ $show "$compile_command"
+ $run $compile_command
+ status=$?
+
+ # If we failed to link statically, then try again.
+ if test $status -ne 0 && test -n "$link_static"; then
+ echo "$progname: cannot link \`$output' statically; retrying semi-dynamically" 1>&2
+ compile_command=`echo "$compile_command " | sed "s% $link_static % %;s/ $//"`
+ $show "$finalize_command"
+ $run $finalize_command
+ status=$?
+ fi
+ exit $status
+ fi
+
+ # Replace the output file specification.
+ compile_command=`echo "$compile_command" | sed 's%@OUTPUT@%'"$objdir/$output"'%g'`
+ finalize_command=`echo "$finalize_command" | sed 's%@OUTPUT@%'"$objdir/$output"'T%g'`
+
+ # Create the binary in the object directory, then wrap it.
+ if test -d $objdir; then :
+ else
+ $show "$mkdir $objdir"
+ $run $mkdir $objdir || exit $?
+ fi
+
+ if test -n "$shlibpath_var"; then
+ # We should set the shlibpath_var
+ rpath=
+ for dir in $temp_rpath; do
+ case "$dir" in
+ /*)
+ # Absolute path.
+ rpath="$rpath$dir:"
+ ;;
+ *)
+ # Relative path: add a thisdir entry.
+ rpath="$rpath\$thisdir/$dir:"
+ ;;
+ esac
+ done
+ fi
+
+ # Delete the old output file.
+ $run $rm $output
+
+ if test -n "$compile_shlibpath"; then
+ compile_command="$shlibpath_var=$compile_shlibpath\$$shlibpath_var $compile_command"
+ fi
+ if test -n "$finalize_shlibpath"; then
+ finalize_command="$shlibpath_var=$finalize_shlibpath\$$shlibpath_var $finalize_command"
+ fi
+
+ case "$hardcode_action" in
+ relink)
+ # AGH! Flame the AIX and HP-UX people for me, will ya?
+ echo "$progname: warning: using a buggy system linker" 1>&2
+ echo "$progname: relinking will be required before \`$output' can be installed" 1>&2
+ ;;
+ esac
+
+ $show "$compile_command"
+ eval "$run $compile_command" || exit $?
+
+ # Now create the wrapper script.
+ echo "creating $output"
+
+ # Only actually do things if our run command is non-null.
+ if test -z "$run"; then
+ $rm $output
+ trap "$rm $output; exit 1" 1 2 15
+
+ cat > $output <<EOF
+#! /bin/sh
+
+# $output - temporary wrapper script for $objdir/$output
+# Generated by $PROGRAM - GNU $PACKAGE $VERSION
+#
+# The $output program cannot be directly executed until all the libtool
+# libraries that it depends on are installed.
+#
+# This wrapper script should never be moved out of \``pwd`'.
+# If it is, it will not operate correctly.
+
+# This environment variable determines our operation mode.
+if test "\$libtool_install_magic" = "$magic"; then
+ # install mode needs the following variables:
+ link_against_libtool_libs="$link_against_libtool_libs"
+ finalize_command="$finalize_command"
+else
+ # Find the directory that this script lives in.
+ thisdir=\`echo \$0 | sed 's%/[^/]*$%%'\`
+ test "x\$thisdir" = "x\$0" && thisdir=.
+
+ # Try to get the absolute directory name.
+ absdir=\`cd "\$thisdir" && pwd\`
+ test -n "\$absdir" && thisdir="\$absdir"
+
+ progdir="\$thisdir/$objdir"
+ program="$output"
+
+ if test -f "\$progdir/\$program"; then
+ # Run the actual program with our arguments.
+ args=
+ for arg
+ do
+ # Quote arguments (to preserve shell metacharacters).
+ args="\$args '\$arg'"
+ done
+
+ # Export the path to the program.
+ PATH="\$progdir:\$PATH"
+ export PATH
+EOF
+
+ # Export our shlibpath_var if we have one.
+ if test -n "$shlibpath_var" && test -n "$rpath"; then
+ cat >> $output <<EOF
+
+ # Add our own library path to $shlibpath_var
+ $shlibpath_var="$rpath\$$shlibpath_var"
+ export $shlibpath_var
+EOF
+ fi
+
+ cat >> $output <<EOF
+
+ eval "exec \$program \$args"
+
+ echo "\$0: cannot exec \$program \$args"
+ exit 1
+ else
+ # The program doesn't exist.
+ echo "\$0: error: \$progdir/\$program does not exist" 1>&2
+ echo "This script is just a wrapper for \$program." 1>&2
+ echo "See the $PACKAGE documentation for more information." 1>&2
+ exit 1
+ fi
+fi
+EOF
+ chmod +x $output
+ fi
+ exit 0
+ ;;
+ esac
+
+
+ # See if we need to build an old-fashioned archive.
+ if test "$build_old_libs" = "yes"; then
+ # Now set the variables for building old libraries.
+ oldlib="$objdir/$libname.a"
+
+ # Transform .lo files to .o (skipping convenience libraries).
+ # FIXME: skipping them is simplistic. We should determine which members
+ # are actually needed to resolve symbols.
+ oldobjs="$objs"`echo "$libobjs " | sed 's/[^ ]*\.a //g; s/\.lo /.o /g; s/ $//g'`
+
+ if test -d "$objdir"; then
+ $show "$rm $oldlib"
+ $run $rm $oldlib
+ else
+ $show "$mkdir $objdir"
+ $run $mkdir $objdir
+ fi
+
+ # Do each command in the archive commands.
+ cmds=`eval echo \"$old_archive_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd" || exit $?
+ done
+ IFS="$save_ifs"
+
+ case "$output" in
+ *.a)
+ # Just move into place if there were any non-libtool objects.
+ if test -n "$objs"; then
+ $show "$mv $oldlib $output"
+ $run $mv $oldlib $output
+
+ elif test -z "$pic_flag" || test "$build_libtool_libs" != yes; then
+ # Just symlink if libtool objects are the same.
+ $show "$rm $output"
+ $run $rm $output
+ $show "$ln_s $oldlib $output"
+ $run $ln_s $oldlib $output
+
+ else
+ # Create an archive of libtool objects.
+ oldlib="$output"
+ oldobjs="$libobjs"
+
+ # Do each command in the archive commands.
+ cmds=`eval echo \"$old_archive_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd" || exit $?
+ done
+ IFS="$save_ifs"
+ fi
+ ;;
+ esac
+ fi
+
+ # Now create the libtool archive.
+ case "$output" in
+ *.la)
+ old_library=
+ test "$build_old_libs" = yes && old_library="$libname.a"
+
+ echo "creating $output"
+
+ # Only create the output if not a dry run.
+ if test -z "$run"; then
+ cat > $output <<EOF
+# $output - a libtool library file
+# Generated by $PROGRAM - GNU $PACKAGE $VERSION
+
+# Names of this library.
+library_names='$library_names'
+
+# The name of the static archive.
+old_library='$old_library'
+
+# The name that we can dlopen(3).
+dlname='$dlname'
+
+# Version information for $libname.
+current=$current
+age=$age
+revision=$revision
+
+# Directory that this library needs to be installed in:
+libdir='$install_libdir'
+EOF
+ fi
+ ;;
+ esac
+ exit 0
+ ;;
+
+ # libtool install mode
+ install)
+ progname="$progname: install"
+
+ # The first argument is the name of the installation program.
+ install_prog="$nonopt"
+
+ # We need to accept at least all the BSD install flags.
+ dest=
+ files=
+ opts=
+ prev=
+ install_type=
+ isdir=
+ stripme=
+ for arg
+ do
+ if test -n "$dest"; then
+ files="$files $dest"
+ dest="$arg"
+ continue
+ fi
+
+ case "$arg" in
+ -d) isdir=yes ;;
+ -f) prev="-f" ;;
+ -g) prev="-g" ;;
+ -m) prev="-m" ;;
+ -o) prev="-o" ;;
+ -s)
+ stripme=" -s"
+ continue
+ ;;
+ -*) ;;
+
+ *)
+ # If the previous option needed an argument, then skip it.
+ if test -n "$prev"; then
+ prev=
+ else
+ dest="$arg"
+ continue
+ fi
+ ;;
+ esac
+ install_prog="$install_prog $arg"
+ done
+
+ if test -z "$install_prog"; then
+ echo "$progname: you must specify an install program" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ if test -n "$prev"; then
+ echo "$progname: the \`$prev' option requires an argument" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ if test -z "$files"; then
+ if test -z "$dest"; then
+ echo "$progname: no file or destination specified" 1>&2
+ else
+ echo "$progname: you must specify a destination" 1>&2
+ fi
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ # Strip any trailing slash from the destination.
+ dest=`echo "$dest" | sed 's%/$%%'`
+
+ # Check to see that the destination is a directory.
+ test -d "$dest" && isdir=yes
+ if test -n "$isdir"; then
+ destdir="$dest"
+ else
+ destdir=`echo "$dest" | sed 's%/[^/]*$%%'`
+ fi
+ case "$destdir" in
+ /*) ;;
+ *)
+ echo "$progname: $destdir must be an absolute directory name" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ esac
+
+ staticlibs=
+ future_libdirs=
+ current_libdirs=
+ for file in $files; do
+
+ # Do each installation.
+ case "$file" in
+ *.a)
+ # Do the static libraries later.
+ staticlibs="$staticlibs $file"
+ ;;
+
+ *.la)
+ # Check to see that this really is a libtool archive.
+ if egrep "^# Generated by $PROGRAM" $file >/dev/null 2>&1; then :
+ else
+ echo "$progname: \`$file' is not a valid libtool archive" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ library_names=
+ old_library=
+ # If there is no directory component, then add one.
+ case "$file" in
+ */*) . $file ;;
+ *) . ./$file ;;
+ esac
+
+ # Add the libdir to current_libdirs if it is the destination.
+ if test "$destdir" = "$libdir"; then
+ case "$current_libdirs " in
+ "* $libdir *") ;;
+ *) current_libdirs="$current_libdirs $libdir" ;;
+ esac
+ else
+ # Note the libdir as a future libdir.
+ case "$future_libdirs " in
+ "* $libdir *") ;;
+ *) future_libdirs="$future_libdirs $libdir" ;;
+ esac
+ fi
+
+ dir="`echo "$file" | sed 's%/[^/]*$%%'`/"
+ test "$dir" = "$file/" && dir=
+ dir="$dir$objdir"
+
+ # See the names of the shared library.
+ set dummy $library_names
+ if test -n "$2"; then
+ realname="$2"
+ shift
+ shift
+
+ # Install the shared library and build the symlinks.
+ $show "$install_prog $dir/$realname $destdir/$realname"
+ eval "$run $install_prog $dir/$realname $destdir/$realname" || exit $?
+ test "X$dlname" = "X$realname" && dlname=
+
+ # Support stripping libraries.
+ if test -n "$stripme"; then
+ if test -n "$striplib"; then
+ $show "$striplib $destdir/$realname"
+ $run $striplib $destdir/$realname || exit $?
+ else
+ echo "$progname: warning: no library stripping program" 1>&2
+ fi
+ fi
+
+ if test -n "$1"; then
+ # Delete the old symlinks.
+ rmcmd="$rm"
+ for linkname
+ do
+ rmcmd="$rmcmd $destdir/$linkname"
+ done
+ $show "$rmcmd"
+ $run $rmcmd
+
+ # ... and create new ones.
+ for linkname
+ do
+ test "X$dlname" = "X$linkname" && dlname=
+ $show "$ln_s $realname $destdir/$linkname"
+ $run $ln_s $realname $destdir/$linkname
+ done
+ fi
+
+ if test -n "$dlname"; then
+ # Install the dynamically-loadable library.
+ $show "$install_prog $dir/$dlname $destdir/$dlname"
+ eval "$run $install_prog $dir/$dlname $destdir/$dlname" || exit $?
+ fi
+
+ # Do each command in the postinstall commands.
+ lib="$destdir/$realname"
+ cmds=`eval echo \"$postinstall_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd" || exit $?
+ done
+ IFS="$save_ifs"
+ fi
+
+ # Install the pseudo-library for information purposes.
+ name=`echo "$file" | sed 's%^.*/%%'`
+ $show "$install_prog $file $destdir/$name"
+ $run $install_prog $file $destdir/$name || exit $?
+
+ # Maybe install the static library, too.
+ test -n "$old_library" && staticlibs="$staticlibs $dir/$old_library"
+ ;;
+
+ *)
+ # Do a test to see if this is really a libtool program.
+ if egrep "^# Generated by $PROGRAM" $file >/dev/null 2>&1; then
+ # This variable tells wrapper scripts just to set variables rather
+ # than running their programs.
+ libtool_install_magic="$magic"
+ link_against_libtool_libs=
+ finalize_command=
+
+ # If there is no directory component, then add one.
+ case "$file" in
+ */*) . $file ;;
+ *) . ./$file ;;
+ esac
+
+ # Check the variables that should have been set.
+ if test -z "$link_against_libtool_libs" || test -z "$finalize_command"; then
+ echo "$progname: invalid libtool wrapper script \`$file'" 1>&2
+ exit 1
+ fi
+
+ finalize=yes
+ for lib in $link_against_libtool_libs; do
+ # Check to see that each library is installed.
+ libdir=
+ if test -f "$lib"; then
+ # If there is no directory component, then add one.
+ case "$lib" in
+ */*) . $lib ;;
+ *) . ./$lib ;;
+ esac
+ fi
+ libfile="$libdir/`echo "$lib" | sed 's%^.*/%%g'`"
+ if test -z "$libdir"; then
+ echo "$progname: warning: \`$lib' contains no -rpath information" 1>&2
+ elif test -f "$libfile"; then :
+ else
+ echo "$progname: warning: \`$lib' has not been installed in \`$libdir'" 1>&2
+ finalize=no
+ fi
+ done
+
+ if test "$hardcode_direct" != no && test "$hardcode_minus_L" != no && test "$hardcode_shlibpath_var" != no; then
+ if test "$finalize" = no; then
+ echo "$progname: warning: cannot relink \`$file' on behalf of your buggy system linker" 1>&2
+ else
+ echo "$progname: warning: relinking \`$file' on behalf of your buggy system linker" 1>&2
+ $show "$finalize_command"
+ if $run $finalize_command; then :
+ else
+ echo "$progname: error: relink \`$file' with the above command before installing it" 1>&2
+ continue
+ fi
+ file="$objdir/$file"T
+ fi
+ else
+ # Install the binary that we compiled earlier.
+ dir=`echo "$file" | sed 's%/[^/]*$%%'`
+ if test "$file" = "$dir"; then
+ file="$objdir/$file"
+ else
+ file="$dir/$objdir/`echo "$file" | sed 's%^.*/%%'`"
+ fi
+ fi
+ fi
+
+ $show "$install_prog$stripme $file $dest"
+ $run $install_prog$stripme $file $dest || exit $?
+ ;;
+ esac
+ done
+
+ for file in $staticlibs; do
+ name=`echo "$file" | sed 's%^.*/%%'`
+
+ # Set up the ranlib parameters.
+ oldlib="$destdir/$name"
+
+ $show "$install_prog $file $oldlib"
+ $run $install_prog $file $oldlib || exit $?
+
+ # Support stripping libraries.
+ if test -n "$stripme"; then
+ if test -n "$old_striplib"; then
+ $show "$old_striplib $oldlib"
+ $run $old_striplib $oldlib || exit $?
+ else
+ echo "$progname: warning: no static library stripping program" 1>&2
+ fi
+ fi
+
+ # Do each command in the postinstall commands.
+ cmds=`eval echo \"$old_postinstall_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd" || exit $?
+ done
+ IFS="$save_ifs"
+ done
+
+ if test -n "$future_libdirs"; then
+ echo "$progname: warning: remember to run \`$progname --finish$future_libdirs'" 1>&2
+ fi
+
+ if test -n "$current_libdirs"; then
+ # Maybe just do a dry run.
+ test -n "$run" && current_libdirs=" -n$current_libdirs"
+ exec $0 --finish$current_libdirs
+ exit 1
+ fi
+
+ exit 0
+ ;;
+
+ # libtool dlname mode
+ dlname)
+ progname="$progname: dlname"
+ ltlibs="$nonopt"
+ for lib
+ do
+ ltlibs="$ltlibs $lib"
+ done
+
+ # Now check to make sure each one is a valid libtool library.
+ status=0
+ for lib in $ltlibs; do
+ dlname=
+ libdir=
+
+ # Check to see that this really is a libtool archive.
+ if egrep "^# Generated by $PROGRAM" $arg >/dev/null 2>&1; then :
+ else
+ echo "$progname: \`$arg' is not a valid libtool archive" 1>&2
+ status=1
+ continue
+ fi
+
+ # If there is no directory component, then add one.
+ case "$arg" in
+ */*) . $arg ;;
+ *) . ./$arg ;;
+ esac
+
+ if test -z "$libdir"; then
+ echo "$progname: \`$arg' contains no -rpath information" 1>&2
+ status=1
+ elif test -n "$dlname"; then
+ echo "$libdir/$dlname"
+ else
+ echo "$progname: \`$arg' was not linked with \`-export-dynamic'" 1>&2
+ status=1
+ fi
+ done
+ exit $status
+ ;;
+
+ # libtool finish mode
+ finish)
+ progname="$progname: finish"
+ libdirs="$nonopt"
+
+ if test -n "$finish_cmds" && test -n "$libdirs"; then
+ for dir
+ do
+ libdirs="$libdirs $dir"
+ done
+
+ for libdir in $libdirs; do
+ # Do each command in the postinstall commands.
+ cmds=`eval echo \"$finish_cmds\"`
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS=';'
+ for cmd in $cmds; do
+ IFS="$save_ifs"
+ $show "$cmd"
+ eval "$run $cmd"
+ done
+ IFS="$save_ifs"
+ done
+ fi
+
+ echo "To link against installed libraries in LIBDIR, users may have to:"
+ if test -n "$shlibpath_var"; then
+ echo " - add LIBDIR to their \`$shlibpath_var' environment variable"
+ fi
+ echo " - use the \`-LLIBDIR' linker flag"
+ exit 0
+ ;;
+
+ # libtool uninstall mode
+ uninstall)
+ progname="$progname: uninstall"
+ rm="$nonopt"
+ files=
+
+ for arg
+ do
+ case "$arg" in
+ -*) rm="$rm $arg" ;;
+ *) files="$files $arg" ;;
+ esac
+ done
+
+ if test -z "$rm"; then
+ echo "$progname: you must specify an RM program" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ fi
+
+ for file in $files; do
+ dir=`echo "$file" | sed -e 's%/[^/]*$%%'`
+ test "$dir" = "$file" && dir=.
+ name=`echo "$file" | sed -e 's%^.*/%%'`
+
+ rmfiles="$file"
+
+ case "$name" in
+ *.la)
+ # Possibly a libtool archive, so verify it.
+ if egrep "^# Generated by $PROGRAM" $file >/dev/null 2>&1; then
+ . $dir/$name
+
+ # Delete the libtool libraries and symlinks.
+ for n in $library_names; do
+ rmfiles="$rmfiles $dir/$n"
+ test "X$n" = "X$dlname" && dlname=
+ done
+ test -n "$dlname" && rmfiles="$rmfiles $dir/$dlname"
+ test -n "$old_library" && rmfiles="$rmfiles $dir/$old_library"
+
+ # FIXME: should reinstall the best remaining shared library.
+ fi
+ ;;
+ esac
+
+ $show "$rm $rmfiles"
+ $run $rm $rmfiles
+ done
+ exit 0
+ ;;
+
+ NONE)
+ echo "$progname: you must specify a MODE" 1>&2
+ echo "$generic_help" 1>&2
+ exit 1
+ ;;
+ esac
+
+ echo "$progname: invalid operation mode \`$mode'" 1>&2
+ echo "$generic_help" 1>&2
+ exit 1
+fi # test -z "$show_help"
+
+# We need to display help for each of the modes.
+case "$mode" in
+NONE) cat <<EOF
+Usage: $progname [OPTION]... [MODE-ARG]...
+
+Provide generalized library-building support services.
+
+-n, --dry-run display commands without modifying any files
+ --features display configuration information and exit
+ --finish same as \`--mode=finish'
+ --help display this help message and exit
+ --mode=MODE use operation mode MODE [default=inferred from MODE-ARGS]
+ --version print version information
+
+MODE must be one of the following:
+
+ compile compile a source file into a libtool object
+ dlname print filenames to use to \`dlopen' libtool libraries
+ finish complete the installation of libtool libraries
+ install install libraries or executables
+ link create a library or an executable
+ uninstall remove libraries from an installed directory
+
+MODE-ARGS vary depending on the MODE. Try \`$progname --help --mode=MODE' for
+a more detailed description of MODE.
+EOF
+ ;;
+
+compile)
+ cat <<EOF
+Usage: $progname [OPTION]... --mode=compile COMPILE-COMMAND... SOURCEFILE
+
+Compile a source file into a libtool library object.
+
+COMPILE-COMMAND is a command to be used in creating a \`standard' object file
+from the given SOURCEFILE.
+
+The output file name is determined by removing the directory component from
+SOURCEFILE, then substituting the C source code suffix \`.c' with the
+library object suffix, \`.lo'.
+EOF
+ ;;
+
+dlname)
+ cat <<EOF
+Usage: $progname [OPTION]... --mode=dlname LTLIBRARY [LTLIBRARY]...
+
+Print filenames to use to \`dlopen' libtool libraries.
+
+Each LTLIBRARY is the name of a dynamically loadable libtool library (one that
+was linked using the \`-export-dynamic' option).
+
+The names to use are printed to standard output, one per line.
+EOF
+ ;;
+
+finish)
+ cat <<EOF
+Usage: $progname [OPTION]... --mode=finish [LIBDIR]...
+
+Complete the installation of libtool libraries.
+
+Each LIBDIR is a directory that contains libtool libraries.
+
+The commands that this mode executes may require superuser privileges. Use
+the \`--dry-run' option if you just want to see what would be executed.
+EOF
+ ;;
+
+install)
+ cat <<EOF
+Usage: $progname [OPTION]... --mode=install INSTALL-COMMAND...
+
+Install executables or libraries.
+
+INSTALL-COMMAND is the installation command. The first component should be
+either the \`install' or \`cp' program.
+
+The rest of the components are interpreted as arguments to that command (only
+BSD-compatible install options are recognized).
+EOF
+ ;;
+
+link)
+ cat <<EOF
+Usage: $progname [OPTION]... --mode=link LINK-COMMAND...
+
+Link object files or libraries together to form another library, or to
+create an executable program.
+
+LINK-COMMAND is a command using the C compiler that you would use to create
+a program from several object files.
+
+The following components of LINK-COMMAND are treated specially:
+
+ -export-dynamic allow the output file to be loaded with dlopen(3)
+ -LLIBDIR search LIBDIR for required installed libraries
+ -lNAME OUTPUT-FILE requires the installed library libNAME
+ -no-whole-archive turn off \`-whole-archive'
+ -o OUTPUT-FILE create OUTPUT-FILE from the specified objects
+ -rpath LIBDIR the created library will eventually be installed in LIBDIR
+ -static do not do any dynamic linking or shared library creation
+ -version-info CURRENT[:REVISION[:AGE]]
+ specify library version info [each variable defaults to 0]
+ -whole-archive use all members from subsequent \`.a' files
+
+All other options (arguments beginning with \`-') are ignored.
+
+Every other argument is treated as a filename. Files ending in \`.la' are
+treated as uninstalled libtool libraries, other files are standard or library
+object files.
+
+If the OUTPUT-FILE ends in \`.la', then a libtool library is created, only
+library objects (\`.lo' files) may be specified, and \`-rpath' is required.
+
+If OUTPUT-FILE ends in \`.a', then a standard library is created using \`ar'
+and \`ranlib'. If only libtool objects are specified, then the output file
+may be used in the creation of other libtool archives.
+
+If OUTPUT-FILE ends in \`.lo' or \`.o', then a reloadable object file is
+created, otherwise an executable program is created.
+EOF
+ ;;
+
+uninstall)
+ cat <<EOF
+Usage: $progname [OPTION]... --mode=uninstall RM [RM-OPTION]... FILE...
+
+Remove libraries from an installation directory.
+
+RM is the name of the program to use to delete files associated with each FILE
+(typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed
+to RM.
+
+If FILE is a libtool library, all the files associated with it are deleted.
+Otherwise, only FILE itself is deleted using RM.
+EOF
+ ;;
+
+*)
+ echo "$progname: invalid operation mode \`$mode'" 1>&2
+ echo "$help" 1>&2
+ exit 1
+ ;;
+esac
+
+case "$mode" in
+archive|compile)
+ echo
+ echo "Try \`$progname --help' for more information about other modes."
+ ;;
+esac
+
+exit 0
+
+# Local Variables:
+# mode:shell-script
+# sh-indentation:2
+# End:
diff --git a/mdate-sh b/mdate-sh
new file mode 100755
index 000000000..0845b8bc8
--- /dev/null
+++ b/mdate-sh
@@ -0,0 +1,91 @@
+#!/bin/sh
+# mdate-sh - get modification time of a file and pretty-print it
+# Copyright (C) 1995 Software Foundation, Inc.
+# Written by Ulrich Drepper <drepper@gnu.ai.mit.edu>, June 1995
+#
+# 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 program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# Prevent date giving response in another language.
+LANG=C
+export LANG
+LC_ALL=C
+export LC_ALL
+LC_TIME=C
+export LC_TIME
+
+# Get the extended ls output of the file.
+if ls -L /dev/null 1>/dev/null 2>&1; then
+ set - `ls -L -l $1`
+else
+ set - `ls -l $1`
+fi
+# The month is at least the fourth argument.
+# (3 shifts here, the next inside the loop)
+shift
+shift
+shift
+
+# Find the month. Next argument is day, followed by the year or time.
+month=
+until test $month
+do
+ shift
+ case $1 in
+ Jan) month=January; nummonth=1;;
+ Feb) month=February; nummonth=2;;
+ Mar) month=March; nummonth=3;;
+ Apr) month=April; nummonth=4;;
+ May) month=May; nummonth=5;;
+ Jun) month=June; nummonth=6;;
+ Jul) month=July; nummonth=7;;
+ Aug) month=August; nummonth=8;;
+ Sep) month=September; nummonth=9;;
+ Oct) month=October; nummonth=10;;
+ Nov) month=November; nummonth=11;;
+ Dec) month=December; nummonth=12;;
+ esac
+done
+
+day=$2
+
+# Here we have to deal with the problem that the ls output gives either
+# the time of day or the year.
+case $3 in
+ *:*) set `date`; eval year=\$$#
+ case $2 in
+ Jan) nummonthtod=1;;
+ Feb) nummonthtod=2;;
+ Mar) nummonthtod=3;;
+ Apr) nummonthtod=4;;
+ May) nummonthtod=5;;
+ Jun) nummonthtod=6;;
+ Jul) nummonthtod=7;;
+ Aug) nummonthtod=8;;
+ Sep) nummonthtod=9;;
+ Oct) nummonthtod=10;;
+ Nov) nummonthtod=11;;
+ Dec) nummonthtod=12;;
+ esac
+ # For the first six month of the year the time notation can also
+ # be used for files modified in the last year.
+ if (expr $nummonth \> $nummonthtod) > /dev/null;
+ then
+ year=`expr $year - 1`
+ fi;;
+ *) year=$3;;
+esac
+
+# The result.
+echo $day $month $year
diff --git a/missing b/missing
new file mode 100755
index 000000000..e4b838ca9
--- /dev/null
+++ b/missing
@@ -0,0 +1,134 @@
+#! /bin/sh
+# Common stub for a few missing GNU programs while installing.
+# Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+# Franc,ois Pinard <pinard@iro.umontreal.ca>, 1996.
+
+# 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 program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+if test $# -eq 0; then
+ echo 1>&2 "Try \`$0 --help' for more information"
+ exit 1
+fi
+
+case "$1" in
+
+ -h|--h|--he|--hel|--help)
+ echo "\
+$0 [OPTION]... PROGRAM [ARGUMENT]...
+
+Handle \`PROGRAM [ARGUMENT]...' for when PROGRAM is missing, or return an
+error status if there is no known handling for PROGRAM.
+
+Options:
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+
+Supported PROGRAM values:
+ aclocal touch file \`aclocal.m4'
+ autoconf touch file \`configure'
+ autoheader touch file \`config.h.in'
+ automake touch all \`Makefile.in' files
+ bison touch file \`y.tab.c'
+ makeinfo touch the output file
+ yacc touch file \`y.tab.c'"
+ ;;
+
+ -v|--v|--ve|--ver|--vers|--versi|--versio|--version)
+ echo "missing - GNU libit 0.0"
+ ;;
+
+ -*)
+ echo 1>&2 "$0: Unknown \`$1' option"
+ echo 1>&2 "Try \`$0 --help' for more information"
+ exit 1
+ ;;
+
+ aclocal)
+ echo 1>&2 "\
+WARNING: \`$1' is missing on your system. It should be needed only if
+ you modified \`acinclude.m4' or \`configure.in'. You might want
+ to install the \`Automake' and \`Perl' packages. Grab them from
+ any GNU archive site."
+ touch aclocal.m4
+ ;;
+
+ autoconf)
+ echo 1>&2 "\
+WARNING: \`$1' is missing on your system. It should be needed only if
+ you modified \`configure.in'. You might want to install the
+ \`Autoconf' and \`GNU m4' packages. Grab them from any GNU
+ archive site."
+ touch configure
+ ;;
+
+ autoheader)
+ echo 1>&2 "\
+WARNING: \`$1' is missing on your system. It should be needed only if
+ you modified \`acconfig.h' or \`configure.in'. You might want
+ to install the \`Autoconf' and \`GNU m4' packages. Grab them
+ from any GNU archive site."
+ touch config.h.in
+ ;;
+
+ automake)
+ echo 1>&2 "\
+WARNING: \`$1' is missing on your system. It should be needed only if
+ you modified \`Makefile.am', \`acinclude.m4' or \`configure.in'.
+ You might want to install the \`Automake' and \`Perl' packages.
+ Grab them from any GNU archive site."
+ find . -type f -name Makefile.am -print \
+ | sed 's/^\(.*\).am$/touch \1.in/' \
+ | sh
+ ;;
+
+ bison|yacc)
+ echo 1>&2 "\
+WARNING: \`$1' is missing on your system. It should be needed only if
+ your modified any \`.y' file. For being effective, your
+ modifications might require the \`Bison' package. Grab it from
+ any GNU archive site."
+ touch y.tab.c
+ ;;
+
+ makeinfo)
+ echo 1>&2 "\
+WARNING: \`$1' is missing on your system. It should be needed only if
+ you modified a \`.texi' or \`.texinfo' file, or any other file
+ indirectly affecting the aspect of the manual. The spurious
+ call might also be the consequence of using a buggy \`make' (AIX,
+ DU, IRIX). You might want to install the \`Texinfo' package or
+ the \`GNU make' package. Grab either from any GNU archive site."
+ file=`echo "$*" | sed -n 's/.*-o \([^ ]*\).*/\1/p'`
+ if test -z "$file"; then
+ file=`echo "$*" | sed 's/.* \([^ ]*\) *$/\1/'`
+ file=`sed -n '/^@setfilename/ { s/.* \([^ ]*\) *$/\1/; p; q; }' $file`
+ fi
+ touch $file
+ ;;
+
+ *)
+ echo 1>&2 "\
+WARNING: \`$1' is needed, and you do not seem to have it handy on your
+ system. You might have modified some files without having the
+ proper tools for further handling them. Check the \`README' file,
+ it often tells you about the needed prerequirements for installing
+ this package. You may also peek at any GNU archive site, in case
+ some other package would contain this missing \`$1' program."
+ exit 1
+ ;;
+esac
+
+exit 0
diff --git a/mkinstalldirs b/mkinstalldirs
new file mode 100755
index 000000000..cc8783edc
--- /dev/null
+++ b/mkinstalldirs
@@ -0,0 +1,36 @@
+#! /bin/sh
+# mkinstalldirs --- make directory hierarchy
+# Author: Noah Friedman <friedman@prep.ai.mit.edu>
+# Created: 1993-05-16
+# Last modified: 1994-03-25
+# Public domain
+
+errstatus=0
+
+for file in ${1+"$@"} ; do
+ set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'`
+ shift
+
+ pathcomp=
+ for d in ${1+"$@"} ; do
+ pathcomp="$pathcomp$d"
+ case "$pathcomp" in
+ -* ) pathcomp=./$pathcomp ;;
+ esac
+
+ if test ! -d "$pathcomp"; then
+ echo "mkdir $pathcomp" 1>&2
+ mkdir "$pathcomp" > /dev/null 2>&1 || lasterr=$?
+ fi
+
+ if test ! -d "$pathcomp"; then
+ errstatus=$lasterr
+ fi
+
+ pathcomp="$pathcomp/"
+ done
+done
+
+exit $errstatus
+
+# mkinstalldirs ends here
diff --git a/qt/.cvsignore b/qt/.cvsignore
new file mode 100644
index 000000000..6a401c3ff
--- /dev/null
+++ b/qt/.cvsignore
@@ -0,0 +1,5 @@
+Makefile
+config.log
+config.status
+qt.h
+.deps
diff --git a/qt/CHANGES b/qt/CHANGES
new file mode 100644
index 000000000..1b74921ee
--- /dev/null
+++ b/qt/CHANGES
@@ -0,0 +1,15 @@
+QuickThreads 002: Changes since QuickThreads 001.
+
+ - Now can be used by C++ programs.
+ - Now *really* works with stacks that grow up.
+ - Supports AXP OSF 2.x cc's varargs.
+ - Supports HP Precision (HP-PA) on workstations and Convex.
+ - Supports assemblers for Intel iX86 ith only '//'-style comments.
+ - Supports Silicon Graphics Irix 5.x with dynamic linking.
+ - Supports System V and Solaris 2.x with no `_' on compiler-generated
+ identifiers; *some* platforms only.
+
+Note: not all "./config" arguments are compatible with QT 001.
+
+
+QuickThreads 001: Base version.
diff --git a/qt/ChangeLog b/qt/ChangeLog
new file mode 100644
index 000000000..0ef86f386
--- /dev/null
+++ b/qt/ChangeLog
@@ -0,0 +1,68 @@
+Mon Feb 24 21:47:16 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Sun Feb 9 15:20:59 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * configure.in: Added changequote(,) before the host case (since
+ we use [ and ] in a pattern).
+ * configure: Regenerated.
+
+Fri Feb 7 18:00:07 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Recognize i686 as an okay processor too.
+ * configure: Regenerated.
+
+Mon Dec 9 17:55:59 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu>
+
+ We need to name the object files produced from the
+ machine-dependent C and assembler files qtmds.o and qtmdc.o, but
+ using -c and -o together on the cc command line isn't portable.
+ * configure.in: Generate the names of the .o files here, and
+ substitute them into Makefile.
+ * Makefile.am (qtmds.o, qtmdc.o): Let CC name them what it wants,
+ and then rename them when it's done.
+ (configure, Makefile.in): Regenerated.
+
+Sat Nov 30 23:59:06 1996 Tom Tromey <tromey@cygnus.com>
+
+ * PLUGIN/greet: Removed.
+ * Makefile.am, md/Makefile.am, time/Makefile.am, aclocal.m4: New
+ files.
+ * configure.in: Updated for Automake.
+
+Sun Nov 10 17:40:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in, Makefile.in: The 'install' and 'uninstall'
+ Makefile targets should be affected by whether or not we have a
+ port to the current target architecture too, not just the 'all'
+ target.
+
+Wed Oct 9 19:40:13 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: If we don't have a port to the current machine,
+ just arrange for 'make all' to do nothing. Don't abort
+ configuration. We need a fully configured directory tree in order
+ to make distributions and the like.
+
+ * Makefile.in (distfiles): Update for the new directory structure.
+ (plugin_distfiles, md_distfiles, time_distfiles): New variables.
+ (dist-dir): New target; use all the above to build a subtree of a
+ distribution.
+ (manifest): Target deleted.
+
+Tue Oct 1 02:06:19 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * configure.in: Solaris 2 should use sparc.s.
+ *Older* systems use _sparc.s
+
+Fri Mar 29 11:50:20 1996 Anthony Green <green@snuffle.cygnus.com>
+
+ * configure: Rebuilt
+ * Makefile.in, configure.in: Fixed installation.
+
+Fri Mar 22 16:20:27 1996 Anthony Green (green@gerbil.cygnus.com)
+
+ * all files: installed qt-002 package. Autoconfiscated.
+
+
diff --git a/qt/INSTALL b/qt/INSTALL
new file mode 100644
index 000000000..5b20f5d5e
--- /dev/null
+++ b/qt/INSTALL
@@ -0,0 +1,81 @@
+Installation of the `QuickThreads' threads-building toolkit.
+
+* Notice
+
+QuickThreads -- Threads-building toolkit.
+Copyright (c) 1993 by David Keppel
+
+Permission to use, copy, modify and distribute this software and
+its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice and this notice
+appear in all copies. This software is provided as a
+proof-of-concept and for demonstration purposes; there is no
+representation about the suitability of this software for any
+purpose.
+
+
+* Configuration
+
+Configure with
+
+ ./config *machtype*
+
+where "*machtype*" is one of the supported target machines. As of
+October 1994, the supported machines (targets) are:
+
+ axp -- All Digital Equipment Corporation AXP (DEC Alpha)
+ processors, compile with GNU CC
+ axp-osf1 -- AXP running OSF 1.x
+ axp-osf2 -- AXP running OSF 2.x
+ hppa -- HP's PA-RISC 1.1 processor
+ hppa-cnx-spp -- Convex SPP (PA-RISC 1.1 processor)
+ iX86 -- 80386, 80486, and 80586-compatible processors
+ See notes below for OS/2.
+ iX86-ss -- 'iX86 for assemblers that use slash-slash ('//')
+ comments.
+ ksr1 -- All KSR processors
+ m88k -- All members of the Motorola 88000 family
+ mips -- MIPS R2000 and R3000 processors
+ mips-irix5 -- Irix 5.xx (use `mips' for Irix 4.xx)
+ sparc-os1 -- V8-compliant SPARC processors using compilers
+ that prefix labels (e.g. "foo" appears as "_foo")
+ Includes Solaris 1 (SunOS 4.X).
+ sparc-os2 -- V8-compliant SPARC processors using compilers
+ that do not prefix labels. Includes Solaris 2.
+ vax -- All VAX processors
+
+In addition, the target `clean' will deconfigure QuickThreads.
+
+Note that a given machine target may not work on all instances of that
+machine because e.g., the assembler syntax varies from machine to
+machine.
+
+Note also that additions to a processor family may require a new
+target. So, for example, the `vax' target might not work for all
+future VAX processors if, say, new VAX processors are introduced and
+they use separate floating-point registers.
+
+For OS/2, change `ranlib' to `ar -s', `configure' to `configure.cmd'
+(or was that `config' to `config.cmd'?), and replace the soft links
+(`ln -s') with plain copies.
+
+
+* Build
+
+To build the QuickThreads library, first configure (see above) then
+type `make libqt.a' in the top-level directory.
+
+To build the demonstration threads package, SimpleThreads, type
+`make libstp.a' in the top-level directory.
+
+To build an executable ``stress-test'' and measurement program, type
+`make run' in the top-level directory. Run `time/raw' to run the
+stress tests.
+
+
+* Installation
+
+Build the QuickThreads library (see above) and then copy `libqt.a' to
+the installation library directory (e.g., /usr/local/lib) and `qt.h'
+and `qtmd.h' to the installation include directory (e.g.,
+/usr/local/include).
diff --git a/qt/Makefile.am b/qt/Makefile.am
new file mode 100644
index 000000000..7b4269477
--- /dev/null
+++ b/qt/Makefile.am
@@ -0,0 +1,23 @@
+## Process this file with automake to produce Makefile.in.
+
+AUTOMAKE_OPTIONS = foreign
+
+## subdirs are for making distributions only.
+SUBDIRS = md time
+
+lib_LIBRARIES = @target_libs@
+EXTRA_LIBRARIES = libqt.a
+
+libqt_a_SOURCES = qt.c copyright.h
+libqt_a_LIBADD = qtmds.o qtmdc.o
+
+qtmds.o: @qtmds_s@
+ $(COMPILE) -c @qtmds_s@
+ mv @qtmds_o@ qtmds.o
+
+qtmdc.o: @qtmdc_c@ @qtmd_h@
+ $(COMPILE) -c @qtmdc_c@
+ mv @qtmdc_o@ qtmdc.o
+
+EXTRA_DIST = CHANGES README.MISC README.PORT b.h meas.c stp.c stp.h \
+PLUGIN/OPT Makefile.base config
diff --git a/qt/Makefile.base b/qt/Makefile.base
new file mode 100644
index 000000000..73a082f50
--- /dev/null
+++ b/qt/Makefile.base
@@ -0,0 +1,112 @@
+.SUFFIXES: .c .o .s .E
+
+#
+# Need to include from the current directory because "qt.h"
+# will include <qtmd.h>.
+#
+CFLAGS = -I. -g
+
+#
+# Fix this to be something meaningful for your system.
+#
+DEST = /dev/null
+
+DOC = users.tout
+
+EXTHDRS = /usr/include/stdio.h
+
+HDRS = qt.h \
+ qtmd.h \
+ stp.h
+
+LDFLAGS = $(CFLAGS)
+
+EXTLIBS =
+
+LIBS = libstp.a libqt.a
+
+LINKER = $(CC)
+
+MAKEFILE = Makefile
+
+M = Makefile configuration
+
+OBJS = qtmdb.o \
+ meas.o
+
+QTOBJS = qt.o qtmds.o qtmdc.o
+
+STPOBJS = stp.o
+
+PR = -Pps
+
+PRINT = pr
+
+PROGRAM = run
+
+SRCS = meas.c \
+ qt.c \
+ qtmdc.c \
+ qtmds.s \
+ qtmdb.s
+
+TMP_INIT = tmp.init
+TMP_SWAP = tmp.swap
+
+.DEFAULT:
+ co -q $@
+
+.c.E: force
+ $(CC) $(CFLAGS) -E $*.c > $*.E
+
+all: libqt.a libstp.a $(PROGRAM) $(M)
+
+libqt.a: $(QTOBJS) $(M)
+ ar crv libqt.a $(QTOBJS)
+ ranlib libqt.a
+
+libstp.a: $(STPOBJS) $(M)
+ ar crv libstp.a $(STPOBJS)
+ ranlib libstp.a
+
+$(PROGRAM): $(OBJS) $(LIBS) $(M)
+ @echo "Loading $(PROGRAM) ... "
+# ld -o $(PROGRAM) /lib/crt0.o $(OBJS) -lc
+ $(LINKER) $(LDFLAGS) $(OBJS) $(LIBS) $(EXTLIBS) -o $(PROGRAM)
+ @echo "done"
+
+clean:
+ rm -f $(OBJS) $(PROGRAM) $(TMP_INIT) $(TMP_SWAP) $(DOC)
+ rm -f libqt.a libstp.a
+ rm -f $(QTOBJS) $(STPOBJS)
+
+depend:; @mkmf -f $(MAKEFILE) PROGRAM=$(PROGRAM) DEST=$(DEST)
+
+doc: users.ms raw
+ time/assim < raw | grep "^init" | sed 's/^init //' > $(TMP_INIT)
+ time/assim < raw | grep "^swap" | sed 's/^swap //' > $(TMP_SWAP)
+ soelim users.ms | tbl $(PR) | troff -t $(PR) -ms > $(DOC)
+
+index:; @ctags -wx $(HDRS) $(SRCS)
+
+print:; @$(PRINT) $(HDRS) $(SRCS)
+
+program: $(PROGRAM)
+
+tags: $(HDRS) $(SRCS); @ctags $(HDRS) $(SRCS)
+
+update: $(DEST)/$(PROGRAM)
+
+$(DEST)/$(PROGRAM): $(SRCS) $(LIBS) $(HDRS) $(EXTHDRS)
+ @make -f $(MAKEFILE) DEST=$(DEST) install
+
+QT_H = qt.h $(QTMD_H)
+QTMD_H = qtmd.h
+
+###
+qtmdb.o: $(M) qtmdb.s b.h
+meas.o: $(M) meas.c /usr/include/stdio.h $(QT_H) b.h stp.h
+qt.o: $(M) qt.c $(QT_H)
+stp.o: $(M) stp.c stp.h $(QT_H)
+qtmds.o: $(M) qtmds.s
+qtmdc.o: $(M) qtmdc.c $(QT_H)
diff --git a/qt/Makefile.in b/qt/Makefile.in
new file mode 100644
index 000000000..ee8ff8a99
--- /dev/null
+++ b/qt/Makefile.in
@@ -0,0 +1,401 @@
+# Makefile.in generated automatically by automake 1.1n from Makefile.am
+
+# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
+
+SHELL = /bin/sh
+
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = .
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = true
+PRE_INSTALL = true
+POST_INSTALL = true
+NORMAL_UNINSTALL = true
+PRE_UNINSTALL = true
+POST_UNINSTALL = true
+host_alias = @host_alias@
+host_triplet = @host@
+CC = @CC@
+MAINT = @MAINT@
+PACKAGE = @PACKAGE@
+RANLIB = @RANLIB@
+VERSION = @VERSION@
+module = @module@
+qtmd_h = @qtmd_h@
+qtmdb_s = @qtmdb_s@
+qtmdc_c = @qtmdc_c@
+qtmdc_o = @qtmdc_o@
+qtmds_o = @qtmds_o@
+qtmds_s = @qtmds_s@
+target_libs = @target_libs@
+
+AUTOMAKE_OPTIONS = foreign
+
+SUBDIRS = md time
+
+lib_LIBRARIES = @target_libs@
+EXTRA_LIBRARIES = libqt.a
+
+libqt_a_SOURCES = qt.c copyright.h
+libqt_a_LIBADD = qtmds.o qtmdc.o
+
+EXTRA_DIST = CHANGES README.MISC README.PORT b.h meas.c stp.c stp.h \
+PLUGIN/OPT Makefile.base config
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_CLEAN_FILES = qt.h
+LIBRARIES = $(lib_LIBRARIES)
+
+
+DEFS = @DEFS@ -I. -I$(srcdir)
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+libqt_a_DEPENDENCIES = qtmds.o qtmdc.o
+libqt_a_OBJECTS = qt.o
+AR = ar
+CFLAGS = @CFLAGS@
+COMPILE = $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+LINK = $(CC) $(LDFLAGS) -o $@
+DIST_COMMON = README ChangeLog INSTALL Makefile.am Makefile.in \
+aclocal.m4 configure configure.in qt.h.in
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = tar
+GZIP = --best
+DEP_FILES = .deps/qt.P
+SOURCES = $(libqt_a_SOURCES)
+OBJECTS = $(libqt_a_OBJECTS)
+
+default: all
+
+.SUFFIXES:
+.SUFFIXES: .c .o
+$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
+ cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile
+
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
+ cd $(top_builddir) \
+ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+$(srcdir)/aclocal.m4: @MAINT@ configure.in
+ cd $(srcdir) && $(ACLOCAL)
+
+config.status: configure
+ $(SHELL) ./config.status --recheck
+$(srcdir)/configure: @MAINT@configure.in $(ACLOCAL_M4) $(CONFIGURE_DEPENDENCIES)
+ cd $(srcdir) && $(AUTOCONF)
+qt.h: $(top_builddir)/config.status qt.h.in
+ cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status
+
+mostlyclean-libLIBRARIES:
+
+clean-libLIBRARIES:
+ test -z "$(lib_LIBRARIES)" || rm -f $(lib_LIBRARIES)
+
+distclean-libLIBRARIES:
+
+maintainer-clean-libLIBRARIES:
+
+install-libLIBRARIES: $(lib_LIBRARIES)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(libdir)
+ list='$(lib_LIBRARIES)'; for p in $$list; do \
+ if test -f $$p; then \
+ echo " $(INSTALL_DATA) $$p $(libdir)/$$p"; \
+ $(INSTALL_DATA) $$p $(libdir)/$$p; \
+ else :; fi; \
+ done
+ @$(POST_INSTALL)
+ @list='$(lib_LIBRARIES)'; for p in $$list; do \
+ if test -f $$p; then \
+ echo " $(RANLIB) $(libdir)/$$p"; \
+ $(RANLIB) $(libdir)/$$p; \
+ else :; fi; \
+ done
+
+uninstall-libLIBRARIES:
+ $(NORMAL_UNINSTALL)
+ list='$(lib_LIBRARIES)'; for p in $$list; do \
+ rm -f $(libdir)/$$p; \
+ done
+
+.c.o:
+ $(COMPILE) -c $<
+
+mostlyclean-compile:
+ rm -f *.o core
+
+clean-compile:
+
+distclean-compile:
+ rm -f *.tab.c
+
+maintainer-clean-compile:
+
+libqt.a: $(libqt_a_OBJECTS) $(libqt_a_DEPENDENCIES)
+ rm -f libqt.a
+ $(AR) cru libqt.a $(libqt_a_OBJECTS) $(libqt_a_LIBADD)
+ $(RANLIB) libqt.a
+
+# This directory's subdirectories are mostly independent; you can cd
+# into them and run `make' without going through this Makefile.
+# To change the values of `make' variables: instead of editing Makefiles,
+# (1) if the variable is set in `config.status', edit `config.status'
+# (which will cause the Makefiles to be regenerated when you run `make');
+# (2) otherwise, pass the desired values on the `make' command line.
+
+@SET_MAKE@
+
+all-recursive install-data-recursive install-exec-recursive \
+installdirs-recursive install-recursive uninstall-recursive \
+check-recursive installcheck-recursive info-recursive dvi-recursive \
+mostlyclean-recursive clean-recursive distclean-recursive \
+maintainer-clean-recursive:
+ @for subdir in $(SUBDIRS); do \
+ target=`echo $@ | sed s/-recursive//`; \
+ echo "Making $$target in $$subdir"; \
+ (cd $$subdir && $(MAKE) $$target) \
+ || case "$(MFLAGS)" in *k*) fail=yes;; *) exit 1;; esac; \
+ done && test -z "$$fail"
+tags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ (cd $$subdir && $(MAKE) tags); \
+ done
+
+tags: TAGS
+
+ID: $(HEADERS) $(SOURCES)
+ here=`pwd` && cd $(srcdir) && mkid -f$$here/ID $(SOURCES) $(HEADERS)
+
+TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES)
+ tags=; \
+ here=`pwd`; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \
+ done; \
+ test -z "$(ETAGS_ARGS)$(SOURCES)$(HEADERS)$$tags" \
+ || (cd $(srcdir) && etags $(ETAGS_ARGS) $$tags $(SOURCES) $(HEADERS) -o $$here/TAGS)
+
+mostlyclean-tags:
+
+clean-tags:
+
+distclean-tags:
+ rm -f TAGS ID
+
+maintainer-clean-tags:
+
+distdir = $(PACKAGE)-$(VERSION)
+# This target untars the dist file and tries a VPATH configuration. Then
+# it guarantees that the distribution is self-contained by making another
+# tarfile.
+distcheck: dist
+ rm -rf $(distdir)
+ GZIP=$(GZIP) $(TAR) zxf $(distdir).tar.gz
+ mkdir $(distdir)/=build
+ mkdir $(distdir)/=inst
+ dc_install_base=`cd $(distdir)/=inst && pwd`; \
+ cd $(distdir)/=build \
+ && ../configure --srcdir=.. --prefix=$$dc_install_base \
+ && $(MAKE) \
+ && $(MAKE) dvi \
+ && $(MAKE) check \
+ && $(MAKE) install \
+ && $(MAKE) installcheck \
+ && $(MAKE) dist
+ rm -rf $(distdir)
+ @echo "========================"; \
+ echo "$(distdir).tar.gz is ready for distribution"; \
+ echo "========================"
+dist: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+dist-all: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+distdir: $(DISTFILES)
+ rm -rf $(distdir)
+ mkdir $(distdir)
+ -chmod 755 $(distdir)
+ here=`pwd`; distdir=`cd $(distdir) && pwd` \
+ && cd $(srcdir) \
+ && $(AUTOMAKE) --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign
+ $(mkinstalldirs) $(distdir)/PLUGIN
+ @for file in $(DISTFILES); do \
+ d=$(srcdir); \
+ test -f $(distdir)/$$file \
+ || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+ || cp -p $$d/$$file $(distdir)/$$file; \
+ done
+ for subdir in $(SUBDIRS); do \
+ test -d $(distdir)/$$subdir \
+ || mkdir $(distdir)/$$subdir \
+ || exit 1; \
+ chmod 755 $(distdir)/$$subdir; \
+ (cd $$subdir && $(MAKE) distdir=../$(distdir)/$$subdir distdir) \
+ || exit 1; \
+ done
+
+MKDEP = gcc -M $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+
+-include .deps/.P
+.deps/.P:
+ test -d .deps || mkdir .deps
+ echo > $@
+
+-include $(DEP_FILES)
+$(DEP_FILES): .deps/.P
+
+mostlyclean-depend:
+
+clean-depend:
+
+distclean-depend:
+
+maintainer-clean-depend:
+ rm -rf .deps
+
+.deps/%.P: $(srcdir)/%.c
+ @echo "Computing dependencies for $<..."
+ @o='o'; \
+ test -n "$o" && o='$$o'; \
+ $(MKDEP) $< | sed "s,^\(.*\)\.o:,\1.$$o \1.l$$o $@:," > $@
+info: info-recursive
+dvi: dvi-recursive
+check: all-am
+ $(MAKE) check-recursive
+installcheck: installcheck-recursive
+all-am: $(LIBRARIES) Makefile
+
+install-exec-am: install-libLIBRARIES
+
+uninstall-am: uninstall-libLIBRARIES
+
+install-exec: install-exec-recursive install-exec-am
+ @$(NORMAL_INSTALL)
+
+install-data: install-data-recursive
+ @$(NORMAL_INSTALL)
+
+install: install-recursive install-exec-am
+ @:
+
+uninstall: uninstall-recursive uninstall-am
+
+all: all-recursive all-am
+
+install-strip:
+ $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
+installdirs: installdirs-recursive
+ $(mkinstalldirs) $(libdir)
+
+
+mostlyclean-generic:
+ test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
+
+clean-generic:
+ test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ rm -f Makefile $(DISTCLEANFILES)
+ rm -f config.cache config.log stamp-h
+ test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+
+maintainer-clean-generic:
+ test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+ test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+mostlyclean-am: mostlyclean-libLIBRARIES mostlyclean-compile \
+ mostlyclean-tags mostlyclean-depend mostlyclean-generic
+
+clean-am: clean-libLIBRARIES clean-compile clean-tags clean-depend \
+ clean-generic mostlyclean-am
+
+distclean-am: distclean-libLIBRARIES distclean-compile distclean-tags \
+ distclean-depend distclean-generic clean-am
+
+maintainer-clean-am: maintainer-clean-libLIBRARIES \
+ maintainer-clean-compile maintainer-clean-tags \
+ maintainer-clean-depend maintainer-clean-generic \
+ distclean-am
+
+mostlyclean: mostlyclean-recursive mostlyclean-am
+
+clean: clean-recursive clean-am
+
+distclean: distclean-recursive distclean-am
+ rm -f config.status
+
+maintainer-clean: maintainer-clean-recursive maintainer-clean-am
+ @echo "This command is intended for maintainers to use;"
+ @echo "it deletes files that may require special tools to rebuild."
+ rm -f config.status
+
+.PHONY: default mostlyclean-libLIBRARIES distclean-libLIBRARIES \
+clean-libLIBRARIES maintainer-clean-libLIBRARIES uninstall-libLIBRARIES \
+install-libLIBRARIES mostlyclean-compile distclean-compile \
+clean-compile maintainer-clean-compile install-data-recursive \
+uninstall-data-recursive install-exec-recursive \
+uninstall-exec-recursive installdirs-recursive uninstalldirs-recursive \
+all-recursive check-recursive installcheck-recursive info-recursive \
+dvi-recursive mostlyclean-recursive distclean-recursive clean-recursive \
+maintainer-clean-recursive tags tags-recursive mostlyclean-tags \
+distclean-tags clean-tags maintainer-clean-tags distdir \
+mostlyclean-depend distclean-depend clean-depend \
+maintainer-clean-depend info dvi installcheck all-am install-exec-am \
+uninstall-am install-exec install-data install uninstall all \
+installdirs mostlyclean-generic distclean-generic clean-generic \
+maintainer-clean-generic clean mostlyclean distclean maintainer-clean
+
+
+qtmds.o: @qtmds_s@
+ $(COMPILE) -c @qtmds_s@
+ mv @qtmds_o@ qtmds.o
+
+qtmdc.o: @qtmdc_c@ @qtmd_h@
+ $(COMPILE) -c @qtmdc_c@
+ mv @qtmdc_o@ qtmdc.o
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/qt/README b/qt/README
new file mode 100644
index 000000000..b014b91bf
--- /dev/null
+++ b/qt/README
@@ -0,0 +1,89 @@
+This is a source code distribution for QuickThreads. QuickThreads is a
+toolkit for building threads packages; it is described in detail in the
+University of Washington CS&E Technical report #93-05-06, available via
+anonymous ftp from `ftp.cs.washington.edu' (128.95.1.4, as of Oct. '94)
+in `tr/1993/05/UW-CSE-93-05-06.PS.Z'.
+
+This distribution shows basic ideas in QuickThreads and elaborates with
+example implementations for a gaggle of machines. As of October those
+machines included:
+
+ 80386 faimly
+ 88000 faimily
+ DEC AXP (Alpha) family
+ HP-PA family
+ KSR
+ MIPS family
+ SPARC V8 family
+ VAX family
+
+Configuration, build, and installation are described in INSTALL.
+
+Be aware: that there is no varargs code for the KSR.
+
+The HP-PA port was designed to work with both HP workstations
+and Convex SPP computers. It was generously provided by Uwe Reder
+<uereder@cip.informatik.uni-erlangen.de>. It is part of the ELiTE
+(Erlangen Lightweight Thread Environment) project directed by
+Frank Bellosa <bellosa@informatik.uni-erlangen.de> at the Operating
+Systems Department of the University of Erlangen (Germany).
+
+Other contributors include: Weihaw Chuang, Richard O'Keefe,
+Laurent Perron, John Polstra, Shinji Suzuki, Assar Westerlund,
+thanks also to Peter Buhr and Dirk Grunwald.
+
+
+Here is a brief summary:
+
+QuickThreads is a toolkit for building threads packages. It is my hope
+that you'll find it easier to use QuickThreads normally than to take it
+and modify the raw cswap code to fit your application. The idea behind
+QuickThreads is that it should make it easy for you to write & retarget
+threads packages. If you want the routine `t_create' to create threads
+and `t_block' to suspend threads, you write them using the QuickThreads
+`primitive' operations `QT_SP', `QT_INIT', and `QT_BLOCK', that perform
+machine-dependent initialization and blocking, plus code you supply for
+performing the portable operatons. For example, you might write:
+
+ t_create (func, arg)
+ {
+ stk = malloc (STKSIZE);
+ stackbase = QT_SP (stk, STKSIZE);
+ sp = QT_INIT (stakcbase, func, arg);
+ qput (runq, sp);
+ }
+
+Threads block by doing something like:
+
+ t_block()
+ {
+ sp_next = qget (runq);
+ QT_BLOCK (helper, runq, sp_next);
+ // wake up again here
+ }
+
+ // called by QT_BLOCK after the old thread has blocked,
+ // puts the old thread on the queue `onq'.
+ helper (sp_old, onq)
+ {
+ qput (onq, sp_old);
+ }
+
+(Of course) it's actually a bit more complex than that, but the general
+idea is that you write portable code to allocate stacks and enqueue and
+dequeue threads. Than, to get your threads package up and running on a
+different machine, you just reconfigure QuickThreads and recompile, and
+that's it.
+
+The QuickThreads `distribution' includes a sample threads package (look
+at stp.{c,h}) that is written in terms of QuickThreads operations. The
+TR mentioned above explains the simple threads package in detail.
+
+
+
+If you do use QuickThreads, I'd like to hear both about what worked for
+you and what didn't work, problems you had, insights gleaned, etc.
+
+Let me know what you think.
+
+David Keppel <pardo@cs.washington.edu>
diff --git a/qt/README.MISC b/qt/README.MISC
new file mode 100644
index 000000000..d10e487cf
--- /dev/null
+++ b/qt/README.MISC
@@ -0,0 +1,56 @@
+Here's some machine-specific informatin for various systems:
+
+m88k on g88.sim
+
+ .g88init:
+ echo (gdb) target sim\n
+ target sim
+ echo (gdb) ecatch all\n
+ ecatch all
+ echo (gdb) break exit\n
+ break exit
+ % vi Makefile // set CC and AS
+ % setenv MEERKAT /projects/cer/meerkat
+ % set path=($MEERKAT/bin $path)
+ % make run
+ % g88.sim run
+ (g88) run run N // where `N' is the test number
+
+
+m88k on meerkats, cross compile as above (make run)
+
+ Run w/ g88:
+ %g88 run
+ (g88) source /homes/rivers/robertb/.gdbinit
+ (g88) me
+ which does
+ (g88) set $firstchars=6
+ (g88) set $resetonattach=1
+ (g88) attach /dev/pp0
+ then download
+ (g88) dl
+ and run with
+ (g88) continue
+
+ Really the way to run it is:
+ (g88) source
+ (g88) me
+ (g88) win
+ (g88) dead 1
+ (g88) dead 2
+ (g88) dead 3
+ (g88) dl
+ (g88) cont
+
+ To rerun
+ (g88) init
+ (g88) dl
+
+ To run simulated meerkat:
+ (g88) att sim
+ <<then use normal commands>>
+
+ On 4.5 g88:
+ (g88) target sim memsize
+ instead of attatch
+ (g88) ecatch all # catch exception before becomes error
diff --git a/qt/README.PORT b/qt/README.PORT
new file mode 100644
index 000000000..d56300923
--- /dev/null
+++ b/qt/README.PORT
@@ -0,0 +1,112 @@
+Date: Tue, 11 Jan 94 13:23:11 -0800
+From: "pardo@cs.washington.edu" <pardo@meitner.cs.washington.edu>
+
+>[What's needed to get `qt' on an i860-based machine?]
+
+Almost certainly "some assembly required" (pun accepted).
+
+To write a cswap port, you need to understand the context switching
+model. Turn to figure 2 in the QT TR. Here's about what the assembly
+code looks like to implement that:
+
+ qt_cswap:
+ adjust stack pointer
+ save callee-save registers on to old's stack
+ argument register <- old sp
+ sp <- new sp
+ (*helper)(args...)
+ restore callee-save registers from new's stack
+ unadjust stack pointer
+ return
+
+Once more in slow motion:
+
+ - `old' thread calls context switch routine (new, a0, a1, h)
+ - cswap routine saves registers that have useful values
+ - cswap routine switches to new stack
+ - cswap routine calls helper function (*h)(old, a0, a1)
+ - when helper returns, cswap routine restores registers
+ that were saved the last time `new' was suspended
+ - cswap routine returns to whatever `new' routine called the
+ context switch routine
+
+There's a few tricks here. First, how do you start a thread running
+for the very first time? Answer is: fake some stuff on the stack
+so it *looks* like it was called from the middle of some routine.
+When the new thread is restarted, it is treated like any other
+thread. It just so happens that it's never really run before, but
+you can't tell that because the saved state makes it look like like
+it's been run. The return pc is set to point at a little stub of
+assembly code that loads up registers with the right values and
+then calls `only'.
+
+Second, I advise you to forget about varargs routines (at least
+until you get single-arg routines up and running).
+
+Third, on most machines `qt_abort' is the same as `qt_cswap' except
+that it need not save any callee-save registers.
+
+Fourth, `qt_cswap' needs to save and restore any floating-point
+registers that are callee-save (see your processor handbook). On
+some machines, *no* floating-point registers are callee-save, so
+`qt_cswap' is exactly the same as the integer-only cswap routine.
+
+I suggest staring at the MIPS code for a few minutes. It's "mostly"
+generic RISC code, so it gets a lot of the flavor across without
+getting too bogged down in little nitty details.
+
+
+
+Now for a bit more detail: The stack is laid out to hold callee-save
+registers. On many machines, I implemented fp cswap as save fp
+regs, call integer cswap, and when integer cswap returns (when the
+thread wakes up again), restore fp regs.
+
+For thread startup, I figure out some callee-save registers that
+I use to hold parameters to the startup routine (`only'). When
+the thread is being started it doesn't have any saved registers
+that need to be restored, but I go ahead and let the integer context
+switch routine restore some registers then "return" to the stub
+code. The stub code then copies the "callee save" registers to
+argument registers and calls the startup routine. That keeps the
+stub code pretty darn simple.
+
+For each machine I need to know the machine's procedure calling
+convention before I write a port. I figure out how many callee-save
+registers are there and allocate enough stack space for those
+registers. I also figure out how parameters are passed, since I
+will need to call the helper function. On most RISC machines, I
+just need to put the old sp in the 0'th arg register and then call
+indirect through the 3rd arg register; the 1st and 2nd arg registers
+are already set up correctly. Likewise, I don't touch the return
+value register between the helper's return and the context switch
+routine's return.
+
+I have a bunch of macros set up to do the stack initialization.
+The easiest way to debug this stuff is to go ahead and write a C
+routine to do stack initialization. Once you're happy with it you
+can turn it in to a macro.
+
+In general there's a lot of ugly macros, but most of them do simple
+things like return constants, etc. Any time you're looking at it
+and it looks confusing you just need to remember "this is actually
+simple code, the only tricky thing is calling the helper between
+the stack switch and the new thread's register restore."
+
+
+You will almost certainly need to write the assembly code fragment
+that starts a thread. You might be able to do a lot of the context
+switch code with `setjmp' and `longjmp', if they *happen* to have
+the "right" implementation. But getting all the details right (the
+helper can return a value to the new thread's cswap routine caller)
+is probaby trickier than writing code that does the minimum and
+thus doesn't have any extra instructions (or generality) to cause
+problems.
+
+I don't know of any ports besides those included with the source
+code distribution. If you send me a port I will hapily add it to
+the distribution.
+
+Let me know as you have questions and/or comments.
+
+ ;-D on ( Now *that*'s a switch... ) Pardo
diff --git a/qt/aclocal.m4 b/qt/aclocal.m4
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/qt/aclocal.m4
diff --git a/qt/b.h b/qt/b.h
new file mode 100644
index 000000000..862e78ba0
--- /dev/null
+++ b/qt/b.h
@@ -0,0 +1,11 @@
+#ifndef B_H
+#define B_H "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/b.h,v 1.1 1996-10-01 03:27:25 mdj Exp $"
+
+#include "copyright.h"
+
+extern void b_call_reg (int n);
+extern void b_call_imm (int n);
+extern void b_add (int n);
+extern void b_load (int n);
+
+#endif /* ndef B_H */
diff --git a/qt/config b/qt/config
new file mode 100755
index 000000000..010071ddd
--- /dev/null
+++ b/qt/config
@@ -0,0 +1,308 @@
+#! /bin/sh -x
+
+rm -f Makefile Makefile.md README.md qtmd.h qtmdb.s qtmdc.c qtmds.s configuration
+
+case $1 in
+ axp*)
+ : "DEC AXP"
+ case $1 in
+ axp-osf1*)
+ : "Compile using /bin/cc under OSF 1.x."
+ ln -s md/axp.1.Makefile Makefile.md
+ ;;
+ axp-osf2*)
+ : "Compile using /bin/cc under OSF 2.x."
+ ln -s md/axp.1.Makefile Makefile.md
+ ;;
+ *)
+ : "Compile using GNU CC."
+ ln -s md/axp.Makefile Makefile.md
+ ;;
+ esac
+
+ ln -s md/axp.h qtmd.h
+ ln -s md/axp.c qtmdc.c
+ ln -s md/axp.s qtmds.s
+ ln -s md/axp_b.s qtmdb.s
+ ln -s md/axp.README README.md
+ iter_init=1000000000
+ iter_runone=10000000
+ iter_blockint=10000000
+ iter_blockfloat=10000000
+ iter_vainit0=10000000
+ iter_vainit2=10000000
+ iter_vainit4=10000000
+ iter_vainit8=10000000
+ iter_vastart0=10000000
+ iter_vastart2=10000000
+ iter_vastart4=10000000
+ iter_vastart8=10000000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=100000000
+ iter_bench_load=100000000
+ ;;
+
+ hppa*)
+ : "HP's PA-RISC 1.1 processors."
+
+ case $1 in
+ hppa-cnx-spp*)
+ : "Convex SPP (PA-RISC 1.1 processors)."
+ ln -s md/hppa-cnx.Makefile Makefile.md
+ ;;
+ *)
+ ln -s md/hppa.Makefile Makefile.md
+ ;;
+ esac
+
+ ln -s md/hppa.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/hppa.s qtmds.s
+ ln -s md/hppa_b.s qtmdb.s
+ iter_init=10000000
+ iter_runone=1000000
+ iter_blockint=1000000
+ iter_blockfloat=1000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=100000000
+ iter_bench_load=100000000
+ ;;
+
+ iX86*)
+ case $1 in
+ iX86-ss*)
+ : "Assemlber comments '//'"
+ sed 's/\/\*/\/\//' < md/i386.s > qtmds.s
+ sed 's/\/\*/\/\//' < md/i386_b.s > qtmdb.s
+ ;;
+
+ *)
+ ln -s md/i386.s qtmds.s
+ ln -s md/i386_b.s qtmdb.s
+ ;;
+ esac
+ : "Intel 80386 and compatibles (not '286...)"
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/i386.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/i386.README README.md
+ iter_init=10000000
+ iter_runone=1000000
+ iter_blockint=1000000
+ iter_blockfloat=1000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=1000000
+ iter_bench_call_imm=1000000
+ iter_bench_add=100000000
+ iter_bench_load=10000000
+ ;;
+
+ m68k)
+ : "Motorola 68000 family -- incomplete!"
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/m68k.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/m68k.s qtmds.s
+ ln -s md/m68k_b.s qtmdb.s
+ ln -s md/null.README README.md
+ ;;
+
+ m88k)
+ : "Motorola 88000 family"
+ ln -s md/m88k.Makefile Makefile.md
+ ln -s md/m88k.h qtmd.h
+ ln -s md/m88k.c qtmdc.c
+ ln -s md/m88k.s qtmds.s
+ ln -s md/m88k_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=1000000
+ iter_runone=100000
+ iter_blockint=100000
+ iter_blockfloat=100000
+ iter_vainit0=100000
+ iter_vainit2=100000
+ iter_vainit4=100000
+ iter_vainit8=100000
+ iter_vastart0=100000
+ iter_vastart2=100000
+ iter_vastart4=100000
+ iter_vastart8=100000
+ iter_bench_call_reg=100000000
+ iter_bench_call_imm=100000000
+ iter_bench_add=1000000000
+ iter_bench_load=100000000
+ ;;
+
+ mips*)
+ : "MIPS R2000 and R3000."
+
+ case $1 in
+ mips-irix5*)
+ : "Silicon Graphics Irix with dynamic linking"
+ : "Use mips for irix4."
+ ln -s md/mips-irix5.s qtmds.s
+ ;;
+ *)
+ ln -s md/mips.s qtmds.s
+ ;;
+ esac
+
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/mips.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/mips_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=10000000
+ iter_runone=10000000
+ iter_blockint=10000000
+ iter_blockfloat=10000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=100000000
+ iter_bench_call_imm=100000000
+ iter_bench_add=1000000000
+ iter_bench_load=100000000
+ ;;
+
+ sparc*)
+ : "SPARC processors"
+ case $1 in
+ sparc-os2*)
+ sed 's/_qt_/qt_/' md/sparc.s > qtmds.s
+ sed 's/_b_/b_/' md/sparc_b.s > qtmdb.s
+ ln -s md/solaris.README README.md
+ ;;
+ *)
+ ln -s md/sparc.s qtmds.s
+ ln -s md/sparc_b.s qtmdb.s
+ ln -s md/null.README README.md
+ ;;
+ esac
+
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/sparc.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ iter_init=10000000
+ iter_runone=1000000
+ iter_blockint=1000000
+ iter_blockfloat=1000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=100000000
+ iter_bench_load=100000000
+ ;;
+
+ vax*)
+ : "DEC VAX processors."
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/vax.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/vax.s qtmds.s
+ ln -s md/vax_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=1000000
+ iter_runone=100000
+ iter_blockint=100000
+ iter_blockfloat=100000
+ iter_vainit0=100000
+ iter_vainit2=100000
+ iter_vainit4=100000
+ iter_vainit8=100000
+ iter_vastart0=100000
+ iter_vastart2=100000
+ iter_vastart4=100000
+ iter_vastart8=100000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=10000000
+ iter_bench_load=1000000
+ ;;
+
+ ksr1)
+ : "Kendall Square Research model KSR-1."
+ : "Varargs is not currently supported."
+ ln -s md/ksr1.Makefile Makefile.md
+ ln -s md/ksr1.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/ksr1.s qtmds.s
+ ln -s md/ksr1_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=1000000
+ iter_runone=100000
+ iter_blockint=100000
+ iter_blockfloat=100000
+ iter_vainit0=100000
+ iter_vainit2=100000
+ iter_vainit4=100000
+ iter_vainit8=100000
+ iter_vastart0=100000
+ iter_vastart2=100000
+ iter_vastart4=100000
+ iter_vastart8=100000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=10000000
+ iter_bench_load=1000000
+ ;;
+
+ clean)
+ : Deconfigure
+ exit 0
+ ;;
+
+ *)
+ echo "Unknown configuration"
+ exit 1
+ ;;
+esac
+
+cat Makefile.md Makefile.base > Makefile
+
+echo set config_machine=$1 >> configuration
+echo set config_init=$iter_init >> configuration
+echo set config_runone=$iter_runone >> configuration
+echo set config_blockint=$iter_blockint >> configuration
+echo set config_blockfloat=$iter_blockfloat >> configuration
+echo set config_vainit0=$iter_vainit0 >> configuration
+echo set config_vainit2=$iter_vainit2 >> configuration
+echo set config_vainit4=$iter_vainit4 >> configuration
+echo set config_vainit8=$iter_vainit8 >> configuration
+echo set config_vastart0=$iter_vastart0 >> configuration
+echo set config_vastart2=$iter_vastart2 >> configuration
+echo set config_vastart4=$iter_vastart4 >> configuration
+echo set config_vastart8=$iter_vastart8 >> configuration
+echo set config_bcall_reg=$iter_bench_call_reg >> configuration
+echo set config_bcall_imm=$iter_bench_call_imm >> configuration
+echo set config_b_add=$iter_bench_add >> configuration
+echo set config_b_load=$iter_bench_load >> configuration
diff --git a/qt/configure b/qt/configure
new file mode 100755
index 000000000..e69de29bb
--- /dev/null
+++ b/qt/configure
diff --git a/qt/configure.in b/qt/configure.in
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/qt/configure.in
diff --git a/qt/copyright.h b/qt/copyright.h
new file mode 100644
index 000000000..8a2361f9e
--- /dev/null
+++ b/qt/copyright.h
@@ -0,0 +1,12 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
diff --git a/qt/md/.cvsignore b/qt/md/.cvsignore
new file mode 100644
index 000000000..f3c7a7c5d
--- /dev/null
+++ b/qt/md/.cvsignore
@@ -0,0 +1 @@
+Makefile
diff --git a/qt/md/Makefile.am b/qt/md/Makefile.am
new file mode 100644
index 000000000..aae2b5904
--- /dev/null
+++ b/qt/md/Makefile.am
@@ -0,0 +1,11 @@
+## Process this file with automake to produce Makefile.in.
+
+AUTOMAKE_OPTIONS = foreign
+
+EXTRA_DIST = _sparc.s _sparc_b.s axp.1.Makefile axp.2.Makefile \
+axp.Makefile axp.README axp.c axp.h axp.s axp_b.s default.Makefile \
+hppa-cnx.Makefile hppa.Makefile hppa.h hppa.s hppa_b.s i386.README \
+i386.h i386.s i386_b.s ksr1.Makefile ksr1.h ksr1.s ksr1_b.s \
+m88k.Makefile m88k.c m88k.h m88k.s m88k_b.s mips-irix5.s mips.h mips.s \
+mips_b.s null.README null.c solaris.README sparc.h sparc.s sparc_b.s \
+vax.h vax.s vax_b.s
diff --git a/qt/md/Makefile.in b/qt/md/Makefile.in
new file mode 100644
index 000000000..49ce85a3c
--- /dev/null
+++ b/qt/md/Makefile.in
@@ -0,0 +1,166 @@
+# Makefile.in generated automatically by automake 1.1n from Makefile.am
+
+# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
+
+SHELL = /bin/sh
+
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = ..
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = true
+PRE_INSTALL = true
+POST_INSTALL = true
+NORMAL_UNINSTALL = true
+PRE_UNINSTALL = true
+POST_UNINSTALL = true
+host_alias = @host_alias@
+host_triplet = @host@
+CC = @CC@
+MAINT = @MAINT@
+PACKAGE = @PACKAGE@
+RANLIB = @RANLIB@
+VERSION = @VERSION@
+module = @module@
+qtmd_h = @qtmd_h@
+qtmdb_s = @qtmdb_s@
+qtmdc_c = @qtmdc_c@
+qtmdc_o = @qtmdc_o@
+qtmds_o = @qtmds_o@
+qtmds_s = @qtmds_s@
+target_libs = @target_libs@
+
+AUTOMAKE_OPTIONS = foreign
+
+EXTRA_DIST = _sparc.s _sparc_b.s axp.1.Makefile axp.2.Makefile \
+axp.Makefile axp.README axp.c axp.h axp.s axp_b.s default.Makefile \
+hppa-cnx.Makefile hppa.Makefile hppa.h hppa.s hppa_b.s i386.README \
+i386.h i386.s i386_b.s ksr1.Makefile ksr1.h ksr1.s ksr1_b.s \
+m88k.Makefile m88k.c m88k.h m88k.s m88k_b.s mips-irix5.s mips.h mips.s \
+mips_b.s null.README null.c solaris.README sparc.h sparc.s sparc_b.s \
+vax.h vax.s vax_b.s
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_CLEAN_FILES =
+DIST_COMMON = Makefile.am Makefile.in
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = tar
+GZIP = --best
+default: all
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
+ cd $(top_srcdir) && $(AUTOMAKE) --foreign md/Makefile
+
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
+ cd $(top_builddir) \
+ && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+tags: TAGS
+TAGS:
+
+
+distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir)
+
+subdir = md
+distdir: $(DISTFILES)
+ @for file in $(DISTFILES); do \
+ d=$(srcdir); \
+ test -f $(distdir)/$$file \
+ || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+ || cp -p $$d/$$file $(distdir)/$$file; \
+ done
+info:
+dvi:
+check: all
+ $(MAKE)
+installcheck:
+install-exec:
+ @$(NORMAL_INSTALL)
+
+install-data:
+ @$(NORMAL_INSTALL)
+
+install: install-exec install-data all
+ @:
+
+uninstall:
+
+all: Makefile
+
+install-strip:
+ $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
+installdirs:
+
+
+mostlyclean-generic:
+ test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
+
+clean-generic:
+ test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ rm -f Makefile $(DISTCLEANFILES)
+ rm -f config.cache config.log stamp-h
+ test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+
+maintainer-clean-generic:
+ test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+ test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+mostlyclean: mostlyclean-generic
+
+clean: clean-generic mostlyclean
+
+distclean: distclean-generic clean
+ rm -f config.status
+
+maintainer-clean: maintainer-clean-generic distclean
+ @echo "This command is intended for maintainers to use;"
+ @echo "it deletes files that may require special tools to rebuild."
+
+.PHONY: default tags distdir info dvi installcheck install-exec \
+install-data install uninstall all installdirs mostlyclean-generic \
+distclean-generic clean-generic maintainer-clean-generic clean \
+mostlyclean distclean maintainer-clean
+
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/qt/md/_sparc.s b/qt/md/_sparc.s
new file mode 100644
index 000000000..1d8adc77e
--- /dev/null
+++ b/qt/md/_sparc.s
@@ -0,0 +1,142 @@
+/* sparc.s -- assembly support for the `qt' thread building kit. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* #include <machine/trap.h> */
+
+ .text
+ .align 4
+ .global _qt_blocki
+ .global _qt_block
+ .global _qt_abort
+ .global _qt_start
+ .global _qt_vstart
+
+/* Register assignment:
+// %o0: incoming `helper' function to call after cswap
+// also used as outgoing sp of old thread (qt_t *)
+// %o1, %o2:
+// parameters to `helper' function called after cswap
+// %o3: sp of new thread
+// %o5: tmp used to save old thread sp, while using %o0
+// to call `helper' f() after cswap.
+//
+//
+// Aborting a thread is easy if there are no cached register window
+// frames: just switch to the new stack and away we go. If there are
+// cached register window frames they must all be written back to the
+// old stack before we move to the new stack. If we fail to do the
+// writeback then the old stack memory can be written with register
+// window contents e.g., after the stack memory has been freed and
+// reused.
+//
+// If you don't believe this, try setting the frame pointer to zero
+// once we're on the new stack. This will not affect correctnes
+// otherwise because the frame pointer will eventually get reloaded w/
+// the new thread's frame pointer. But it will be zero briefly before
+// the reload. You will eventually (100,000 cswaps later on a small
+// SPARC machine that I tried) get an illegal instruction trap from
+// the kernel trying to flush a cached window to location 0x0.
+//
+// Solution: flush windows before switching stacks, which invalidates
+// all the other register windows. We could do the trap
+// conditionally: if we're in the lowest frame of a thread, the fp is
+// zero already so we know there's nothing cached. But we expect most
+// aborts will be done from a first function that does a `save', so we
+// will rarely save anything and always pay the cost of testing to see
+// if we should flush.
+//
+// All floating-point registers are caller-save, so this routine
+// doesn't need to do anything to save and restore them.
+//
+// `qt_block' and `qt_blocki' return the same value as the value
+// returned by the helper function. We get this ``for free''
+// since we don't touch the return value register between the
+// return from the helper function and return from qt_block{,i}.
+*/
+
+_qt_block:
+_qt_blocki:
+ sub %sp, 8, %sp /* Allocate save area for return pc. */
+ st %o7, [%sp+64] /* Save return pc. */
+_qt_abort:
+ ta 0x03 /* Save locals and ins. */
+ mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */
+ sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */
+ call %o0, 0 /* Call `helper' routine. */
+ mov %o5, %o0 /* Pass old thread to qt_after_t() */
+ /* .. along w/ args in %o1 & %o2. */
+
+ /* Restore callee-save regs. The kwsa
+ // is on this stack, so offset all
+ // loads by sizeof(kwsa), 64 bytes.
+ */
+ ldd [%sp+ 0+64], %l0
+ ldd [%sp+ 8+64], %l2
+ ldd [%sp+16+64], %l4
+ ldd [%sp+24+64], %l6
+ ldd [%sp+32+64], %i0
+ ldd [%sp+40+64], %i2
+ ldd [%sp+48+64], %i4
+ ldd [%sp+56+64], %i6
+ ld [%sp+64+64], %o7 /* Restore return pc. */
+
+ retl /* Return to address in %o7. */
+ add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */
+
+
+/* The function calling conventions say there has to be a 1-word area
+// in the caller's stack to hold a pointer to space for aggregate
+// return values. It also says there should be a 6-word area to hold
+// %o0..%o5 if the callee wants to save them (why? I don't know...)
+// Round up to 8 words to maintain alignment.
+//
+// Parameter values were stored in callee-save regs and are moved to
+// the parameter registers.
+*/
+_qt_start:
+ mov %i1, %o0 /* `pu': Set up args to `only'. */
+ mov %i2, %o1 /* `pt'. */
+ mov %i4, %o2 /* `userf'. */
+ call %i5, 0 /* Call client function. */
+ sub %sp, 32, %sp /* Allocate 6-word callee space. */
+
+ call _qt_error, 0 /* `only' erroniously returned. */
+ nop
+
+
+/* Same comments as `_qt_start' about allocating rounded-up 7-word
+// save areas. */
+
+_qt_vstart:
+ sub %sp, 32, %sp /* Allocate 7-word callee space. */
+ call %i5, 0 /* call `startup'. */
+ mov %i2, %o0 /* .. with argument `pt'. */
+
+ add %sp, 32, %sp /* Use 7-word space in varargs. */
+ ld [%sp+ 4+64], %o0 /* Load arg0 ... */
+ ld [%sp+ 8+64], %o1
+ ld [%sp+12+64], %o2
+ ld [%sp+16+64], %o3
+ ld [%sp+20+64], %o4
+ call %i4, 0 /* Call `userf'. */
+ ld [%sp+24+64], %o5
+
+ /* Use 6-word space in varargs. */
+ mov %o0, %o1 /* Pass return value from userf */
+ call %i3, 0 /* .. when call `cleanup. */
+ mov %i2, %o0 /* .. along with argument `pt'. */
+
+ call _qt_error, 0 /* `cleanup' erroniously returned. */
+ nop
diff --git a/qt/md/_sparc_b.s b/qt/md/_sparc_b.s
new file mode 100644
index 000000000..cd26672d7
--- /dev/null
+++ b/qt/md/_sparc_b.s
@@ -0,0 +1,106 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .globl _b_call_reg
+ .globl _b_call_imm
+ .globl _b_add
+ .globl _b_load
+
+_b_null:
+ retl
+ nop
+
+_b_call_reg:
+ sethi %hi(_b_null),%o4
+ or %o4,%lo(_b_null),%o4
+ add %o7,%g0, %o3
+L0:
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+_b_call_imm:
+ sethi %hi(_b_null),%o4
+ or %o4,%lo(_b_null),%o4
+ add %o7,%g0, %o3
+L1:
+ call _b_null
+ call _b_null
+ call _b_null
+ call _b_null
+ call _b_null
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+
+_b_add:
+ add %o0,%g0,%o1
+ add %o0,%g0,%o2
+ add %o0,%g0,%o3
+ add %o0,%g0,%o4
+L2:
+ sub %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ subcc %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ bg L2
+ nop
+ retl
+ nop
+
+
+_b_load:
+ ld [%sp+ 0], %g0
+L3:
+ ld [%sp+ 4],%g0
+ ld [%sp+ 8],%g0
+ ld [%sp+12],%g0
+ ld [%sp+16],%g0
+ ld [%sp+20],%g0
+ ld [%sp+24],%g0
+ ld [%sp+28],%g0
+ ld [%sp+32],%g0
+ ld [%sp+36],%g0
+
+ subcc %o0,10,%o0
+ bg L3
+ ld [%sp+ 0],%g0
+ retl
+ nop
diff --git a/qt/md/axp.1.Makefile b/qt/md/axp.1.Makefile
new file mode 100644
index 000000000..86ccd8f42
--- /dev/null
+++ b/qt/md/axp.1.Makefile
@@ -0,0 +1,5 @@
+
+#
+# Compiling for the DEC AXP (alpha) with GNU CC or version 1.x of OSF.
+#
+CC = cc -std1 -D__AXP__ -D__OSF1__
diff --git a/qt/md/axp.2.Makefile b/qt/md/axp.2.Makefile
new file mode 100644
index 000000000..268636fc9
--- /dev/null
+++ b/qt/md/axp.2.Makefile
@@ -0,0 +1,5 @@
+
+#
+# Compiling for the DEC AXP (alpha) with GNU CC or version 2.x of OSF.
+#
+CC = cc -std1 -D__AXP__ -D__OSF2__
diff --git a/qt/md/axp.Makefile b/qt/md/axp.Makefile
new file mode 100644
index 000000000..4e6d74da4
--- /dev/null
+++ b/qt/md/axp.Makefile
@@ -0,0 +1,5 @@
+
+#
+# GNU CC
+#
+CC = gcc -D__AXP__
diff --git a/qt/md/axp.README b/qt/md/axp.README
new file mode 100644
index 000000000..b6a705c07
--- /dev/null
+++ b/qt/md/axp.README
@@ -0,0 +1,10 @@
+The handling of varargs is platform-dependent. Assar Westerlund
+stared at the problem for a while and deduces the following table:
+
+vers / compiler cc gcc
+----------------------------------------------------------------------
+1.3 a0, offset __base, __offset
+2.0 _a0, _offset __base, __offset
+
+The current code should handle both cc and gcc versions, provided
+you configure for the correct compiler.
diff --git a/qt/md/axp.c b/qt/md/axp.c
new file mode 100644
index 000000000..26c15c0ea
--- /dev/null
+++ b/qt/md/axp.c
@@ -0,0 +1,133 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#include <stdarg.h>
+#include "qt.h"
+
+
+/* Varargs is harder on the AXP. Parameters are saved on the stack as
+ something like (stack grows down to low memory; low at bottom of
+ picture):
+
+ | :
+ | arg6
+ +---
+ | iarg5
+ | :
+ | iarg3 <-- va_list._a0 + va_list._offset
+ | :
+ | iarg0 <-- va_list._a0
+ +---
+ | farg5
+ | :
+ | farg0
+ +---
+
+ When some of the arguments have known type, there is no need to
+ save all of them in the struct. So, for example, if the routine is
+ called
+
+ zork (int a0, float a1, int a2, ...)
+ {
+ va_list ap;
+ va_start (ap, a2);
+ qt_vargs (... &ap ...);
+ }
+
+ then offset is set to 3 * 8 (8 === sizeof machine word) = 24.
+
+ What this means for us is that the user's routine needs to be
+ called with an arg list where some of the words in the `any type'
+ parameter list have to be split and moved up in to the int/fp
+ region.
+
+ Ways in which this can fail:
+ - The user might not know the size of the pushed arguments anyway.
+ - Structures have funny promotion rules.
+ - Probably lots of other things.
+
+ All in all, we never promised varargs would work reliably. */
+
+
+
+#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 6*2*8 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_R26, qt_vstart))
+
+
+/* Different machines use different implementations for varargs.
+ Unfortunately, the code below ``looks in to'' the varargs
+ structure, `va_list', and thus depends on the conventions.
+ The following #defines try to deal with it but don't catch
+ everything. */
+
+#ifdef __GNUC__
+#define _a0 __base
+#define _offset __offset
+#else
+#ifdef __OSF1__
+#define _a0 a0
+#define _offset offset
+#endif
+#endif /* def __GNUC__ */
+
+
+ struct qt_t *
+qt_vargs (struct qt_t *qsp, int nbytes, struct va_list *vargs,
+ void *pt, qt_function_t *startup,
+ qt_function_t *vuserf, qt_function_t *cleanup)
+{
+ va_list ap;
+ int i;
+ int max; /* Maximum *words* of args to copy. */
+ int tmove; /* *Words* of args moved typed->typed. */
+ qt_word_t *sp;
+
+ ap = *(va_list *)vargs;
+ qsp = QT_VARGS_MD0 (qsp, nbytes);
+ sp = (qt_word_t *)qsp;
+
+ tmove = 6 - ap._offset/sizeof(qt_word_t);
+
+ /* Copy from one typed area to the other. */
+ for (i=0; i<tmove; ++i) {
+ /* Integer args: */
+ sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
+ /* Fp args: */
+ sp[i] = ((qt_word_t *)(ap._a0 + ap._offset))[i-6];
+ }
+
+ max = nbytes/sizeof(qt_word_t);
+
+ /* Copy from the untyped area to the typed area. Split each arg.
+ in to integer and floating-point save areas. */
+ for (; i<6 && i<max; ++i) {
+ sp[i] = sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
+ }
+
+ /* Copy from the untyped area to the other untyped area. */
+ for (; i<max; ++i) {
+ sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
+ }
+
+ QT_VARGS_MD1 (QT_VADJ(sp));
+ QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
+ QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
+ QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
+ QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
+ return ((qt_t *)QT_VADJ(sp));
+}
diff --git a/qt/md/axp.h b/qt/md/axp.h
new file mode 100644
index 000000000..ff951a0d3
--- /dev/null
+++ b/qt/md/axp.h
@@ -0,0 +1,160 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_AXP_H
+#define QT_AXP_H
+
+#define QT_GROW_DOWN
+
+typedef unsigned long qt_word_t;
+
+
+/* Stack layout on the Alpha:
+
+ Integer:
+
+ Caller-save: r0..r8, r22..r25, r27..r29
+ argument/caller-save: r16..r21
+ callee-save: r9..r15
+ return pc *callee-save*: r26
+ stack pointer: r30
+ zero: r31
+
+ Floating-point:
+
+ Caller-save: f0..f1, f10..f15
+ argument/caller-save: f16..f21, f22..f30
+ callee-save: f2..f9
+ zero: f31
+
+ Non-varargs:
+
+ +---
+ | padding
+ | f9
+ | f8
+ | f7
+ | f6
+ | f5
+ | f4
+ | f3
+ | f2
+ | r26
+ +---
+ | padding
+ | r29
+ | r15
+ | r14
+ | r13
+ | r12 on startup === `only'
+ | r11 on startup === `userf'
+ | r10 on startup === `qt'
+ | r9 on startup === `qu'
+ | r26 on startup === qt_start <--- qt.sp
+ +---
+
+ Conventions for varargs startup:
+
+ | :
+ | arg6
+ | iarg5
+ | :
+ | iarg0
+ | farg5
+ | :
+ | farg0
+ +---
+ | padding
+ | r29
+ | r15
+ | r14
+ | r13
+ | r12 on startup === `startup'
+ | r11 on startup === `vuserf'
+ | r10 on startup === `cleanup'
+ | r9 on startup === `qt'
+ | r26 on startup === qt_vstart <--- qt.sp
+ +---
+
+ Note: this is a pretty cheap/sleazy way to get things going,
+ but ``there must be a better way.'' For instance, some varargs
+ parameters could be loaded in to integer registers, or the return
+ address could be stored on top of the stack. */
+
+
+/* Stack must be 16-byte aligned. */
+#define QT_STKALIGN (16)
+
+/* How much space is allocated to hold all the crud for
+ initialization: 7 registers times 8 bytes/register. */
+
+#define QT_STKBASE (10 * 8)
+#define QT_VSTKBASE QT_STKBASE
+
+
+/* Offsets of various registers. */
+#define QT_R26 0
+#define QT_R9 1
+#define QT_R10 2
+#define QT_R11 3
+#define QT_R12 4
+
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it just calls the client's `only' function.
+ For varargs functions, it calls the startup, user, and cleanup
+ functions.
+
+ The varargs startup routine always reads 12 8-byte arguments from
+ the stack. If fewer argumets were pushed, the startup routine
+ would read off the top of the stack. To prevent errors we always
+ allocate enough space. When there are fewer args, the preallocated
+ words are simply wasted. */
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_R26, qt_start))
+
+
+/* The AXP uses a struct for `va_list', so pass a pointer to the
+ struct. This may break some uses of `QT_VARGS', but then we never
+ claimed it was totally portable. */
+
+typedef void (qt_function_t)(void);
+
+struct qt_t;
+struct va_list;
+extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes,
+ struct va_list *vargs, void *pt,
+ qt_function_t *startup,
+ qt_function_t *vuserf,
+ qt_function_t *cleanup);
+
+#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, (struct va_list *)(&(vargs)), pt, \
+ (qt_function_t *) startup, (qt_function_t *)vuserf, \
+ (qt_function_t *)cleanup));
+
+
+/* The *index* (positive offset) of where to put each value. */
+#define QT_ONLY_INDEX (QT_R12)
+#define QT_USER_INDEX (QT_R11)
+#define QT_ARGT_INDEX (QT_R10)
+#define QT_ARGU_INDEX (QT_R9)
+
+#define QT_VCLEANUP_INDEX (QT_R10)
+#define QT_VUSERF_INDEX (QT_R11)
+#define QT_VSTARTUP_INDEX (QT_R12)
+#define QT_VARGT_INDEX (QT_R9)
+
+#endif /* ndef QT_AXP_H */
diff --git a/qt/md/axp.s b/qt/md/axp.s
new file mode 100644
index 000000000..a84aab2cc
--- /dev/null
+++ b/qt/md/axp.s
@@ -0,0 +1,160 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* axp.s -- assembly support. */
+
+ .text
+ .align 4
+ .file 2 "axp.s"
+
+ .globl qt_block
+ .globl qt_blocki
+ .globl qt_abort
+ .globl qt_start
+ .globl qt_vstart
+
+ /*
+ ** $16: ptr to function to call once curr is suspended
+ ** and control is on r19's stack.
+ ** $17: 1'th arg to (*$16)(...).
+ ** $18: 2'th arg to (*$16)(...).
+ ** $19: sp of thread to resume.
+ **
+ ** The helper routine returns a value that is passed on as the
+ ** return value from the blocking routine. Since we don't
+ ** touch r0 between the helper's return and the end of
+ ** function, we get this behavior for free.
+ */
+
+ .ent qt_blocki
+qt_blocki:
+ subq $30,80, $30 /* Allocate save area. */
+ stq $26, 0($30) /* Save registers. */
+ stq $9, 8($30)
+ stq $10,16($30)
+ stq $11,24($30)
+ stq $12,32($30)
+ stq $13,40($30)
+ stq $14,48($30)
+ stq $15,56($30)
+ stq $29,64($30)
+ .end qt_blocki
+ .ent qt_abort
+qt_abort:
+ addq $16,$31, $27 /* Put argument function in PV. */
+ addq $30,$31, $16 /* Save stack ptr in outgoing arg. */
+ addq $19,$31, $30 /* Set new stack pointer. */
+ jsr $26,($27),0 /* Call helper function. */
+
+ ldq $26, 0($30) /* Restore registers. */
+ ldq $9, 8($30)
+ ldq $10,16($30)
+ ldq $11,24($30)
+ ldq $12,32($30)
+ ldq $13,40($30)
+ ldq $14,48($30)
+ ldq $15,56($30)
+ ldq $29,64($30)
+
+ addq $30,80, $30 /* Deallocate save area. */
+ ret $31,($26),1 /* Return, predict===RET. */
+ .end qt_abort
+
+
+ /*
+ ** Non-varargs thread startup.
+ */
+ .ent qt_start
+qt_start:
+ addq $9,$31, $16 /* Load up `qu'. */
+ addq $10,$31, $17 /* ... user function's `pt'. */
+ addq $11,$31, $18 /* ... user function's `userf'. */
+ addq $12,$31, $27 /* ... set procedure value to `only'. */
+ jsr $26,($27),0 /* Call `only'. */
+
+ jsr $26,qt_error /* `only' erroniously returned. */
+ .end qt_start
+
+
+ .ent qt_vstart:
+qt_vstart:
+ /* Call startup function. */
+ addq $9,$31, $16 /* Arg0 to `startup'. */
+ addq $12,$31, $27 /* Set procedure value. */
+ jsr $26,($27),0 /* Call `startup'. */
+
+ /* Call user function. */
+ ldt $f16, 0($30) /* Load fp arg regs. */
+ ldt $f17, 8($30)
+ ldt $f18,16($30)
+ ldt $f19,24($30)
+ ldt $f20,32($30)
+ ldt $f21,40($30)
+ ldq $16,48($30) /* And integer arg regs. */
+ ldq $17,56($30)
+ ldq $18,64($30)
+ ldq $19,72($30)
+ ldq $20,80($30)
+ ldq $21,88($30)
+ addq $30,96 $30 /* Pop 6*2*8 saved arg regs. */
+ addq $11,$31, $27 /* Set procedure value. */
+ jsr $26,($27),0 /* Call `vuserf'. */
+
+ /* Call cleanup. */
+ addq $9,$31, $16 /* Arg0 to `cleanup'. */
+ addq $0,$31, $17 /* Users's return value is arg1. */
+ addq $10,$31, $27 /* Set procedure value. */
+ jsr $26,($27),0 /* Call `cleanup'. */
+
+ jsr $26,qt_error /* Cleanup erroniously returned. */
+ .end qt_start
+
+
+ /*
+ ** Save calle-save floating-point regs $f2..$f9.
+ ** Also save return pc from whomever called us.
+ **
+ ** Return value from `qt_block' is the same as the return from
+ ** `qt_blocki'. We get that for free since we don't touch $0
+ ** between the return from `qt_blocki' and the return from
+ ** `qt_block'.
+ */
+ .ent qt_block
+qt_block:
+ subq $30,80, $30 /* Allocate a save space. */
+ stq $26, 0($30) /* Save registers. */
+ stt $f2, 8($30)
+ stt $f3,16($30)
+ stt $f4,24($30)
+ stt $f5,32($30)
+ stt $f6,40($30)
+ stt $f7,48($30)
+ stt $f8,56($30)
+ stt $f9,64($30)
+
+ jsr $26,qt_blocki /* Call helper. */
+ /* .. who will also restore $gp. */
+
+ ldq $26, 0($30) /* restore registers. */
+ ldt $f2, 8($30)
+ ldt $f3,16($30)
+ ldt $f4,24($30)
+ ldt $f5,32($30)
+ ldt $f6,40($30)
+ ldt $f7,48($30)
+ ldt $f8,56($30)
+ ldt $f9,64($30)
+
+ addq $30,80, $30 /* Deallcate save space. */
+ ret $31,($26),1 /* Return, predict===RET. */
+ .end qt_block
diff --git a/qt/md/axp_b.s b/qt/md/axp_b.s
new file mode 100644
index 000000000..60be726ff
--- /dev/null
+++ b/qt/md/axp_b.s
@@ -0,0 +1,111 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .text
+ .globl b_call_reg
+ .globl b_call_imm
+ .globl b_add
+ .globl b_load
+
+ .ent b_null
+b_null:
+ ret $31,($18),1
+ .end b_null
+
+ .ent b_call_reg
+b_call_reg:
+ lda $27,b_null
+$L0:
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+
+ subq $16,1,$16
+ bgt $16,$L0
+
+ ret $31,($26),1
+ .end
+
+
+ .ent b_call_imm
+b_call_imm:
+$L1:
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+
+ subq $16,1,$16
+ bgt $16,$L1
+
+ ret $31,($26),1
+ .end
+
+
+ .ent b_add
+b_add:
+$L2:
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+
+ subq $16,1,$16
+ bgt $16,$L2
+
+ ret $31,($26),1
+ .end
+
+
+ .ent b_load
+b_load:
+$L3:
+ ldq $31,0($30)
+ ldq $31,8($30)
+ ldq $31,16($30)
+ ldq $31,24($30)
+ ldq $31,32($30)
+
+ ldq $31,0($30)
+ ldq $31,8($30)
+ ldq $31,16($30)
+ ldq $31,24($30)
+ ldq $31,32($30)
+
+ subq $16,1,$16
+ bgt $16,$L3
+
+ ret $31,($26),1
+ .end
diff --git a/qt/md/default.Makefile b/qt/md/default.Makefile
new file mode 100644
index 000000000..e240ca270
--- /dev/null
+++ b/qt/md/default.Makefile
@@ -0,0 +1,6 @@
+
+#
+# `Normal' configuration.
+#
+CC = gcc -ansi -Wall -pedantic
+
diff --git a/qt/md/hppa-cnx.Makefile b/qt/md/hppa-cnx.Makefile
new file mode 100644
index 000000000..bff257d9f
--- /dev/null
+++ b/qt/md/hppa-cnx.Makefile
@@ -0,0 +1,9 @@
+# This file (cnx_spp.Makefile) is part of the port of QuickThreads for
+# PA-RISC 1.1 architecture on a Convex SPP. This file is a machine dependent
+# makefile for QuickThreads. It was written in 1994 by Uwe Reder
+# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
+# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
+
+# `Normal' configuration.
+
+CC = /usr/convex/bin/cc
diff --git a/qt/md/hppa.Makefile b/qt/md/hppa.Makefile
new file mode 100644
index 000000000..a15e28c99
--- /dev/null
+++ b/qt/md/hppa.Makefile
@@ -0,0 +1,9 @@
+# This file (pa-risc.Makefile) is part of the port of QuickThreads for
+# PA-RISC 1.1 architecture. This file is a machine dependent makefile
+# for QuickThreads. It was written in 1994 by Uwe Reder
+# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
+# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
+
+# `Normal' configuration.
+
+CC = cc -Aa
diff --git a/qt/md/hppa.h b/qt/md/hppa.h
new file mode 100644
index 000000000..0df98de88
--- /dev/null
+++ b/qt/md/hppa.h
@@ -0,0 +1,194 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/*
+ * This file (pa-risc.h) is part of the port of QuickThreads for the
+ * PA-RISC 1.1 architecture. This file is a machine dependent header
+ * file. It was written in 1994 by Uwe Reder
+ * (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
+ * Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
+ */
+
+
+#ifndef QT_PA_RISC_H
+#define QT_PA_RISC_H
+
+#include <qt.h>
+
+/* size of an integer-register (32 bit) */
+typedef unsigned long qt_word_t;
+
+/* PA-RISC's stack grows up */
+#define QT_GROW_UP
+
+/* Stack layout on PA-RISC according to PA-RISC Procedure Calling Conventions:
+
+ Callee-save registers are: gr3-gr18, fr12-fr21.
+ Also save gr2, return pointer.
+
+ +---
+ | fr12 Each floating register is a double word (8 bytes).
+ | fr13 Floating registers are only saved if `qt_block' is
+ | fr14 called, in which case it saves the floating-point
+ | fr15 registers then calls `qt_blocki' to save the integer
+ | fr16 registers.
+ | fr17
+ | fr18
+ | fr19
+ | fr20
+ | fr21
+ | <arg word 3> fixed arguments (must be allocated; may remain unused)
+ | <arg word 2>
+ | <arg word 1>
+ | <arg word 0>
+ | <LPT> frame marker
+ | <LPT'>
+ | <RP'>
+ | <Current RP>
+ | <Static Link>
+ | <Clean Up>
+ | <RP''>
+ | <Previous SP>
+ +---
+ | gr3 word each (4 bytes)
+ | gr4
+ | gr5
+ | gr6
+ | gr7
+ | gr8
+ | gr9
+ | gr10
+ | gr11
+ | gr12
+ | gr13
+ | gr14
+ | gr15
+ | gr16
+ | gr17
+ | gr18
+ | <16 bytes filled in (sp has to be 64-bytes aligned)>
+ | <arg word 3> fixed arguments (must be allocated; may remain unused)
+ | <arg word 2>
+ | <arg word 1>
+ | <arg word 0>
+ | <LPT> frame marker
+ | <LPT'>
+ | <RP'>
+ | <Current RP>
+ | <Static Link>
+ | <Clean Up>
+ | <RP''>
+ | <Previous SP>
+ +--- <--- sp
+*/
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it just calls the client's `only' function.
+ For varargs functions, it calls the startup, user, and cleanup
+ functions. */
+
+/* Note: Procedue Labels on PA-RISC
+
+ <--2--><-------28---------><1-><1->
+ -----------------------------------
+ | SID | Adress Part | L | X |
+ -----------------------------------
+
+ On HP-UX the L field is used to flag wheather the procedure
+ label (plabel) is a pointer to an LT entry or to the entry point
+ of the procedure (PA-RISC Procedure Calling Conventions Reference
+ Manual, 5.3.2 Procedure Labels and Dynamic Calls). */
+
+#define QT_PA_RISC_READ_PLABEL(plabel) \
+ ( (((int)plabel) & 2) ? \
+ ( (*((int *)(((int)plabel) & 0xfffffffc)))) : ((int)plabel) )
+
+/* Stack must be 64 bytes aligned. */
+#define QT_STKALIGN (64)
+
+/* Internal helper for putting stuff on stack (negative index!). */
+#define QT_SPUT(top, at, val) \
+ (((qt_word_t *)(top))[-(at)] = (qt_word_t)(val))
+
+/* Offsets of various registers which are modified on the stack.
+ rp (return-pointer) has to be stored in the frame-marker-area
+ of the "older" stack-segment. */
+
+#define QT_crp (12+4+16+5)
+#define QT_15 (12+4+4)
+#define QT_16 (12+4+3)
+#define QT_17 (12+4+2)
+#define QT_18 (12+4+1)
+
+
+/** This stuff is for NON-VARARGS. **/
+
+/* Stack looks like this (2 stack frames):
+
+ <--- 64-bytes aligned --><------- 64-bytes aligned ------------>
+ | || |
+ <--16--><------48-------><----16*4-----><--16-><------48------->
+ || | || | | ||
+ ||filler|arg|frame-marker||register-save|filler|arg|frame-marker||
+ ------------------------------------------------------------------
+ */
+
+#define QT_STKBASE (16+48+(16*sizeof(qt_word_t))+16+48)
+
+/* The index, relative to sp, of where to put each value. */
+#define QT_ONLY_INDEX (QT_15)
+#define QT_USER_INDEX (QT_16)
+#define QT_ARGT_INDEX (QT_17)
+#define QT_ARGU_INDEX (QT_18)
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) \
+ (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_start)))
+
+
+/** This is for VARARGS. **/
+
+#define QT_VARGS_DEFAULT
+
+/* Stack looks like this (2 stack frames):
+
+ <------ 64-bytes aligned -------><--------- 64-bytes aligned ---------->
+ | || |
+ <---?--><--?---><16><----32-----><----16*4-----><-16--><16><----32----->
+ || | | | || | | | ||
+ ||filler|varargs|arg|frame-marker||register-save|filler|arg|frame-marker||
+ --------------------------------------------------------------------------
+ */
+
+/* Sp is moved to the end of the first stack frame. */
+#define QT_VARGS_MD0(sp, vasize) \
+ ((qt_t *)(((char *)sp) + QT_STKROUNDUP(vasize + 4*4 + 32)))
+
+/* To reach the arguments from the end of the first stack frame use 32
+ as a negative adjustment. */
+#define QT_VARGS_ADJUST(sp) ((qt_t *)(((char *)sp) - 32))
+
+/* Offset to reach the end of the second stack frame. */
+#define QT_VSTKBASE ((16*sizeof(qt_word_t)) + 16 + 4*4 + 32)
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) \
+ (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_vstart)))
+
+#define QT_VARGT_INDEX (QT_15)
+#define QT_VSTARTUP_INDEX (QT_16)
+#define QT_VUSERF_INDEX (QT_17)
+#define QT_VCLEANUP_INDEX (QT_18)
+
+#endif /* ndef QT_PA_RISC_H */
diff --git a/qt/md/hppa.s b/qt/md/hppa.s
new file mode 100644
index 000000000..84d8e875b
--- /dev/null
+++ b/qt/md/hppa.s
@@ -0,0 +1,237 @@
+; pa-risc.s -- assembly support.
+
+; QuickThreads -- Threads-building toolkit.
+; Copyright (c) 1993 by David Keppel
+;
+; Permission to use, copy, modify and distribute this software and
+; its documentation for any purpose and without fee is hereby
+; granted, provided that the above copyright notice and this notice
+; appear in all copies. This software is provided as a
+; proof-of-concept and for demonstration purposes; there is no
+; representation about the suitability of this software for any
+; purpose.
+
+; This file (pa-risc.s) is part of the port of QuickThreads for
+; PA-RISC 1.1 architecture. This file implements context switches
+; and thread startup. It was written in 1994 by Uwe Reder
+; (`uereder@cip.informatik.uni-erlangen.de') for the Operating
+; Systems Department (IMMD4) at the University of Erlangen/Nuernberg
+; Germany.
+
+
+; Callee saves general registers gr3..gr18,
+; floating-point registers fr12..fr21.
+
+ .CODE
+
+ .IMPORT $$dyncall, MILLICODE
+ .IMPORT qt_error, CODE
+
+ .EXPORT qt_blocki, ENTRY
+ .EXPORT qt_block, ENTRY
+ .EXPORT qt_abort, ENTRY
+ .EXPORT qt_start, ENTRY
+ .EXPORT qt_vstart, ENTRY
+
+
+; arg0: ptr to function (helper) to call once curr is suspended
+; and control is on arg3's stack.
+; arg1: 1'th arg to *arg0.
+; arg2: 2'th arg to *arg0.
+; arg3: sp of new thread.
+
+qt_blocki
+ .PROC
+ .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_GR=18
+ .ENTRY
+
+ stw %rp,-20(%sp) ; save rp to old frame-marker
+
+ stwm %r3,128(%sp) ; save callee-saves general registers
+ stw %r4,-124(%sp)
+ stw %r5,-120(%sp)
+ stw %r6,-116(%sp)
+ stw %r7,-112(%sp)
+ stw %r8,-108(%sp)
+ stw %r9,-104(%sp)
+ stw %r10,-100(%sp)
+ stw %r11,-96(%sp)
+ stw %r12,-92(%sp)
+ stw %r13,-88(%sp)
+ stw %r14,-84(%sp)
+ stw %r15,-80(%sp)
+ stw %r16,-76(%sp)
+ stw %r17,-72(%sp)
+ stw %r18,-68(%sp)
+
+qt_abort
+ copy %arg0,%r22 ; helper to be called by $$dyncall
+ copy %sp,%arg0 ; pass current sp as arg0 to helper
+ copy %arg3,%sp ; set new sp
+
+ .CALL
+ bl $$dyncall,%mrp ; call helper
+ copy %mrp,%rp
+
+ ldw -68(%sp),%r18 ; restore general registers
+ ldw -72(%sp),%r17
+ ldw -76(%sp),%r16
+ ldw -80(%sp),%r15
+ ldw -84(%sp),%r14
+ ldw -88(%sp),%r13
+ ldw -92(%sp),%r12
+ ldw -96(%sp),%r11
+ ldw -100(%sp),%r10
+ ldw -104(%sp),%r9
+ ldw -108(%sp),%r8
+ ldw -112(%sp),%r7
+ ldw -116(%sp),%r6
+ ldw -120(%sp),%r5
+ ldw -124(%sp),%r4
+
+ ldw -148(%sp),%rp ; restore return-pointer
+
+ bv %r0(%rp) ; return to caller
+ ldwm -128(%sp),%r3
+
+ .EXIT
+ .PROCEND
+
+
+qt_block
+ .PROC
+ .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_FR=21
+ .ENTRY
+
+ stw %rp,-20(%sp) ; save rp to old frame-marker
+
+ fstds,ma %fr12,8(%sp) ; save callee-saves float registers
+ fstds,ma %fr13,8(%sp)
+ fstds,ma %fr14,8(%sp)
+ fstds,ma %fr15,8(%sp)
+ fstds,ma %fr16,8(%sp)
+ fstds,ma %fr17,8(%sp)
+ fstds,ma %fr18,8(%sp)
+ fstds,ma %fr19,8(%sp)
+ fstds,ma %fr20,8(%sp)
+ fstds,ma %fr21,8(%sp)
+
+ .CALL
+ bl qt_blocki,%rp
+ ldo 48(%sp),%sp
+
+ ldo -48(%sp),%sp
+
+ fldds,mb -8(%sp),%fr21 ; restore callee-saves float registers
+ fldds,mb -8(%sp),%fr20
+ fldds,mb -8(%sp),%fr19
+ fldds,mb -8(%sp),%fr18
+ fldds,mb -8(%sp),%fr17
+ fldds,mb -8(%sp),%fr16
+ fldds,mb -8(%sp),%fr15
+ fldds,mb -8(%sp),%fr14
+ fldds,mb -8(%sp),%fr13
+
+ ldw -28(%sp),%rp ; restore return-pointer
+
+ bv %r0(%rp) ; return to caller.
+ fldds,mb -8(%sp),%fr12
+
+ .EXIT
+ .PROCEND
+
+
+qt_start
+ .PROC
+ .CALLINFO CALLER, FRAME=0
+ .ENTRY
+
+ copy %r18,%arg0 ; set user arg `pu'.
+ copy %r17,%arg1 ; ... user function pt.
+ copy %r16,%arg2 ; ... user function userf.
+ ; %r22 is a caller-saves register
+ copy %r15,%r22 ; function to be called by $$dyncall
+
+ .CALL ; in=%r22
+ bl $$dyncall,%mrp ; call `only'.
+ copy %mrp,%rp
+
+ bl,n qt_error,%r0 ; `only' erroniously returned.
+
+ .EXIT
+ .PROCEND
+
+
+; Varargs
+;
+; First, call `startup' with the `pt' argument.
+;
+; Next, call the user's function with all arguments.
+; We don't know whether arguments are integers, 32-bit floating-points or
+; even 64-bit floating-points, so we reload all the registers, possibly
+; with garbage arguments. The thread creator provided non-garbage for
+; the arguments that the callee actually uses, so the callee never gets
+; garbage.
+;
+; -48 -44 -40 -36 -32
+; | arg3 | arg2 | arg1 | arg0 |
+; -----------------------------
+; integers: arg3 arg2 arg1 arg0
+; 32-bit fps: farg3 farg2 farg1 farg0
+; 64-bit fps: <---farg3--> <---farg1-->
+;
+; Finally, call `cleanup' with the `pt' argument and with the return value
+; from the user's function. It is an error for `cleanup' to return.
+
+qt_vstart
+ .PROC
+ .CALLINFO CALLER, FRAME=0
+ .ENTRY
+
+ ; Because the startup function may damage the fixed arguments
+ ; on the stack (PA-RISC Procedure Calling Conventions Reference
+ ; Manual, 2.4 Fixed Arguments Area), we allocate a seperate
+ ; stack frame for it.
+ ldo 64(%sp),%sp
+
+ ; call: void startup(void *pt)
+
+ copy %r15,%arg0 ; `pt' is arg0 to `startup'.
+ copy %r16,%r22
+ .CALL
+ bl $$dyncall,%mrp ; Call `startup'.
+ copy %mrp,%rp
+
+ ldo -64(%sp),%sp
+
+ ; call: void *qt_vuserf_t(...)
+
+ ldw -36(%sp),%arg0 ; Load args to integer registers.
+ ldw -40(%sp),%arg1
+ ldw -44(%sp),%arg2
+ ldw -48(%sp),%arg3
+ ; Index of fld[w|d]s only ranges from -16 to 15, so we
+ ; take r22 to be our new base register.
+ ldo -32(%sp),%r22
+ fldws -4(%r22),%farg0 ; Load args to floating-point registers.
+ fldds -8(%r22),%farg1
+ fldws -12(%r22),%farg2
+ fldds -16(%r22),%farg3
+ copy %r17,%r22
+ .CALL
+ bl $$dyncall,%mrp ; Call `userf'.
+ copy %mrp,%rp
+
+ ; call: void cleanup(void *pt, void *vuserf_return)
+
+ copy %r15,%arg0 ; `pt' is arg0 to `cleanup'.
+ copy %ret0,%arg1 ; Return-value is arg1 to `cleanup'.
+ copy %r18,%r22
+ .CALL
+ bl $$dyncall,%mrp ; Call `cleanup'.
+ copy %mrp,%rp
+
+ bl,n qt_error,%r0
+
+ .EXIT
+ .PROCEND
diff --git a/qt/md/hppa_b.s b/qt/md/hppa_b.s
new file mode 100644
index 000000000..1b1e8264e
--- /dev/null
+++ b/qt/md/hppa_b.s
@@ -0,0 +1,203 @@
+; QuickThreads -- Threads-building toolkit.
+; Copyright (c) 1993 by David Keppel
+
+; Permission to use, copy, modify and distribute this software and
+; its documentation for any purpose and without fee is hereby
+; granted, provided that the above copyright notice and this notice
+; appear in all copies. This software is provided as a
+; proof-of-concept and for demonstration purposes; there is no
+; representation about the suitability of this software for any
+; purpose.
+
+; This file (pa-risc_b.s) is part of the port of QuickThreads for
+; PA-RISC 1.1 architecture. It contains assembly-level support for
+; raw processor performance measurement. It was written in 1994 by
+; Uwe Reder (`uereder@cip.informatik.uni-erlangen.de')
+; for the Operating Systems Department (IMMD4) at the
+; University of Erlangen/Nuernberg Germany.
+
+
+; Note that the number of instructions in the measurement-loops, differ
+; from implementation to implementation. I took eight instructions in a loop
+; for every test (execute eight instructions and loop to the start).
+
+ .CODE
+
+ .IMPORT $global$,DATA
+ .IMPORT $$dyncall,MILLICODE
+ .EXPORT b_call_reg
+ .EXPORT b_call_imm
+ .EXPORT b_add
+ .EXPORT b_load
+
+; Just do nothing, only return to caller. This procedure is called by
+; `b_call_reg' and `b_call_imm'.
+
+b_null
+ .PROC
+ .CALLINFO NO_CALLS, FRAME=0
+ .ENTRY
+
+ bv,n %r0(%rp) ; just return
+
+ .EXIT
+ .PROCEND
+
+; Call the procedure `b_null' with function pointer in a register.
+
+b_call_reg
+ .PROC
+ .CALLINFO CALLER, FRAME=0
+ .ENTRY
+
+ stwm %r3,64(%sp) ; store r3 (may be used by caller)
+ stw %rp,-20(%sp) ; save return-pointer to frame-marker
+
+ addil LR'to_call-$global$,%r27
+ ldw RR'to_call-$global$(%r1),%r3
+
+_loop0
+ copy %r3,%r22 ; copy the procedure label to r22, ...
+ .CALL ; ...this is the input to $$dyncall
+ bl $$dyncall,%mrp ; call $$dyncall (millicode function)
+ copy %mrp,%rp ; remember the return-pointer
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ addibf,<= -8,%arg0,_loop0 ; decrement counter by 8 and loop
+ nop
+
+ ldw -20(%sp),%rp ; restore return-pointer
+ bv %r0(%rp) ; return to caller
+ ldwm -64(%sp),%r3 ; resore r3 and remove stack frame
+
+ .EXIT
+ .PROCEND
+
+; Call the procedure `b_null' immediate.
+
+b_call_imm
+ .PROC
+ .CALLINFO CALLER, FRAME=0, SAVE_RP
+ .ENTRY
+
+ ldo 64(%sp),%sp ; caller needs a stack-frame
+ stw %rp,-20(%sp) ; save return-pointer to frame-marker
+
+_loop1
+ bl b_null,%rp ; call `b_null' immediate (8 times)
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+
+ addibf,<= -8,%arg0,_loop1 ; decrement counter by 8 and loop
+ nop
+
+ ldw -20(%sp),%rp ; restore return-pointer
+ bv %r0(%rp) ; return to caller
+ ldo -64(%sp),%sp ; remove stack-frame
+
+ .EXIT
+ .PROCEND
+
+; Copy register-to-register.
+; On PA-RISC this is implemented with an `or'.
+; The `or' is hidden by a pseudo-operation called `copy'.
+
+b_add
+ .PROC
+ .CALLINFO NO_CALLS, FRAME=0
+ .ENTRY
+
+_loop2
+ copy %r19,%r20 ; copy register-to-register
+ copy %r20,%r21 ; use caller-saves registers
+ copy %r21,%r22
+ copy %r22,%r21
+ copy %r21,%r20
+ copy %r20,%r19
+ copy %r19,%r20
+ copy %r20,%r21
+
+ addibf,<= -8,%arg0,_loop2 ; decrement counter by 8 and loop
+ nop
+
+ bv,n %r0(%rp)
+
+ .EXIT
+ .PROCEND
+
+; Load memory to a register.
+
+b_load
+ .PROC
+ .CALLINFO NO_CALLS, FRAME=0
+ .ENTRY
+
+_loop3
+ ldw -4(%sp),%r22 ; load data from frame-marker
+ ldw -8(%sp),%r22 ; use a caller-saves register
+ ldw -12(%sp),%r22
+ ldw -16(%sp),%r22
+ ldw -20(%sp),%r22
+ ldw -24(%sp),%r22
+ ldw -28(%sp),%r22
+ ldw -32(%sp),%r22
+
+ addibf,<= -8,%arg0,_loop3 ; decrement counter by 8 and loop
+ nop
+
+ bv,n %r0(%rp)
+
+ .EXIT
+ .PROCEND
+
+
+ .ALIGN 8
+to_call
+ .WORD b_null
diff --git a/qt/md/i386.README b/qt/md/i386.README
new file mode 100644
index 000000000..8ffb92198
--- /dev/null
+++ b/qt/md/i386.README
@@ -0,0 +1,7 @@
+Note that some machines want labels to have leading underscores,
+while others (e.g. System V) do not. Thus, several labels appear
+duplicated except for the leading underscore, e.g.
+
+ _qt_cswap:
+ qt_cswap:
+
diff --git a/qt/md/i386.h b/qt/md/i386.h
new file mode 100644
index 000000000..158fe2703
--- /dev/null
+++ b/qt/md/i386.h
@@ -0,0 +1,120 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_386_H
+#define QT_386_H
+
+typedef unsigned long qt_word_t;
+
+/* Thread's initial stack layout on the i386:
+
+ non-varargs:
+
+ +---
+ | arg[2] === `userf' on startup
+ | arg[1] === `pt' on startup
+ | arg[0] === `pu' on startup
+ +---
+ | ret pc === qt_error
+ +---
+ | ret pc === `only' on startup
+ +---
+ | %ebp
+ | %esi
+ | %edi
+ | %ebx <--- qt_t.sp
+ +---
+
+ When a non-varargs thread is started, it ``returns'' directly to
+ the client's `only' function.
+
+ varargs:
+
+ +---
+ | arg[n-1]
+ | ..
+ | arg[0]
+ +---
+ | ret pc === `qt_vstart'
+ +---
+ | %ebp === `startup'
+ | %esi === `cleanup'
+ | %edi === `pt'
+ | %ebx === `vuserf' <--- qt_t.sp
+ +---
+
+ When a varargs thread is started, it ``returns'' to the `qt_vstart'
+ startup code. The startup code calls the appropriate functions. */
+
+
+/* What to do to start a varargs thread running. */
+extern void qt_vstart (void);
+
+
+/* Hold 4 saved regs plus two return pcs (qt_error, qt_start) plus
+ three args. */
+#define QT_STKBASE (9 * 4)
+
+/* Hold 4 saved regs plus one return pc (qt_vstart). */
+#define QT_VSTKBASE (5 * 4)
+
+
+/* Stack must be 4-byte aligned. */
+#define QT_STKALIGN (4)
+
+
+/* Where to place various arguments. */
+#define QT_ONLY_INDEX (QT_PC)
+#define QT_USER_INDEX (QT_ARG2)
+#define QT_ARGT_INDEX (QT_ARG1)
+#define QT_ARGU_INDEX (QT_ARG0)
+
+#define QT_VSTARTUP_INDEX (QT_EBP)
+#define QT_VUSERF_INDEX (QT_EBX)
+#define QT_VCLEANUP_INDEX (QT_ESI)
+#define QT_VARGT_INDEX (QT_EDI)
+
+
+#define QT_EBX 0
+#define QT_EDI 1
+#define QT_ESI 2
+#define QT_EBP 3
+#define QT_PC 4
+/* The following are defined only for non-varargs. */
+#define QT_RPC 5
+#define QT_ARG0 6
+#define QT_ARG1 7
+#define QT_ARG2 8
+
+
+/* Stack grows down. The top of the stack is the first thing to
+ pop off (preincrement, postdecrement). */
+#define QT_GROW_DOWN
+
+extern void qt_error (void);
+
+/* Push on the error return address. */
+#define QT_ARGS_MD(sto) \
+ (QT_SPUT (sto, QT_RPC, qt_error))
+
+
+/* When varargs are pushed, allocate space for all the args. */
+#define QT_VARGS_MD0(sto, nbytes) \
+ ((qt_t *)(((char *)(sto)) - QT_STKROUNDUP(nbytes)))
+
+#define QT_VARGS_MD1(sto) \
+ (QT_SPUT (sto, QT_PC, qt_vstart))
+
+#define QT_VARGS_DEFAULT
+
+#endif /* QT_386_H */
diff --git a/qt/md/i386.s b/qt/md/i386.s
new file mode 100644
index 000000000..ed2c533d1
--- /dev/null
+++ b/qt/md/i386.s
@@ -0,0 +1,108 @@
+/* i386.s -- assembly support. */
+
+/*
+// QuickThreads -- Threads-building toolkit.
+// Copyright (c) 1993 by David Keppel
+//
+// Permission to use, copy, modify and distribute this software and
+// its documentation for any purpose and without fee is hereby
+// granted, provided that the above copyright notice and this notice
+// appear in all copies. This software is provided as a
+// proof-of-concept and for demonstration purposes; there is no
+// representation about the suitability of this software for any
+// purpose. */
+
+/* NOTE: double-labeled `_name' and `name' for System V compatability. */
+/* NOTE: Comment lines start with '/*' and '//' ONLY. Sorry! */
+
+/* Callee-save: %esi, %edi, %ebx, %ebp
+// Caller-save: %eax, %ecx
+// Can't tell: %edx (seems to work w/o saving it.)
+//
+// Assignment:
+//
+// See ``i386.h'' for the somewhat unconventional stack layout. */
+
+
+ .text
+ .align 2
+
+ .globl _qt_abort
+ .globl qt_abort
+ .globl _qt_block
+ .globl qt_block
+ .globl _qt_blocki
+ .globl qt_blocki
+
+/* These all have the type signature
+//
+// void *blocking (helper, arg0, arg1, new)
+//
+// On procedure entry, the helper is at 4(sp), args at 8(sp) and
+// 12(sp) and the new thread's sp at 16(sp). It *appears* that the
+// calling convention for the 8X86 requires the caller to save all
+// floating-point registers, this makes our life easy. */
+
+/* Halt the currently-running thread. Save it's callee-save regs on
+// to the stack, 32 bytes. Switch to the new stack (next == 16+32(sp))
+// and call the user function (f == 4+32(sp) with arguments: old sp
+// arg1 (8+32(sp)) and arg2 (12+32(sp)). When the user function is
+// done, restore the new thread's state and return.
+//
+// `qt_abort' is (currently) an alias for `qt_block' because most of
+// the work is shared. We could save the insns up to `qt_common' by
+// replicating, but w/o replicating we need an inital subtract (to
+// offset the stack as if it had been a qt_block) and then a jump
+// to qt_common. For the cost of a jump, we might as well just do
+// all the work.
+//
+// The helper function (4(sp)) can return a void* that is returned
+// by the call to `qt_blockk{,i}'. Since we don't touch %eax in
+// between, we get that ``for free''. */
+
+_qt_abort:
+qt_abort:
+_qt_block:
+qt_block:
+_qt_blocki:
+qt_blocki:
+ pushl %ebp /* Save callee-save, sp-=4. */
+ pushl %esi /* Save callee-save, sp-=4. */
+ pushl %edi /* Save callee-save, sp-=4. */
+ pushl %ebx /* Save callee-save, sp-=4. */
+ movl %esp, %eax /* Remember old stack pointer. */
+
+qt_common:
+ movl 32(%esp), %esp /* Move to new thread. */
+ pushl 28(%eax) /* Push arg 2. */
+ pushl 24(%eax) /* Push arg 1. */
+ pushl %eax /* Push arg 0. */
+ movl 20(%eax), %ebx /* Get function to call. */
+ call *%ebx /* Call f. */
+ addl $12, %esp /* Pop args. */
+
+ popl %ebx /* Restore callee-save, sp+=4. */
+ popl %edi /* Restore callee-save, sp+=4. */
+ popl %esi /* Restore callee-save, sp+=4. */
+ popl %ebp /* Restore callee-save, sp+=4. */
+ ret /* Resume the stopped function. */
+ hlt
+
+
+/* Start a varargs thread. */
+
+ .globl _qt_vstart
+ .globl qt_vstart
+_qt_vstart:
+qt_vstart:
+ pushl %edi /* Push `pt' arg to `startup'. */
+ call *%ebp /* Call `startup'. */
+ popl %eax /* Clean up the stack. */
+
+ call *%ebx /* Call the user's function. */
+
+ pushl %eax /* Push return from user's. */
+ pushl %edi /* Push `pt' arg to `cleanup'. */
+ call *%esi /* Call `cleanup'. */
+
+ hlt /* `cleanup' never returns. */
diff --git a/qt/md/i386_b.s b/qt/md/i386_b.s
new file mode 100644
index 000000000..32129a5d1
--- /dev/null
+++ b/qt/md/i386_b.s
@@ -0,0 +1,30 @@
+/*
+// QuickThreads -- Threads-building toolkit.
+// Copyright (c) 1993 by David Keppel
+//
+// Permission to use, copy, modify and distribute this software and
+// its documentation for any purpose and without fee is hereby
+// granted, provided that the above copyright notice and this notice
+// appear in all copies. This software is provided as a
+// proof-of-concept and for demonstration purposes; there is no
+// representation about the suitability of this software for any
+// purpose. */
+
+ .globl _b_call_reg
+ .globl b_call_reg
+ .globl _b_call_imm
+ .globl b_call_imm
+ .globl _b_add
+ .globl b_add
+ .globl _b_load
+ .globl b_load
+
+_b_call_reg:
+b_call_reg:
+_b_call_imm:
+b_call_imm:
+_b_add:
+b_add:
+_b_load:
+b_load:
+ hlt
diff --git a/qt/md/ksr1.Makefile b/qt/md/ksr1.Makefile
new file mode 100644
index 000000000..aa195839a
--- /dev/null
+++ b/qt/md/ksr1.Makefile
@@ -0,0 +1,6 @@
+
+#
+# KSR1 configuration.
+#
+CC = cc -ansi
+
diff --git a/qt/md/ksr1.h b/qt/md/ksr1.h
new file mode 100644
index 000000000..83537a3c2
--- /dev/null
+++ b/qt/md/ksr1.h
@@ -0,0 +1,164 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_KSR1_H
+#define QT_KSR1_H
+
+/*
+ Stack layout:
+
+ Registers are saved in strictly low to high order, FPU regs first
+ (only if qt_block is called), CEU regs second, IPU regs next, with no
+ padding between the groups.
+
+ Callee-save: f16..f63; c15..c30; i12..i30.
+ Args passed in i2..i5.
+
+ Note: c31 is a private data pointer. It is not changed on thread
+ swaps with the assumption that it represents per-processor rather
+ than per-thread state.
+
+ Note: i31 is an instruction count register that is updated by the
+ context switch routines. Like c31, it is not changed on context
+ switches.
+
+ This is what we want on startup:
+
+
+ +------ <-- BOS: Bottom of stack (grows down)
+ | 80 (128 - 48) bytes of padding to a 128-byte boundary
+ +---
+ | only
+ | userf
+ | t
+ | u
+ | qt_start$TXT
+ | (empty) <-- qt.sp
+ +------ <-- (BOS - 128)
+
+ This is why we want this on startup:
+
+ A thread begins running when the restore procedure switches thread stacks
+ and pops a return address off of the top of the new stack (see below
+ for the reason why we explicitly store qt_start$TXT). The
+ block procedure pushes two jump addresses on a thread's stack before
+ it switches stacks. The first is the return address for the block
+ procedure, and the second is a restore address. The return address
+ is used to jump back to the thread that has been switched to; the
+ restore address is a jump within the block code to restore the registers.
+ Normally, this is just a jump to the next address. However, on thread
+ startup, this is a jump to qt_start$TXT. (The block procedure stores
+ the restore address at an offset of 8 bytes from the top of the stack,
+ which is also the offset at which qt_start$TXT is stored on the stacks
+ of new threads. Hence, when the block procedure switches to a new
+ thread stack, it will initially jump to qt_start$TXT; thereafter,
+ it jumps to the restore code.)
+
+ qt_start$TXT, after it has read the initial data on the new thread's
+ stack and placed it in registers, pops the initial stack frame
+ and gives the thread the entire stack to use for execution.
+
+ The KSR runtime system has an unusual treatment of pointers to
+ functions. From C, taking the `name' of a function yields a
+ pointer to a _constant block_ and *not* the address of the
+ function. The zero'th entry in the constant block is a pointer to
+ the function.
+
+ We have to be careful: the restore procedure expects a return
+ address on the top of the stack (pointed to by qt.sp). This is not
+ a problem when restoring a thread that has run before, since the
+ block routine would have stored the return address on top of the
+ stack. However, when ``faking up'' a thread start (bootstrapping a
+ thread stack frame), the top of the stack needs to contain a
+ pointer to the code that will start the thread running.
+
+ The pointer to the startup code is *not* `qt_start'. It is the
+ word *pointed to* by `qt_start'. Thus, we dereference `qt_start',
+ see QT_ARGS_MD below.
+
+ On varargs startup (still unimplemented):
+
+ | padding to 128 byte boundary
+ | varargs <-- padded to a 128-byte-boundary
+ +---
+ | caller's frame, 16 bytes
+ | 80 bytes of padding (frame padded to a 128-byte boundary)
+ +---
+ | cleanup
+ | vuserf
+ | startup
+ | t
+ +---
+ | qt_start <-- qt.sp
+ +---
+
+ Of a suspended thread:
+
+ +---
+ | caller's frame, 16 bytes
+ | fpu registers 47 regs * 8 bytes/reg 376 bytes
+ | ceu registers 16 regs * 8 bytes/reg 128 bytes
+ | ipu registers 19 regs * 8 bytes/reg 152 bytes
+ | :
+ | 80 bytes of padding
+ | :
+ | qt_restore <-- qt.sp
+ +---
+
+ */
+
+
+#define QT_STKALIGN 128
+#define QT_GROW_DOWN
+typedef unsigned long qt_word_t;
+
+#define QT_STKBASE QT_STKALIGN
+#define QT_VSTKBASE QT_STKBASE
+
+extern void qt_start(void);
+/*
+ * See the discussion above for what indexing into a procedure ptr
+ * does for us (it's lovely, though, isn't it?).
+ *
+ * This assumes that the address of a procedure's code is the
+ * first word in a procedure's constant block. That's how the manual
+ * says it will be arranged.
+ */
+#define QT_ARGS_MD(sp) (QT_SPUT (sp, 1, ((qt_word_t *)qt_start)[0]))
+
+/*
+ * The *index* (positive offset) of where to put each value.
+ * See the picture of the stack above that explains the offsets.
+ */
+#define QT_ONLY_INDEX (5)
+#define QT_USER_INDEX (4)
+#define QT_ARGT_INDEX (3)
+#define QT_ARGU_INDEX (2)
+
+#define QT_VARGS_DEFAULT
+#define QT_VARGS(sp, nb, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, &vargs, pt, startup, vuserf, cleanup))
+
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 4*8 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, 0, ((qt_word_t *)qt_vstart)[0]))
+
+#define QT_VCLEANUP_INDEX (4)
+#define QT_VUSERF_INDEX (3)
+#define QT_VSTARTUP_INDEX (2)
+#define QT_VARGT_INDEX (1)
+
+#endif /* def QT_KSR1_H */
diff --git a/qt/md/ksr1.s b/qt/md/ksr1.s
new file mode 100644
index 000000000..d4d51a0a6
--- /dev/null
+++ b/qt/md/ksr1.s
@@ -0,0 +1,424 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .file "ksr1.s"
+ .def .debug; .endef
+
+ .align 128
+ .globl qt_blocki
+ .globl qt_blocki$TXT
+ .globl qt_block
+ .globl qt_block$TXT
+ .globl qt_start$TXT
+ .globl qt_start
+ .globl qt_abort$TXT
+ .globl qt_abort
+ .globl qt_vstart
+ .globl qt_vstart$TXT
+
+#
+# KSR convention: on procedure calls, load both the procedure address
+# and a pointer to a constant block. The address of function `f' is
+# `f$TXT', and the constant block address is `f'. The constant block
+# has several reserved values:
+#
+# 8 bytes fpu register save mask
+# 4 bytes ipu register save mask
+# 4 bytes ceu register save mask
+# f: f$TXT
+# ... whatever you want ... (not quite...read on)
+#
+# Note, by the way, that a pointer to a function is passed as a
+# pointer to the constant area, and the constant area has the text
+# address.
+#
+
+#
+# Procedures that do not return structures prefix their code with
+#
+# proc$TXT:
+# finop; cxnop
+# finop; cxnop
+# <proc code>
+#
+# Calls to those procedures branch to a 16 byte offset (4 instrs) in
+# to the procedure to skip those instructions.
+#
+# Procedures that return structures use a different code prefix:
+#
+# proc$TXT:
+# finop; beq.qt %rc, %rc, 24 # return value entry
+# finop; cxnop
+# finop; movi8 0, %rc # no return value entry
+# <proc code>
+#
+# Calls that want the returned structure branch directly to the
+# procedure address. Callers that don't want (or aren't expecting) a
+# return value branche 16 bytes in to the procedure, which will zero
+# %rc, telling the called procedure not to return a structure.
+#
+
+#
+# On entry:
+# %i2 -- control block of helper function to run
+# (dereference to get helper)
+# %i3 -- a1
+# %i4 -- a2
+# %i5 -- sp of new to run
+#
+
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_blocki:
+qt_abort:
+ .word qt_blocki$TXT
+ .word qt_restore$TXT
+
+ .text
+qt_abort$TXT:
+qt_blocki$TXT:
+ finop ; cxnop # entry prefix
+ finop ; cxnop # entry prefix
+ add8.ntr 75,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust
+ finop ; ssub8.ntr 0,%sp,%c5,%sp
+ finop ; st8 %fp,504(%sp) # Save caller's fp
+ finop ; st8 %cp,496(%sp) # Save caller's cp
+ finop ; ld8 8(%c10),%c5 # ld qt_restore$TXT
+ finop ; st8 %c14,0(%sp) # Save special ret addr
+ finop ; mov8_8 %c10, %cp # Our cp
+ finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr
+ finop ; st8 %c5,8(%sp) # st qt_restore$TXT
+#
+# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later)
+#
+ finop ; st8 %c15,456(%sp)
+ finop ; st8 %c16,448(%sp)
+ finop ; st8 %c17,440(%sp)
+ finop ; st8 %c18,432(%sp)
+ finop ; st8 %c19,424(%sp)
+ finop ; st8 %c20,416(%sp)
+ finop ; st8 %c21,408(%sp)
+ finop ; st8 %c22,400(%sp)
+ finop ; st8 %c23,392(%sp)
+ finop ; st8 %c24,384(%sp)
+#
+# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't
+# use nested procedures, we ignore it (leaving a gap, though)
+#
+ finop ; st8 %c26,368(%sp)
+ finop ; st8 %c27,360(%sp)
+ finop ; st8 %c28,352(%sp)
+ finop ; st8 %c29,344(%sp)
+ finop ; st8 %c30,336(%sp)
+#
+# IPU registers %i12-%i30
+#
+ finop ; st8 %i12,328(%sp)
+ finop ; st8 %i13,320(%sp)
+ finop ; st8 %i14,312(%sp)
+ finop ; st8 %i15,304(%sp)
+# (gap to get alignment for st64)
+# -- Doesn't work on version 1.1.3 of the OS
+# finop ; st64 %i16,256(%sp)
+
+ finop ; st8 %i16,256(%sp)
+ finop ; st8 %i17,248(%sp)
+ finop ; st8 %i18,240(%sp)
+ finop ; st8 %i19,232(%sp)
+ finop ; st8 %i20,224(%sp)
+ finop ; st8 %i21,216(%sp)
+ finop ; st8 %i22,208(%sp)
+ finop ; st8 %i23,200(%sp)
+ finop ; st8 %i24,192(%sp)
+ finop ; st8 %i25,184(%sp)
+ finop ; st8 %i26,176(%sp)
+ finop ; st8 %i27,168(%sp)
+ finop ; st8 %i28,160(%sp)
+ finop ; st8 %i29,152(%sp)
+ finop ; st8 %i30,144(%sp)
+#
+# FPU already saved, or saving not necessary
+#
+
+#
+# Switch to the stack passed in as fourth argument to the block
+# routine (%i5) and call the helper routine passed in as the first
+# argument (%i2). Note that the address of the helper's constant
+# block is passed in, so we must derefence it to get the helper's text
+# address.
+#
+ finop ; movb8_8 %i2,%c10 # helper's ConstBlock
+ finop ; cxnop # Delay slot, fill w/
+ finop ; cxnop # .. 2 st8 from above
+ finop ; ld8 0(%c10),%c4 # load addr of helper
+ finop ; movb8_8 %sp, %i2 # 1st arg to helper
+ # is this stack; other
+ # args remain in regs
+ finop ; movb8_8 %i5,%sp # switch stacks
+ finop ; jsr %c14,16(%c4) # call helper
+ movi8 3, %i0 ; movi8 0,%c8 # nargs brain dmg
+ finop ; cxnop
+ finop ; cxnop
+#
+# Here is where behavior differs for threads being restored and threads
+# being started. Blocked threads have a pointer to qt_restore$TXT on
+# the top of their stacks; manufactured stacks have a pointer to qt_start$TXT
+# on the top of their stacks. With this setup, starting threads
+# skip the (unecessary) restore operations.
+#
+# We jump to an offset of 16 to either (1) skip past the two noop pairs
+# at the start of qt_start$TXT, or (2) skip past the two noop pairs
+# after qt_restore$TXT.
+#
+ finop ; ld8 8(%sp),%c4
+ finop ; cxnop
+ finop ; cxnop
+ finop ; jmp 16(%c4)
+qt_restore$TXT:
+ finop ; cxnop
+ finop ; cxnop
+#
+# Point of Restore:
+#
+# The helper funtion will return here. Any result it has placed in
+# a return register (most likely %i0) will not get overwritten below
+# and will consequently be the return value of the blocking routine.
+#
+
+#
+# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later)
+#
+ finop ; ld8 456(%sp),%c15
+ finop ; ld8 448(%sp),%c16
+ finop ; ld8 440(%sp),%c17
+ finop ; ld8 432(%sp),%c18
+ finop ; ld8 424(%sp),%c19
+ finop ; ld8 416(%sp),%c20
+ finop ; ld8 408(%sp),%c21
+ finop ; ld8 400(%sp),%c22
+ finop ; ld8 392(%sp),%c23
+ finop ; ld8 384(%sp),%c24
+#
+# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't
+# use nested procedures, we ignore it (leaving a gap, though)
+#
+ finop ; ld8 368(%sp),%c26
+ finop ; ld8 360(%sp),%c27
+ finop ; ld8 352(%sp),%c28
+ finop ; ld8 344(%sp),%c29
+ finop ; ld8 336(%sp),%c30
+#
+# IPU registers %i12-%i30
+#
+ finop ; ld8 328(%sp),%i12
+ finop ; ld8 320(%sp),%i13
+ finop ; ld8 312(%sp),%i14
+ finop ; ld8 304(%sp),%i15
+# (gap to get alignment for ld64)
+# -- Doesn't work on version 1.1.3 of the OS
+# finop ; ld64 256(%sp),%i16
+
+ finop ; ld8 256(%sp),%i16
+ finop ; ld8 248(%sp),%i17
+ finop ; ld8 240(%sp),%i18
+ finop ; ld8 232(%sp),%i19
+ finop ; ld8 224(%sp),%i20
+ finop ; ld8 216(%sp),%i21
+ finop ; ld8 208(%sp),%i22
+ finop ; ld8 200(%sp),%i23
+ finop ; ld8 192(%sp),%i24
+ finop ; ld8 184(%sp),%i25
+ finop ; ld8 176(%sp),%i26
+ finop ; ld8 168(%sp),%i27
+ finop ; ld8 160(%sp),%i28
+ finop ; ld8 152(%sp),%i29
+ finop ; ld8 144(%sp),%i30
+
+#
+# FPU registers don't need to be loaded, or will be loaded by an
+# enclosing scope (e.g., if this is called by qt_block).
+#
+
+#
+# Load the special registers. We don't load the stack ptr because
+# the new stack is passed in as an argument, we don't load the EFP
+# because we don't use it, and we load the return address specially
+# off the top of the stack.
+#
+ finop ; ld8 0(%sp),%c14 # return addr
+ finop ; ld8 496(%sp),%cp
+ finop ; ld8 504(%sp),%fp
+
+ finop ; jmp 32(%c14) # jump back to thread
+ finop ; movi8 512,%c5 # stack adjust
+ finop ; sadd8.ntr 0,%sp,%c5,%sp
+
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_block:
+ .word qt_block$TXT
+ .word qt_error
+ .word qt_error$TXT
+ .word qt_blocki
+#
+# Handle saving and restoring the FPU regs, relying on qt_blocki
+# to save and restore the remaining registers.
+#
+ .text
+qt_block$TXT:
+ finop ; cxnop # entry prefix
+ finop ; cxnop # entry prefix
+
+ add8.ntr 29,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust
+ finop ; ssub8.ntr 0,%sp,%c5,%sp
+ finop ; st8 %fp,504(%sp) # Save caller's fp
+ finop ; st8 %cp,496(%sp) # Save caller's cp
+ finop ; st8 %c14,488(%sp) # store ret addr
+ finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr
+ finop ; mov8_8 %c10, %cp # Our cp
+
+#
+# Store 8 registers at once...destination must be a multiple of 64
+#
+ finop ; st64 %f16,384(%sp)
+ finop ; st64 %f24,320(%sp)
+ finop ; st64 %f32,256(%sp)
+ finop ; st64 %f40,192(%sp)
+ finop ; st64 %f48,128(%sp)
+ finop ; st64 %f56,64(%sp)
+
+#
+# Call the integer blocking routine, passing the arguments passed to us
+#
+ finop ; ld8 24(%cp), %c10
+ finop ; cxnop
+ finop ; jsr %c14, qt_blocki$TXT
+ finop ; cxnop
+ finop ; cxnop
+ movi8 4,%i0 ; movi8 0,%c8 # nargs brain dmg
+
+#
+# Load 8 registers at once...source must be a multiple of 64
+#
+ finop ; ld64 64(%sp),%f56
+ finop ; ld64 128(%sp),%f48
+ finop ; ld64 192(%sp),%f40
+ finop ; ld64 256(%sp),%f32
+ finop ; ld64 320(%sp),%f24
+ finop ; ld64 384(%sp),%f16
+
+ finop ; ld8 488(%sp),%c14
+ finop ; ld8 496(%sp),%cp
+ finop ; ld8 504(%sp),%fp
+ finop ; jmp 32(%c14) # jump back to thread
+ finop ; movi8 512,%c5 # stack adjust
+ finop ; sadd8.ntr 0,%sp,%c5,%sp
+
+
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_start:
+ .word qt_start$TXT
+#
+# A new thread is set up to "appear" as if it were executing code at
+# the beginning of qt_start and then it called a blocking routine
+# (qt_blocki). So when a new thread starts to run, it gets unblocked
+# by the code above and "returns" to `qt_start$TXT' in the
+# restore step of the switch. Blocked threads jump to 16(qt_restore$TXT),
+# and starting threads jump to 16(qt_start$TXT).
+#
+ .text
+qt_start$TXT:
+ finop ; cxnop #
+ finop ; cxnop #
+ finop ; ld8 40(%sp),%c10 # `only' constant block
+ finop ; ld8 32(%sp),%i4 # `userf' arg.
+ finop ; ld8 24(%sp),%i3 # `t' arg.
+ finop ; ld8 0(%c10),%c4 # `only' text location
+ finop ; ld8 16(%sp),%i2 # `u' arg.
+ finop ; cxnop
+ finop ; jsr %c14,16(%c4) # call `only'
+#
+# Pop the frame used to store the thread's initial data
+#
+ finop ; sadd8.ntr 0,%sp,128,%sp
+ finop ; cxnop
+ movi8 2,%i0 ; movi8 0,%c8 # nargs brain dmg
+#
+# If we ever return, it's an error.
+#
+ finop ; jmp qt_error$TXT
+ finop ; cxnop
+ finop ; cxnop
+ movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
+
+
+#
+# This stuff is broken
+#
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_vstart:
+ .word qt_vstart$TXT
+
+ .text
+qt_vstart$TXT:
+ finop ; cxnop # entry prefix
+ finop ; cxnop # entry prefix
+ finop ; cxnop
+ finop ; cxnop
+ add8.ntr 11,%i31,%i31 ; movi8 512,%c5
+ finop ; ssub8.ntr 0,%sp,%c5,%sp # fix stack
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; cxnop # `startup'
+ finop ; cxnop
+ finop ; ld8 16(%sp),%c10 # `startup' const block
+ finop ; cxnop
+ finop ; cxnop
+ finop ; ld8 0(%c10),%c4 # `startup' text loc.
+ finop ; cxnop
+ finop ; cxnop
+ finop ; jsr %c14,16(%c4) # call `startup'
+ finop ; cxnop
+ finop ; cxnop
+ movi8 1, %i0 ; movi8 0,%c8 # nargs brain dmg
+#
+# finop ; sadd 0,%sp,128,%sp # alter stack
+#
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+
+ finop ; ld8 32(%sp),%c10 # `only' constant block
+ finop ; ld8 8(%sp),%i2 # `u' arg.
+ finop ; ld8 16(%sp),%i3 # `t' arg.
+ finop ; ld8 0(%c10),%c4 # `only' text location
+ finop ; ld8 24(%sp),%i4 # `userf' arg.
+ finop ; cxnop
+ finop ; jsr %c4,16(%c4) # call `only'
+ finop ; cxnop
+ finop ; cxnop
+#
+# If the callee ever calls `nargs', the following instruction (pair)
+# will be executed. However, we don't know when we compile this code
+# how many args are being passed. So we give our best guess: 0.
+#
+ movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
+#
+# If we ever return, it's an error.
+#
+ finop ; jmp qt_error$TXT
+ finop ; cxnop
+ finop ; cxnop
+ movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
diff --git a/qt/md/ksr1_b.s b/qt/md/ksr1_b.s
new file mode 100644
index 000000000..80b0c59eb
--- /dev/null
+++ b/qt/md/ksr1_b.s
@@ -0,0 +1,49 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .file "ksr1_b.s"
+ .def .debug; .endef
+
+ .globl b_call_reg$TXT
+ .globl b_call_reg
+ .globl b_call_imm$TXT
+ .globl b_call_imm
+ .globl b_add$TXT
+ .globl b_add
+ .globl b_load$TXT
+ .globl b_load
+
+
+b_call_reg:
+b_call_imm:
+b_add:
+b_load:
+ .word b_call_reg$TXT
+ .word qt_error
+ .word qt_error$TXT
+
+
+b_call_reg$TXT:
+b_call_imm$TXT:
+b_add$TXT:
+b_load$TXT:
+ finop ; cxnop
+ finop ; cxnop
+ finop ; ld8 16(%cp),%c4
+ finop ; ld8 8(%cp),%cp
+ finop ; cxnop
+ finop ; cxnop
+ finop ; jsr %c4,0(%c4)
+ finop ; cxnop
+ finop ; cxnop
+
diff --git a/qt/md/m88k.Makefile b/qt/md/m88k.Makefile
new file mode 100644
index 000000000..608c70690
--- /dev/null
+++ b/qt/md/m88k.Makefile
@@ -0,0 +1,6 @@
+
+#
+# Hosted compilers for 88k for Meerkat.
+#
+CC = gcc88 -Dm88k -ansi -pedantic -Wall -fno-builtin
+AS = as88
diff --git a/qt/md/m88k.c b/qt/md/m88k.c
new file mode 100644
index 000000000..9e3ae8ba8
--- /dev/null
+++ b/qt/md/m88k.c
@@ -0,0 +1,111 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#include <stdarg.h>
+#include "qt.h"
+
+/* Varargs is harder on the m88k. Parameters are saved on the stack as
+ something like (stack grows down to low memory; low at bottom of
+ picture):
+
+ | :
+ | arg8 <-- va_list.__va_stk
+ +---
+ | :
+ +---
+ | arg7
+ | :
+ | iarg0 <-- va_list.__va_reg
+ +---
+ | :
+ | va_list { __va_arg, __va_stk, __va_reg }
+ | :
+ +---
+
+ Here, `va_list.__va_arg' is the number of word-size arguments
+ that have already been skipped. Doubles must be double-arligned.
+
+ What this means for us is that the user's routine needs to be
+ called with an arg list where some of the words in the `__va_stk'
+ part of the parameter list have to be promoted to registers.
+
+ BUG: doubleword register arguments must be double-aligned. If
+ something is passed as an even # arg and used as an odd # arg or
+ vice-versa, the code in the called routine (in the new thread) that
+ decides how to adjust the index will get it wrong, because it will
+ be expect it to be, say, doubleword aligned and it will really be
+ singleword aligned.
+
+ I'm not sure you can solve this without knowing the types of all
+ the arguments. All in all, we never promised varargs would work
+ reliably. */
+
+
+
+#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
+
+/* Always allocate at least enough space for 8 args; waste some space
+ at the base of the stack to ensure the startup routine doesn't read
+ off the end of the stack. */
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_1, qt_vstart))
+
+
+ struct qt_t *
+qt_vargs (struct qt_t *qsp, int nbytes, void *vargs,
+ void *pt, qt_function_t *startup,
+ qt_function_t *vuserf, qt_function_t *cleanup)
+{
+ va_list ap;
+ int i;
+ int n; /* Number of words into original arg list. */
+ qt_word_t *sp;
+ int *reg; /* Where to read passed-in-reg args. */
+ int *stk; /* Where to read passed-on-stk args. */
+
+ ap = *(va_list *)vargs;
+ qsp = QT_VARGS_MD0 (qsp, nbytes);
+ sp = (qt_word_t *)qsp;
+
+ reg = (ap.__va_arg < 8)
+ ? &ap.__va_reg[ap.__va_arg]
+ : 0;
+ stk = &ap.__va_stk[8];
+ n = ap.__va_arg;
+ for (i=0; i<nbytes/sizeof(qt_word_t) && n<8; ++i,++n) {
+ sp[i] = *reg++;
+ }
+ for (; i<nbytes/sizeof(qt_word_t); ++i) {
+ sp[i] = *stk++;
+ }
+
+#ifdef QT_NDEF
+ for (i=0; i<nbytes/sizeof(qt_word_t); ++i) {
+ sp[i] = (n < 8)
+ ? *reg++
+ : *stk++;
+ ++n;
+ }
+#endif
+
+ QT_VARGS_MD1 (QT_VADJ(sp));
+ QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
+ QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
+ QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
+ QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
+ return ((qt_t *)QT_VADJ(sp));
+}
diff --git a/qt/md/m88k.h b/qt/md/m88k.h
new file mode 100644
index 000000000..df7e07a85
--- /dev/null
+++ b/qt/md/m88k.h
@@ -0,0 +1,159 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_M88K_H
+#define QT_M88K_H
+
+typedef unsigned long qt_word_t;
+
+#define QT_GROW_DOWN
+
+/* Stack layout on the mips:
+
+ Callee-save registers are: $16-$23, $30; $f20-$f30.
+ Also save $31, return pc.
+
+ Non-varargs:
+
+ +---
+ | r30 (fp) on startup === 0
+ | r25
+ | r24
+ | r23
+ | r22
+ | r21
+ | r20
+ | r19
+ | r18
+ | r17 on startup === `only'
+ | r16 on startup === `userf'
+ | r15 on startup === `pt'
+ | r14 on startup === `pu'
+ | r1 on startup === `qt_start'
+ | 0
+ | 0
+ +---
+ | 0
+ | ... (8 regs worth === 32 bytes of homing area)
+ | 0 <--- sp
+ +---
+
+ Conventions for varargs:
+
+ | :
+ | arg8
+ +---
+ | r30 (fp) arg7
+ | r25 arg6
+ | r24 arg5
+ | r23 arg4
+ | r22 arg3
+ | r21 arg2
+ | r20 arg1
+ | r19 arg0
+ | r18
+ | r17 on startup === `startup'
+ | r16 on startup === `vuserf'
+ | r15 on startup === `pt'
+ | r14 on startup === `cleanup'
+ | r1 on startup === `qt_vstart'
+ | 0
+ | 0
+ +---
+ | 0
+ | ... (8 regs worth === 32 bytes of homing area)
+ | 0 <--- sp
+ +---
+
+ */
+
+
+/* Stack must be doubleword aligned. */
+#define QT_STKALIGN (16) /* Doubleword aligned. */
+
+/* How much space is allocated to hold all the crud for
+ initialization: saved registers plus padding to keep the stack
+ aligned plus 8 words of padding to use as a `homing area' (for
+ r2-r9) when calling helper functions on the stack of the (not yet
+ started) thread. The varargs save area is small because it gets
+ overlapped with the top of the parameter list. In case the
+ parameter list is less than 8 args, QT_ARGS_MD0 adds some dead
+ space at the top of the stack. */
+
+#define QT_STKBASE (16*4 + 8*4)
+#define QT_VSTKBASE (8*4 + 8*4)
+
+
+/* Index of various registers. */
+#define QT_1 (8+2)
+#define QT_14 (8+3)
+#define QT_15 (8+4)
+#define QT_16 (8+5)
+#define QT_17 (8+6)
+#define QT_30 (8+15)
+
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it sets up arguments and calls the client's
+ `only' function. For varargs functions, the startup code calls the
+ startup, user, and cleanup functions.
+
+ For non-varargs functions, we set the frame pointer to 0 to
+ null-terminate the call chain.
+
+ For varargs functions, the frame pointer register is used to hold
+ one of the arguments, so that all arguments can be laid out in
+ memory by the conventional `qt_vargs' varargs initialization
+ routine.
+
+ The varargs startup routine always reads 8 words of arguments from
+ the stack. If there are less than 8 words of arguments, then the
+ arg list could call off the top of the stack. To prevent fall-off,
+ always allocate 8 words. */
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) \
+ (QT_SPUT (sp, QT_1, qt_start), \
+ QT_SPUT (sp, QT_30, 0))
+
+
+/* The m88k uses a struct for `va_list', so pass a pointer to the
+ struct. */
+
+typedef void (qt_function_t)(void);
+
+struct qt_t;
+extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes,
+ void *vargs, void *pt,
+ qt_function_t *startup,
+ qt_function_t *vuserf,
+ qt_function_t *cleanup);
+
+#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, &(vargs), pt, (qt_function_t *)startup, \
+ (qt_function_t *)vuserf, (qt_function_t *)cleanup))
+
+
+/* The *index* (positive offset) of where to put each value. */
+#define QT_ONLY_INDEX (QT_17)
+#define QT_USER_INDEX (QT_16)
+#define QT_ARGT_INDEX (QT_15)
+#define QT_ARGU_INDEX (QT_14)
+
+#define QT_VCLEANUP_INDEX (QT_14)
+#define QT_VUSERF_INDEX (QT_16)
+#define QT_VSTARTUP_INDEX (QT_17)
+#define QT_VARGT_INDEX (QT_15)
+
+#endif /* ndef QT_M88K_H */
diff --git a/qt/md/m88k.s b/qt/md/m88k.s
new file mode 100644
index 000000000..42467e8d5
--- /dev/null
+++ b/qt/md/m88k.s
@@ -0,0 +1,132 @@
+/* m88k.s -- assembly support. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* Callee-save r14..r25, r31(sp), r30(fp). r1 === return pc.
+ * Argument registers r2..r9, return value r2..r3.
+ *
+ * On startup, restore regs so retpc === call to a function to start.
+ *
+ * We're going to call a function (r2) from within the context switch
+ * routine. Call it on the new thread's stack on behalf of the old
+ * thread.
+ */
+
+ .globl _qt_block
+ .globl _qt_blocki
+ .globl _qt_abort
+ .globl _qt_start
+ .globl _qt_vstart
+
+ /*
+ ** r2: ptr to function to call once curr is suspended
+ ** and control is on r5's stack.
+ ** r3: 1'th arg to *r2.
+ ** r4: 2'th arg to *r2.
+ ** r5: sp of thread to suspend.
+ **
+ ** The helper routine returns a value that is passed on as the
+ ** return value from the blocking routine. Since we don't
+ ** touch r2 between the helper's return and the end of
+ ** function, we get this behavior for free.
+ **
+ ** Same entry for integer-only and floating-point, since there
+ ** are no separate integer and floating-point registers.
+ **
+ ** Each procedure call sets aside a ``home region'' of 8 regs
+ ** for r2-r9 for varargs. For context switches we don't use
+ ** the ``home region'' for varargs so use it to save regs.
+ ** Allocate 64 bytes of save space -- use 32 bytes of register
+ ** save area passed in to us plus 32 bytes we allcated, use
+ ** the other 32 bytes for save area for a save area to call
+ ** the helper function.
+ */
+_qt_block:
+_qt_blocki:
+ sub r31, r31,64 /* Allocate reg save space. */
+ st r1, r31,8+32 /* Save callee-save registers. */
+ st r14, r31,12+32
+ st.d r15, r31,16+32
+ st.d r17, r31,24+32
+ st.d r19, r31,32+32
+ st.d r21, r31,40+32
+ st.d r23, r31,48+32
+ st r25, r31,56+32
+ st r30, r31,60+32
+
+_qt_abort:
+ addu r14, r31,0 /* Remember old sp. */
+ addu r31, r5,0 /* Set new sp. */
+ jsr.n r2 /* Call helper. */
+ addu r2, r14,0 /* Pass old sp as an arg0 to helper. */
+
+ ld r1, r31,8+32 /* Restore callee-save registers. */
+ ld r14, r31,12+32
+ ld.d r15, r31,16+32
+ ld.d r17, r31,24+32
+ ld.d r19, r31,32+32
+ ld.d r21, r31,40+32
+ ld.d r23, r31,48+32
+ ld r25, r31,56+32
+ ld r30, r31,60+32
+
+ jmp.n r1 /* Return to new thread's caller. */
+ addu r31, r31,64 /* Free register save space. */
+
+
+ /*
+ ** Non-varargs thread startup.
+ ** See `m88k.h' for register use conventions.
+ */
+_qt_start:
+ addu r2, r14,0 /* Set user arg `pu'. */
+ addu r3, r15,0 /* ... user function pt. */
+ jsr.n r17 /* Call `only'. */
+ addu r4, r16,0 /* ... user function userf. */
+
+ bsr _qt_error /* `only' erroniously returned. */
+
+
+ /*
+ ** Varargs thread startup.
+ ** See `m88k.h' for register use conventions.
+ **
+ ** Call the `startup' function with just argument `pt'.
+ ** Then call `vuserf' with 8 register args plus any
+ ** stack args.
+ ** Then call `cleanup' with `pt' and the return value
+ ** from `vuserf'.
+ */
+_qt_vstart:
+ addu r18, r30,0 /* Remember arg7 to `vuserf'. */
+ addu r30, r0,0 /* Null-terminate call chain. */
+
+ jsr.n r17 /* Call `startup'. */
+ addu r2, r15,0 /* `pt' is arg0 to `startup'. */
+
+ addu r2, r19,0 /* Set arg0. */
+ addu r3, r20,0 /* Set arg1. */
+ addu r4, r21,0 /* Set arg2. */
+ addu r5, r22,0 /* Set arg3. */
+ addu r6, r23,0 /* Set arg4. */
+ addu r7, r24,0 /* Set arg5. */
+ addu r8, r25,0 /* Set arg6. */
+ jsr.n r16 /* Call `vuserf'. */
+ addu r9, r18,0 /* Set arg7. */
+
+ addu r3, r2,0 /* Ret. value is arg1 to `cleanup'. */
+ jsr.n r14 /* Call `cleanup'. */
+ addu r2, r15,0 /* `pt' is arg0 to `cleanup'. */
+
+ bsr _qt_error /* `cleanup' erroniously returned. */
diff --git a/qt/md/m88k_b.s b/qt/md/m88k_b.s
new file mode 100644
index 000000000..1926e6ae8
--- /dev/null
+++ b/qt/md/m88k_b.s
@@ -0,0 +1,117 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .text
+ .globl _b_call_reg
+ .globl _b_call_imm
+ .globl _b_add
+ .globl _b_load
+
+_b_null:
+ jmp r1
+
+_b_call_reg:
+ subu r31, r31,8 /* Alloc ret pc save space. */
+ st r1, r31,32 /* Save ret pc. */
+ or.u r3, r0,hi16(_b_null) /* Put call addr in a reg. */
+ or r3, r3,lo16(_b_null)
+ jsr r3
+L0:
+ jsr r3
+ jsr r3
+ jsr r3
+ jsr.n r3
+ subu r2, r2,5 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L0
+ jsr r3
+
+ ld r1, r31,32
+ jmp r1
+
+
+_b_call_imm:
+ subu r31, r31,8 /* Alloc ret pc save space. */
+ st r1, r31,32 /* Save ret pc. */
+ bsr _b_null
+L1:
+ bsr _b_null
+ bsr _b_null
+ bsr _b_null
+ bsr.n _b_null
+ subu r2, r2,5 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L1
+ bsr _b_null
+
+ ld r1, r31,32
+ jmp r1
+
+_b_add:
+ add r0, r3,r4
+L2:
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+ add r0, r3,r4
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+
+ add r0, r3,r4
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+ add r0, r3,r4
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+
+ subu r2, r2,20 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L2
+ add r0, r3,r4
+
+ jmp r1
+
+
+_b_load:
+ ld r0, r31,0
+L3:
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+ ld r0, r31,0
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+
+ ld r0, r31,0
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+ ld r0, r31,0
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+
+ subu r2, r2,20 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L3
+ ld r0, r31,0
+
+ jmp r1
diff --git a/qt/md/mips-irix5.s b/qt/md/mips-irix5.s
new file mode 100644
index 000000000..234a953ed
--- /dev/null
+++ b/qt/md/mips-irix5.s
@@ -0,0 +1,182 @@
+/* mips.s -- assembly support. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* Callee-save $16-$23, $30-$31.
+ *
+ * $25 is used as a procedure value pointer, used to discover constants
+ * in a callee. Thus, each caller here sets $25 before the call.
+ *
+ * On startup, restore regs so retpc === call to a function to start.
+ * We're going to call a function ($4) from within this routine.
+ * We're passing 3 args, therefore need to allocate 12 extra bytes on
+ * the stack for a save area. The start routine needs a like 16-byte
+ * save area. Must be doubleword aligned (_mips r3000 risc
+ * architecture_, gerry kane, pg d-23).
+ */
+
+/*
+ * Modified by Assar Westerlund <assar@sics.se> to support Irix 5.x
+ * calling conventions for dynamically-linked code.
+ */
+
+ /* Make this position-independent code. */
+ .option pic2
+
+ .globl qt_block
+ .globl qt_blocki
+ .globl qt_abort
+ .globl qt_start
+ .globl qt_vstart
+
+ /*
+ ** $4: ptr to function to call once curr is suspended
+ ** and control is on $7's stack.
+ ** $5: 1'th arg to $4.
+ ** $6: 2'th arg to $4
+ ** $7: sp of thread to suspend.
+ **
+ ** Totally gross hack: The MIPS calling convention reserves
+ ** 4 words on the stack for a0..a3. This routine "ought" to
+ ** allocate space for callee-save registers plus 4 words for
+ ** the helper function, but instead we use the 4 words
+ ** provided by the function that called us (we don't need to
+ ** save our argument registers). So what *appears* to be
+ ** allocating only 40 bytes is actually allocating 56, by
+ ** using the caller's 16 bytes.
+ **
+ ** The helper routine returns a value that is passed on as the
+ ** return value from the blocking routine. Since we don't
+ ** touch $2 between the helper's return and the end of
+ ** function, we get this behavior for free.
+ */
+qt_blocki:
+ sub $sp,$sp,40 /* Allocate reg save space. */
+ sw $16, 0+16($sp)
+ sw $17, 4+16($sp)
+ sw $18, 8+16($sp)
+ sw $19,12+16($sp)
+ sw $20,16+16($sp)
+ sw $21,20+16($sp)
+ sw $22,24+16($sp)
+ sw $23,28+16($sp)
+ sw $30,32+16($sp)
+ sw $31,36+16($sp)
+ add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */
+qt_abort:
+ add $sp, $7,$0 /* $sp <= new sp. */
+ .set noreorder
+ add $25, $4,$0 /* Set helper function procedure value. */
+ jal $31,$25 /* Call helper func@$4 . */
+ add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */
+ .set reorder
+ lw $31,36+16($sp) /* Restore callee-save regs... */
+ lw $30,32+16($sp)
+ lw $23,28+16($sp)
+ lw $22,24+16($sp)
+ lw $21,20+16($sp)
+ lw $20,16+16($sp)
+ lw $19,12+16($sp)
+ lw $18, 8+16($sp)
+ lw $17, 4+16($sp)
+ lw $16, 0+16($sp) /* Restore callee-save */
+
+ add $sp,$sp,40 /* Deallocate reg save space. */
+ j $31 /* Return to caller. */
+
+ /*
+ ** Non-varargs thread startup.
+ ** Note: originally, 56 bytes were allocated on the stack.
+ ** The thread restore routine (_blocki/_abort) removed 40
+ ** of them, which means there is still 16 bytes for the
+ ** argument area required by the MIPS calling convention.
+ */
+qt_start:
+ add $4, $16,$0 /* Load up user function pu. */
+ add $5, $17,$0 /* ... user function pt. */
+ add $6, $18,$0 /* ... user function userf. */
+ add $25, $19,$0 /* Set `only' procedure value. */
+ jal $31,$25 /* Call `only'. */
+ la $25,qt_error /* Set `qt_error' procedure value. */
+ j $25
+
+
+ /*
+ ** Save calle-save floating-point regs $f20-$f30
+ ** See comment in `qt_block' about calling conventinos and
+ ** reserved space. Use the same trick here, but here we
+ ** actually have to allocate all the bytes since we have to
+ ** leave 4 words leftover for `qt_blocki'.
+ **
+ ** Return value from `qt_block' is the same as the return from
+ ** `qt_blocki'. We get that for free since we don't touch $2
+ ** between the return from `qt_blocki' and the return from
+ ** `qt_block'.
+ */
+qt_block:
+ sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */
+ swc1 $f20, 0+16($sp)
+ swc1 $f22, 8+16($sp)
+ swc1 $f24, 16+16($sp)
+ swc1 $f26, 24+16($sp)
+ swc1 $f28, 32+16($sp)
+ swc1 $f30, 40+16($sp)
+ sw $31, 48+16($sp)
+ jal qt_blocki
+ lwc1 $f20, 0+16($sp)
+ lwc1 $f22, 8+16($sp)
+ lwc1 $f24, 16+16($sp)
+ lwc1 $f26, 24+16($sp)
+ lwc1 $f28, 32+16($sp)
+ lwc1 $f30, 40+16($sp)
+ lw $31, 48+16($sp)
+ add $sp, $sp,56
+ j $31
+
+
+ /*
+ ** First, call `startup' with the `pt' argument.
+ **
+ ** Next, call the user's function with all arguments.
+ ** Note that we don't know whether args were passed in
+ ** integer regs, fp regs, or on the stack (See Gerry Kane
+ ** "MIPS R2000 RISC Architecture" pg D-22), so we reload
+ ** all the registers, possibly with garbage arguments.
+ **
+ ** Finally, call `cleanup' with the `pt' argument and with
+ ** the return value from the user's function. It is an error
+ ** for `cleanup' to return.
+ */
+qt_vstart:
+ add $4, $17,$0 /* `pt' is arg0 to `startup'. */
+ add $25, $18,$0 /* Set `startup' procedure value. */
+ jal $31, $25 /* Call `startup'. */
+
+ add $sp, $sp,16 /* Free extra save space. */
+ lw $4, 0($sp) /* Load up args. */
+ lw $5, 4($sp)
+ lw $6, 8($sp)
+ lw $7, 12($sp)
+ lwc1 $f12, 0($sp) /* Load up fp args. */
+ lwc1 $f14, 8($sp)
+ add $25, $19,$0 /* Set `userf' procedure value. */
+ jal $31,$25 /* Call `userf'. */
+
+ add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */
+ add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */
+ add $25, $16,$0 /* Set `cleanup' procedure value. */
+ jal $31, $25 /* Call `cleanup'. */
+
+ la $25,qt_error /* Set `qt_error' procedure value. */
+ j $25
diff --git a/qt/md/mips.h b/qt/md/mips.h
new file mode 100644
index 000000000..c584a681e
--- /dev/null
+++ b/qt/md/mips.h
@@ -0,0 +1,134 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_MIPS_H
+#define QT_MIPS_H
+
+typedef unsigned long qt_word_t;
+
+#define QT_GROW_DOWN
+
+/* Stack layout on the mips:
+
+ Callee-save registers are: $16-$23, $30; $f20-$f30.
+ Also save $31, return pc.
+
+ Non-varargs:
+
+ +---
+ | $f30 The first clump is only saved if `qt_block'
+ | $f28 is called, in which case it saves the fp regs
+ | $f26 then calls `qt_blocki' to save the int regs.
+ | $f24
+ | $f22
+ | $f20
+ | $31 === return pc in `qt_block'
+ +---
+ | $31 === return pc; on startup == qt_start
+ | $30
+ | $23
+ | $22
+ | $21
+ | $20
+ | $19 on startup === only
+ | $18 on startup === $a2 === userf
+ | $17 on startup === $a1 === pt
+ | $16 on startup === $a0 === pu
+ | <a3> save area req'd by MIPS calling convention
+ | <a2> save area req'd by MIPS calling convention
+ | <a1> save area req'd by MIPS calling convention
+ | <a0> save area req'd by MIPS calling convention <--- sp
+ +---
+
+ Conventions for varargs:
+
+ | args ...
+ +---
+ | :
+ | :
+ | $21
+ | $20
+ | $19 on startup === `userf'
+ | $18 on startup === `startup'
+ | $17 on startup === `pt'
+ | $16 on startup === `cleanup'
+ | <a3>
+ | <a2>
+ | <a1>
+ | <a0> <--- sp
+ +---
+
+ Note: if we wanted to, we could muck about and try to get the 4
+ argument registers loaded in to, e.g., $22, $23, $30, and $31,
+ and the return pc in, say, $20. Then, the first 4 args would
+ not need to be loaded from memory, they could just use
+ register-to-register copies. */
+
+
+/* Stack must be doubleword aligned. */
+#define QT_STKALIGN (8) /* Doubleword aligned. */
+
+/* How much space is allocated to hold all the crud for
+ initialization: $16-$23, $30, $31. Just do an integer restore,
+ no need to restore floating-point. Four words are needed for the
+ argument save area for the helper function that will be called for
+ the old thread, just before the new thread starts to run. */
+
+#define QT_STKBASE (14 * 4)
+#define QT_VSTKBASE QT_STKBASE
+
+
+/* Offsets of various registers. */
+#define QT_31 (9+4)
+#define QT_19 (3+4)
+#define QT_18 (2+4)
+#define QT_17 (1+4)
+#define QT_16 (0+4)
+
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it just calls the client's `only' function.
+ For varargs functions, it calls the startup, user, and cleanup
+ functions.
+
+ The varargs startup routine always reads 4 words of arguments from
+ the stack. If there are less than 4 words of arguments, then the
+ startup routine can read off the top of the stack. To prevent
+ errors we always allocate 4 words. If there are more than 3 words
+ of arguments, the 4 preallocated words are simply wasted. */
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_31, qt_start))
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 4*4 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_31, qt_vstart))
+
+#define QT_VARGS_DEFAULT
+
+
+/* The *index* (positive offset) of where to put each value. */
+#define QT_ONLY_INDEX (QT_19)
+#define QT_USER_INDEX (QT_18)
+#define QT_ARGT_INDEX (QT_17)
+#define QT_ARGU_INDEX (QT_16)
+
+#define QT_VCLEANUP_INDEX (QT_16)
+#define QT_VUSERF_INDEX (QT_19)
+#define QT_VSTARTUP_INDEX (QT_18)
+#define QT_VARGT_INDEX (QT_17)
+
+#endif /* ndef QT_MIPS_H */
diff --git a/qt/md/mips.s b/qt/md/mips.s
new file mode 100644
index 000000000..b074b98dc
--- /dev/null
+++ b/qt/md/mips.s
@@ -0,0 +1,164 @@
+/* mips.s -- assembly support. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* Callee-save $16-$23, $30-$31.
+ *
+ * On startup, restore regs so retpc === call to a function to start.
+ * We're going to call a function ($4) from within this routine.
+ * We're passing 3 args, therefore need to allocate 12 extra bytes on
+ * the stack for a save area. The start routine needs a like 16-byte
+ * save area. Must be doubleword aligned (_mips r3000 risc
+ * architecture_, gerry kane, pg d-23).
+ */
+
+ .globl qt_block
+ .globl qt_blocki
+ .globl qt_abort
+ .globl qt_start
+ .globl qt_vstart
+
+ /*
+ ** $4: ptr to function to call once curr is suspended
+ ** and control is on $7's stack.
+ ** $5: 1'th arg to $4.
+ ** $6: 2'th arg to $4
+ ** $7: sp of thread to suspend.
+ **
+ ** Totally gross hack: The MIPS calling convention reserves
+ ** 4 words on the stack for a0..a3. This routine "ought" to
+ ** allocate space for callee-save registers plus 4 words for
+ ** the helper function, but instead we use the 4 words
+ ** provided by the function that called us (we don't need to
+ ** save our argument registers). So what *appears* to be
+ ** allocating only 40 bytes is actually allocating 56, by
+ ** using the caller's 16 bytes.
+ **
+ ** The helper routine returns a value that is passed on as the
+ ** return value from the blocking routine. Since we don't
+ ** touch $2 between the helper's return and the end of
+ ** function, we get this behavior for free.
+ */
+qt_blocki:
+ sub $sp,$sp,40 /* Allocate reg save space. */
+ sw $16, 0+16($sp)
+ sw $17, 4+16($sp)
+ sw $18, 8+16($sp)
+ sw $19,12+16($sp)
+ sw $20,16+16($sp)
+ sw $21,20+16($sp)
+ sw $22,24+16($sp)
+ sw $23,28+16($sp)
+ sw $30,32+16($sp)
+ sw $31,36+16($sp)
+ add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */
+qt_abort:
+ add $sp, $7,$0 /* $sp <= new sp. */
+ .set noreorder
+ jal $31,$4 /* Call helper func@$4 . */
+ add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */
+ .set reorder
+ lw $31,36+16($sp) /* Restore callee-save regs... */
+ lw $30,32+16($sp)
+ lw $23,28+16($sp)
+ lw $22,24+16($sp)
+ lw $21,20+16($sp)
+ lw $20,16+16($sp)
+ lw $19,12+16($sp)
+ lw $18, 8+16($sp)
+ lw $17, 4+16($sp)
+ lw $16, 0+16($sp) /* Restore callee-save */
+
+ add $sp,$sp,40 /* Deallocate reg save space. */
+ j $31 /* Return to caller. */
+
+ /*
+ ** Non-varargs thread startup.
+ ** Note: originally, 56 bytes were allocated on the stack.
+ ** The thread restore routine (_blocki/_abort) removed 40
+ ** of them, which means there is still 16 bytes for the
+ ** argument area required by the MIPS calling convention.
+ */
+qt_start:
+ add $4, $16,$0 /* Load up user function pu. */
+ add $5, $17,$0 /* ... user function pt. */
+ add $6, $18,$0 /* ... user function userf. */
+ jal $31,$19 /* Call `only'. */
+ j qt_error
+
+
+ /*
+ ** Save calle-save floating-point regs $f20-$f30
+ ** See comment in `qt_block' about calling conventinos and
+ ** reserved space. Use the same trick here, but here we
+ ** actually have to allocate all the bytes since we have to
+ ** leave 4 words leftover for `qt_blocki'.
+ **
+ ** Return value from `qt_block' is the same as the return from
+ ** `qt_blocki'. We get that for free since we don't touch $2
+ ** between the return from `qt_blocki' and the return from
+ ** `qt_block'.
+ */
+qt_block:
+ sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */
+ swc1 $f20, 0+16($sp)
+ swc1 $f22, 8+16($sp)
+ swc1 $f24, 16+16($sp)
+ swc1 $f26, 24+16($sp)
+ swc1 $f28, 32+16($sp)
+ swc1 $f30, 40+16($sp)
+ sw $31, 48+16($sp)
+ jal qt_blocki
+ lwc1 $f20, 0+16($sp)
+ lwc1 $f22, 8+16($sp)
+ lwc1 $f24, 16+16($sp)
+ lwc1 $f26, 24+16($sp)
+ lwc1 $f28, 32+16($sp)
+ lwc1 $f30, 40+16($sp)
+ lw $31, 48+16($sp)
+ add $sp, $sp,56
+ j $31
+
+
+ /*
+ ** First, call `startup' with the `pt' argument.
+ **
+ ** Next, call the user's function with all arguments.
+ ** Note that we don't know whether args were passed in
+ ** integer regs, fp regs, or on the stack (See Gerry Kane
+ ** "MIPS R2000 RISC Architecture" pg D-22), so we reload
+ ** all the registers, possibly with garbage arguments.
+ **
+ ** Finally, call `cleanup' with the `pt' argument and with
+ ** the return value from the user's function. It is an error
+ ** for `cleanup' to return.
+ */
+qt_vstart:
+ add $4, $17,$0 /* `pt' is arg0 to `startup'. */
+ jal $31, $18 /* Call `startup'. */
+
+ add $sp, $sp,16 /* Free extra save space. */
+ lw $4, 0($sp) /* Load up args. */
+ lw $5, 4($sp)
+ lw $6, 8($sp)
+ lw $7, 12($sp)
+ lwc1 $f12, 0($sp) /* Load up fp args. */
+ lwc1 $f14, 8($sp)
+ jal $31,$19 /* Call `userf'. */
+
+ add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */
+ add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */
+ jal $31, $16 /* Call `cleanup'. */
+
+ j qt_error
diff --git a/qt/md/mips_b.s b/qt/md/mips_b.s
new file mode 100644
index 000000000..5b3740843
--- /dev/null
+++ b/qt/md/mips_b.s
@@ -0,0 +1,99 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .globl b_call_reg
+ .globl b_call_imm
+ .globl b_add
+ .globl b_load
+
+ .ent b_null
+b_null:
+ j $31
+ .end b_null
+
+ .ent b_call_reg
+b_call_reg:
+ la $5,b_null
+ add $6, $31,0
+$L0:
+ jal $5
+ jal $5
+ jal $5
+ jal $5
+ jal $5
+
+ sub $4, $4,5
+ bgtz $4,$L0
+ j $6
+ .end
+
+
+ .ent b_call_imm
+b_call_imm:
+ add $6, $31,0
+$L1:
+ jal b_null
+ jal b_null
+ jal b_null
+ jal b_null
+ jal b_null
+
+ sub $4, $4,5
+ bgtz $4,$L1
+ j $6
+ .end
+
+
+ .ent b_add
+b_add:
+ add $5, $0,$4
+ add $6, $0,$4
+ add $7, $0,$4
+ add $8, $0,$4
+$L2:
+ sub $4, $4,5
+ sub $5, $5,5
+ sub $6, $6,5
+ sub $7, $7,5
+ sub $8, $8,5
+
+ sub $4, $4,5
+ sub $5, $5,5
+ sub $6, $6,5
+ sub $7, $7,5
+ sub $8, $8,5
+
+ bgtz $4,$L2
+ j $31
+ .end
+
+
+ .ent b_load
+b_load:
+$L3:
+ ld $0, 0($sp)
+ ld $0, 4($sp)
+ ld $0, 8($sp)
+ ld $0, 12($sp)
+ ld $0, 16($sp)
+
+ ld $0, 20($sp)
+ ld $0, 24($sp)
+ ld $0, 28($sp)
+ ld $0, 32($sp)
+ ld $0, 36($sp)
+
+ sub $4, $4,10
+ bgtz $4,$L3
+ j $31
+ .end
diff --git a/qt/md/null.README b/qt/md/null.README
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/qt/md/null.README
diff --git a/qt/md/null.c b/qt/md/null.c
new file mode 100644
index 000000000..775db62be
--- /dev/null
+++ b/qt/md/null.c
@@ -0,0 +1,14 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+char const qtmd_rcsid[] = "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/md/null.c,v 1.1 1996-10-01 03:34:16 mdj Exp $";
diff --git a/qt/md/solaris.README b/qt/md/solaris.README
new file mode 100644
index 000000000..04f855c44
--- /dev/null
+++ b/qt/md/solaris.README
@@ -0,0 +1,19 @@
+Solaris 2.x is like System V (maybe it *is* System V?) and is different
+from older versions in that it uses no leading underscore for variable
+and function names. That is, the old convention was:
+
+ foo(){}
+
+got compiled as
+
+ .globl _foo
+ _foo:
+
+and is now compiled as
+
+ .globl foo
+ foo:
+
+The `config' script should fix up the older (leading underscore) versions
+of the machine-dependent files to use the newer (no leading underscore)
+calling conventions.
diff --git a/qt/md/sparc.h b/qt/md/sparc.h
new file mode 100644
index 000000000..e2ab281b4
--- /dev/null
+++ b/qt/md/sparc.h
@@ -0,0 +1,140 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_SPARC_H
+#define QT_SPARC_H
+
+typedef unsigned long qt_word_t;
+
+/* Stack layout on the sparc:
+
+ non-varargs:
+
+ +---
+ | <blank space for alignment>
+ | %o7 == return address -> qt_start
+ | %i7
+ | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain)
+ | %i5 -> only
+ | %i4 -> userf
+ | %i3
+ | %i2 -> pt
+ | %i1 -> pu
+ | %i0
+ | %l7
+ | %l6
+ | %l5
+ | %l4
+ | %l3
+ | %l2
+ | %l1
+ | %l0 <--- qt_t.sp
+ +---
+
+ varargs:
+
+ | :
+ | :
+ | argument list
+ | one-word aggregate return pointer
+ +---
+ | <blank space for alignment>
+ | %o7 == return address -> qt_vstart
+ | %i7
+ | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain)
+ | %i5 -> startup
+ | %i4 -> userf
+ | %i3 -> cleanup
+ | %i2 -> pt
+ | %i1
+ | %i0
+ | %l7
+ | %l6
+ | %l5
+ | %l4
+ | %l3
+ | %l2
+ | %l1
+ | %l0 <--- qt_t.sp
+ +---
+
+ */
+
+
+/* What to do to start a thread running. */
+extern void qt_start (void);
+extern void qt_vstart (void);
+
+
+/* Hold 17 saved registers + 1 word for alignment. */
+#define QT_STKBASE (18 * 4)
+#define QT_VSTKBASE QT_STKBASE
+
+
+/* Stack must be doubleword aligned. */
+#define QT_STKALIGN (8) /* Doubleword aligned. */
+
+#define QT_ONLY_INDEX (QT_I5)
+#define QT_USER_INDEX (QT_I4)
+#define QT_ARGT_INDEX (QT_I2)
+#define QT_ARGU_INDEX (QT_I1)
+
+#define QT_VSTARTUP_INDEX (QT_I5)
+#define QT_VUSERF_INDEX (QT_I4)
+#define QT_VCLEANUP_INDEX (QT_I3)
+#define QT_VARGT_INDEX (QT_I2)
+
+#define QT_O7 (16)
+#define QT_I6 (14)
+#define QT_I5 (13)
+#define QT_I4 (12)
+#define QT_I3 (11)
+#define QT_I2 (10)
+#define QT_I1 ( 9)
+
+
+/* The thread will ``return'' to the `qt_start' routine to get things
+ going. The normal return sequence takes us to QT_O7+8, so we
+ pre-subtract 8. The frame pointer chain is 0-terminated to prevent
+ the trap handler from chasing off in to random memory when flushing
+ stack windows. */
+
+#define QT_ARGS_MD(top) \
+ (QT_SPUT ((top), QT_O7, ((void *)(((int)qt_start)-8))), \
+ QT_SPUT ((top), QT_I6, 0))
+
+
+/* The varargs startup routine always reads 6 words of arguments
+ (6 argument registers) from the stack, offset by one word to
+ allow for an aggregate return area pointer. If the varargs
+ routine actually pushed fewer words than that, qt_vstart could read
+ off the top of the stack. To prevent errors, we always allocate 8
+ words. The space is often just wasted. */
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes)))
+
+#define QT_VARGS_MD1(sp) \
+ (QT_SPUT (sp, QT_O7, ((void *)(((int)qt_vstart)-8))))
+
+/* The SPARC has wierdo calling conventions which stores a hidden
+ parameter for returning aggregate values, so the rest of the
+ parameters are shoved up the stack by one place. */
+#define QT_VARGS_ADJUST(sp) (((char *)sp)+4)
+
+#define QT_VARGS_DEFAULT
+
+
+#define QT_GROW_DOWN
+
+#endif /* ndef QT_SPARC_H */
diff --git a/qt/md/sparc.s b/qt/md/sparc.s
new file mode 100644
index 000000000..d9bdf0c58
--- /dev/null
+++ b/qt/md/sparc.s
@@ -0,0 +1,142 @@
+/* sparc.s -- assembly support for the `qt' thread building kit. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* #include <machine/trap.h> */
+
+ .text
+ .align 4
+ .global qt_blocki
+ .global qt_block
+ .global qt_abort
+ .global qt_start
+ .global qt_vstart
+
+/* Register assignment:
+// %o0: incoming `helper' function to call after cswap
+// also used as outgoing sp of old thread (qt_t *)
+// %o1, %o2:
+// parameters to `helper' function called after cswap
+// %o3: sp of new thread
+// %o5: tmp used to save old thread sp, while using %o0
+// to call `helper' f() after cswap.
+//
+//
+// Aborting a thread is easy if there are no cached register window
+// frames: just switch to the new stack and away we go. If there are
+// cached register window frames they must all be written back to the
+// old stack before we move to the new stack. If we fail to do the
+// writeback then the old stack memory can be written with register
+// window contents e.g., after the stack memory has been freed and
+// reused.
+//
+// If you don't believe this, try setting the frame pointer to zero
+// once we're on the new stack. This will not affect correctnes
+// otherwise because the frame pointer will eventually get reloaded w/
+// the new thread's frame pointer. But it will be zero briefly before
+// the reload. You will eventually (100,000 cswaps later on a small
+// SPARC machine that I tried) get an illegal instruction trap from
+// the kernel trying to flush a cached window to location 0x0.
+//
+// Solution: flush windows before switching stacks, which invalidates
+// all the other register windows. We could do the trap
+// conditionally: if we're in the lowest frame of a thread, the fp is
+// zero already so we know there's nothing cached. But we expect most
+// aborts will be done from a first function that does a `save', so we
+// will rarely save anything and always pay the cost of testing to see
+// if we should flush.
+//
+// All floating-point registers are caller-save, so this routine
+// doesn't need to do anything to save and restore them.
+//
+// `qt_block' and `qt_blocki' return the same value as the value
+// returned by the helper function. We get this ``for free''
+// since we don't touch the return value register between the
+// return from the helper function and return from qt_block{,i}.
+*/
+
+qt_block:
+qt_blocki:
+ sub %sp, 8, %sp /* Allocate save area for return pc. */
+ st %o7, [%sp+64] /* Save return pc. */
+qt_abort:
+ ta 0x03 /* Save locals and ins. */
+ mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */
+ sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */
+ call %o0, 0 /* Call `helper' routine. */
+ mov %o5, %o0 /* Pass old thread to qt_after_t() */
+ /* .. along w/ args in %o1 & %o2. */
+
+ /* Restore callee-save regs. The kwsa
+ // is on this stack, so offset all
+ // loads by sizeof(kwsa), 64 bytes.
+ */
+ ldd [%sp+ 0+64], %l0
+ ldd [%sp+ 8+64], %l2
+ ldd [%sp+16+64], %l4
+ ldd [%sp+24+64], %l6
+ ldd [%sp+32+64], %i0
+ ldd [%sp+40+64], %i2
+ ldd [%sp+48+64], %i4
+ ldd [%sp+56+64], %i6
+ ld [%sp+64+64], %o7 /* Restore return pc. */
+
+ retl /* Return to address in %o7. */
+ add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */
+
+
+/* The function calling conventions say there has to be a 1-word area
+// in the caller's stack to hold a pointer to space for aggregate
+// return values. It also says there should be a 6-word area to hold
+// %o0..%o5 if the callee wants to save them (why? I don't know...)
+// Round up to 8 words to maintain alignment.
+//
+// Parameter values were stored in callee-save regs and are moved to
+// the parameter registers.
+*/
+qt_start:
+ mov %i1, %o0 /* `pu': Set up args to `only'. */
+ mov %i2, %o1 /* `pt'. */
+ mov %i4, %o2 /* `userf'. */
+ call %i5, 0 /* Call client function. */
+ sub %sp, 32, %sp /* Allocate 6-word callee space. */
+
+ call qt_error, 0 /* `only' erroniously returned. */
+ nop
+
+
+/* Same comments as `qt_start' about allocating rounded-up 7-word
+// save areas. */
+
+qt_vstart:
+ sub %sp, 32, %sp /* Allocate 7-word callee space. */
+ call %i5, 0 /* call `startup'. */
+ mov %i2, %o0 /* .. with argument `pt'. */
+
+ add %sp, 32, %sp /* Use 7-word space in varargs. */
+ ld [%sp+ 4+64], %o0 /* Load arg0 ... */
+ ld [%sp+ 8+64], %o1
+ ld [%sp+12+64], %o2
+ ld [%sp+16+64], %o3
+ ld [%sp+20+64], %o4
+ call %i4, 0 /* Call `userf'. */
+ ld [%sp+24+64], %o5
+
+ /* Use 6-word space in varargs. */
+ mov %o0, %o1 /* Pass return value from userf */
+ call %i3, 0 /* .. when call `cleanup. */
+ mov %i2, %o0 /* .. along with argument `pt'. */
+
+ call qt_error, 0 /* `cleanup' erroniously returned. */
+ nop
diff --git a/qt/md/sparc_b.s b/qt/md/sparc_b.s
new file mode 100644
index 000000000..08351d76d
--- /dev/null
+++ b/qt/md/sparc_b.s
@@ -0,0 +1,106 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .globl b_call_reg
+ .globl b_call_imm
+ .globl b_add
+ .globl b_load
+
+b_null:
+ retl
+ nop
+
+b_call_reg:
+ sethi %hi(b_null),%o4
+ or %o4,%lo(b_null),%o4
+ add %o7,%g0, %o3
+L0:
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+b_call_imm:
+ sethi %hi(b_null),%o4
+ or %o4,%lo(b_null),%o4
+ add %o7,%g0, %o3
+L1:
+ call b_null
+ call b_null
+ call b_null
+ call b_null
+ call b_null
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+
+b_add:
+ add %o0,%g0,%o1
+ add %o0,%g0,%o2
+ add %o0,%g0,%o3
+ add %o0,%g0,%o4
+L2:
+ sub %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ subcc %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ bg L2
+ nop
+ retl
+ nop
+
+
+b_load:
+ ld [%sp+ 0], %g0
+L3:
+ ld [%sp+ 4],%g0
+ ld [%sp+ 8],%g0
+ ld [%sp+12],%g0
+ ld [%sp+16],%g0
+ ld [%sp+20],%g0
+ ld [%sp+24],%g0
+ ld [%sp+28],%g0
+ ld [%sp+32],%g0
+ ld [%sp+36],%g0
+
+ subcc %o0,10,%o0
+ bg L3
+ ld [%sp+ 0],%g0
+ retl
+ nop
diff --git a/qt/md/vax.h b/qt/md/vax.h
new file mode 100644
index 000000000..1a5af0f2b
--- /dev/null
+++ b/qt/md/vax.h
@@ -0,0 +1,130 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_VAX_H
+#define QT_VAX_H
+
+typedef unsigned long qt_word_t;
+
+/* Thread's initial stack layout on the VAX:
+
+ non-varargs:
+
+ +---
+ | arg[2] === `userf' on startup
+ | arg[1] === `pt' on startup
+ | arg[0] === `pu' on startup
+ | ... === `only' on startup.
+ +---
+ | ret pc === `qt_start' on startup
+ | fp === 0 on startup
+ | ap === 0 on startup
+ | <mask>
+ | 0 (handler) <--- qt_t.sp
+ +---
+
+ When a non-varargs thread is started, it ``returns'' to the start
+ routine, which calls the client's `only' function.
+
+ The varargs case is clearly bad code. The various values should be
+ stored in a save area and snarfed in to callee-save registers on
+ startup. However, it's too painful to figure out the register
+ mask (right now), so do it the slow way.
+
+ +---
+ | arg[n-1]
+ | ..
+ | arg[0]
+ | nargs
+ +---
+ | === `cleanup'
+ | === `vuserf'
+ | === `startup'
+ | === `pt'
+ +---
+ | ret pc === `qt_start' on startup
+ | fp === 0 on startup
+ | ap === 0 on startup
+ | <mask>
+ | 0 (handler) <--- qt_t.sp
+ +---
+
+ When a varargs thread is started, it ``returns'' to the `qt_vstart'
+ startup code. The startup code pops all the extra arguments, then
+ calls the appropriate functions. */
+
+
+/* What to do to start a thread running. */
+extern void qt_start (void);
+extern void qt_vstart (void);
+
+
+/* Initial call frame for non-varargs and varargs cases. */
+#define QT_STKBASE (10 * 4)
+#define QT_VSTKBASE (9 * 4)
+
+
+/* Stack "must be" 4-byte aligned. (Actually, no, but it's
+ easiest and probably fastest to do so.) */
+
+#define QT_STKALIGN (4)
+
+
+/* Where to place various arguments. */
+#define QT_ONLY_INDEX (5)
+#define QT_USER_INDEX (8)
+#define QT_ARGT_INDEX (7)
+#define QT_ARGU_INDEX (6)
+
+#define QT_VSTARTUP_INDEX (6)
+#define QT_VUSERF_INDEX (7)
+#define QT_VCLEANUP_INDEX (8)
+#define QT_VARGT_INDEX (5)
+
+
+/* Stack grows down. The top of the stack is the first thing to
+ pop off (predecrement, postincrement). */
+#define QT_GROW_DOWN
+
+
+extern void qt_error (void);
+
+#define QT_VAX_GMASK_NOREGS (0)
+
+/* Push on the error return address, null termination to call chains,
+ number of arguments to `only', register save mask (save no
+ registers). */
+
+#define QT_ARGS_MD(sto) \
+ (QT_SPUT (sto, 0, 0), \
+ QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \
+ QT_SPUT (sto, 2, 0), \
+ QT_SPUT (sto, 3, 0), \
+ QT_SPUT (sto, 4, qt_start))
+
+#define QT_VARGS_MD0(sto, nbytes) \
+ (QT_SPUT (sto, (-(nbytes)/4)-1, (nbytes)/4), \
+ ((char *)(((sto)-4) - QT_STKROUNDUP(nbytes))))
+
+#define QT_VARGS_ADJUST(sp) ((char *)sp + 4)
+
+#define QT_VARGS_MD1(sto) \
+ (QT_SPUT (sto, 0, 0), \
+ QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \
+ QT_SPUT (sto, 2, 0), \
+ QT_SPUT (sto, 3, 0), \
+ QT_SPUT (sto, 4, qt_vstart))
+
+#define QT_VARGS_DEFAULT
+
+#endif /* QT_VAX_H */
diff --git a/qt/md/vax.s b/qt/md/vax.s
new file mode 100644
index 000000000..fed03f043
--- /dev/null
+++ b/qt/md/vax.s
@@ -0,0 +1,69 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .text
+
+ .globl _qt_abort
+ .globl _qt_block
+ .globl _qt_blocki
+ .globl _qt_start
+ .globl _qt_vstart
+
+
+/*
+// Calls to these routines have the signature
+//
+// void *block (func, arg1, arg2, newsp)
+//
+// Since the prologue saves 5 registers, nargs, pc, fp, ap, mask, and
+// a condition handler (at sp+0), the first argument is 40=4*10 bytes
+// offset from the stack pointer.
+*/
+_qt_block:
+_qt_blocki:
+_qt_abort:
+ .word 0x7c0 /* Callee-save mask: 5 registers. */
+ movl 56(sp),r1 /* Get stack pointer of new thread. */
+ movl 52(sp),-(r1) /* Push arg2 */
+ movl 48(sp),-(r1) /* Push arg1 */
+ movl sp,-(r1) /* Push arg0 */
+
+ movl 44(sp),r0 /* Get helper to call. */
+ movl r1,sp /* Move to new thread's stack. */
+ addl3 sp,$12,fp /* .. including the frame pointer. */
+ calls $3,(r0) /* Call helper. */
+
+ ret
+
+_qt_start:
+ movl (sp)+,r0 /* Get `only'. */
+ calls $3,(r0) /* Call `only'. */
+ calls $0,_qt_error /* `only' erroniously returned. */
+
+
+_qt_vstart:
+ movl (sp)+,r10 /* Get `pt'. */
+ movl (sp)+,r9 /* Get `startup'. */
+ movl (sp)+,r8 /* Get `vuserf'. */
+ movl (sp)+,r7 /* Get `cleanup'. */
+
+ pushl r10 /* Push `qt'. */
+ calls $1,(r9) /* Call `startup', pop `qt' on return. */
+
+ calls (sp)+,(r8) /* Call user's function. */
+
+ pushl r0 /* Push `vuserf_retval'. */
+ pushl r10 /* Push `qt'. */
+ calls $2,(r7) /* Call `cleanup', never return. */
+
+ calls $0,_qt_error /* `cleanup' erroniously returned. */
diff --git a/qt/md/vax_b.s b/qt/md/vax_b.s
new file mode 100644
index 000000000..2db2d4fec
--- /dev/null
+++ b/qt/md/vax_b.s
@@ -0,0 +1,92 @@
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .text
+ .globl _b_call_reg
+ .globl _b_call_imm
+ .globl _b_add
+ .globl _b_load
+
+_b_null:
+ .word 0x0
+ ret
+
+_b_call_reg:
+ .word 0x0
+ movl 4(ap),r0
+ moval _b_null,r1
+L0:
+ calls $0,(r1)
+ calls $0,(r1)
+ calls $0,(r1)
+ calls $0,(r1)
+ calls $0,(r1)
+
+ subl2 $5,r0
+ bgtr L0
+ ret
+
+
+_b_call_imm:
+ .word 0x0
+ movl 4(ap),r0
+L1:
+ calls $0,_b_null
+ calls $0,_b_null
+ calls $0,_b_null
+ calls $0,_b_null
+ calls $0,_b_null
+
+ subl2 $5,r0
+ bgtr L1
+ ret
+
+
+_b_add:
+ .word 0x0
+ movl 4(ap),r0
+L2:
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+
+ bgtr L2
+ ret
+
+
+_b_load:
+ .word 0x0
+ movl 4(ap),r0
+L3:
+ movl 0(sp),r1
+ movl 4(sp),r1
+ movl 8(sp),r1
+ movl 12(sp),r1
+ movl 16(sp),r1
+ movl 20(sp),r1
+ movl 24(sp),r1
+ movl 28(sp),r1
+ movl 32(sp),r1
+ movl 36(sp),r1
+
+ subl2 $1,r0
+ bgtr L3
+ ret
diff --git a/qt/meas.c b/qt/meas.c
new file mode 100644
index 000000000..3faab3c52
--- /dev/null
+++ b/qt/meas.c
@@ -0,0 +1,1049 @@
+/* meas.c -- measure qt stuff. */
+
+#include "copyright.h"
+
+/* Need this to get assertions under Mach on the Sequent/i386: */
+#ifdef __i386__
+#define assert(ex) \
+ do { \
+ if (!(ex)) { \
+ fprintf (stderr, "[%s:%d] Assertion " #ex " failed\n", __FILE__, __LINE__); \
+ abort(); \
+ } \
+ } while (0)
+#else
+#include <assert.h>
+#endif
+
+/* This really ought to be defined in some ANSI include file (*I*
+ think...), but it's defined here instead, which leads us to another
+ machine dependency.
+
+ The `iaddr_t' type is an integer representation of a pointer,
+ suited for doing arithmetic on addresses, e.g. to round an address
+ to an alignment boundary. */
+typedef unsigned long iaddr_t;
+
+#include <stdarg.h> /* For varargs tryout. */
+#include <stdio.h>
+#include "b.h"
+#include "qt.h"
+#include "stp.h"
+
+extern void exit (int status);
+extern int atoi (char const *s);
+extern int fprintf (FILE *out, char const *fmt, ...);
+extern int fputs (char const *s, FILE *fp);
+extern void free (void *sto);
+extern void *malloc (unsigned nbytes);
+extern void perror (char const *s);
+
+void usage (void);
+void tracer(void);
+
+/* Round `v' to be `a'-aligned, assuming `a' is a power of two. */
+#define ROUND(v, a) (((v) + (a) - 1) & ~((a)-1))
+
+typedef struct thread_t {
+ qt_t *qt; /* Pointer to thread of function... */
+ void *stk;
+ void *top; /* Set top of stack if reuse. */
+ struct thread_t *next;
+} thread_t;
+
+
+ static thread_t *
+t_alloc (void)
+{
+ thread_t *t;
+ int ssz = 0x1000;
+
+ t = malloc (sizeof(thread_t));
+ if (!t) {
+ perror ("malloc");
+ exit (1);
+ }
+ assert (ssz > QT_STKBASE);
+ t->stk = malloc (ssz);
+ t->stk = (void *)ROUND (((iaddr_t)t->stk), QT_STKALIGN);
+ if (!t->stk) {
+ perror ("malloc");
+ exit (1);
+ }
+ assert ((((iaddr_t)t->stk) & (QT_STKALIGN-1)) == 0);
+ t->top = QT_SP (t->stk, ssz - QT_STKBASE);
+
+ return (t);
+}
+
+
+ static thread_t *
+t_create (qt_only_t *starter, void *p0, qt_userf_t *f)
+{
+ thread_t *t;
+
+ t = t_alloc();
+ t->qt = QT_ARGS (t->top, p0, t, f, starter);
+ return (t);
+}
+
+
+ static void
+t_free (thread_t *t)
+{
+ free (t->stk);
+ free (t);
+}
+
+
+ static void *
+t_null (qt_t *old, void *p1, void *p2)
+{
+ /* return (garbage); */
+}
+
+
+ static void *
+t_splat (qt_t *old, void *oldp, void *null)
+{
+ *(qt_t **)oldp = old;
+ /* return (garbage); */
+}
+
+
+static char const test01_msg[] =
+ "*QT_SP(sto,sz), QT_ARGS(top,p0,p1,userf,first)";
+
+static char const *test01_descr[] = {
+ "Performs 1 QT_SP and one QT_ARGS per iteration.",
+ NULL
+};
+
+/* This test gives a guess on how long it takes to initalize
+ a thread. */
+
+ static void
+test01 (int n)
+{
+ char stack[QT_STKBASE+QT_STKALIGN];
+ char *stk;
+ qt_t *top;
+
+ stk = (char *)ROUND (((iaddr_t)stack), QT_STKALIGN);
+
+ {
+ int i;
+
+ for (i=0; i<QT_STKBASE; ++i) {
+ stk[i] = 0;
+ }
+ }
+
+ while (n>0) {
+ /* RETVALUSED */
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+#ifdef NDEF
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+
+ n -= 10;
+#else
+ n -= 1;
+#endif
+ }
+}
+
+
+static char const test02_msg[] = "QT_BLOCKI (0, 0, test02_aux, t->qt)";
+static qt_t *rootthread;
+
+ static void
+test02_aux1 (void *pu, void *pt, qt_userf_t *f)
+{
+ QT_ABORT (t_null, 0, 0, rootthread);
+}
+
+ static void *
+test02_aux2 (qt_t *old, void *farg1, void *farg2)
+{
+ rootthread = old;
+ /* return (garbage); */
+}
+
+ static void
+test02 (int n)
+{
+ thread_t *t;
+
+ while (n>0) {
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+
+ n -= 5;
+ }
+}
+
+
+static char const test03_msg[] = "QT_BLOCKI (...) test vals are right.";
+
+
+/* Called by the thread function when it wants to shut down.
+ Return a value to the main thread. */
+
+ static void *
+test03_aux0 (qt_t *old_is_garbage, void *farg1, void *farg2)
+{
+ assert (farg1 == (void *)5);
+ assert (farg2 == (void *)6);
+ return ((void *)15); /* Some unlikely value. */
+}
+
+
+/* Called during new thread startup by main thread. Since the new
+ thread has never run before, return value is ignored. */
+
+ static void *
+test03_aux1 (qt_t *old, void *farg1, void *farg2)
+{
+ assert (old != NULL);
+ assert (farg1 == (void *)5);
+ assert (farg2 == (void *)6);
+ rootthread = old;
+ return ((void *)16); /* Different than `15'. */
+}
+
+ static void
+test03_aux2 (void *pu, void *pt, qt_userf_t *f)
+{
+ assert (pu == (void *)1);
+ assert (f == (qt_userf_t *)4);
+ QT_ABORT (test03_aux0, (void *)5, (void *)6, rootthread);
+}
+
+ static void
+test03 (int n)
+{
+ thread_t *t;
+ void *rv;
+
+ while (n>0) {
+ t = t_create (test03_aux2, (void *)1, (qt_userf_t *)4);
+ rv = QT_BLOCKI (test03_aux1, (void *)5, (void *)6, t->qt);
+ assert (rv == (void *)15);
+ t_free (t);
+
+ --n;
+ }
+}
+
+
+static char const test04_msg[] = "stp_start w/ no threads.";
+
+ static void
+test04 (int n)
+{
+ while (n>0) {
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+
+ n -= 10;
+ }
+}
+
+
+static char const test05_msg[] = "stp w/ 2 yielding thread.";
+
+ static void
+test05_aux (void *null)
+{
+ stp_yield();
+ stp_yield();
+}
+
+ static void
+test05 (int n)
+{
+ while (n>0) {
+ stp_init();
+ stp_create (test05_aux, 0);
+ stp_create (test05_aux, 0);
+ stp_start();
+
+ --n;
+ }
+}
+
+
+static char const test06_msg[] = "*QT_ARGS(...), QT_BLOCKI one thread";
+
+static char const *test06_descr[] = {
+ "Does a QT_ARGS, QT_BLOCKI to a helper function that saves the",
+ "stack pointer of the main thread, calls an `only' function that",
+ "saves aborts the thread, calling a null helper function.",
+ ":: start/stop = QT_ARGS + QT_BLOCKI + QT_ABORT + 3 procedure calls.",
+ NULL
+};
+
+/* This test initializes a thread, runs it, then returns to the main
+ program, which reinitializes the thread, runs it again, etc. Each
+ iteration corresponds to 1 init, 1 abort, 1 block. */
+
+static qt_t *test06_sp;
+
+
+ static void
+test06_aux2 (void *null0a, void *null1b, void *null2b, qt_userf_t *null)
+{
+ QT_ABORT (t_null, 0, 0, test06_sp);
+}
+
+
+ static void *
+test06_aux3 (qt_t *sp, void *null0c, void *null1c)
+{
+ test06_sp = sp;
+ /* return (garbage); */
+}
+
+
+ static void
+test06 (int n)
+{
+ thread_t *t;
+
+ t = t_create (0, 0, 0);
+
+ while (n>0) {
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+#ifdef NDEF
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ n -= 5;
+#else
+ --n;
+#endif
+ }
+}
+
+static char test07_msg[] = "*cswap between threads";
+
+static char const *test07_descr[] = {
+ "Build a chain of threads where each thread has a fixed successor.",
+ "There is no scheduling performed. Each thread but one is a loop",
+ "that simply blocks with QT_BLOCKI, calling a helper that saves the",
+ "current stack pointer. The last thread decrements a count, and,",
+ "if zero, aborts back to the main thread. Else it continues with",
+ "the blocking chain. The count is divided by the number of threads",
+ "in the chain, so `n' is the number of integer block operations.",
+ ":: integer cswap = QT_BLOCKI + a procedure call.",
+ NULL
+};
+
+/* This test repeatedly blocks a bunch of threads.
+ Each iteration corresponds to one block operation.
+
+ The threads are arranged so that there are TEST07_N-1 of them that
+ run `test07_aux2'. Each one of those blocks saving it's sp to
+ storage owned by the preceding thread; a pointer to that storage is
+ passed in via `mep'. Each thread has a handle on it's own storage
+ for the next thread, referenced by `nxtp', and it blocks by passing
+ control to `*nxtp', telling the helper function to save its state
+ in `*mep'. The last thread in the chain decrements a count and, if
+ it's gone below zero, returns to `test07'; otherwise, it invokes
+ the first thread in the chain. */
+
+static qt_t *test07_heavy;
+
+#define TEST07_N (4)
+
+
+ static void
+test07_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
+{
+ qt_t *nxt;
+
+ while (1) {
+ nxt = *(qt_t **)nxtp;
+#ifdef NDEF
+ printf ("Helper 0x%p\n", nxtp);
+#endif
+ QT_BLOCKI (t_splat, mep, 0, nxt);
+ }
+}
+
+ static void
+test07_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
+{
+ int n;
+
+ n = *(int *)np;
+ while (1) {
+ n -= TEST07_N;
+ if (n<0) {
+ QT_ABORT (t_splat, mep, 0, test07_heavy);
+ }
+ QT_BLOCKI (t_splat, mep, 0, *(qt_t **)nxtp);
+ }
+}
+
+
+ static void
+test07 (int n)
+{
+ int i;
+ thread_t *t[TEST07_N];
+
+ for (i=0; i<TEST07_N; ++i) {
+ t[i] = t_create (0, 0, 0);
+ }
+ for (i=0; i<TEST07_N-1; ++i) {
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test07_aux2);
+ }
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, &n, &t[TEST07_N-1]->qt, &t[0]->qt, test07_aux3);
+ QT_BLOCKI (t_splat, &test07_heavy, 0, t[0]->qt);
+}
+
+
+static char test08_msg[] = "Floating-point cswap between threads";
+
+static char const *test08_descr[] = {
+ "Measure context switch times including floating-point, use QT_BLOCK.",
+ NULL
+};
+
+static qt_t *test08_heavy;
+
+#define TEST08_N (4)
+
+
+ static void
+test08_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
+{
+ qt_t *nxt;
+
+ while (1) {
+ nxt = *(qt_t **)nxtp;
+ QT_BLOCK (t_splat, mep, 0, nxt);
+ }
+}
+
+ static void
+test08_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
+{
+ int n;
+
+ n = *(int *)np;
+ while (1) {
+ n -= TEST08_N;
+ if (n<0) {
+ QT_ABORT (t_splat, mep, 0, test08_heavy);
+ }
+ QT_BLOCK (t_splat, mep, 0, *(qt_t **)nxtp);
+ }
+}
+
+
+ static void
+test08 (int n)
+{
+ int i;
+ thread_t *t[TEST08_N];
+
+ for (i=0; i<TEST08_N; ++i) {
+ t[i] = t_create (0, 0, 0);
+ }
+ for (i=0; i<TEST08_N-1; ++i) {
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test08_aux2);
+ }
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, &n, &t[TEST08_N-1]->qt, &t[0]->qt, test08_aux3);
+ QT_BLOCK (t_splat, &test08_heavy, 0, t[0]->qt);
+}
+
+
+/* Test the varargs procedure calling. */
+
+char const test09_msg[] = { "Start and run threads using varargs." };
+
+thread_t *test09_t0, *test09_t1, *test09_t2, *test09_main;
+
+ thread_t *
+test09_create (qt_startup_t *start, qt_vuserf_t *f,
+ qt_cleanup_t *cleanup, int nbytes, ...)
+{
+ va_list ap;
+ thread_t *t;
+
+ t = t_alloc();
+ va_start (ap, nbytes);
+ t->qt = QT_VARGS (t->top, nbytes, ap, t, start, f, cleanup);
+ va_end (ap);
+ return (t);
+}
+
+
+ static void
+test09_cleanup (void *pt, void *vuserf_retval)
+{
+ assert (vuserf_retval == (void *)17);
+ QT_ABORT (t_splat, &((thread_t *)pt)->qt, 0,
+ ((thread_t *)pt)->next->qt);
+}
+
+
+ static void
+test09_start (void *pt)
+{
+}
+
+
+ static void *
+test09_user0 (void)
+{
+ QT_BLOCKI (t_splat, &test09_t0->qt, 0, test09_t1->qt);
+ return ((void *)17);
+}
+
+ static void *
+test09_user2 (int one, int two)
+{
+ assert (one == 1);
+ assert (two == 2);
+ QT_BLOCKI (t_splat, &test09_t1->qt, 0, test09_t2->qt);
+ assert (one == 1);
+ assert (two == 2);
+ return ((void *)17);
+}
+
+ static void *
+test09_user10 (int one, int two, int three, int four, int five,
+ int six, int seven, int eight, int nine, int ten)
+{
+ assert (one == 1);
+ assert (two == 2);
+ assert (three == 3);
+ assert (four == 4);
+ assert (five == 5);
+ assert (six == 6);
+ assert (seven == 7);
+ assert (eight == 8);
+ assert (nine == 9);
+ assert (ten == 10);
+ QT_BLOCKI (t_splat, &test09_t2->qt, 0, test09_main->qt);
+ assert (one == 1);
+ assert (two == 2);
+ assert (three == 3);
+ assert (four == 4);
+ assert (five == 5);
+ assert (six == 6);
+ assert (seven == 7);
+ assert (eight == 8);
+ assert (nine == 9);
+ assert (ten == 10);
+ return ((void *)17);
+}
+
+
+ void
+test09 (int n)
+{
+ thread_t main;
+
+ test09_main = &main;
+
+ while (--n >= 0) {
+ test09_t0 = test09_create (test09_start, (qt_vuserf_t*)test09_user0,
+ test09_cleanup, 0);
+ test09_t1 = test09_create (test09_start, (qt_vuserf_t*)test09_user2,
+ test09_cleanup, 2 * sizeof(qt_word_t), 1, 2);
+ test09_t2 = test09_create (test09_start, (qt_vuserf_t*)test09_user10,
+ test09_cleanup, 10 * sizeof(qt_word_t),
+ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10);
+
+ /* Chaining used by `test09_cleanup' to determine who is next. */
+ test09_t0->next = test09_t1;
+ test09_t1->next = test09_t2;
+ test09_t2->next = test09_main;
+
+ QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);
+ QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);
+
+ t_free (test09_t0);
+ t_free (test09_t1);
+ t_free (test09_t2);
+ }
+}
+
+
+ /* Test 10/11/12: time the cost of various number of args. */
+
+char const test10_msg[] = { "*Test varargs init & startup w/ 0 args." };
+
+char const *test10_descr[] = {
+ "Start and stop threads that use variant argument lists (varargs).",
+ "Each thread is initialized by calling a routine that calls",
+ "QT_VARARGS. Then runs the thread by calling QT_BLOCKI to hald the",
+ "main thread, a helper that saves the main thread's stack pointer,",
+ "a null startup function, a null user function, a cleanup function",
+ "that calls QT_ABORT and restarts the main thread. Copies no user",
+ "parameters.",
+ ":: varargs start/stop = QT_BLOCKI + QT_ABORT + 6 function calls.",
+ NULL
+};
+
+/* Helper function to send control back to main.
+ Don't save anything. */
+
+
+/* Helper function for starting the varargs thread. Save the stack
+ pointer of the main thread so we can get back there eventually. */
+
+
+/* Startup function for a varargs thread. */
+
+ static void
+test10_startup (void *pt)
+{
+}
+
+
+/* User function for a varargs thread. */
+
+ static void *
+test10_run (int arg0, ...)
+{
+ /* return (garbage); */
+}
+
+
+/* Cleanup function for a varargs thread. Send control
+ back to the main thread. Don't save any state from the thread that
+ is halting. */
+
+ void
+test10_cleanup (void *pt, void *vuserf_retval)
+{
+ QT_ABORT (t_null, 0, 0, ((thread_t *)pt)->qt);
+}
+
+
+ void
+test10_init (thread_t *new, thread_t *next, int nbytes, ...)
+{
+ va_list ap;
+
+ va_start (ap, nbytes);
+ new->qt = QT_VARGS (new->top, nbytes, ap, next, test10_startup,
+ test10_run, test10_cleanup);
+ va_end (ap);
+}
+
+
+ void
+test10 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 0);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+
+char const test11_msg[] = { "*Test varargs init & startup w/ 2 args." };
+
+char const *test11_descr[] = {
+ "Varargs initialization/run. Copies 2 user arguments.",
+ ":: varargs 2 start/stop = QT_VARGS(2 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
+ NULL
+};
+
+
+ void
+test11 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 2 * sizeof(int), 2, 1);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+char const test12_msg[] = { "*Test varargs init & startup w/ 4 args." };
+
+char const *test12_descr[] = {
+ "Varargs initialization/run. Copies 4 user arguments.",
+ ":: varargs 4 start/stop = QT_VARGS(4 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
+ NULL
+};
+
+
+ void
+test12 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+
+char const test13_msg[] = { "*Test varargs init & startup w/ 8 args." };
+
+char const *test13_descr[] = {
+ "Varargs initialization/run. Copies 8 user arguments.",
+ ":: varargs 8 start/stop = QT_VARGS(8 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
+ NULL
+};
+
+ void
+test13 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+
+char const test14_msg[] = { "*Test varargs initialization w/ 0 args." };
+
+char const *test14_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 0 init = QT_VARGS()",
+ NULL
+};
+
+ void
+test14 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 0 * sizeof(int));
+ }
+ t_free (t);
+}
+
+
+char const test15_msg[] = { "*Test varargs initialization w/ 2 args." };
+
+char const *test15_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 2 init = QT_VARGS(2 args)",
+ NULL
+};
+
+ void
+test15 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 2 * sizeof(int), 2, 1);
+ }
+ t_free (t);
+}
+
+char const test16_msg[] = { "*Test varargs initialization w/ 4 args." };
+
+char const *test16_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 4 init = QT_VARGS(4 args)",
+ NULL
+};
+
+
+ void
+test16 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
+ }
+ t_free (t);
+}
+
+
+char const test17_msg[] = { "*Test varargs initialization w/ 8 args." };
+
+char const *test17_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 8 init = QT_VARGS(8 args)",
+ NULL
+};
+
+
+ void
+test17 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
+ }
+ t_free (t);
+}
+
+ /* Test times for basic machine operations. */
+
+char const test18_msg[] = { "*Call register indirect." };
+char const *test18_descr[] = { NULL };
+
+ void
+test18 (int n)
+{
+ b_call_reg (n);
+}
+
+
+char const test19_msg[] = { "*Call immediate." };
+char const *test19_descr[] = { NULL };
+
+ void
+test19 (int n)
+{
+ b_call_imm (n);
+}
+
+
+char const test20_msg[] = { "*Add register-to-register." };
+char const *test20_descr[] = { NULL };
+
+ void
+test20 (int n)
+{
+ b_add (n);
+}
+
+
+char const test21_msg[] = { "*Load memory to a register." };
+char const *test21_descr[] = { NULL };
+
+ void
+test21 (int n)
+{
+ b_load (n);
+}
+
+ /* Driver. */
+
+typedef struct foo_t {
+ char const *msg; /* Message to print for generic help. */
+ char const **descr; /* A description of what is done by the test. */
+ void (*f)(int n);
+} foo_t;
+
+
+static foo_t foo[] = {
+ { "Usage:\n", NULL, (void(*)(int n))usage },
+ { test01_msg, test01_descr, test01 },
+ { test02_msg, NULL, test02 },
+ { test03_msg, NULL, test03 },
+ { test04_msg, NULL, test04 },
+ { test05_msg, NULL, test05 },
+ { test06_msg, test06_descr, test06 },
+ { test07_msg, test07_descr, test07 },
+ { test08_msg, test08_descr, test08 },
+ { test09_msg, NULL, test09 },
+ { test10_msg, test10_descr, test10 },
+ { test11_msg, test11_descr, test11 },
+ { test12_msg, test12_descr, test12 },
+ { test13_msg, test13_descr, test13 },
+ { test14_msg, test14_descr, test14 },
+ { test15_msg, test15_descr, test15 },
+ { test16_msg, test16_descr, test16 },
+ { test17_msg, test17_descr, test17 },
+ { test18_msg, test18_descr, test18 },
+ { test19_msg, test19_descr, test19 },
+ { test20_msg, test20_descr, test20 },
+ { test21_msg, test21_descr, test21 },
+ { 0, 0 }
+};
+
+static int tv = 0;
+
+ void
+tracer ()
+{
+
+ fprintf (stderr, "tracer\t%d\n", tv++);
+ fflush (stderr);
+}
+
+ void
+tracer2 (void *val)
+{
+ fprintf (stderr, "tracer2\t%d val=0x%p", tv++, val);
+ fflush (stderr);
+}
+
+
+ void
+describe()
+{
+ int i;
+ FILE *out = stdout;
+
+ for (i=0; foo[i].msg; ++i) {
+ if (foo[i].descr) {
+ int j;
+
+ putc ('\n', out);
+ fprintf (out, "[%d]\n", i);
+ for (j=0; foo[i].descr[j]; ++j) {
+ fputs (foo[i].descr[j], out);
+ putc ('\n', out);
+ }
+ }
+ }
+ exit (0);
+}
+
+
+ void
+usage()
+{
+ int i;
+
+ fputs (foo[0].msg, stderr);
+ for (i=1; foo[i].msg; ++i) {
+ fprintf (stderr, "%2d\t%s\n", i, foo[i].msg);
+ }
+ exit (1);
+}
+
+
+ void
+args (int *which, int *n, int argc, char **argv)
+{
+ static int nfuncs = 0;
+
+ if (argc == 2 && argv[1][0] == '-' && argv[1][1] == 'h') {
+ describe();
+ }
+
+ if (nfuncs == 0) {
+ for (nfuncs=0; foo[nfuncs].msg; ++nfuncs)
+ ;
+ }
+
+ if (argc != 2 && argc != 3) {
+ usage();
+ }
+
+ *which = atoi (argv[1]);
+ if (*which < 0 || *which >= nfuncs) {
+ usage();
+ }
+ *n = (argc == 3)
+ ? atoi (argv[2])
+ : 1;
+}
+
+
+ int
+main (int argc, char **argv)
+{
+ int which, n;
+ args (&which, &n, argc, argv);
+ (*(foo[which].f))(n);
+ exit (0);
+ return (0);
+}
diff --git a/qt/qt.c b/qt/qt.c
new file mode 100644
index 000000000..1e406d24c
--- /dev/null
+++ b/qt/qt.c
@@ -0,0 +1,48 @@
+#include "copyright.h"
+#include "qt.h"
+
+#ifdef QT_VARGS_DEFAULT
+
+/* If the stack grows down, `vargs' is a pointer to the lowest
+ address in the block of arguments. If the stack grows up, it is a
+ pointer to the highest address in the block. */
+
+ qt_t *
+qt_vargs (qt_t *sp, int nbytes, void *vargs,
+ void *pt, qt_startup_t *startup,
+ qt_vuserf_t *vuserf, qt_cleanup_t *cleanup)
+{
+ int i;
+
+ sp = QT_VARGS_MD0 (sp, nbytes);
+#ifdef QT_GROW_UP
+ for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
+ QT_SPUT (QT_VARGS_ADJUST(sp), i, ((qt_word_t *)vargs)[-i]);
+ }
+#else
+ for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
+ QT_SPUT (QT_VARGS_ADJUST(sp), i-1, ((qt_word_t *)vargs)[i-1]);
+ }
+#endif
+
+ QT_VARGS_MD1 (QT_VADJ(sp));
+ QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
+ QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
+ QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
+ QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
+ return ((qt_t *)QT_VADJ(sp));
+}
+#endif /* def QT_VARGS_DEFAULT */
+
+ void
+qt_null (void)
+{
+}
+
+ void
+qt_error (void)
+{
+ extern void abort(void);
+
+ abort();
+}
diff --git a/qt/qt.h.in b/qt/qt.h.in
new file mode 100644
index 000000000..6e01fec0c
--- /dev/null
+++ b/qt/qt.h.in
@@ -0,0 +1,176 @@
+#ifndef QT_H
+#define QT_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <@qtmd_h@>
+
+
+/* A QuickThreads thread is represented by it's current stack pointer.
+ To restart a thread, you merely need pass the current sp (qt_t*) to
+ a QuickThreads primitive. `qt_t*' is a location on the stack. To
+ improve type checking, represent it by a particular struct. */
+
+typedef struct qt_t {
+ char dummy;
+} qt_t;
+
+
+/* Alignment is guaranteed to be a power of two. */
+#ifndef QT_STKALIGN
+ #error "Need to know the machine-dependent stack alignment."
+#endif
+
+#define QT_STKROUNDUP(bytes) \
+ (((bytes)+QT_STKALIGN) & ~(QT_STKALIGN-1))
+
+
+/* Find ``top'' of the stack, space on the stack. */
+#ifndef QT_SP
+#ifdef QT_GROW_DOWN
+#define QT_SP(sto, size) ((qt_t *)(&((char *)(sto))[(size)]))
+#endif
+#ifdef QT_GROW_UP
+#define QT_SP(sto, size) ((void *)(sto))
+#endif
+#if !defined(QT_SP)
+ #error "QT_H: Stack must grow up or down!"
+#endif
+#endif
+
+
+/* The type of the user function:
+ For non-varargs, takes one void* function.
+ For varargs, takes some number of arguments. */
+typedef void *(qt_userf_t)(void *pu);
+typedef void *(qt_vuserf_t)(int arg0, ...);
+
+/* For non-varargs, just call a client-supplied function,
+ it does all startup and cleanup, and also calls the user's
+ function. */
+typedef void (qt_only_t)(void *pu, void *pt, qt_userf_t *userf);
+
+/* For varargs, call `startup', then call the user's function,
+ then call `cleanup'. */
+typedef void (qt_startup_t)(void *pt);
+typedef void (qt_cleanup_t)(void *pt, void *vuserf_return);
+
+
+/* Internal helper for putting stuff on stack. */
+#ifndef QT_SPUT
+#define QT_SPUT(top, at, val) \
+ (((qt_word_t *)(top))[(at)] = (qt_word_t)(val))
+#endif
+
+
+/* Push arguments for the non-varargs case. */
+#ifndef QT_ARGS
+
+#ifndef QT_ARGS_MD
+#define QT_ARGS_MD (0)
+#endif
+
+#ifndef QT_STKBASE
+ #error "Need to know the machine-dependent stack allocation."
+#endif
+
+/* All things are put on the stack relative to the final value of
+ the stack pointer. */
+#ifdef QT_GROW_DOWN
+#define QT_ADJ(sp) (((char *)sp) - QT_STKBASE)
+#else
+#define QT_ADJ(sp) (((char *)sp) + QT_STKBASE)
+#endif
+
+#define QT_ARGS(sp, pu, pt, userf, only) \
+ (QT_ARGS_MD (QT_ADJ(sp)), \
+ QT_SPUT (QT_ADJ(sp), QT_ONLY_INDEX, only), \
+ QT_SPUT (QT_ADJ(sp), QT_USER_INDEX, userf), \
+ QT_SPUT (QT_ADJ(sp), QT_ARGT_INDEX, pt), \
+ QT_SPUT (QT_ADJ(sp), QT_ARGU_INDEX, pu), \
+ ((qt_t *)QT_ADJ(sp)))
+
+#endif
+
+
+/* Push arguments for the varargs case.
+ Has to be a function call because initialization is an expression
+ and we need to loop to copy nbytes of stuff on to the stack.
+ But that's probably OK, it's not terribly cheap, anyway. */
+
+#ifdef QT_VARGS_DEFAULT
+#ifndef QT_VARGS_MD0
+#define QT_VARGS_MD0(sp, vasize) (sp)
+#endif
+#ifndef QT_VARGS_MD1
+#define QT_VARGS_MD1(sp) do { ; } while (0)
+#endif
+
+#ifndef QT_VSTKBASE
+ #error "Need base stack size for varargs functions."
+#endif
+
+/* Sometimes the stack pointer needs to munged a bit when storing
+ the list of arguments. */
+#ifndef QT_VARGS_ADJUST
+#define QT_VARGS_ADJUST(sp) (sp)
+#endif
+
+/* All things are put on the stack relative to the final value of
+ the stack pointer. */
+#ifdef QT_GROW_DOWN
+#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
+#else
+#define QT_VADJ(sp) (((char *)sp) + QT_VSTKBASE)
+#endif
+
+extern qt_t *qt_vargs (qt_t *sp, int nbytes, void *vargs,
+ void *pt, qt_startup_t *startup,
+ qt_vuserf_t *vuserf, qt_cleanup_t *cleanup);
+
+#ifndef QT_VARGS
+#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, vargs, pt, startup, vuserf, cleanup))
+#endif
+
+#endif
+
+
+/* Save the state of the thread and call the helper function
+ using the stack of the new thread. */
+typedef void *(qt_helper_t)(qt_t *old, void *a0, void *a1);
+typedef void *(qt_block_t)(qt_helper_t *helper, void *a0, void *a1,
+ qt_t *newthread);
+
+/* Rearrange the parameters so that things passed to the helper
+ function are already in the right argument registers. */
+#ifndef QT_ABORT
+extern qt_abort (qt_helper_t *h, void *a0, void *a1, qt_t *newthread);
+/* The following does, technically, `return' a value, but the
+ user had better not rely on it, since the function never
+ returns. */
+#define QT_ABORT(h, a0, a1, newthread) \
+ do { qt_abort (h, a0, a1, newthread); } while (0)
+#endif
+
+#ifndef QT_BLOCK
+extern void *qt_block (qt_helper_t *h, void *a0, void *a1,
+ qt_t *newthread);
+#define QT_BLOCK(h, a0, a1, newthread) \
+ (qt_block (h, a0, a1, newthread))
+#endif
+
+#ifndef QT_BLOCKI
+extern void *qt_blocki (qt_helper_t *h, void *a0, void *a1,
+ qt_t *newthread);
+#define QT_BLOCKI(h, a0, a1, newthread) \
+ (qt_blocki (h, a0, a1, newthread))
+#endif
+
+#ifdef __cplusplus
+} /* Match `extern "C" {' at top. */
+#endif
+
+#endif /* ndef QT_H */
diff --git a/qt/stp.c b/qt/stp.c
new file mode 100644
index 000000000..bfacc893b
--- /dev/null
+++ b/qt/stp.c
@@ -0,0 +1,199 @@
+#include "copyright.h"
+#include "qt.h"
+#include "stp.h"
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+#define STP_STKSIZE (0x1000)
+
+/* `alignment' must be a power of 2. */
+#define STP_STKALIGN(sp, alignment) \
+ ((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))
+
+
+/* The notion of a thread is merged with the notion of a queue.
+ Thread stuff: thread status (sp) and stuff to use during
+ (re)initialization. Queue stuff: next thread in the queue
+ (next). */
+
+struct stp_t {
+ qt_t *sp; /* QuickThreads handle. */
+ void *sto; /* `malloc'-allocated stack. */
+ struct stp_t *next; /* Next thread in the queue. */
+};
+
+
+/* A queue is a circular list of threads. The queue head is a
+ designated list element. If this is a uniprocessor-only
+ implementation we can store the `main' thread in this, but in a
+ multiprocessor there are several `heavy' threads but only one run
+ queue. A fancier implementation might have private run queues,
+ which would lead to a simpler (trivial) implementation */
+
+typedef struct stp_q_t {
+ stp_t t;
+ stp_t *tail;
+} stp_q_t;
+
+
+ /* Helper functions. */
+
+extern void *malloc (unsigned size);
+extern void perror (char const *msg);
+extern void free (void *sto);
+
+ void *
+xmalloc (unsigned size)
+{
+ void *sto;
+
+ sto = malloc (size);
+ if (!sto) {
+ perror ("malloc");
+ exit (1);
+ }
+ return (sto);
+}
+
+ /* Queue access functions. */
+
+ static void
+stp_qinit (stp_q_t *q)
+{
+ q->t.next = q->tail = &q->t;
+}
+
+
+ static stp_t *
+stp_qget (stp_q_t *q)
+{
+ stp_t *t;
+
+ t = q->t.next;
+ q->t.next = t->next;
+ if (t->next == &q->t) {
+ if (t == &q->t) { /* If it was already empty .. */
+ return (NULL); /* .. say so. */
+ }
+ q->tail = &q->t; /* Else now it is empty. */
+ }
+ return (t);
+}
+
+
+ static void
+stp_qput (stp_q_t *q, stp_t *t)
+{
+ q->tail->next = t;
+ t->next = &q->t;
+ q->tail = t;
+}
+
+
+ /* Thread routines. */
+
+static stp_q_t stp_global_runq; /* A queue of runable threads. */
+static stp_t stp_global_main; /* Thread for the process. */
+static stp_t *stp_global_curr; /* Currently-executing thread. */
+
+static void *stp_starthelp (qt_t *old, void *ignore0, void *ignore1);
+static void stp_only (void *pu, void *pt, qt_userf_t *f);
+static void *stp_aborthelp (qt_t *sp, void *old, void *null);
+static void *stp_yieldhelp (qt_t *sp, void *old, void *blockq);
+
+
+ void
+stp_init()
+{
+ stp_qinit (&stp_global_runq);
+}
+
+
+ void
+stp_start()
+{
+ stp_t *next;
+
+ while ((next = stp_qget (&stp_global_runq)) != NULL) {
+ stp_global_curr = next;
+ QT_BLOCK (stp_starthelp, 0, 0, next->sp);
+ }
+}
+
+
+ static void *
+stp_starthelp (qt_t *old, void *ignore0, void *ignore1)
+{
+ stp_global_main.sp = old;
+ stp_qput (&stp_global_runq, &stp_global_main);
+ /* return (garbage); */
+}
+
+
+ void
+stp_create (stp_userf_t *f, void *pu)
+{
+ stp_t *t;
+ void *sto;
+
+ t = xmalloc (sizeof(stp_t));
+ t->sto = xmalloc (STP_STKSIZE);
+ sto = STP_STKALIGN (t->sto, QT_STKALIGN);
+ t->sp = QT_SP (sto, STP_STKSIZE - QT_STKALIGN);
+ t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, stp_only);
+ stp_qput (&stp_global_runq, t);
+}
+
+
+ static void
+stp_only (void *pu, void *pt, qt_userf_t *f)
+{
+ stp_global_curr = (stp_t *)pt;
+ (*(stp_userf_t *)f)(pu);
+ stp_abort();
+ /* NOTREACHED */
+}
+
+
+ void
+stp_abort (void)
+{
+ stp_t *old, *newthread;
+
+ newthread = stp_qget (&stp_global_runq);
+ old = stp_global_curr;
+ stp_global_curr = newthread;
+ QT_ABORT (stp_aborthelp, old, (void *)NULL, newthread->sp);
+}
+
+
+ static void *
+stp_aborthelp (qt_t *sp, void *old, void *null)
+{
+ free (((stp_t *)old)->sto);
+ free (old);
+ /* return (garbage); */
+}
+
+
+ void
+stp_yield()
+{
+ stp_t *old, *newthread;
+
+ newthread = stp_qget (&stp_global_runq);
+ old = stp_global_curr;
+ stp_global_curr = newthread;
+ QT_BLOCK (stp_yieldhelp, old, &stp_global_runq, newthread->sp);
+}
+
+
+ static void *
+stp_yieldhelp (qt_t *sp, void *old, void *blockq)
+{
+ ((stp_t *)old)->sp = sp;
+ stp_qput ((stp_q_t *)blockq, (stp_t *)old);
+ /* return (garbage); */
+}
diff --git a/qt/stp.h b/qt/stp.h
new file mode 100644
index 000000000..1220e47e2
--- /dev/null
+++ b/qt/stp.h
@@ -0,0 +1,51 @@
+#ifndef STP_H
+#define STP_H
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+typedef struct stp_t stp_t;
+
+/* Each thread starts by calling a user-supplied function of this
+ type. */
+
+typedef void (stp_userf_t)(void *p0);
+
+/* Call this before any other primitives. */
+extern void stp_init();
+
+/* When one or more threads are created by the main thread,
+ the system goes multithread when this is called. It is done
+ (no more runable threads) when this returns. */
+
+extern void stp_start (void);
+
+/* Create a thread and make it runable. When the thread starts
+ running it will call `f' with arguments `p0' and `p1'. */
+
+extern void stp_create (stp_userf_t *f, void *p0);
+
+/* The current thread stops running but stays runable.
+ It is an error to call `stp_yield' before `stp_start'
+ is called or after `stp_start' returns. */
+
+extern void stp_yield (void);
+
+/* Like `stp_yield' but the thread is discarded. Any intermediate
+ state is lost. The thread can also terminate by simply
+ returning. */
+
+extern void stp_abort (void);
+
+
+#endif /* ndef STP_H */
diff --git a/qt/time/.cvsignore b/qt/time/.cvsignore
new file mode 100644
index 000000000..f3c7a7c5d
--- /dev/null
+++ b/qt/time/.cvsignore
@@ -0,0 +1 @@
+Makefile
diff --git a/qt/time/Makefile.am b/qt/time/Makefile.am
new file mode 100644
index 000000000..d56f14496
--- /dev/null
+++ b/qt/time/Makefile.am
@@ -0,0 +1,5 @@
+## Process this file with automake to produce Makefile.in.
+
+AUTOMAKE_OPTIONS = foreign
+
+EXTRA_DIST = README.time assim cswap go init prim raw
diff --git a/qt/time/Makefile.in b/qt/time/Makefile.in
new file mode 100644
index 000000000..ab2e07f2e
--- /dev/null
+++ b/qt/time/Makefile.in
@@ -0,0 +1,160 @@
+# Makefile.in generated automatically by automake 1.1n from Makefile.am
+
+# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
+
+SHELL = /bin/sh
+
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = ..
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = true
+PRE_INSTALL = true
+POST_INSTALL = true
+NORMAL_UNINSTALL = true
+PRE_UNINSTALL = true
+POST_UNINSTALL = true
+host_alias = @host_alias@
+host_triplet = @host@
+CC = @CC@
+MAINT = @MAINT@
+PACKAGE = @PACKAGE@
+RANLIB = @RANLIB@
+VERSION = @VERSION@
+module = @module@
+qtmd_h = @qtmd_h@
+qtmdb_s = @qtmdb_s@
+qtmdc_c = @qtmdc_c@
+qtmdc_o = @qtmdc_o@
+qtmds_o = @qtmds_o@
+qtmds_s = @qtmds_s@
+target_libs = @target_libs@
+
+AUTOMAKE_OPTIONS = foreign
+
+EXTRA_DIST = README.time assim cswap go init prim raw
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_CLEAN_FILES =
+DIST_COMMON = Makefile.am Makefile.in
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = tar
+GZIP = --best
+default: all
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
+ cd $(top_srcdir) && $(AUTOMAKE) --foreign time/Makefile
+
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
+ cd $(top_builddir) \
+ && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+tags: TAGS
+TAGS:
+
+
+distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir)
+
+subdir = time
+distdir: $(DISTFILES)
+ @for file in $(DISTFILES); do \
+ d=$(srcdir); \
+ test -f $(distdir)/$$file \
+ || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+ || cp -p $$d/$$file $(distdir)/$$file; \
+ done
+info:
+dvi:
+check: all
+ $(MAKE)
+installcheck:
+install-exec:
+ @$(NORMAL_INSTALL)
+
+install-data:
+ @$(NORMAL_INSTALL)
+
+install: install-exec install-data all
+ @:
+
+uninstall:
+
+all: Makefile
+
+install-strip:
+ $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
+installdirs:
+
+
+mostlyclean-generic:
+ test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
+
+clean-generic:
+ test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ rm -f Makefile $(DISTCLEANFILES)
+ rm -f config.cache config.log stamp-h
+ test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+
+maintainer-clean-generic:
+ test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+ test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+mostlyclean: mostlyclean-generic
+
+clean: clean-generic mostlyclean
+
+distclean: distclean-generic clean
+ rm -f config.status
+
+maintainer-clean: maintainer-clean-generic distclean
+ @echo "This command is intended for maintainers to use;"
+ @echo "it deletes files that may require special tools to rebuild."
+
+.PHONY: default tags distdir info dvi installcheck install-exec \
+install-data install uninstall all installdirs mostlyclean-generic \
+distclean-generic clean-generic maintainer-clean-generic clean \
+mostlyclean distclean maintainer-clean
+
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/qt/time/README.time b/qt/time/README.time
new file mode 100644
index 000000000..4bb190e18
--- /dev/null
+++ b/qt/time/README.time
@@ -0,0 +1,17 @@
+The program `raw', when run in `..' runs the program `run' produced
+from `meas.c'. It produces a raw output file (see `../tmp/*.raw').
+`raw' will die with an error if run in the current directory. Note
+that some versions of `time' produce output in an unexpected format;
+edit them by hand.
+
+`prim', `init', `cswap' and `go' produce formatted table entries used
+in the documentation (in `../doc'). For example, from `..',
+
+ foreach i (tmp/*.raw)
+ time/prim $i
+ end
+
+See notes in the QuickThreads document about the applicability of
+these microbenchmark measurements -- in general, you can expect all
+QuickThreads operations to be a bit slower when used in a real
+application.
diff --git a/qt/time/assim b/qt/time/assim
new file mode 100755
index 000000000..6c4c52183
--- /dev/null
+++ b/qt/time/assim
@@ -0,0 +1,42 @@
+#! /bin/awk -f
+
+BEGIN {
+ nmach = 0;
+
+ init_test = "1";
+ abort_test = "6";
+ blocki_test = "7";
+ block_test = "8";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+ init = times[m "_" init_test];
+ printf ("init %s | %f\n", m, init);
+
+ init_abort_blocki = times[m "_" abort_test];
+ abort_blocki = init_abort_blocki - init;
+ blocki = times[m "_" blocki_test];
+ abort = abort_blocki - blocki;
+ blockf = times[m "_" block_test];
+ printf ("swap %s | %f | %f | %f\n", m, abort, blocki, blockf);
+ }
+}
diff --git a/qt/time/cswap b/qt/time/cswap
new file mode 100755
index 000000000..0ec811bcd
--- /dev/null
+++ b/qt/time/cswap
@@ -0,0 +1,37 @@
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "report time used by int only and int+fp cswaps";
+
+ nmach = 0;
+
+ test_int = "7";
+ test_fp = "8";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ integer = times[m "_" test_int];
+ fp = times[m "_" test_fp];
+ printf ("%s|%3.1f|%3.1f\n", m, integer, fp);
+ }
+}
diff --git a/qt/time/go b/qt/time/go
new file mode 100755
index 000000000..489d53882
--- /dev/null
+++ b/qt/time/go
@@ -0,0 +1,43 @@
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "report times used for init/start/stop";
+
+ nmach = 0;
+
+ test_single = "6";
+ test_v0 = "10";
+ test_v2 = "11";
+ test_v4 = "12";
+ test_v8 = "13";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ single = times[m "_" test_single];
+ v0 = times[m "_" test_v0];
+ v2 = times[m "_" test_v2];
+ v4 = times[m "_" test_v4];
+ v8 = times[m "_" test_v8];
+ printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
+ }
+}
diff --git a/qt/time/init b/qt/time/init
new file mode 100755
index 000000000..8bcbf3428
--- /dev/null
+++ b/qt/time/init
@@ -0,0 +1,42 @@
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "Report time used to initialize a thread."
+ nmach = 0;
+
+ test_single = "1";
+ test_v0 = "14";
+ test_v2 = "15";
+ test_v4 = "16";
+ test_v8 = "17";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ single = times[m "_" test_single];
+ v0 = times[m "_" test_v0];
+ v2 = times[m "_" test_v2];
+ v4 = times[m "_" test_v4];
+ v8 = times[m "_" test_v8];
+ printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
+ }
+}
diff --git a/qt/time/prim b/qt/time/prim
new file mode 100755
index 000000000..22b323f6f
--- /dev/null
+++ b/qt/time/prim
@@ -0,0 +1,41 @@
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "report times for microbenchmarks"
+
+ nmach = 0;
+
+ test_callind = "18";
+ test_callimm = "18";
+ test_addreg = "20";
+ test_loadreg = "21";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ ns_per_op = time / iter * 1000000
+ times[mach "_" test] = ns_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ ind = times[m "_" test_callind];
+ imm = times[m "_" test_callimm];
+ add = times[m "_" test_addreg];
+ load = times[m "_" test_loadreg];
+ printf ("%s|%1.3f|%1.3f|%1.3f|%1.3f\n", m, ind, imm, add, load);
+ }
+}
diff --git a/qt/time/raw b/qt/time/raw
new file mode 100755
index 000000000..96ae10ad1
--- /dev/null
+++ b/qt/time/raw
@@ -0,0 +1,58 @@
+#! /bin/csh
+
+rm -f timed
+
+set init=1
+set runone=6
+set blockint=7
+set blockfloat=8
+set vainit0=14
+set vainit2=15
+set vainit4=16
+set vainit8=17
+set vastart0=10
+set vastart2=11
+set vastart4=12
+set vastart8=13
+set bench_regcall=18
+set bench_immcall=19
+set bench_add=20
+set bench_load=21
+
+source configuration
+
+echo -n $config_machine $init $config_init
+/bin/time run $init $config_init
+echo -n $config_machine $runone $config_runone
+/bin/time run $runone $config_runone
+echo -n $config_machine $blockint $config_blockint
+/bin/time run $blockint $config_blockint
+echo -n $config_machine $blockfloat $config_blockfloat
+/bin/time run $blockfloat $config_blockfloat
+
+echo -n $config_machine $vainit0 $config_vainit0
+/bin/time run $vainit0 $config_vainit0
+echo -n $config_machine $vainit2 $config_vainit2
+/bin/time run $vainit2 $config_vainit2
+echo -n $config_machine $vainit4 $config_vainit4
+/bin/time run $vainit4 $config_vainit4
+echo -n $config_machine $vainit8 $config_vainit8
+/bin/time run $vainit8 $config_vainit8
+
+echo -n $config_machine $vastart0 $config_vastart0
+/bin/time run $vastart0 $config_vastart0
+echo -n $config_machine $vastart2 $config_vastart2
+/bin/time run $vastart2 $config_vastart2
+echo -n $config_machine $vastart4 $config_vastart4
+/bin/time run $vastart4 $config_vastart4
+echo -n $config_machine $vastart8 $config_vastart8
+/bin/time run $vastart8 $config_vastart8
+
+echo -n $config_machine $bench_regcall $config_bcall_reg
+/bin/time run $bench_regcall $config_bcall_reg
+echo -n $config_machine $bench_immcall $config_bcall_imm
+/bin/time run $bench_immcall $config_bcall_imm
+echo -n $config_machine $bench_add $config_b_add
+/bin/time run $bench_add $config_b_add
+echo -n $config_machine $bench_load $config_b_load
+/bin/time run $bench_load $config_b_load
diff --git a/threads.m4 b/threads.m4
new file mode 100644
index 000000000..98526d6de
--- /dev/null
+++ b/threads.m4
@@ -0,0 +1,102 @@
+dnl
+dnl CY_AC_WITH_THREADS determines which thread library the user intends
+dnl to put underneath guile. Pass it the path to find the guile top-level
+dnl source directory. Eg CY_AC_WITH_THREADS(../..) for tcl/unix.
+dnl
+
+AC_DEFUN([CY_AC_WITH_THREADS],[
+AC_CACHE_CHECK("threads package type",cy_cv_threads_package,[
+AC_CACHE_VAL(cy_cv_threads_cflags,[
+AC_CACHE_VAL(cy_cv_threads_libs,[
+use_threads=no;
+AC_ARG_WITH(threads,[ --with-threads thread interface],
+ use_threads=$withval, use_threads=no)
+test -n "$use_threads" || use_threads=qt
+threads_package=unknown
+if test "$use_threads" != no; then
+dnl
+dnl Test for the qt threads package - used for cooperative threads
+dnl This may not necessarily be built yet - so just check for the
+dnl header files.
+dnl
+ if test "$use_threads" = yes || test "$use_threads" = qt; then
+ # Look for qt in source directory. This is a hack: we look in
+ # "./qt" because this check might be run at the top level.
+ if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$srcdir/../qt -I../qt"
+ cy_cv_threads_libs="../qt/libqt.a"
+ fi
+ else
+ if test -f $use_threads/qt.c; then
+ # FIXME seems as though we should try to use an installed qt here.
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$use_threads -I../qt"
+ cy_cv_threads_libs="../qt/libqt.a"
+ fi
+ fi
+ if test "$use_threads" = pthreads; then
+ # Look for pthreads in srcdir. See above to understand why
+ # we always set threads_package.
+ if test -f $srcdir/../../pthreads/pthreads/queue.c \
+ || test -f $srcdir/../pthreads/pthreads/queue.c; then
+ threads_package=MIT
+ cy_cv_threads_cflags="-I$srcdir/../../pthreads/include"
+ cy_cv_threads_libs="-L../../pthreads/lib -lpthread"
+ fi
+ fi
+ saved_CPP="$CPPFLAGS"
+ saved_LD="$LDFLAGS"
+ saved_LIBS="$LIBS"
+ if test "$threads_package" = unknown; then
+dnl
+dnl Test for the FSU threads package
+dnl
+ CPPFLAGS="-I$use_threads/include"
+ LDFLAGS="-L$use_threads/lib"
+ LIBS="-lgthreads -lmalloc"
+ AC_TRY_LINK([#include <pthread.h>],[
+pthread_equal(NULL,NULL);
+], threads_package=FSU)
+ fi
+ if test "$threads_package" = unknown; then
+dnl
+dnl Test for the MIT threads package
+dnl
+ LIBS="-lpthread"
+ AC_TRY_LINK([#include <pthread.h>],[
+pthread_equal(NULL,NULL);
+], threads_package=MIT)
+ fi
+ if test "$threads_package" = unknown; then
+dnl
+dnl Test for the PCthreads package
+dnl
+ LIBS="-lpthreads"
+ AC_TRY_LINK([#include <pthread.h>],[
+pthread_equal(NULL,NULL);
+], threads_package=PCthreads)
+ fi
+dnl
+dnl Set the appropriate flags!
+dnl
+ cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags"
+ cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs"
+ cy_cv_threads_package=$threads_package
+ CPPFLAGS="$saved_CPP"
+ LDFLAGS="$saved_LD"
+ LIBS="$saved_LIBS"
+ if test "$threads_package" = unknown; then
+ AC_MSG_ERROR("cannot find thread library installation")
+ fi
+fi
+])
+])
+],
+dnl
+dnl Set flags according to what is cached.
+dnl
+CPPFLAGS="$cy_cv_threads_cflags"
+LIBS="$cy_cv_threads_libs"
+)
+])