summaryrefslogtreecommitdiff
path: root/ice-9
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9')
-rw-r--r--ice-9/.cvsignore3
-rw-r--r--ice-9/ChangeLog524
-rw-r--r--ice-9/Makefile.am10
-rw-r--r--ice-9/Makefile.in240
-rw-r--r--ice-9/aclocal.m464
-rw-r--r--ice-9/boot-9.scm1588
-rwxr-xr-xice-9/configure283
-rw-r--r--ice-9/configure.in12
-rw-r--r--ice-9/debug.scm120
-rw-r--r--ice-9/expect.scm125
-rw-r--r--ice-9/lineio.scm17
-rw-r--r--ice-9/mapping.scm3
-rw-r--r--ice-9/poe.scm2
-rw-r--r--ice-9/r4rs.scm149
-rw-r--r--ice-9/slib.scm64
-rw-r--r--ice-9/test.scm1032
-rw-r--r--ice-9/threads.scm53
17 files changed, 3424 insertions, 865 deletions
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..6f3002e31 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,527 @@
+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..c8fd1686b 100644
--- a/ice-9/Makefile.in
+++ b/ice-9/Makefile.in
@@ -1,71 +1,207 @@
-# 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.1l 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 = .
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+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 = $(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) $(MANS) $(EXTRA_DIST)
+
+TAR = tar
+default: all
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL)
+ 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: configure.in
+ cd $(srcdir) && aclocal
+
+config.status: configure
+ $(SHELL) ./config.status --recheck
+$(srcdir)/configure: configure.in $(ACLOCAL) $(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:
+ 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)
+ $(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)
+ $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+dist-all: distdir
+ -chmod -R a+r $(distdir)
+ $(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/ice-9/aclocal.m4 b/ice-9/aclocal.m4
new file mode 100644
index 000000000..ace866913
--- /dev/null
+++ b/ice-9/aclocal.m4
@@ -0,0 +1,64 @@
+dnl aclocal.m4 generated automatically by aclocal 1.1l
+
+
+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)
+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)
+
+AC_DEFUN(AM_INIT_AUTOMAKE,
+[AC_REQUIRE([AM_PROG_INSTALL])
+PACKAGE=[$1]
+AC_SUBST(PACKAGE)
+AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE")
+VERSION=[$2]
+AC_SUBST(VERSION)
+AC_DEFINE_UNQUOTED(VERSION, "$VERSION")
+AM_SANITY_CHECK
+AC_ARG_PROGRAM
+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])
+echo timestamp > conftestfile
+# Do this in a subshell so we don't clobber the current shell's
+# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test?
+if (set X `ls -t $srcdir/configure conftestfile`; 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)])
+
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index fa55e9a1d..5a695f967 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,27 @@
;;;
+;;; During Guile development, we want to use debugging evaluator and record
+;;; positions of source expressions in boot-9.scm by default.
-;; {Simple Debugging Tools}
+(debug-options-interface (cons 'debug (debug-options-interface)))
+(read-options-interface (cons 'positions (read-options-interface)))
+
+
+;;; {Features}
+;;
+
+(define (provide sym)
+ (if (not (memq sym *features*))
+ (set! *features* (cons sym *features*))))
+
+
+;;; {R4RS compliance}
+
+(primitive-load-path "ice-9/r4rs.scm")
+
+
+;;; {Simple Debugging Tools}
;;
@@ -54,7 +73,7 @@
(lambda ()
(newline)
(display ";;; WARNING ")
- (print stuff)
+ (display stuff)
(newline)
(car (last-pair stuff)))))
@@ -66,12 +85,22 @@
;;;
(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
-(define (call-with-current-continuation proc) (@call-with-current-continuation proc))
+(define (call-with-current-continuation proc)
+ (@call-with-current-continuation proc))
-;;; {apply-to-args}
+;;; {Trivial Functions}
;;;
+
+(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 is functionally redunant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
;;;
@@ -87,28 +116,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 +141,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 +160,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}
;;;
@@ -287,28 +317,34 @@
(and rem (pair? (cdr rem)) (cadr rem))))
-
;;; {Print}
-;;;
+;;; MDJ 960919 <djurfeldt@nada.kth.se>: This code will probably be
+;;; removed before the first release of Guile. Later releases may
+;;; contain more fancy printing code.
(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))
+ ((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)))))))))
+ ((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 (make-print-style) (make-vector 59 '()))
-(define (extend-print-style! style utag printer) (hashq-set! style utag printer))
+(define (extend-print-style! style utag printer)
+ (hashq-set! style utag printer))
(define (print-style-hook style obj)
(let ((type-tag (tag obj)))
@@ -322,10 +358,12 @@
(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 (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 (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)))
@@ -348,13 +386,14 @@
((null? (cdr pair)) (display #\) port))
(else (display " . " port)
- (print (cdr pair) port (+ 1 depth) 0 style table)
+ (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-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))))
@@ -365,7 +404,9 @@
(cond
((>= (+ 1 length) (vector-length obj)) (display #\) port))
(else (display #\space port)
- (print obj port depth (+ 1 length) style table))))
+ (print obj port depth
+ (+ 1 length)
+ style table))))
(define default-print-style (make-print-style))
@@ -390,16 +431,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 +458,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 +494,8 @@
(struct-vtable obj)
(error 'not-a-record obj)))
+(provide 'record)
+
;;; {Booleans}
;;;
@@ -552,15 +599,52 @@
;;; !!!! 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 +652,64 @@
(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)))))
+
+(define (scm-error key subr message args rest)
+ (throw key subr message args rest))
+
+;; 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,94 +717,57 @@
(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))
@@ -754,12 +776,12 @@
(define (endservent) (setserv))
(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 (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))
@@ -767,224 +789,42 @@
(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 (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)
-
+;;; {Loading by paths}
-(define (load name)
- (if (eval '(defined? %load-path))
- (load-with-path name (eval '%load-path))
- (load-with-path name '())))
+;;; 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 #t read-sharp)))
@@ -1111,7 +951,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,7 +959,7 @@
=> (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))))
@@ -1148,11 +988,6 @@
((#\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))))
(define (read:array digit port)
@@ -1284,15 +1119,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 +1127,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 +1185,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 +1205,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))))
-
- (if (> (length args) 0)
- (begin
- (set! binder (or (car args) binder))
- (set! args (cdr args))))
-
- (if (not (null? args))
- (error "Too many args to make-module." args))
- (if (not (integer? size))
- (error "Illegal size to make-module." size))
+ (define (parse-arg index default)
+ (if (> (length args) index)
+ (list-ref args index)
+ default))
+
+ (if (> (length args) 3)
+ (error "Too many args to make-module." args))
- (and (list? uses)
- (or (and-map module? uses)
- (error "Incorrect use list." uses)))
+ (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))
+ (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 +1396,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 +1527,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 +1543,7 @@
bi))))
(define (make-root-module)
- (make-module 1019 #f root-module-thunk))
+ (make-module 1019 '() root-module-closure))
;; make-scm-module
@@ -1740,7 +1556,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 +1580,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 +1606,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
@@ -1857,9 +1659,6 @@
(cons interface (delq! interface (module-uses module)))))
-
-
-;;;;
;;; {Recursive Namespaces}
;;;
;;;
@@ -1870,7 +1669,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 +1679,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 +1703,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 +1752,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)
@@ -1997,43 +1796,46 @@
(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 (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" (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 +1853,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 +1869,143 @@
(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 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.
+
+(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 (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-link filename)))
+ (if (dynamic-maybe-call initname dynobj)
+ (set! registered-modules (append! (convert-c-registered-modules dynobj)
+ registered-modules))
+ (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 +2040,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))
@@ -2138,7 +2077,7 @@
(define (macroexpand-1 e)
(cond
((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
+ (val (and (symbol? a) (defined? a) (eval a))))
(if (defmacro? val)
(apply (defmacro-transformer val) (cdr e))
e)))
@@ -2147,7 +2086,7 @@
(define (macroexpand e)
(cond
((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
+ (val (and (symbol? a) (defined? a) (eval a))))
(if (defmacro? val)
(macroexpand (apply (defmacro-transformer val) (cdr e)))
e)))
@@ -2176,7 +2115,13 @@
(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)
@@ -2188,51 +2133,140 @@
(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))))
+
+ (lambda args
+ (save-stack 1)
+ (apply throw args))))
+
+ (lambda (key . args)
+ (case key
+ ((quit)
+ (force-output)
+ #f)
+
+ ((switch-repl)
+ (apply throw 'switch-repl args))
+
+ ((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))
+ (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 ()
- (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))))))))
+ (cond ((= (length args) 4)
+ (apply handle-system-error key args))
+ (else
+ (apply bad-throw key args))))))))))
(and next (loop next))))
(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 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 #f)
+(define after-error-hook #f)
+(define before-backtrace-hook #f)
+(define after-backtrace-hook #f)
+
+(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))
+ (and before-backtrace-hook (before-backtrace-hook))
+ (newline cep)
+ (display-backtrace the-last-stack cep)
+ (newline cep)
+ (and after-backtrace-hook (after-backtrace-hook))))
+ (and before-error-hook (before-error-hook))
+ (apply display-error the-last-stack cep args)
+ (and after-error-hook (after-error-hook))
+ (force-output cep)
+ (throw 'abort key)))
+
(define (quit . args)
(apply throw 'quit args))
+;;(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 #f)
+(define after-read-hook #f)
+
(define (scm-style-repl)
(letrec (
(start-gc-rt #f)
@@ -2257,7 +2291,9 @@
(display the-prompt-string)
(force-output)
(repl-report-reset)))
+ (and before-read-hook (before-read-hook))
(let ((val (read (current-input-port) #t read-sharp)))
+ (and after-read-hook (after-read-hook))
(if (eof-object? val)
(begin
(if scm-repl-verbose
@@ -2270,13 +2306,16 @@
(-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)))))
@@ -2309,7 +2348,7 @@
-
+;;; {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 +2403,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 +2471,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))
@@ -2469,11 +2514,15 @@
(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 +2820,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 +2843,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 +3001,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 +3040,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 +3064,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 +3090,6 @@
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;
-
;;;;
;;; Q: Based on the interface to
;;;
@@ -3044,7 +3097,6 @@
;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
;;;
-
;;;;
;;; {Q}
;;;
@@ -3156,12 +3208,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 +3230,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 +3448,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 +3582,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 +3591,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 +3600,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 +3610,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 +3628,7 @@
(define-public string-prefix=? (string-prefix-predicate string=?))
-;;;;
-;;; {Strippers}
+;;; {String Fun: Strippers}
;;;
;;; <stripper> = sans-<removable-part>
;;;
@@ -3639,8 +3681,7 @@
(else str)))
-;;;;
-;;; {has-trailing-newline?}
+;;; {String Fun: has-trailing-newline?}
;;;
(define-public (has-trailing-newline? str)
@@ -3649,7 +3690,7 @@
-
+;;; {String Fun: with-regexp-parts}
(define-public (with-regexp-parts regexp fields str return fail)
(let ((parts (regexec regexp str fields)))
@@ -3658,6 +3699,35 @@
(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 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 (or (member "-e" (cdr (program-arguments)))
+ (member "--emacs" (cdr (program-arguments))))
+ (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..4676147d1 100755
--- a/ice-9/configure
+++ b/ice-9/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
@@ -49,6 +49,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 +332,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 +434,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 +503,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,16 +518,184 @@ else
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:552: 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
-scm_files=""
-aux_files=""
-. $srcdir/PLUGIN/this.configure
+PACKAGE=$PACKAGE
+cat >> confdefs.h <<EOF
+#define PACKAGE "$PACKAGE"
+EOF
+VERSION=$VERSION
+cat >> confdefs.h <<EOF
+#define VERSION "$VERSION"
+EOF
+echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6
+echo "configure:620: checking whether build environment is sane" >&5
+echo timestamp > conftestfile
+# Do this in a subshell so we don't clobber the current shell's
+# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test?
+if (set X `ls -t $srcdir/configure conftestfile`; 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,"
+
+echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
+echo "configure:654: 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=ice-9
trap '' 1 2 15
cat > confcache <<\EOF
@@ -540,11 +714,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
@@ -611,7 +799,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 ;;
@@ -620,6 +808,7 @@ do
done
ac_given_srcdir=$srcdir
+ac_given_INSTALL="$INSTALL"
trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
EOF
@@ -651,28 +840,66 @@ 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
+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%@SET_MAKE@%$SET_MAKE%g
+s%@module@%$module%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"}
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%/[^/][^/]*$%%'`
@@ -696,6 +923,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."
@@ -704,15 +936,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
diff --git a/ice-9/configure.in b/ice-9/configure.in
index cb1926a87..b2d4c334b 100644
--- a/ice-9/configure.in
+++ b/ice-9/configure.in
@@ -3,15 +3,5 @@
#
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)
+AM_INIT_GUILE_MODULE(ice-9)
AC_OUTPUT(Makefile)
diff --git a/ice-9/debug.scm b/ice-9/debug.scm
new file mode 100644
index 000000000..20e67f9cf
--- /dev/null
+++ b/ice-9/debug.scm
@@ -0,0 +1,120 @@
+;;;; 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)
+
+
+
+;;; 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/expect.scm b/ice-9/expect.scm
new file mode 100644
index 000000000..6d25c8ba3
--- /dev/null
+++ b/ice-9/expect.scm
@@ -0,0 +1,125 @@
+;;; 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)))
+ (relative-s (inexact->exact
+ (floor (/ relative internal-time-units-per-second))))
+ (relative-ms (inexact->exact
+ (round (/ (* (- relative relative-s) 1000)
+ internal-time-units-per-second)))))
+ (and (> relative 0)
+ (pair? (car (select (list port) () ()
+ relative-s
+ relative-ms))))))
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/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..696ba4059
--- /dev/null
+++ b/ice-9/r4rs.scm
@@ -0,0 +1,149 @@
+;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
+;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
+
+;;;; 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.
+
+
+;;;; apply and call-with-current-continuation
+
+;;; These turn syntax, @apply and @call-with-current-continuation,
+;;; into procedures. If someone knows why they have to be syntax to
+;;; begin with, please fix this comment.
+(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)
+
+;;; If we load boot-9.scm, it provides a definition for this which is
+;;; more sophisticated.
+(define read-sharp #f)
+
+(define (load name)
+ (start-stack 'load-stack
+ (primitive-load name #t read-sharp)))
diff --git a/ice-9/slib.scm b/ice-9/slib.scm
index 3178598fd..0e717db71 100644
--- a/ice-9/slib.scm
+++ b/ice-9/slib.scm
@@ -56,27 +56,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)
'())
@@ -108,19 +108,39 @@
(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 +159,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/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)))