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/ChangeLog707
-rw-r--r--ice-9/Makefile.am10
-rw-r--r--ice-9/Makefile.in253
-rw-r--r--ice-9/aclocal.m40
-rw-r--r--ice-9/boot-9.scm1983
-rwxr-xr-xice-9/configure722
-rw-r--r--ice-9/configure.in17
-rw-r--r--ice-9/debug.scm195
-rw-r--r--ice-9/emacs.scm163
-rw-r--r--ice-9/expect.scm124
-rw-r--r--ice-9/gtcl.scm379
-rw-r--r--ice-9/gwish.scm90
-rw-r--r--ice-9/lineio.scm17
-rw-r--r--ice-9/mapping.scm3
-rw-r--r--ice-9/nonblocking.scm82
-rw-r--r--ice-9/oldprint.scm122
-rw-r--r--ice-9/poe.scm2
-rw-r--r--ice-9/r4rs.scm145
-rw-r--r--ice-9/slib.scm73
-rw-r--r--ice-9/source.scm161
-rw-r--r--ice-9/test.scm1032
-rw-r--r--ice-9/threads.scm53
23 files changed, 4607 insertions, 1729 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..58141312a 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,710 @@
+Sat Apr 19 08:03:50 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+* * boot-9.scm (eval-string, command-line, load-user-init): New
+ functions.
+
+Sat Apr 12 08:27:05 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (log10): defined.
+
+Tue Apr 1 17:46:49 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * expect.scm (expect-select): correct the millisecond timeout
+ arithmetic (from Marko.Kohtala@ntc.nokia.com).
+
+Mon Mar 31 03:23:19 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (open-input-pipe, open-output-pipe): defined here
+ instead of in libguile.
+ (tm:sec etc.) new accessors for broken-down time.
+ (set-tm:sec etc.) new setters for broken-down time.
+
+Thu Mar 27 05:06:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (netent:addrtype, servent:port): added missing
+ procedures.
+ (netent:net, servent:proto): repaired.
+ (utsname:sysname etc.): new accessors for uname.
+
+Tue Mar 25 03:04:03 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (sockaddr:fam, sockaddr:path, sockaddr:addr,
+ sockaddr:port): new functions.
+
+Wed Mar 19 04:50:34 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: define accessor procedures for the objects returned
+ by getpw, getgr, gethost, getnet, getproto, getserv (e.g.,
+ passwd:name, where the first component is the name of the C structure
+ and the second is the unprefixed C member name.)
+
+Tue Mar 18 18:39:31 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+* * boot-9.scm (setpwent, setgrent, sethostent, setnetent, setprotoent,
+ setservent): no longer take an argument, it was bogus.
+
+Thu Mar 13 00:13:41 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (scm-error): deleted, reimplemented in C.
+
+Mon Mar 10 15:48:31 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (process-define-module): Modified to handle both
+ keywords and symbols.
+
+Sat Mar 8 04:32:44 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * slib.scm: update read usage.
+
+ * r4rs.scm: update primitive-load usage.
+ Don't define read-sharp.
+
+ * boot-9.scm: use read-hash-extend to install extra read syntax.
+ (read-sharp): removed.
+ Adjust usage of primitive-load-path, read, which no longer take
+ case_i or read-sharp arguments.
+
+Sat Mar 8 00:07:54 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Added loading of session support module.
+
+ * debug.scm: Removed `display-application'. (Replaced by
+ primitive procedure.)
+
+ * boot-9.scm (beautify-user-module!): Don't add the root module
+ interface to the end of the use-list of the root module.
+
+Thu Mar 6 07:26:34 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: repl-quit, repl-abort: obsolete variables deleted.
+
+Wed Mar 5 20:30:24 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: check use-emacs-interface for emacs support.
+
+Sun Mar 2 19:47:14 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (scm-style-repl): call repl-report-start-timing if
+ read gets EOF.
+ * (exit): alias for quit.
+
+Sun Mar 2 05:25:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (error-catching-loop thunk): use a status variable to
+ return the quit args.
+ (scm-style-repl): call -quit, passing return value from
+ error-catching-repl. Make -quit return its args.
+ stand-alone-repl: comment out, since it seems unused.
+
+ (error-catching-loop thunk): discard trailing junk after a (quit).
+
+Sat Mar 1 15:24:39 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Removed the old printer code.
+
+ * r4rs.scm (apply, call-with-current-continuation): Added comment
+ explaining why apply and call/cc need to be closures.
+
+ * boot-9.scm (apply, call-with-current-continuation): Bugfix:
+ Removed. These definitions are already present in r4rs.scm.
+
+ * debug.scm (trace-entry, trace-exit): Check that we're on a repl
+ stack before printing traced frames; Re-enable trace flag at end
+ of handlers.
+
+Sat Mar 1 00:10:38 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.scm: Add hook for reset of trace level at abort.
+
+ * boot-9.scm (run-hooks): New procedure.
+ (add-hooks!): New macro.
+ Change hooks to use these functions.
+
+* * debug.scm: *Warning* This feature is a bit premature. I add
+ it anyway because 1. it is very useful, and, 2. you can start
+ making it less premature by complaining to me and by modifying
+ the source! :-)
+ (trace): Given one or more procedure objects, trace each one.
+ Given no arguments, show all traced procedures.
+ (untrace): Given one or more procedure objects, untrace each one.
+ Given no arguments, untrace all traced procedures. The tracing in
+ Guile have an advantage to most other systems: We don't create new
+ procedure objects, but mark the procedure objects themselves.
+ This means that also anonymous and internal procedures can be
+ traced.
+
+ * boot-9.scm (error-catching-loop): Added handling of apply-frame
+ and exit-frame exceptions.
+
+* * boot-9.scm (assert-repl-prompt, the-prompt-string): Removed.
+ (set-repl-prompt!): Setter for repl prompt.
+ (scm-style-repl): If prompt is #f, don't prompt; if prompt is a
+ string, display it; if prompt is a thunk, call it and display its
+ result; otherwise display "> ".
+ (Change suggested by Roland Orre <orre@nada.kth.se>.)
+
+ * r4rs.scm (%load-verbosely): Reverted change to
+ `module-defined?', since the module system isn't bootstrapped when
+ we load r4rs.scm. This is just a temporary fix to make the
+ repository version runnable.
+
+Thu Feb 27 23:25:47 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Removed the enabling of debug evaluator and
+ recording of source code positions. This was placed there for our
+ convenience, but it has already sneaked into the distribution
+ once... so we'd better add this in our local copies instead when
+ we need it. (These options are normally enabled at the end of
+ boot-9.scm when loading the debug module.)
+
+Thu Feb 27 16:04:45 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (module-defined?): New function.
+ (macroexpand-1, macroexpand): Use local-ref instead of defined?
+ and eval.
+ * r4rs.scm (%load-verbosely): Use "module-defined?" instead of
+ "defined?".
+ * slib.scm (defined?): New function to take the place of the
+ builtin "defined?". It allways examines the slib module.
+
+Mon Feb 24 21:46:15 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Sat Feb 15 04:51:20 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (read-sharp): define directly, don't go through a
+ %read-sharp layer.
+
+Tue Feb 11 08:45:48 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (uniform-vector-set!): use uniform-array-set1!, not
+ uniform-vector-set1! which doesn't exist.
+
+Mon Feb 10 03:01:48 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (backtrace): Removed. (A C version now exists in
+ backtrace.c.)
+
+Fri Jan 24 06:05:36 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (read-line!, read-delimited!, read-delimited,
+ read-line): new procedures, see libguile/ChangeLog.
+
+Thu Jan 16 17:07:03 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Added dynamic linking of modules. See libguile/DYNAMIC-LINKING.
+
+ * boot-9.scm (split-c-module-name, convert-c-registered-modules,
+ init-dynamic-module, dynamic-maybe-call,
+ find-and-link-dynamic-module, link-dynamic-module,
+ try-module-dynamic-link, registered-modules): New definitions for
+ dynamic linking of modules.
+ (resolve-module): Try to dynamically link the requested module
+ after failing to load it as Scheme code.
+
+Wed Jan 8 05:50:14 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (getservbyport, getservbyname): remove stray %.
+
+Tue Jan 7 20:02:24 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (and=>): Rename THUNK argument to PROCEDURE, 'cos
+ that's what it is.
+
+ * lineio.scm (make-line-buffering-input-port): Properly test for
+ the case of an empty buffer list. The old code assumed that '()
+ was false.
+
+Mon Jan 6 01:13:53 1997 Mikael Djurfeldt <mdj@kenneth>
+
+* * boot-9.scm (use-modules): New macro (from Marius Vollmer).
+ (use-modules <module name> ...) Put the the modules named by
+ <module name> ... on the use list of the current module.
+
+Sun Jan 5 15:52:59 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (error-catching-loop): Remove message saying that
+ typing "$" will put you in the debugger. This isn't implemented
+ yet.
+
+Sun Dec 22 23:27:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (delq-all!): Function deleted; delq!'s semantics have
+ been fixed, so this function is superfluous.
+ (transform-usage-lambda): Use delq!, not delq-all!.
+
+Tue Dec 17 20:36:45 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (resolve-module): New optional parameter that
+ controls whether autoloading is attempted or not. Default is #t.
+ (process-define-module): Don't autoload the defined module.
+ (try-module-autoload): Don't autoload the directory modules.
+
+ * boot-9.scm (process-define-module): Ensure that the-scm-module
+ is last in the `uses' list to allow shadowing builtin
+ bindings. All :use-module options are added in the order they
+ appear in the arguments but before anything already on the list
+ (such as the-scm-module).
+
+Wed Dec 11 21:06:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * slib.scm (slib-parent-dir): throw error if #f returned from
+ %search-load-path.
+
+Sat Nov 30 23:57:28 1996 Tom Tromey <tromey@cygnus.com>
+
+ * PLUGIN/greet, PLUGIN/split.sed, PLUGIN/this.configure: Removed.
+ * Makefile.am, aclocal.m4: New files.
+ * configure.in: Updated for Automake.
+
+Wed Nov 27 14:16:14 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (macroexpand-1, macroexpand), slib.scm
+ (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a
+ function, use it accordingly.
+
+Thu Nov 21 11:12:10 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ It's an "eval closure", not an "eval thunk." A thunk is a
+ function of no arguments.
+ * boot-9.scm (module-type): Rename module field.
+ (make-module, eval-in-module, make-root-module,
+ set-current-module): Uses changed.
+ (module-eval-closure, set-module-eval-closure!,
+ root-module-closure): Renamed from module-eval-thunk,
+ set-module-eval-thunk!, root-module-thunk.
+ (set-current-module): Change uses of *top-level-lookup-thunk* to
+ *top-level-eval-closure*.
+
+Wed Nov 20 14:45:27 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * slib.scm (slib-parent-dir): Use string-length, not length.
+ (Thanks to Bernard Urban.)
+
+Sat Nov 2 20:00:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: The debugging evaluator and recording of positions
+ aren't enabled by default any longer (they are switched on in
+ debug.scm). But during development we want to have them also
+ *inside* boot-9.scm. Therefore, two lines are added at the
+ beginning of boot-9.scm to enable these.
+
+ Call `provide' so that `records' are included among the
+ `*features*'.
+
+ The scheme for saving the stack has been adjusted: save-stack is
+ now commonly available for saving the stack. Calling `save-stack'
+ sets a flag `stack-saved?' which prevents overwriting the stack.
+ `stack-saved?' is reset at `abort'.
+
+ Spelling correction: seperate --> separate.
+
+ Removed `:'s that had creeped into some comments.
+
+ The repl now doesn't print #<unspecified> results any longer
+ If the user wants to see this, he can do
+ (assert-repl-print-unspecified #t) in his startup file.
+
+ The user now gets a friendly message instead of a backtrace at
+ error.
+
+ Added `before-read-hook'.
+
+ Load module (ice-9 emacs) if option `-e' was specified.
+
+ (provide): New function.
+
+ (error): Save stack at entry, so that Guile entrails won't show up
+ in backtraces.
+
+ (backtrace): New function.
+
+ (save-stack): Can now take arbitrary number of stack narrowing
+ specifier pairs. The first specifier in a pair controls inner
+ border, the second the outer border. A number means cut that
+ number of frames, a procedure object means cut until that object
+ is found in operator position in a frame.
+
+ * debug.scm: Enable debugging evaluator and recording of positions
+ by default.
+
+ * slib.scm (slib:load): Adapt to the new behavior of
+ primitive-load: It doesn't any longer try both with and without
+ ".scm" extension. (We don't want to use %search-load-path here.)
+
+ (implementation-vicinity): New function. slib requires it
+
+ (library-vicinity): Updated.
+
+ Load "require.scm" in the library-vicinity.
+
+ (install-require-vicinity, install-require-module): New functions.
+
+Mon Oct 28 17:56:29 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (load-from-path): New function.
+
+ * boot-9.scm (try-load, basic-try-load, try-load-module,
+ try-load): Deleted. I don't think they're being used.
+
+ * Makefile.in (scm_files): Add r4rs.scm and test.scm to this list,
+ so they'll get distributed.
+
+ Get Guile to be a little less chatty by default. The new user
+ should see as little clutter as possible.
+ * r4rs.scm (%load-verbosely): Make this #f by default.
+ * boot-9.scm (scm-repl-verbose): Make this #f by default.
+ (scm-style-repl): Don't run 'pk' on the value passed to quit.
+
+ * r4rs.scm: New file.
+ * boot-9.scm: Load r4rs.scm, first thing.
+ (OPEN_READ, OPEN_WRITE, OPEN_BOTH, *null-device*, open-input-file,
+ open-output-file, open-io-file, close-input-port,
+ close-output-port, close-io-port, call-with-input-file,
+ call-with-output-file, with-input-from-port, with-output-to-port,
+ with-error-to-port, with-input-from-file, with-output-to-file,
+ with-error-to-file, with-input-from-string, with-output-to-string,
+ with-error-to-string, the-eof-object): Definitions moved to
+ r4rs.scm. Not all of them are R4RS, but those that are use those
+ that are not.
+ (load, %load-verbosely, %load-announce): Moved, along with code to
+ set %load-hook, to r4rs.scm.
+
+ * test.scm: New file.
+
+ * boot-9.scm (integer?): Definition deleted, in favor of the one
+ present in libguile (which used to be called int?). I have no
+ idea why integer? didn't just call int? to begin with.
+
+ * boot-9.scm (<, <=, =, >, >=): Definitions in terms of <?, <=?,
+ =?, >?, and >=? deleted; they're defined that way by libguile now.
+
+ * boot-9.scm (load): Simplified; primitive-load does most of this
+ work now.
+ (%load-announce-win): Removed; no longer used. Set %load-hook to
+ call %load-announce.
+
+Sun Oct 27 07:47:03 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (stat:dev, stat:ino, stat:mode, stat:nlink, stat:uid,
+ stat:gid, stat:rdev, stat:size, stat:atime, stat:mtime,
+ stat:ctime, stat:blksize, stat:blocks) accessor functions for stat
+ components.
+ (file-is-directory?): use stat:type.
+
+Fri Oct 25 03:34:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (%read-sharp): Don't recognize the `#!' syntax here;
+ that's now taken care of in libguile, and in a way compatible with
+ SCSH (which this isn't).
+
+Mon Oct 21 18:52:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm: Formatting tweaks.
+
+Fri Oct 18 01:03:08 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (handle-system-error): Added hooks before-error-hook,
+ after-error-hook, before-backtrace-hook and after-backtrace-hook
+ to the error handler. E.g.: fancy emacs support could plug into
+ these.
+ (save-stack): New function. The stack is now made differently
+ depending on the stack id. (The motivation is to make a better
+ choice regarding what stack frames to present to the user.)
+ (error-catching-loop): Stack handling code moved outside into
+ save-stack.
+
+Thu Oct 17 20:33:08 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Makefile.in (scm_files): add expect.scm.
+
+ * expect.scm: new file ported from guile-iii.
+
+ * boot-9.scm: remove handle-system-error, after moving the code into
+ error-catching-loop.
+ Don't set 'throw-handler-default property on error keys.
+ Just interpret (almost) any throw with 4 args as an error throw.
+ Delete some try-load stuff that was already commented out.
+
+ Second thoughts, keep handle-system-error but call it from
+ error-catching-loop.
+
+Tue Oct 15 17:07:20 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm: Doc fixes.
+ (make-module): Rework for readability.
+ (make-root-module, make-scm-module): USES argument to make-module
+ should be '(), not #f.
+
+ * boot-9.scm (try-load): %sys-load-path has been renamed to
+ primitive-load-path; adjust call here.
+
+Tue Oct 15 14:25:01 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (signal-handler): Bugfix: Moved the recording of
+ the stack to the correct place: when it is decided to generate an
+ error-signal.
+
+Mon Oct 14 22:20:30 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (error-catching-loop, signal-handler,
+ handle-system-error): Backtracing now works for signals aswell;
+ Backtracing mechanism can now identify the stack root created by
+ start-stack so that the user isn't exposed to system stack frames.
+
+Mon Oct 14 06:05:42 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * Makefile.in: Added threads.scm.
+
+Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.scm (make-enable, make-disable): Simplified.
+
+ * boot-9.scm: Renamed %%throw-handler-default -->
+ throw-handler-default.
+ ((handle-system-error key . arg-list)): Changed the way errors are
+ reported.
+ ((scm-style-repl)): Wrap up the call to eval in a start-stack
+ acro.
+ ((error-catching-loop thunk)): Introduce a lazy-catch into
+ error-catching-loop so that the stack can be captured.
+
+Thu Oct 10 22:27:32 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * mapping.scm (hash-table-mapping): Explicitly request that
+ make-vector fill new vectors with '(); this will make it easier to
+ port Guile Scheme code to other Schemes.
+ * boot-9.scm (make-print-style, make-print-table): Same.
+
+Sun Oct 6 03:54:59 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (load): rewritten again.
+ Append "." to the default %load-path.
+ (feature?): new function: checks for a symbol in the features list.
+ (module-local-variable): remove apparently useless (caddr (list m v
+ ...))
+ (%load-announce): minor formatting change.
+ (file-exists?): use access? if posix is featured.
+ (file-is-directory?): use stat if i/o-extensions is featured.
+ (try-module-autoload module-name): use file-exists? before
+ file-is-directory?
+
+Sat Oct 5 18:54:03 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm: Added conditional loading of threads.scm.
+
+ * threads.scm: New file. Modified from the Cygnus-r0.3
+ distribution.
+
+ * boot-9.scm (error-catching-loop): Added handling of key
+ `switch-repl'.
+
+ * boot-9.scm: Name change %%bad-throw --> bad-throw.
+
+Wed Oct 2 23:38:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (make-record-type, record-constructor): Don't assume
+ the empty list is false when parsing the argument list.
+
+Mon Sep 30 22:15:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (signal-handler): Clean up logic.
+
+ * boot-9.scm (load): Assume %load-path is always bound.
+
+Sat Sep 28 00:15:37 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (error): replace another throw with scm-error. Throw
+ to 'misc-error instead of 'error (no need to distinguish these.)
+ Don't set up 'error as a key.
+ Set up regex-error as a key, if regex is available.
+ (signal-handler): use scm-error, not throw.
+
+ (%try-load, try-load-with-path, %load, load-with-path,
+ basic-try-load-with-path, basic-load-with-path,
+ try-load-module-with-path,load-module-with-path): deleted, since
+ they seem redundant.
+ (try-load): define using %try-load, not try-load-with-path.
+ (load): rewritten. load tries to open the file directly and
+ with a .scm extension before searching the library directories
+ (should "." be added to %load-path? then load could still open
+ directly files starting with "/").
+ (try-module-autoload): use load, not load-with-path.
+ (%load-indent): deleted, -2 was causing errors.
+
+ (%read-sharp): use port-line, not line-number.
+
+Fri Sep 27 16:23:51 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (%%bad-throw): Delete definition. 1) It's very
+ straightforward to provide the equivalent functionality using
+ (catch #t ...), so there's no need for the extra complexity. 2)
+ Outside the context of a read-eval-print loop (which Guile should
+ not require) it's not clear we should do anything more complicated
+ than print an error and exit; the user or REPL can establish
+ something better if it wants. 3) In that case, it's much more
+ robust to just do it in the C code.
+
+Tue Sep 24 06:53:04 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%try-load): define using primitive-load. Previously
+ %try-load itself was the primitive.
+ (load-with-path): use scm-error instead of %load-announce-lossage.
+ Errors are thrown to 'misc-error instead of 'could-not-load.
+ (%load-announce-lossage): deleted.
+
+Mon Sep 23 00:16:31 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (warn, scm-style-repl): Use C printer instead of `print'.
+ (make-record-type type-name fields): Temporarily remove support
+ for printing of records (not possible yet with C printer).
+
+Fri Sep 20 00:24:27 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (file-exists?, file-is-directory): catch only
+ system-error, not every kind of error.
+ (scm-error): new procedure.
+
+Thu Sep 19 16:02:46 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm: Formatting tweaks.
+
+Wed Sep 18 09:07:37 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error key): remove the code for
+ SCM-style errors. handle the case that an unexpected number
+ of args are supplied.
+ (%%system-errors): removed.
+ (error): redefine using a throw with key and 4 args.
+ ('error): associate 'error, 'error-signal keys with
+ %%handle-system-error.
+ (%%default-error-handler): removed.
+ (signal-handler): throw with 4 args and use the error-signal key.
+ Create an error message instead of using numerical codes.
+ (%%bad-throw): call error instead of throw if key not found.
+
+Tue Sep 17 04:11:28 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: initialize new error keys (see libguile/ChangeLog).
+ (%%handle-system-error key): check subr is not #f before printing.
+ Recognize %s (embed an argument using "display") and
+ %S (embed an argument using "write").
+
+Sun Sep 15 03:55:35 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error key): set args and rest to
+ the empty list if they are #f.
+ Initialize out-of-range as an error key.
+
+Sat Sep 14 03:41:15 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * PLUGIN/REQ: remove the "ice-9 lgh" line which causes a cycle.
+
+ * boot-9.scm: remove leading %% from references to '%%system-error.
+ (%%handle-system-error): don't pass all the thrown arguments when
+ aborting, just the key and subr.
+ Remove the code to "Install default handlers for built-in errors."
+ Remove the definition of the syserror procedure.
+ Associate 'numerical-overflow with default handler.
+
+Fri Sep 13 04:58:11 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm: Name change: value-ref --> local-ref
+ resolved-ref --> nested-ref Motivation: conformance to the other
+ dictionary operators: list-ref operates on list, vector-ref
+ operates on vector, nested-ref operates on nested namespace,
+ local-ref operates on the local nested namespace.
+
+Sat Sep 7 06:44:47 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error): recognise errors thrown
+ by lgh-error (fill-message etc.)
+ (fill-message): check first whether args is null.
+ (fill-message): bug fix and check that args is a list.
+
+Thu Sep 5 11:33:41 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm: %load-path is initialized in C code now.
+ (implementation-vicinity, parse-path): Deleted, along with code to
+ initialize %load-path.
+
+ * boot-9.scm (in-vicinity): If the vicinity doesn't end with a
+ "/", use one to separate it from the file.
+
+Thu Aug 29 23:05:11 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu>
+
+ * boot-9.scm (%load-path): Add the site directory.
+ Add the directory named after the version number.
+ Prepend the version number to the other directories in the path.
+ Simplify by mapping the common prefix onto each item.
+ * Makefile.in (datadir, pkgdatadir, pkgverdatadir, subpkgdatadir,
+ sitedatadir): New definitions.
+ (libparent, libdir, install_path): Replaced by above.
+ (install): Create the above directories.
+ Put the source files into subpkgdatadir.
+ (uninstall): Remove the above directories.
+
+Thu Aug 29 21:48:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Don't use the PLUGIN system to gather information for the
+ Makefile's distribution and installation targets; just put it all
+ in the Makefile directly.
+ * PLUGIN/this.configure (scm_files, aux_files): Remove sections
+ for these.
+ * configure.in: Remove code that gets and substitutes scm_files and
+ aux_files.
+ * Makefile.in (scm_files, aux_files): Write out the list of files
+ here, where people expect to find them.
+
+Fri Aug 23 06:44:36 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm: Preliminary solution: optionally load the debug
+ module. Changed "gls" to "guile1.0b3".
+
+ * debug.scm: New file: debug extensions.
+
+Wed Aug 21 13:06:56 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (print-vector): Renamed weak-hash-table? -->
+ weak-key-hash-table?. (Again!)
+
+Tue Aug 20 07:31:39 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (print-vector, macro-table, xformer-table):
+ Renamed weak-hash-table --> weak-key-hash-table.
+
+ * poe.scm (funcq-memo): Renamed weak-hash-table -->
+ weak-key-hash-table.
+
+Sat Aug 3 06:16:35 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (*null-device*): global constant from goonix.
+ (move->fdes): adjusted for boolean primitive-move->fdes. return
+ the modified port, always set revealed count to 1 (SCSH compatible).
+ (release-port-handle port): from goonix (SCSH compatible).
+ (%open-file): removed.
+ (open-input-file, open-output-file, file-exists?, file-is-directory?):
+ modified for open-file change (does not return #f).
+
+Thu Aug 1 02:52:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in (dist-dir): New target for new dist system.
+ (manifest): Deleted.
+ * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a
+ directory, and needs special treatment in the dist-dir target.
+
+Thu Aug 1 09:00:21 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: remove the wrappers for '%' system primitives,
+ now that they throw errors directly.
+ remove make-simple-wrapper and similar functions.
+ protect a call to getenv which may now throw an exception.
+
+Wed Jul 31 23:44:42 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (false-if-exception): new macro.
+
Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive>
* The more things change...
diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
new file mode 100644
index 000000000..1647cffcc
--- /dev/null
+++ b/ice-9/Makefile.am
@@ -0,0 +1,10 @@
+## Process this file with automake to produce Makefile.in.
+
+AUTOMAKE_OPTIONS = foreign
+
+subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@
+subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
+mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
+
+## test.scm is not currently installed.
+EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm
diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in
index 318dc4a56..7ae7dd7f6 100644
--- a/ice-9/Makefile.in
+++ b/ice-9/Makefile.in
@@ -1,71 +1,220 @@
-# Copyright (C) 1995 Free Software Foundation, Inc.
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-#
-
-
+# Makefile.in generated automatically by automake 1.1n from Makefile.am
+
+# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
SHELL = /bin/sh
srcdir = @srcdir@
+top_srcdir = @top_srcdir@
VPATH = @srcdir@
prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = .
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = true
+PRE_INSTALL = true
+POST_INSTALL = true
+NORMAL_UNINSTALL = true
+PRE_UNINSTALL = true
+POST_UNINSTALL = true
+MAINT = @MAINT@
+PACKAGE = @PACKAGE@
+VERSION = @VERSION@
+module = @module@
+
+AUTOMAKE_OPTIONS = foreign
+
+subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@
+subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
+mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
+
+EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_CLEAN_FILES =
+DATA = $(subpkgdata_DATA)
+
+DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in aclocal.m4 \
+configure configure.in
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = tar
+GZIP = --best
+default: all
+
+.SUFFIXES:
+$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
+ cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile
+
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
+ cd $(top_builddir) \
+ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+$(srcdir)/aclocal.m4: @MAINT@ configure.in
+ cd $(srcdir) && $(ACLOCAL)
+
+config.status: configure
+ $(SHELL) ./config.status --recheck
+$(srcdir)/configure: @MAINT@configure.in $(ACLOCAL_M4) $(CONFIGURE_DEPENDENCIES)
+ cd $(srcdir) && $(AUTOCONF)
+
+install-subpkgdataDATA: $(subpkgdata_DATA)
+ @$(NORMAL_INSTALL)
+ $(mkinstalldirs) $(subpkgdatadir)
+ @list='$(subpkgdata_DATA)'; for p in $$list; do \
+ if test -f $(srcdir)/$$p; then \
+ echo " $(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p"; \
+ $(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p; \
+ else if test -f $$p; then \
+ echo " $(INSTALL_DATA) $$p $(subpkgdatadir)/$$p"; \
+ $(INSTALL_DATA) $$p $(subpkgdatadir)/$$p; \
+ fi; fi; \
+ done
-VERSION=@GUILE_VERSION@
+uninstall-subpkgdataDATA:
+ $(NORMAL_UNINSTALL)
+ list='$(subpkgdata_DATA)'; for p in $$list; do \
+ rm -f $(subpkgdatadir)/$$p; \
+ done
+tags: TAGS
+TAGS:
+
+
+distdir = $(PACKAGE)-$(VERSION)
+# This target untars the dist file and tries a VPATH configuration. Then
+# it guarantees that the distribution is self-contained by making another
+# tarfile.
+distcheck: dist
+ rm -rf $(distdir)
+ GZIP=$(GZIP) $(TAR) zxf $(distdir).tar.gz
+ mkdir $(distdir)/=build
+ mkdir $(distdir)/=inst
+ dc_install_base=`cd $(distdir)/=inst && pwd`; \
+ cd $(distdir)/=build \
+ && ../configure --srcdir=.. --prefix=$$dc_install_base \
+ && $(MAKE) \
+ && $(MAKE) dvi \
+ && $(MAKE) check \
+ && $(MAKE) install \
+ && $(MAKE) installcheck \
+ && $(MAKE) dist
+ rm -rf $(distdir)
+ @echo "========================"; \
+ echo "$(distdir).tar.gz is ready for distribution"; \
+ echo "========================"
+dist: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+dist-all: distdir
+ -chmod -R a+r $(distdir)
+ GZIP=$(GZIP) $(TAR) chozf $(distdir).tar.gz $(distdir)
+ rm -rf $(distdir)
+distdir: $(DISTFILES)
+ rm -rf $(distdir)
+ mkdir $(distdir)
+ -chmod 755 $(distdir)
+ here=`pwd`; distdir=`cd $(distdir) && pwd` \
+ && cd $(srcdir) \
+ && $(AUTOMAKE) --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign
+ $(mkinstalldirs) $(distdir)/PLUGIN
+ @for file in $(DISTFILES); do \
+ d=$(srcdir); \
+ test -f $(distdir)/$$file \
+ || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+ || cp -p $$d/$$file $(distdir)/$$file; \
+ done
+info:
+dvi:
+check: all
+ $(MAKE)
+installcheck:
+install-exec:
+ @$(NORMAL_INSTALL)
-libparent=$(prefix)/lib
-libdir=$(libparent)/guile$(VERSION)
-install_path=$(libdir)/@library_name@
+install-data: install-subpkgdataDATA
+ @$(NORMAL_INSTALL)
-INSTALL = $(srcdir)/../install-sh -c
-INSTALL_DATA = $(INSTALL) -m 644
+install: install-exec install-data all
+ @:
-scm_files= @scm_files@
-aux_files = @aux_files@
+uninstall: uninstall-subpkgdataDATA
-all:
+all: $(DATA) Makefile
-install: all
- test -d $(libparent) || mkdir $(libparent)
- test -d $(libdir) || mkdir $(libdir)
- test -d $(install_path) || mkdir $(install_path)
- cd $(srcdir); \
- for file in $(scm_files); do \
- $(INSTALL_DATA) $$file $(install_path); \
- done
+install-strip:
+ $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
+installdirs:
+ $(mkinstalldirs) $(subpkgdatadir)
-uninstall:
- for file in $(scm_files) ; do \
- rm -f $(install_path)/$$file; \
- done;
- -rmdir $(install_path)
- -rmdir $(libdir)
+mostlyclean-generic:
+ test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
-SUBDIR=.
-manifest:
- srcdir=./$(SUBDIR) ; \
- . $(SUBDIR)/PLUGIN/this.configure; \
- for file in $$scm_files $$aux_files ; \
- do echo $(SUBDIR)/$$file ; \
- done
+clean-generic:
+ test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ rm -f Makefile $(DISTCLEANFILES)
+ rm -f config.cache config.log stamp-h
+ test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+
+maintainer-clean-generic:
+ test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+ test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+mostlyclean: mostlyclean-generic
+
+clean: clean-generic mostlyclean
+
+distclean: distclean-generic clean
+ rm -f config.status
-clean:
+maintainer-clean: maintainer-clean-generic distclean
+ @echo "This command is intended for maintainers to use;"
+ @echo "it deletes files that may require special tools to rebuild."
+ rm -f config.status
-distclean:
- -rm -f config.log config.status Makefile
+.PHONY: default uninstall-subpkgdataDATA install-subpkgdataDATA tags \
+distdir info dvi installcheck install-exec install-data install \
+uninstall all installdirs mostlyclean-generic distclean-generic \
+clean-generic maintainer-clean-generic clean mostlyclean distclean \
+maintainer-clean
-realclean:
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/ice-9/aclocal.m4 b/ice-9/aclocal.m4
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/ice-9/aclocal.m4
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index fa55e9a1d..919b5d7ae 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -26,8 +26,20 @@
;;;
+;;; {Features}
+;;
+
+(define (provide sym)
+ (if (not (memq sym *features*))
+ (set! *features* (cons sym *features*))))
+
+
+;;; {R4RS compliance}
-;; {Simple Debugging Tools}
+(primitive-load-path "ice-9/r4rs.scm")
+
+
+;;; {Simple Debugging Tools}
;;
@@ -54,24 +66,22 @@
(lambda ()
(newline)
(display ";;; WARNING ")
- (print stuff)
+ (display stuff)
(newline)
(car (last-pair stuff)))))
-;;; {apply and call-with-current-continuation}
+;;; {Trivial Functions}
;;;
-;;; These turn syntax, @apply and @call-with-current-continuation,
-;;; into procedures.
-;;;
-
-(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
-(define (call-with-current-continuation proc) (@call-with-current-continuation proc))
+(define (id x) x)
+(define (1+ n) (+ n 1))
+(define (-1+ n) (+ n -1))
+(define 1- -1+)
+(define return-it noop)
+(define (and=> value procedure) (and value (procedure value)))
+(define (make-hash-table k) (make-vector k '()))
-
-;;; {apply-to-args}
-;;;
;;; apply-to-args is functionally redunant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
;;;
@@ -87,28 +97,9 @@
(define (apply-to-args args fn) (apply fn args))
-;;; {Silly Naming Cleanups and Trivial Functions}
-;;;
-
-(define %open-file open-file)
-(define (id x) x)
-(define < <?)
-(define <= <=?)
-(define = =?)
-(define > >?)
-(define >= >=?)
-(define (1+ n) (+ n 1))
-(define (-1+ n) (+ n -1))
-(define 1- -1+)
-(define return-it noop)
-(define (and=> value thunk) (and value (thunk value)))
-(define (make-hash-table k) (make-vector k '()))
-
;;; {Integer Math}
;;;
-(define (integer? x) (and (number? x) (= x (inexact->exact x))))
-
(define (ipow-by-squaring x k acc proc)
(cond ((zero? k) acc)
((= 1 k) (proc acc x))
@@ -131,102 +122,6 @@
(else (apply logior args))))
-;;; {Basic Port Code}
-;;;
-;;; Specificly, the parts of the low-level port code that are written in
-;;; Scheme rather than C.
-;;;
-;;; WARNING: the parts of this interface that refer to file ports
-;;; is going away. It would be gone already except that it is used
-;;; "internally" in a few places.
-;;;
-
-
-;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
-;; mode to open files in. MSDOS does carraige return - newline
-;; translation if not opened in `b' mode.
-;;
-(define OPEN_READ (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "rb")
- (else "r")))
-(define OPEN_WRITE (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "wb")
- (else "w")))
-(define OPEN_BOTH (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "r+b")
- (else "r+")))
-
-(define (open-input-file str)
- (or (open-file str OPEN_READ)
- (error "OPEN-INPUT-FILE couldn't find file " str)))
-
-(define (open-output-file str)
- (or (open-file str OPEN_WRITE)
- (error "OPEN-OUTPUT-FILE couldn't find file " str)))
-
-(define (open-io-file str) (open-file str OPEN_BOTH))
-(define close-input-port close-port)
-(define close-output-port close-port)
-(define close-io-port close-port)
-
-(define (call-with-input-file str proc)
- (let* ((file (open-input-file str))
- (ans (proc file)))
- (close-input-port file)
- ans))
-
-(define (call-with-output-file str proc)
- (let* ((file (open-output-file str))
- (ans (proc file)))
- (close-output-port file)
- ans))
-
-(define (with-input-from-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-output-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-error-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-input-from-file file thunk)
- (let* ((nport (open-input-file file))
- (ans (with-input-from-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-output-to-file file thunk)
- (let* ((nport (open-output-file file))
- (ans (with-output-to-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-error-to-file file thunk)
- (let* ((nport (open-output-file file))
- (ans (with-error-to-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-input-from-string string thunk)
- (call-with-input-string string
- (lambda (p) (with-input-from-port p thunk))))
-
-(define (with-output-to-string thunk)
- (call-with-output-string
- (lambda (p) (with-output-to-port p thunk))))
-
-(define (with-error-to-string thunk)
- (call-with-output-string
- (lambda (p) (with-error-to-port p thunk))))
-
-(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
-
-
-
;;; {Symbol Properties}
;;;
@@ -246,6 +141,122 @@
(symbol-pset! sym (delq! pair (symbol-pref sym))))))
+
+;;; {Line and Delimited I/O}
+
+;;; corresponds to SCM_LINE_INCREMENTORS in libguile.
+(define scm-line-incrementors "\n")
+
+(define (read-line! string . maybe-port)
+ (let* ((port (if (pair? maybe-port)
+ (car maybe-port)
+ (current-input-port))))
+ (let* ((rv (%read-delimited! scm-line-incrementors
+ string
+ #t
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((and (= nchars 0)
+ (eof-object? terminator))
+ terminator)
+ ((not terminator) #f)
+ (else nchars)))))
+
+(define (read-delimited! delims buf . args)
+ (let* ((num-args (length args))
+ (port (if (> num-args 0)
+ (car args)
+ (current-input-port)))
+ (handle-delim (if (> num-args 1)
+ (cadr args)
+ 'trim))
+ (start (if (> num-args 2)
+ (caddr args)
+ 0))
+ (end (if (> num-args 3)
+ (cadddr args)
+ (string-length buf))))
+ (let* ((rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port
+ start
+ end))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((or (not terminator) ; buffer filled
+ (eof-object? terminator))
+ (if (zero? nchars)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons nchars terminator)
+ nchars)))
+ (else
+ (case handle-delim
+ ((trim peek) nchars)
+ ((concat) (string-set! buf nchars terminator)
+ (+ nchars 1))
+ ((split) (cons nchars terminator))
+ (else (error "unexpected handle-delim value: "
+ handle-delim))))))))
+
+(define (read-delimited delims . args)
+ (let* ((port (if (pair? args)
+ (let ((pt (car args)))
+ (set! args (cdr args))
+ pt)
+ (current-input-port)))
+ (handle-delim (if (pair? args)
+ (car args)
+ 'trim)))
+ (let loop ((substrings ())
+ (total-chars 0)
+ (buf-size 100)) ; doubled each time through.
+ (let* ((buf (make-string buf-size))
+ (rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv))
+ (join-substrings
+ (lambda ()
+ (apply string-append
+ (reverse
+ (cons (if (and (eq? handle-delim 'concat)
+ (not (eof-object? terminator)))
+ (string terminator)
+ "")
+ (cons (make-shared-substring buf 0 nchars)
+ substrings))))))
+ (new-total (+ total-chars nchars)))
+ (cond ((not terminator)
+ ;; buffer filled.
+ (loop (cons (substring buf 0 nchars) substrings)
+ new-total
+ (* buf-size 2)))
+ ((eof-object? terminator)
+ (if (zero? new-total)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons (join-substrings) terminator)
+ (join-substrings))))
+ (else
+ (case handle-delim
+ ((trim peek concat) (join-substrings))
+ ((split) (cons (join-substrings) terminator))
+ (else (error "unexpected handle-delim value: "
+ handle-delim)))))))))
+
+(define (read-line . args)
+ (apply read-delimited scm-line-incrementors args))
+
+
;;; {Arrays}
;;;
@@ -254,7 +265,7 @@
(define make-uniform-vector dimensions->uniform-array)
; (define uniform-vector-ref array-ref)
(define (uniform-vector-set! u i o)
- (uniform-vector-set1! u o i))
+ (uniform-array-set1! u o i))
(define uniform-vector-fill! array-fill!)
(define uniform-vector-read! uniform-array-read!)
(define uniform-vector-write uniform-array-write)
@@ -287,100 +298,6 @@
(and rem (pair? (cdr rem)) (cadr rem))))
-
-;;; {Print}
-;;;
-
-(define (print obj . args)
- (let ((default-args (list (current-output-port) 0 0 default-print-style #f)))
- (apply-to-args (append args (list-cdr-ref default-args (length args)))
- (lambda (port depth length style table)
- (cond
- ((and table (print-table-ref table obj)) ((print-style-tag-hook style 'eq-val)
- obj port depth length style table))
- (else
- (and table (print-table-add! table obj))
- (cond
- ((print-style-max-depth? style depth) ((print-style-excess-depth-hook style)))
- ((print-style-max-length? style length) ((print-style-excess-length-hook style)))
- (else ((print-style-hook style obj)
- obj port depth length style table)))))))))
-
-(define (make-print-style) (make-vector 59))
-
-(define (extend-print-style! style utag printer) (hashq-set! style utag printer))
-
-(define (print-style-hook style obj)
- (let ((type-tag (tag obj)))
- (or (hashq-ref style type-tag)
- (hashq-ref style (logand type-tag 255))
- print-obj)))
-
-(define (print-style-tag-hook style type-tag)
- (or (hashq-ref style type-tag)
- print-obj))
-
-(define (print-style-max-depth? style d) #f)
-(define (print-style-max-length? style l) #f)
-(define (print-style-excess-length-hook style) (hashq-ref style 'excess-length-hook))
-(define (print-style-excess-depth-hook style) (hashq-ref style 'excess-depth-hook))
-
-(define (make-print-table) (make-vector 59))
-(define (print-table-ref table obj) (hashq-ref table obj))
-(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref)))
-
-(define (print-obj obj port depth length style table) (write obj port))
-
-(define (print-pair pair port depth length style table)
- (if (= 0 length)
- (display #\( port))
-
- (print (car pair) port (+ 1 depth) 0 style table)
-
- (cond
- ((and (pair? (cdr pair))
- (or (not table)
- (not (print-table-ref table (cdr pair)))))
-
- (display #\space port)
- (print (cdr pair) port depth (+ 1 length) style table))
-
- ((null? (cdr pair)) (display #\) port))
-
- (else (display " . " port)
- (print (cdr pair) port (+ 1 depth) 0 style table)
- (display #\) port))))
-
-(define (print-vector obj port depth length style table)
- (if (= 0 length)
- (cond
- ((weak-hash-table? obj) (display "#wh(" port))
- ((weak-value-hash-table? obj) (display "#whv(" port))
- ((doubly-weak-hash-table? obj) (display "#whd(" port))
- (else (display "#(" port))))
-
- (if (< length (vector-length obj))
- (print (vector-ref obj length) port (+ 1 depth) 0 style table))
-
- (cond
- ((>= (+ 1 length) (vector-length obj)) (display #\) port))
- (else (display #\space port)
- (print obj port depth (+ 1 length) style table))))
-
-(define default-print-style (make-print-style))
-
-(extend-print-style! default-print-style utag_vector print-vector)
-(extend-print-style! default-print-style utag_wvect print-vector)
-(extend-print-style! default-print-style utag_pair print-pair)
-(extend-print-style! default-print-style 'eq-val
- (lambda (obj port depth length style table)
- (if (symbol? obj)
- (display obj)
- (begin
- (display "##" port)
- (display (print-table-ref table obj))))))
-
-
;;; {Records}
;;;
@@ -390,16 +307,20 @@
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
(define (make-record-type type-name fields . opt)
- (let ((printer-fn (and opt (car opt))))
+ (let ((printer-fn (and (pair? opt) (car opt))))
(let ((struct (make-struct record-type-vtable 0
- (make-struct-layout (apply symbol-append (map (lambda (f) "pw") fields)))
+ (make-struct-layout
+ (apply symbol-append
+ (map (lambda (f) "pw") fields)))
type-name
(copy-tree fields))))
;; !!! leaks printer functions
- (if printer-fn
- (extend-print-style! default-print-style
- (logior utag_struct_base (ash (struct-vtable-tag struct) 8))
- printer-fn))
+ ;; MDJ 960919 <djurfeldt@nada.kth.se>: *fixme* need to make it
+ ;; possible to print records nicely.
+ ;(if printer-fn
+; (extend-print-style! default-print-style
+; (logior utag_struct_base (ash (struct-vtable-tag struct) 8))
+; printer-fn))
struct)))
(define (record-type-name obj)
@@ -413,7 +334,7 @@
(error 'not-a-record-type obj)))
(define (record-constructor rtd . opt)
- (let ((field-names (if opt (car opt) (record-type-fields rtd))))
+ (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
(eval `(lambda ,field-names
(make-struct ',rtd 0 ,@(map (lambda (f)
(if (memq f field-names)
@@ -449,6 +370,8 @@
(struct-vtable obj)
(error 'not-a-record obj)))
+(provide 'record)
+
;;; {Booleans}
;;;
@@ -548,19 +471,69 @@
(map-in-order fn (cdr l)))))
+;;; {Hooks}
+(define (run-hooks hook)
+ (for-each (lambda (thunk) (thunk)) hook))
+
+(define add-hook!
+ (procedure->macro
+ (lambda (exp env)
+ `(let ((thunk ,(caddr exp)))
+ (if (not (memq thunk ,(cadr exp)))
+ (set! ,(cadr exp)
+ (cons thunk ,(cadr exp))))))))
+
+
;;; {Files}
;;; !!!! these should be implemented using Tcl commands, not fports.
;;;
-(define (file-exists? str)
- (let ((port (open-file str OPEN_READ)))
- (if port (begin (close-port port) #t)
- #f)))
-
-(define (file-is-directory? str)
- (let ((port (open-file (string-append str "/.") OPEN_READ)))
- (if port (begin (close-port port) #t)
- #f)))
+(define (feature? feature)
+ (and (memq feature *features*) #t))
+
+;; Using the vector returned by stat directly is probably not a good
+;; idea (it could just as well be a record). Hence some accessors.
+(define (stat:dev f) (vector-ref f 0))
+(define (stat:ino f) (vector-ref f 1))
+(define (stat:mode f) (vector-ref f 2))
+(define (stat:nlink f) (vector-ref f 3))
+(define (stat:uid f) (vector-ref f 4))
+(define (stat:gid f) (vector-ref f 5))
+(define (stat:rdev f) (vector-ref f 6))
+(define (stat:size f) (vector-ref f 7))
+(define (stat:atime f) (vector-ref f 8))
+(define (stat:mtime f) (vector-ref f 9))
+(define (stat:ctime f) (vector-ref f 10))
+(define (stat:blksize f) (vector-ref f 11))
+(define (stat:blocks f) (vector-ref f 12))
+
+;; derived from stat mode.
+(define (stat:type f) (vector-ref f 13))
+(define (stat:perms f) (vector-ref f 14))
+
+(define file-exists?
+ (if (feature? 'posix)
+ (lambda (str)
+ (access? str F_OK))
+ (lambda (str)
+ (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
+
+(define file-is-directory?
+ (if (feature? 'i/o-extensions)
+ (lambda (str)
+ (eq? (stat:type (stat str)) 'directory))
+ (lambda (str)
+ (display str)
+ (newline)
+ (let ((port (catch 'system-error
+ (lambda () (open-file (string-append str "/.")
+ OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
(define (has-suffix? str suffix)
(let ((sufl (string-length suffix))
@@ -568,89 +541,61 @@
(and (> sl sufl)
(string=? (substring str (- sl sufl) sl) suffix))))
-
-
;;; {Error Handling}
;;;
-
-;; (error . args) is short for (throw (quote error) . args)
-;;
(define (error . args)
- (apply throw 'error args))
-
-
-
-
-;; Error handling a la SCM.
-;;
-(define (%%default-error-handler tag . args)
- (define cep (current-error-port))
- (perror "ERROR")
- (errno 0)
- (display "ERROR: " cep)
- (if (not (null? args))
- (begin (display (car args) cep)
- (for-each (lambda (x) (display #\ cep) (write x cep))
- (cdr args))))
- (newline cep)
- (force-output cep)
- (apply throw 'abort tag args))
-
-
-
-;; Install SCM error handling as the default.
-;;
-(set-symbol-property! 'error
- 'throw-handler-default
- %%default-error-handler)
-
-
-
-
-
-;; %%bad-throw is the hook that is called upon a throw to a an unhandled
-;; key. If the key has a default handler (a throw-handler-default property),
+ (save-stack)
+ (if (null? args)
+ (scm-error 'misc-error #f "?" #f #f)
+ (let loop ((msg "%s")
+ (rest (cdr args)))
+ (if (not (null? rest))
+ (loop (string-append msg " %S")
+ (cdr rest))
+ (scm-error 'misc-error #f msg args #f)))))
+
+;; bad-throw is the hook that is called upon a throw to a an unhandled
+;; key (unless the throw has four arguments, in which case
+;; it's usually interpreted as an error throw.)
+;; If the key has a default handler (a throw-handler-default property),
;; it is applied to the throw.
;;
-(define (%%bad-throw key . args)
+(define (bad-throw key . args)
(let ((default (symbol-property key 'throw-handler-default)))
(or (and default (apply default key args))
- (throw 'error 'unhandled-exception key args))))
+ (apply error "unhandled-exception:" key args))))
-
-
-
-
-;; A number of internally defined error types are represented
+;; mostly obsolete.
+;; A number of internally defined error types were represented
;; as integers. Here is the mapping to symbolic names
;; and error messages.
;;
-(define %%system-errors
- '((-1 UNKNOWN "Unknown error")
- (0 ARGn "Wrong type argument to ")
- (1 ARG1 "Wrong type argument in position 1 to ")
- (2 ARG2 "Wrong type argument in position 2 to ")
- (3 ARG3 "Wrong type argument in position 3 to ")
- (4 ARG4 "Wrong type argument in position 4 to ")
- (5 ARG5 "Wrong type argument in position 5 to ")
- (6 ARG5 "Wrong type argument in position 5 to ")
- (7 ARG5 "Wrong type argument in position 5 to ")
- (8 WNA "Wrong number of arguments to ")
- (9 OVFLOW "Numerical overflow to ")
- (10 OUTOFRANGE "Argument out of range to ")
- (11 NALLOC "Could not allocate to ")
- (12 STACK_OVFLOW "Stack overflow")
- (13 EXIT "Exit (internal error?).")
- (14 HUP_SIGNAL "hang-up")
- (15 INT_SIGNAL "user interrupt")
- (16 FPE_SIGNAL "arithmetic error")
- (17 BUS_SIGNAL "bus error")
- (18 SEGV_SIGNAL "segmentation violation")
- (19 ALRM_SIGNAL "alarm")
- (20 GC_SIGNAL "gc")
- (21 TICK_SIGNAL "tick")))
+;(define %%system-errors
+; '((-1 UNKNOWN "Unknown error")
+; (0 ARGn "Wrong type argument to ")
+; (1 ARG1 "Wrong type argument in position 1 to ")
+; (2 ARG2 "Wrong type argument in position 2 to ")
+; (3 ARG3 "Wrong type argument in position 3 to ")
+; (4 ARG4 "Wrong type argument in position 4 to ")
+; (5 ARG5 "Wrong type argument in position 5 to ")
+; (6 ARG5 "Wrong type argument in position 5 to ")
+; (7 ARG5 "Wrong type argument in position 5 to ")
+; (8 WNA "Wrong number of arguments to ")
+; (9 OVFLOW "Numerical overflow to ")
+; (10 OUTOFRANGE "Argument out of range to ")
+; (11 NALLOC "Could not allocate to ")
+; (12 STACK_OVFLOW "Stack overflow")
+; (13 EXIT "Exit (internal error?).")
+; (14 HUP_SIGNAL "hang-up")
+; (15 INT_SIGNAL "user interrupt")
+; (16 FPE_SIGNAL "arithmetic error")
+; (17 BUS_SIGNAL "bus error")
+; (18 SEGV_SIGNAL "segmentation violation")
+; (19 ALRM_SIGNAL "alarm")
+; (20 GC_SIGNAL "gc")
+; (21 TICK_SIGNAL "tick")))
(define (timer-thunk) #t)
@@ -658,333 +603,216 @@
(define (alarm-thunk) #t)
(define (signal-handler n)
- (cond
- ((= n 21) (unmask-signals) (timer-thunk))
- ((= n 20) (unmask-signals) (gc-thunk))
- ((= n 19) (unmask-signals) (alarm-thunk))
- (else (unmask-signals) (throw '%%system-error n #f))))
-
-
-;; The default handler for built-in error types when
-;; thrown by their symbolic name. The action is to
-;; convert the error into a generic error, building
-;; a descriptive message for the error.
-;;
-(define (%%handle-system-error ignored desc proc . args)
- (let* ((b (assoc desc %%system-errors))
- (msghead (cond
- (b (caddr b))
- ((or (symbol? desc) (string? desc))
- (string-append desc " "))
- (#t "Unknown error")))
- (msg (if (symbol? proc)
- (string-append msghead proc ":")
- msghead))
- (rest (if (and proc (not (symbol? proc)))
- (cons proc args)
- args))
- (fixed-args (cons msg rest)))
- (apply error fixed-args)))
-
-
-(set-symbol-property! '%%system-error
- 'throw-handler-default
- %%handle-system-error)
-
-
-;; Install default handlers for built-in errors.
-;;
-(map (lambda (err)
- (set-symbol-property! (cadr err)
- 'throw-handler-default
- %%handle-system-error))
- (cdr %%system-errors))
-
-
-
-
-(define ((make-simple-wrapper func) . args)
- (or (apply func args)
- (apply throw 'syserror func (errno) args)))
-
-(define ((make-eof-wrapper func) . args)
- (let ((rv (apply func args)))
- (if (eof-object? rv)
- (apply throw 'syserror func (errno) args)
- rv)))
-
-(define ((make-errno-wrapper func) . args)
- (let ((rv (apply func args)))
- (if (number? rv)
- (apply throw 'syserror func rv args)
- rv)))
-
-(define ((make-errpair-wrapper func) . args)
- (let ((rv (apply func args)))
- (if (and (pair? rv)
- (number? (car rv))
- (null? (cdr rv)))
- (apply throw 'syserror func (car rv) args)
- rv)))
-
-(begin
- (define (syserror key fn err . args)
- (errno err)
- (apply error (cons fn args)))
- (set-symbol-property! 'syserror 'throw-handler-default syserror))
-
-
-(define (%getgrnam name) (%getgr name))
-(define (%getgrgid id) (%getgr id))
-(define (%gethostbyaddr addr) (%gethost addr))
-(define (%gethostbyname name) (%gethost name))
-(define (%getnetbyaddr addr) (%getnet addr))
-(define (%getnetbyname name) (%getnet name))
-(define (%getprotobyname name) (%getproto name))
-(define (%getprotobynumber addr) (%getproto addr))
-(define (%getpwnam name) (%getpw name))
-(define (%getpwuid uid) (%getpw uid))
-(define (%getservbyname name proto) (%getserv name proto))
-(define (%getservbyport port proto) (%getserv port proto))
+ (let* (
+ ;; these numbers are set in libguile, not the same as those
+ ;; interned in posix.c for SIGSEGV etc.
+ ;;
+ (signal-messages `((14 . "hang-up")
+ (15 . "user interrupt")
+ (16 . "arithmetic error")
+ (17 . "bus error")
+ (18 . "segmentation violation"))))
+ (cond
+ ((= n 21) (unmask-signals) (timer-thunk))
+ ((= n 20) (unmask-signals) (gc-thunk))
+ ((= n 19) (unmask-signals) (alarm-thunk))
+ (else (set! the-last-stack
+ (make-stack #t
+ (list-ref (list %hup-thunk
+ %int-thunk
+ %fpe-thunk
+ %bus-thunk
+ %segv-thunk)
+ (- n 14))
+ 1))
+ (set! stack-saved? #t)
+ (if (not (and (memq 'debug (debug-options-interface))
+ (eq? (stack-id the-last-stack) 'repl-stack)))
+ (set! the-last-stack #f))
+ (unmask-signals)
+ (let ((sig-pair (assoc n signal-messages)))
+ (scm-error 'error-signal #f
+ (cdr (or sig-pair
+ (cons n "Unknown signal: %s")))
+ (if sig-pair
+ #f
+ (list n))
+ (list n)))))))
+
+
+;;; {Non-polymorphic versions of POSIX functions}
+
+(define (getgrnam name) (getgr name))
+(define (getgrgid id) (getgr id))
+(define (gethostbyaddr addr) (gethost addr))
+(define (gethostbyname name) (gethost name))
+(define (getnetbyaddr addr) (getnet addr))
+(define (getnetbyname name) (getnet name))
+(define (getprotobyname name) (getproto name))
+(define (getprotobynumber addr) (getproto addr))
+(define (getpwnam name) (getpw name))
+(define (getpwuid uid) (getpw uid))
+(define (getservbyname name proto) (getserv name proto))
+(define (getservbyport port proto) (getserv port proto))
(define (endgrent) (setgr))
(define (endhostent) (sethost))
(define (endnetent) (setnet))
(define (endprotoent) (setproto))
(define (endpwent) (setpw))
(define (endservent) (setserv))
+(define (getgrent) (getgr))
+(define (gethostent) (gethost))
+(define (getnetent) (getnet))
+(define (getprotoent) (getproto))
+(define (getpwent) (getpw))
+(define (getservent) (getserv))
+(define (reopen-file . args) (apply freopen args))
+(define (setgrent) (setgr #f))
+(define (sethostent) (sethost #t))
+(define (setnetent) (setnet #t))
+(define (setprotoent) (setproto #t))
+(define (setpwent) (setpw #t))
+(define (setservent) (setserv #t))
+
+(define (passwd:name obj) (vector-ref obj 0))
+(define (passwd:passwd obj) (vector-ref obj 1))
+(define (passwd:uid obj) (vector-ref obj 2))
+(define (passwd:gid obj) (vector-ref obj 3))
+(define (passwd:gecos obj) (vector-ref obj 4))
+(define (passwd:dir obj) (vector-ref obj 5))
+(define (passwd:shell obj) (vector-ref obj 6))
+
+(define (group:name obj) (vector-ref obj 0))
+(define (group:passwd obj) (vector-ref obj 1))
+(define (group:gid obj) (vector-ref obj 2))
+(define (group:mem obj) (vector-ref obj 3))
+
+(define (hostent:name obj) (vector-ref obj 0))
+(define (hostent:aliases obj) (vector-ref obj 1))
+(define (hostent:addrtype obj) (vector-ref obj 2))
+(define (hostent:length obj) (vector-ref obj 3))
+(define (hostent:addr-list obj) (vector-ref obj 4))
+
+(define (netent:name obj) (vector-ref obj 0))
+(define (netent:aliases obj) (vector-ref obj 1))
+(define (netent:addrtype obj) (vector-ref obj 2))
+(define (netent:net obj) (vector-ref obj 3))
+
+(define (protoent:name obj) (vector-ref obj 0))
+(define (protoent:aliases obj) (vector-ref obj 1))
+(define (protoent:proto obj) (vector-ref obj 2))
+
+(define (servent:name obj) (vector-ref obj 0))
+(define (servent:aliases obj) (vector-ref obj 1))
+(define (servent:port obj) (vector-ref obj 2))
+(define (servent:proto obj) (vector-ref obj 3))
+
+(define (sockaddr:fam obj) (vector-ref obj 0))
+(define (sockaddr:path obj) (vector-ref obj 1))
+(define (sockaddr:addr obj) (vector-ref obj 1))
+(define (sockaddr:port obj) (vector-ref obj 2))
+
+(define (utsname:sysname obj) (vector-ref obj 0))
+(define (utsname:nodename obj) (vector-ref obj 1))
+(define (utsname:release obj) (vector-ref obj 2))
+(define (utsname:version obj) (vector-ref obj 3))
+(define (utsname:machine obj) (vector-ref obj 4))
+
+(define (tm:sec obj) (vector-ref obj 0))
+(define (tm:min obj) (vector-ref obj 1))
+(define (tm:hour obj) (vector-ref obj 2))
+(define (tm:mday obj) (vector-ref obj 3))
+(define (tm:mon obj) (vector-ref obj 4))
+(define (tm:year obj) (vector-ref obj 5))
+(define (tm:wday obj) (vector-ref obj 6))
+(define (tm:yday obj) (vector-ref obj 7))
+(define (tm:isdst obj) (vector-ref obj 8))
+(define (tm:gmtoff obj) (vector-ref obj 9))
+(define (tm:zone obj) (vector-ref obj 10))
+
+(define (set-tm:sec obj val) (vector-set! obj 0 val))
+(define (set-tm:min obj val) (vector-set! obj 1 val))
+(define (set-tm:hour obj val) (vector-set! obj 2 val))
+(define (set-tm:mday obj val) (vector-set! obj 3 val))
+(define (set-tm:mon obj val) (vector-set! obj 4 val))
+(define (set-tm:year obj val) (vector-set! obj 5 val))
+(define (set-tm:wday obj val) (vector-set! obj 6 val))
+(define (set-tm:yday obj val) (vector-set! obj 7 val))
+(define (set-tm:isdst obj val) (vector-set! obj 8 val))
+(define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
+(define (set-tm:zone obj val) (vector-set! obj 10 val))
+
(define (file-position . args) (apply ftell args))
(define (file-set-position . args) (apply fseek args))
-(define (getgrent) (%getgr))
-(define (gethostent) (%gethost))
-(define (getnetent) (%getnet))
-(define (getprotoent) (%getproto))
-(define (getpwent) (%getpw))
-(define (getservent) (%getserv))
-(define (reopen-file . args) (apply freopen args))
-(define (setgrent arg) (setgr arg))
-(define (sethostent arg) (sethost arg))
-(define (setnetent arg) (setnet arg))
-(define (setprotoent arg) (setproto arg))
-(define (setpwent arg) (setpw arg))
-(define (setservent arg) (setserv arg))
-(define (%move->fdes port fd)
- (if (= 1 (primitive-move->fdes port fd))
- (set-port-revealed! port 1)
- #t))
-
-(define accept (make-errno-wrapper %accept))
-(define bind (make-errno-wrapper %bind))
-(define chdir (make-errno-wrapper %chdir))
-(define chmod (make-errno-wrapper %chmod))
-(define chown (make-errno-wrapper %chown))
-(define close (make-errno-wrapper %close))
-(define closedir (make-errno-wrapper %closedir))
-(define connect (make-errno-wrapper %connect))
-(define copy-file (make-simple-wrapper %copy-file))
-(define ctermid (make-simple-wrapper %ctermid))
-(define delete-file (make-errno-wrapper %delete-file))
-(define duplicate-port (make-simple-wrapper %duplicate-port))
-(define execl (make-errno-wrapper %execl))
-(define execlp (make-errno-wrapper %execlp))
-(define fdopen (make-errno-wrapper %fdopen))
-(define fileno (make-simple-wrapper %fileno))
-(define fork (make-simple-wrapper %fork))
-(define freopen (make-errno-wrapper %freopen))
-(define fseek (make-errno-wrapper %fseek))
-(define ftell (make-errno-wrapper %ftell))
-(define getcwd (make-errno-wrapper %getcwd))
-(define getenv (make-simple-wrapper %getenv))
-(define getgrgid (make-errno-wrapper %getgrgid))
-(define getgrnam (make-errno-wrapper %getgrnam))
-(define getgroups (make-errno-wrapper %getgroups))
-(define gethostbyaddr (make-simple-wrapper %gethostbyaddr))
-(define gethost (make-simple-wrapper %gethost))
-(define gethostbyname (make-simple-wrapper %gethostbyname))
-(define getnetbyaddr (make-simple-wrapper %getnetbyaddr))
-(define getnetbyname (make-simple-wrapper %getnetbyname))
-(define getpeername (make-errno-wrapper %getpeername))
-(define getprotobyname (make-simple-wrapper %getprotobyname))
-(define getprotobynumber (make-simple-wrapper %getprotobynumber))
-(define getpwnam (make-simple-wrapper %getpwnam))
-(define getpwuid (make-simple-wrapper %getpwuid))
-(define getservbyname (make-simple-wrapper %getservbyname))
-(define getservbyport (make-simple-wrapper %getservbyport))
-(define getsockname (make-errno-wrapper %getsockname))
-(define getsockopt (make-errpair-wrapper %getsockopt))
-(define inet-aton (make-simple-wrapper %inet-aton))
-(define isatty? (make-errno-wrapper %isatty?))
-(define kill (make-errno-wrapper %kill))
-(define link (make-errno-wrapper %link))
-(define listen (make-errno-wrapper %listen))
-(define lstat (make-errno-wrapper %lstat))
-(define mkdir (make-errno-wrapper %mkdir))
-(define mknod (make-errno-wrapper %mknod))
-(define nice (make-errno-wrapper %nice))
-(define opendir (make-errno-wrapper %opendir))
-(define pipe (make-errno-wrapper %pipe))
-(define primitive-move->fdes (make-simple-wrapper %primitive-move->fdes))
-(define putenv (make-errno-wrapper %putenv))
-(define read-fd (make-errpair-wrapper %read-fd))
-(define readdir (make-errno-wrapper %readdir))
-(define readlink (make-errno-wrapper %readlink))
-(define recv (make-errno-wrapper %recv))
-(define recvfrom (make-errno-wrapper %recvfrom))
-(define redirect-port (make-errno-wrapper %redirect-port))
-(define rename-file (make-errno-wrapper %rename-file))
-(define rmdir (make-errno-wrapper %rmdir))
-(define select (make-errno-wrapper %select))
-(define send (make-errpair-wrapper %send))
-(define sendto (make-errpair-wrapper %sendto))
-(define setegid (make-errno-wrapper %setegid))
-(define seteuid (make-errno-wrapper %seteuid))
-(define setgid (make-errno-wrapper %setgid))
-(define setlocale (make-errno-wrapper %setlocale))
-(define setpgid (make-errno-wrapper %setpgid))
-(define setsid (make-simple-wrapper %setsid))
-(define setsockopt (make-errno-wrapper %setsockopt))
-(define setuid (make-errno-wrapper %setuid))
-(define shutdown (make-errno-wrapper %shutdown))
-(define socket (make-errno-wrapper %socket))
-(define socketpair (make-errno-wrapper %socketpair))
-(define stat (make-errno-wrapper %stat))
-(define strptime (make-simple-wrapper %strptime))
-(define symlink (make-simple-wrapper %symlink))
-(define tcgetpgrp (make-simple-wrapper %tcgetpgrp))
-(define tcsetpgrp (make-simple-wrapper %tcsetpgrp))
-(define ttyname (make-errno-wrapper %ttyname))
-(define uname (make-errno-wrapper %uname))
-(define utime (make-errno-wrapper %utime))
-(define waitpid (make-errno-wrapper %waitpid))
-(define write-fd (make-errpair-wrapper %write-fd))
-(define move->fdes (make-simple-wrapper %move->fdes))
+
+(define (open-input-pipe command) (open-pipe command OPEN_READ))
+(define (open-output-pipe command) (open-pipe command OPEN_WRITE))
+
+(define (move->fdes port fd)
+ (primitive-move->fdes port fd)
+ (set-port-revealed! port 1)
+ port)
+
+(define (release-port-handle port)
+ (let ((revealed (port-revealed port)))
+ (if (> revealed 0)
+ (set-port-revealed! port (- revealed 1)))))
;;; {Load Paths}
;;;
-(define implementation-vicinity compiled-library-path)
-
;;; Here for backward compatability
;;
(define scheme-file-suffix (lambda () ".scm"))
-(define in-vicinity string-append)
-
-(define (parse-path env_path)
- (cond ((string? env_path)
- (let loop ((curdir "") (env env_path) (path '()))
- (cond ((= (string-length env) 0)
- (if (> (string-length curdir) 0)
- (append path (list curdir))
- path))
- ((char=? (string-ref env 0) #\:)
- (loop ""
- (substring env 1 (string-length env))
- (append path (list curdir))))
- (#t
- (loop (string-append curdir (substring env 0 1))
- (substring env 1 (string-length env))
- path)))))
- (#t '())))
-
-(define %load-path (append (parse-path (%getenv "SCHEME_LOAD_PATH"))
- (list ""
- (in-vicinity (implementation-vicinity) "gls/guile/")
- (in-vicinity (implementation-vicinity) "gls/")
- (in-vicinity (implementation-vicinity) "slib/"))))
+(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)))
+
-;;; {try-load}
-;;;
+;;; {Help for scm_shell}
+;;; The argument-processing code used by Guile-based shells generates
+;;; Scheme code based on the argument list. This page contains help
+;;; functions for the code it generates.
+
+(define (eval-string string)
+ (call-with-input-string
+ string
+ (lambda (port)
+ (let loop ()
+ (let ((expr (read port)))
+ (if (eof-object? expr) #f
+ (begin (eval expr) (loop))))))))
+
+(define (command-line) (program-arguments))
-(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 (load-user-init)
+ (define (has-init? dir)
+ (let ((path (in-vicinity dir ".guile")))
+ (catch 'system-error
+ (lambda ()
+ (let ((stats (stat path)))
+ (if (not (eq? (stat:type stats) 'directory))
+ path)))
+ (lambda dummy #f))))
+ (let ((path (or (has-init? (getenv "HOME"))
+ (has-init? (passwd:dir (getpw (getuid)))))))
+ (if path (primitive-load path))))
-(define (try-load name)
- (if (eval '(defined? %load-path))
- (try-load-with-path name (eval '%load-path))
- (%try-load name #t read-sharp)))
-;;; {Load}
-;;;
-
-(define %load-verbosely #t)
-(define (assert-load-verbosity v) (set! %load-verbosely v))
-(define %load-indent -2)
-
-(define (%load f)
- (current-module)
- (or (and (not (file-is-directory? f))
- (%try-load f #t read-sharp))
- (and (not (has-suffix? f (scheme-file-suffix)))
- (%try-load (string-append f (scheme-file-suffix)) #t read-sharp))))
-
-(define (%load-announce file)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display (make-string %load-indent #\ ))
- (display "loading ")
- (display file)
- (display "...")
- (newline)
- (force-output)))))
-
-(define (%load-announce-win file)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display (make-string %load-indent #\ ))
- (display "...loaded ")
- (display file)
- (display ".")
- (newline)
- (force-output)))))
-
-(define (%load-announce-lossage file path)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display (make-string %load-indent #\ ))
- (display "...COULD NOT LOAD ")
- (display file)
- (display " from ")
- (write path)
- (newline)
- (force-output))))
- (throw 'could-not-load file path))
-
-
-(define (load-with-path name path)
- (define (do-load)
- (%load-announce name)
- (if (not (or-map (lambda (d)
- (if (%load (in-vicinity d name))
- (begin
- (%load-announce-win (in-vicinity d name))
- #t)
- #f))
- path))
- (%load-announce-lossage name path)))
-
- (let ((indent %load-indent))
- (dynamic-wind
- (lambda () (set! %load-indent (modulo (+ indent 2) 16)))
- do-load
- (lambda () (set! %load-indent indent))))
- #t)
-
-
-(define (load name)
- (if (eval '(defined? %load-path))
- (load-with-path name (eval '%load-path))
- (load-with-path name '())))
+;;; {Loading by paths}
+
+;;; Load a Scheme source file named NAME, searching for it in the
+;;; directories listed in %load-path, and applying each of the file
+;;; name extensions listed in %load-extensions.
+(define (load-from-path name)
+ (start-stack 'load-stack
+ (primitive-load-path name)))
@@ -1086,6 +914,9 @@
(set! abs magnitude)
+(define (log10 arg)
+ (/ (log arg) (log 10)))
+
;;; {User Settable Hooks}
;;;
@@ -1100,7 +931,6 @@
(define end-of-program #f)
(define hang-up #f)
(define arithmetic-error #f)
-(define read-sharp #f)
@@ -1111,7 +941,7 @@
;;;
(define (parse-path-symbol s)
- (define (seperate-fields-discarding-char ch str ret)
+ (define (separate-fields-discarding-char ch str ret)
(let loop ((fields '())
(str str))
(cond
@@ -1119,41 +949,68 @@
=> (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields)
(make-shared-substring str 0 pos))))
(else (ret (cons str fields))))))
- (seperate-fields-discarding-char #\/
+ (separate-fields-discarding-char #\/
s
(lambda (fields)
(map string->symbol fields))))
-(define (%read-sharp c port)
- (define (barf)
- (error "unknown # object" c))
-
- (case c
- ((#\/) (let ((look (peek-char port)))
- (if (or (eof-object? look)
- (and (char? look)
- (or (char-whitespace? look)
- (string-index ")" look))))
- '()
- (parse-path-symbol (read port #t read-sharp)))))
- ((#\') (read port #t read-sharp))
- ((#\.) (eval (read port #t read-sharp)))
- ((#\b) (read:uniform-vector #t port))
- ((#\a) (read:uniform-vector #\a port))
- ((#\u) (read:uniform-vector 1 port))
- ((#\e) (read:uniform-vector -1 port))
- ((#\s) (read:uniform-vector 1.0 port))
- ((#\i) (read:uniform-vector 1/3 port))
- ((#\c) (read:uniform-vector 0+i port))
- ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
- (read:array c port))
- ((#\!) (if (= 1 (line-number))
- (let skip () (if (eq? #\newline (peek-char port))
- (read port #t read-sharp)
- (begin (read-char port) (skip))))
- (barf)))
- (else (barf))))
+(read-hash-extend #\' (lambda (c port)
+ (read port)))
+(read-hash-extend #\. (lambda (c port)
+ (eval (read port))))
+
+(if (feature? 'array)
+ (begin
+ (let ((make-array-proc (lambda (template)
+ (lambda (c port)
+ (read:uniform-vector template port)))))
+ (for-each (lambda (char template)
+ (read-hash-extend char
+ (make-array-proc template)))
+ '(#\b #\a #\u #\e #\s #\i #\c)
+ '(#t #\a 1 -1 1.0 1/3 0+i)))
+ (let ((array-proc (lambda (c port)
+ (read:array c port))))
+ (for-each (lambda (char) (read-hash-extend char array-proc))
+ '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))))
+
+;; pushed to the beginning of the alist since it's used more than the
+;; others at present.
+(read-hash-extend #\/
+ (lambda (c port)
+ (let ((look (peek-char port)))
+ (if (or (eof-object? look)
+ (and (char? look)
+ (or (char-whitespace? look)
+ (string-index ")" look))))
+ '()
+ (parse-path-symbol (read port))))))
+
+;(define (read-sharp c port)
+; (define (barf)
+; (error "unknown # object" c))
+
+; (case c
+; ((#\/) (let ((look (peek-char port)))
+; (if (or (eof-object? look)
+; (and (char? look)
+; (or (char-whitespace? look)
+; (string-index ")" look))))
+; '()
+; (parse-path-symbol (read port #t read-sharp)))))
+; ((#\') (read port #t read-sharp))
+; ((#\.) (eval (read port #t read-sharp)))
+; ((#\b) (read:uniform-vector #t port))
+; ((#\a) (read:uniform-vector #\a port))
+; ((#\u) (read:uniform-vector 1 port))
+; ((#\e) (read:uniform-vector -1 port))
+; ((#\s) (read:uniform-vector 1.0 port))
+; ((#\i) (read:uniform-vector 1/3 port))
+; ((#\c) (read:uniform-vector 0+i port))
+; ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+; (read:array c port))
+; (else (barf))))
(define (read:array digit port)
(define chr0 (char->integer #\0))
@@ -1174,27 +1031,14 @@
((#\c) 0+i)
(else (error "read:array unknown option " c)))))))
(if (eq? (peek-char port) #\()
- (list->uniform-array rank prot (read port #t read-sharp))
+ (list->uniform-array rank prot (read port))
(error "read:array list not found"))))
(define (read:uniform-vector proto port)
(if (eq? #\( (peek-char port))
- (list->uniform-array 1 proto (read port #t read-sharp))
+ (list->uniform-array 1 proto (read port))
(error "read:uniform-vector list not found")))
-
-(define read-sharp (lambda a (apply %read-sharp a)))
-
-
-
-;;; {Dynamic Roots}
-;;;
-
-; mystery integers passed dynamic root error handlers
-(define repl-quit -1)
-(define repl-abort -2)
-
-
;;; {Command Line Options}
;;;
@@ -1284,15 +1128,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 +1136,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 +1194,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 +1214,74 @@
;; A module is characterized by an obarray in which local symbols
;; are interned, a list of modules, "uses", from which non-local
;; bindings can be inherited, and an optional lazy-binder which
-;; is a (THUNK module symbol) which, as a last resort, can provide
+;; is a (CLOSURE module symbol) which, as a last resort, can provide
;; bindings that would otherwise not be found locally in the module.
;;
(define module-type
- (make-record-type 'module '(obarray uses binder eval-thunk name kind) %print-module))
+ (make-record-type 'module '(obarray uses binder eval-closure name kind)
+ %print-module))
-;; make-module &opt size uses
+;; make-module &opt size uses binder
;;
-;; Create a new module, perhaps with a particular size of obarray
-;; or initial uses list.
+;; Create a new module, perhaps with a particular size of obarray,
+;; initial uses list, or binding procedure.
;;
-(define module-constructor (record-constructor module-type))
-
(define make-module
(lambda args
- (let* ((size 1021)
- (uses '())
- (binder #f)
- (answer #f)
- (eval-thunk
- (lambda (symbol define?)
- (if define?
- (module-make-local-var! answer symbol)
- (module-variable answer symbol)))))
-
- (if (> (length args) 0)
- (begin
- (set! size (or (car args) size))
- (set! args (cdr args))))
- (if (> (length args) 0)
- (begin
- (set! uses (or (car args) uses))
- (set! args (cdr args))))
+ (define (parse-arg index default)
+ (if (> (length args) index)
+ (list-ref args index)
+ default))
- (if (> (length args) 0)
- (begin
- (set! binder (or (car args) binder))
- (set! args (cdr args))))
+ (if (> (length args) 3)
+ (error "Too many args to make-module." args))
- (if (not (null? args))
- (error "Too many args to make-module." args))
+ (let ((size (parse-arg 0 1021))
+ (uses (parse-arg 1 '()))
+ (binder (parse-arg 2 #f)))
(if (not (integer? size))
(error "Illegal size to make-module." size))
-
- (and (list? uses)
- (or (and-map module? uses)
- (error "Incorrect use list." uses)))
-
+ (if (not (and (list? uses)
+ (and-map module? uses)))
+ (error "Incorrect use list." uses))
(if (and binder (not (procedure? binder)))
(error
"Lazy-binder expected to be a procedure or #f." binder))
- (set! answer
- (module-constructor (make-vector size '())
- uses
- binder
- eval-thunk
- #f
- #f))
- answer)))
+ (let ((module (module-constructor (make-vector size '())
+ uses binder #f #f #f)))
+ ;; We can't pass this as an argument to module-constructor,
+ ;; because we need it to close over a pointer to the module
+ ;; itself.
+ (set-module-eval-closure! module
+ (lambda (symbol define?)
+ (if define?
+ (module-make-local-var! module symbol)
+ (module-variable module symbol))))
+
+ module))))
+
+(define module-constructor (record-constructor module-type))
(define module-obarray (record-accessor module-type 'obarray))
(define set-module-obarray! (record-modifier module-type 'obarray))
(define module-uses (record-accessor module-type 'uses))
(define set-module-uses! (record-modifier module-type 'uses))
(define module-binder (record-accessor module-type 'binder))
(define set-module-binder! (record-modifier module-type 'binder))
-(define module-eval-thunk (record-accessor module-type 'eval-thunk))
-(define set-module-eval-thunk! (record-modifier module-type 'eval-thunk))
+(define module-eval-closure (record-accessor module-type 'eval-closure))
+(define set-module-eval-closure! (record-modifier module-type 'eval-closure))
(define module-name (record-accessor module-type 'name))
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define set-module-kind! (record-modifier module-type 'kind))
(define module? (record-predicate module-type))
+
(define (eval-in-module exp module)
- (eval2 exp (module-eval-thunk module)))
+ (eval2 exp (module-eval-closure module)))
;;; {Module Searching in General}
@@ -1581,12 +1405,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 +1536,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 +1552,7 @@
bi))))
(define (make-root-module)
- (make-module 1019 #f root-module-thunk))
+ (make-module 1019 '() root-module-closure))
;; make-scm-module
@@ -1740,7 +1565,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 +1589,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 +1615,14 @@
(set-current-module outer-module)
(set! outer-module #f)))))
-(define basic-try-load-with-path try-load-with-path)
-(define basic-try-load try-load)
-(define basic-load-with-path load-with-path)
(define basic-load load)
-
-(define (try-load-module-with-path . args)
- (save-module-excursion (lambda () (apply basic-try-load-with-path args))))
-
-(define (try-load-module . args)
- (save-module-excursion (lambda () (apply basic-try-load args))))
-
-(define (load-module-with-path . args)
- (save-module-excursion (lambda () (apply basic-load-with-path args))))
-
(define (load-module . args)
(save-module-excursion (lambda () (apply basic-load args))))
-
-;; MODULE-REF -- exported
+;;; {MODULE-REF -- exported}
;;
;; Returns the value of a variable called NAME in MODULE or any of its
;; used modules. If there is no such variable, then if the optional third
@@ -1848,6 +1659,15 @@
(variable-set! variable value)
(module-add! module name (make-variable value name)))))
+;; MODULE-DEFINED? -- exported
+;;
+;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
+;; uses)
+;;
+(define (module-defined? module name)
+ (let ((variable (module-variable module name)))
+ (and variable (variable-bound? variable))))
+
;; MODULE-USE! module interface
;;
;; Add INTERFACE to the list of interfaces used by MODULE.
@@ -1857,9 +1677,6 @@
(cons interface (delq! interface (module-uses module)))))
-
-
-;;;;
;;; {Recursive Namespaces}
;;;
;;;
@@ -1870,7 +1687,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 +1697,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 +1721,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 +1770,19 @@
(set-current-module the-root-module)
(define app (make-module 31))
-(value-define '(app modules) (make-module 31))
-(value-define '(app modules guile) the-root-module)
+(local-define '(app modules) (make-module 31))
+(local-define '(app modules guile) the-root-module)
;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
-(define (resolve-module name)
+(define (resolve-module name . maybe-autoload)
(let ((full-name (append '(app modules) name)))
- (let ((already (value-ref full-name)))
+ (let ((already (local-ref full-name)))
(or already
(begin
- (try-module-autoload name)
+ (if (or (null? maybe-autoload) (car maybe-autoload))
+ (or (try-module-autoload name)
+ (try-module-dynamic-link name)))
(make-modules-in (current-module) full-name))))))
(define (beautify-user-module! module)
@@ -1974,7 +1791,8 @@
(set-module-name! interface (module-name module))
(set-module-kind! interface 'interface)
(set-module-public-interface! module interface)))
- (if (not (memq the-scm-module (module-uses module)))
+ (if (and (not (memq the-scm-module (module-uses module)))
+ (not (eq? module the-root-module)))
(set-module-uses! module (append (module-uses module) (list the-scm-module)))))
(define (make-modules-in module name)
@@ -1997,43 +1815,51 @@
(define (process-define-module args)
(let* ((module-id (car args))
- (module (resolve-module module-id))
+ (module (resolve-module module-id #f))
(kws (cdr args)))
(beautify-user-module! module)
- (let loop ((kws kws))
- (and (not (null? kws))
- (case (car kws)
- ((:use-module)
- (if (not (pair? (cdr kws)))
- (error "unrecognized defmodule argument" kws))
- (let* ((used-name (cadr kws))
- (used-module (resolve-module used-name)))
- (if (not (module-ref used-module '%module-public-interface #f))
- (begin
- ((if %autoloader-developer-mode warn error) "no code for module" used-module)
- (beautify-user-module! used-module)))
- (let ((interface (module-ref used-module '%module-public-interface #f)))
- (if (not interface)
- (error "missing interface for use-module" used-module))
- (set-module-uses! module
- (append! (delq! interface (module-uses module))
- (list interface)))))
- (loop (cddr kws)))
-
- (else (error "unrecognized defmodule argument" kws)))))
+ (let loop ((kws kws)
+ (reversed-interfaces '()))
+ (if (null? kws)
+ (for-each (lambda (interface)
+ (module-use! module interface))
+ reversed-interfaces)
+ (case (cond ((keyword? (car kws))
+ (keyword->symbol (car kws)))
+ ((and (symbol? (car kws))
+ (eq? (string-ref (car kws) 0) #\:))
+ (string->symbol (substring (car kws) 1)))
+ (else #f))
+ ((use-module)
+ (if (not (pair? (cdr kws)))
+ (error "unrecognized defmodule argument" kws))
+ (let* ((used-name (cadr kws))
+ (used-module (resolve-module used-name)))
+ (if (not (module-ref used-module '%module-public-interface #f))
+ (begin
+ ((if %autoloader-developer-mode warn error)
+ "no code for module" (module-name used-module))
+ (beautify-user-module! used-module)))
+ (let ((interface (module-public-interface used-module)))
+ (if (not interface)
+ (error "missing interface for use-module" used-module))
+ (loop (cddr kws) (cons interface reversed-interfaces)))))
+ (else
+ (error "unrecognized defmodule argument" kws)))))
module))
+;;; {Autoloading modules}
(define autoloads-in-progress '())
(define (try-module-autoload module-name)
-
+
(define (sfx name) (string-append name (scheme-file-suffix)))
(let* ((reverse-name (reverse module-name))
(name (car reverse-name))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name))))
- (resolve-module dir-hint-module-name)
+ (resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
(let ((didit #f))
(dynamic-wind
@@ -2051,13 +1877,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 +1893,156 @@
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
+;;; Dynamic linking of modules
+
+;; Initializing a module that is written in C is a two step process.
+;; First the module's `module init' function is called. This function
+;; is expected to call `scm_register_module_xxx' to register the `real
+;; init' function. Later, when the module is referenced for the first
+;; time, this real init function is called in the right context. See
+;; gtcltk-lib/gtcltk-module.c for an example.
+;;
+;; The code for the module can be in a regular shared library (so that
+;; the `module init' function will be called when libguile is
+;; initialized). Or it can be dynamically linked.
+;;
+;; You can safely call `scm_register_module_xxx' before libguile
+;; itself is initialized. You could call it from an C++ constructor
+;; of a static object, for example.
+;;
+;; To make your Guile extension into a dynamic linkable module, follow
+;; these easy steps:
+;;
+;; - Find a name for your module, like #/ice-9/gtcltk
+;; - Write a function with a name like
+;;
+;; scm_init_ice_9_gtcltk_module
+;;
+;; This is your `module init' function. It should call
+;;
+;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk);
+;;
+;; "ice-9 gtcltk" is the C version of the module name. Slashes are
+;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is
+;; the real init function that executes the usual initializations
+;; like making new smobs, etc.
+;;
+;; - Make a shared library with your code and a name like
+;;
+;; ice-9/libgtcltk.so
+;;
+;; and put it somewhere in %load-path.
+;;
+;; - Then you can simply write `:use-module #/ice-9/gtcltk' and it
+;; will be linked automatically.
+;;
+;; This is all very experimental.
+
+(define (split-c-module-name str)
+ (let loop ((rev '())
+ (start 0)
+ (pos 0)
+ (end (string-length str)))
+ (cond
+ ((= pos end)
+ (reverse (cons (string->symbol (substring str start pos)) rev)))
+ ((eq? (string-ref str pos) #\space)
+ (loop (cons (string->symbol (substring str start pos)) rev)
+ (+ pos 1)
+ (+ pos 1)
+ end))
+ (else
+ (loop rev start (+ pos 1) end)))))
+
+(define (convert-c-registered-modules dynobj)
+ (let ((res (map (lambda (c)
+ (list (split-c-module-name (car c)) (cdr c) dynobj))
+ (c-registered-modules))))
+ (c-clear-registered-modules)
+ res))
+
+(define registered-modules (convert-c-registered-modules #f))
+
+(define (init-dynamic-module modname)
+ (or-map (lambda (modinfo)
+ (if (equal? (car modinfo) modname)
+ (let ((mod (resolve-module modname #f)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module mod)
+ (dynamic-call (cadr modinfo) (caddr modinfo))
+ (set-module-public-interface! mod mod)))
+ (set! registered-modules (delq! modinfo registered-modules))
+ #t)
+ #f))
+ registered-modules))
+
+(define (dynamic-maybe-call name dynobj)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-call name dynobj))
+ (lambda args
+ #f)))
+
+(define (dynamic-maybe-link filename)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-link filename))
+ (lambda args
+ #f)))
+
+(define (find-and-link-dynamic-module module-name)
+ (define (make-init-name mod-name)
+ (string-append 'scm_init
+ (list->string (map (lambda (c)
+ (if (or (char-alphabetic? c)
+ (char-numeric? c))
+ c
+ #\_))
+ (string->list mod-name)))
+ '_module))
+ (let ((libname
+ (let loop ((dirs "")
+ (syms module-name))
+ (cond
+ ((null? (cdr syms))
+ (string-append dirs "lib" (car syms) ".so"))
+ (else
+ (loop (string-append dirs (car syms) "/") (cdr syms))))))
+ (init (make-init-name (apply string-append
+ (map (lambda (s)
+ (string-append "_" s))
+ module-name)))))
+ ;; (pk 'libname libname 'init init)
+ (or-map
+ (lambda (dir)
+ (let ((full (in-vicinity dir libname)))
+ ;; (pk 'trying full)
+ (if (file-exists? full)
+ (begin
+ (link-dynamic-module full init)
+ #t)
+ #f)))
+ %load-path)))
+
+(define (link-dynamic-module filename initname)
+ (let ((dynobj (dynamic-maybe-link filename)))
+ (if dynobj
+ (if (dynamic-maybe-call initname dynobj)
+ (set! registered-modules
+ (append! (convert-c-registered-modules dynobj)
+ registered-modules))
+ (begin
+ (pk 'no_init)
+ (dynamic-unlink dynobj))))))
+
+(define (try-module-dynamic-link module-name)
+ (or (init-dynamic-module module-name)
+ (and (find-and-link-dynamic-module module-name)
+ (init-dynamic-module module-name))))
+
+
+
(define autoloads-done '((guile . guile)))
(define (autoload-done-or-in-progress? p m)
@@ -2101,8 +2077,8 @@
;;; {Macros}
;;;
-(define macro-table (make-weak-hash-table 523))
-(define xformer-table (make-weak-hash-table 523))
+(define macro-table (make-weak-key-hash-table 523))
+(define xformer-table (make-weak-key-hash-table 523))
(define (defmacro? m) (hashq-ref macro-table m))
(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
@@ -2135,10 +2111,14 @@
(lambda (exp env)
(copy-tree (apply f (cdr exp)))))))
+
+;; XXX - should the definition of the car really be looked up in the
+;; current module?
+
(define (macroexpand-1 e)
(cond
((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
+ (val (and (symbol? a) (local-ref (list a)))))
(if (defmacro? val)
(apply (defmacro-transformer val) (cdr e))
e)))
@@ -2147,7 +2127,7 @@
(define (macroexpand e)
(cond
((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (eval `(defined? ,a)) (eval a))))
+ (val (and (symbol? a) (local-ref (list a)))))
(if (defmacro? val)
(macroexpand (apply (defmacro-transformer val) (cdr e)))
e)))
@@ -2167,72 +2147,194 @@
;;;
(define (repl read evaler print)
- (let loop ((source (read (current-input-port) #t read-sharp)))
+ (let loop ((source (read (current-input-port))))
(print (evaler source))
- (loop (read (current-input-port) #t read-sharp))))
+ (loop (read (current-input-port)))))
;; A provisional repl that acts like the SCM repl:
;;
(define scm-repl-silent #f)
(define (assert-repl-silence v) (set! scm-repl-silent v))
-(define scm-repl-verbose #t)
+(define *unspecified* (if #f #f))
+(define (unspecified? v) (eq? v *unspecified*))
+
+(define scm-repl-print-unspecified #f)
+(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
+
+(define scm-repl-verbose #f)
(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
-(define scm-repl-prompt #t)
-(define (assert-repl-prompt v) (set! scm-repl-prompt v))
+(define scm-repl-prompt "guile> ")
+
+(define (set-repl-prompt! v) (set! scm-repl-prompt v))
+
+(define (default-lazy-handler key . args)
+ (save-stack lazy-handler-dispatch)
+ (apply throw key args))
+
+(define apply-frame-handler default-lazy-handler)
+(define exit-frame-handler default-lazy-handler)
-(define the-prompt-string "guile> ")
+(define (lazy-handler-dispatch key . args)
+ (case key
+ ((apply-frame)
+ (apply apply-frame-handler key args))
+ ((exit-frame)
+ (apply exit-frame-handler key args))
+ (else
+ (apply default-lazy-handler key args))))
+
+(define abort-hook '())
(define (error-catching-loop thunk)
- (define (loop first)
- (let ((next
- (catch #t
- (lambda ()
- (dynamic-wind
- (lambda () (unmask-signals))
- (lambda ()
- (first)
-
- ;; This line is needed because mark doesn't do closures quite right.
- ;; Unreferenced locals should be collected.
- ;;
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)
- (lambda () (mask-signals))))
-
- (lambda (key . args)
- (case key
- ((quit) (force-output)
- (pk 'quit args)
- #f)
-
- ((abort) ;; This is one of the closures that require (set! first #f)
- ;; above
- ;;
- (lambda ()
- (force-output)
- (display "ABORT: " (current-error-port))
- (write args (current-error-port))
- (newline (current-error-port))))
-
- (else ;; This is the other cons-leak closure...
- (lambda ()
- (apply %%bad-throw key args))))))))
- (and next (loop next))))
- (loop (lambda () #t)))
+ (let ((status #f))
+ (define (loop first)
+ (let ((next
+ (catch #t
+
+ (lambda ()
+ (lazy-catch #t
+ (lambda ()
+ (dynamic-wind
+ (lambda () (unmask-signals))
+ (lambda ()
+ (first)
+
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ ;;
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)
+ (lambda () (mask-signals))))
+
+ lazy-handler-dispatch))
+
+ (lambda (key . args)
+ (case key
+ ((quit)
+ (read-line) ; discard trailing junk and linefeed.
+ (force-output)
+ (set! status args)
+ #f)
+
+ ((switch-repl)
+ (apply throw 'switch-repl args))
+
+ ((abort)
+ ;; This is one of the closures that require
+ ;; (set! first #f) above
+ ;;
+ (lambda ()
+ (run-hooks abort-hook)
+ (force-output)
+ (display "ABORT: " (current-error-port))
+ (write args (current-error-port))
+ (newline (current-error-port))
+ (if (and (not has-shown-debugger-hint?)
+ (not (memq 'backtrace
+ (debug-options-interface)))
+ (stack? the-last-stack))
+ (begin
+ (newline (current-error-port))
+ (display
+ "Type \"(backtrace)\" to get more information.\n"
+ (current-error-port))
+ (set! has-shown-debugger-hint? #t)))
+ (set! stack-saved? #f)))
+
+ (else
+ ;; This is the other cons-leak closure...
+ (lambda ()
+ (cond ((= (length args) 4)
+ (apply handle-system-error key args))
+ (else
+ (apply bad-throw key args))))))))))
+ (if next (loop next) status)))
+ (loop (lambda () #t))))
+
+;;(define the-last-stack #f) Defined by scm_init_backtrace ()
+(define stack-saved? #f)
+
+(define (save-stack . narrowing)
+ (cond (stack-saved?)
+ ((not (memq 'debug (debug-options-interface)))
+ (set! the-last-stack #f)
+ (set! stack-saved? #t))
+ (else
+ (set! the-last-stack
+ (case (stack-id #t)
+ ((repl-stack)
+ (apply make-stack #t save-stack eval narrowing))
+ ((load-stack)
+ (apply make-stack #t save-stack gsubr-apply narrowing))
+ ((tk-stack)
+ (apply make-stack #t save-stack tk-stack-mark narrowing))
+ ((#t)
+ (apply make-stack #t save-stack 0 1 narrowing))
+ (else (let ((id (stack-id #t)))
+ (and (procedure? id)
+ (apply make-stack #t save-stack id narrowing))))))
+ (set! stack-saved? #t))))
+
+(define before-error-hook '())
+(define after-error-hook '())
+(define before-backtrace-hook '())
+(define after-backtrace-hook '())
+
+(define has-shown-debugger-hint? #f)
+
+(define (handle-system-error key . args)
+ (let ((cep (current-error-port)))
+ (cond ((not (stack? the-last-stack)))
+ ((memq 'backtrace (debug-options-interface))
+ (run-hooks before-backtrace-hook)
+ (newline cep)
+ (display-backtrace the-last-stack cep)
+ (newline cep)
+ (run-hooks after-backtrace-hook)))
+ (run-hooks before-error-hook)
+ (apply display-error the-last-stack cep args)
+ (run-hooks after-error-hook)
+ (force-output cep)
+ (throw 'abort key)))
(define (quit . args)
(apply throw 'quit args))
+(define exit quit)
+
+;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
+
+;; Replaced by C code:
+;;(define (backtrace)
+;; (if the-last-stack
+;; (begin
+;; (newline)
+;; (display-backtrace the-last-stack (current-output-port))
+;; (newline)
+;; (if (and (not has-shown-backtrace-hint?)
+;; (not (memq 'backtrace (debug-options-interface))))
+;; (begin
+;; (display
+;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
+;;automatically if an error occurs in the future.\n")
+;; (set! has-shown-backtrace-hint? #t))))
+;; (display "No backtrace available.\n")))
+
(define (error-catching-repl r e p)
(error-catching-loop (lambda () (p (e (r))))))
(define (gc-run-time)
(cdr (assq 'gc-time-taken (gc-stats))))
+(define before-read-hook '())
+(define after-read-hook '())
+
(define (scm-style-repl)
(letrec (
(start-gc-rt #f)
@@ -2254,12 +2356,19 @@
(-read (lambda ()
(if scm-repl-prompt
(begin
- (display the-prompt-string)
+ (display (cond ((string? scm-repl-prompt)
+ scm-repl-prompt)
+ ((thunk? scm-repl-prompt)
+ (scm-repl-prompt))
+ (else "> ")))
(force-output)
(repl-report-reset)))
- (let ((val (read (current-input-port) #t read-sharp)))
+ (run-hooks before-read-hook)
+ (let ((val (read (current-input-port))))
+ (run-hooks after-read-hook)
(if (eof-object? val)
(begin
+ (repl-report-start-timing)
(if scm-repl-verbose
(begin
(newline)
@@ -2270,24 +2379,27 @@
(-eval (lambda (sourc)
(repl-report-start-timing)
- (eval sourc)))
+ (start-stack 'repl-stack (eval sourc))))
(-print (lambda (result)
(if (not scm-repl-silent)
(begin
- (print result)
- (newline)
+ (if (or scm-repl-print-unspecified
+ (not (unspecified? result)))
+ (begin
+ (write result)
+ (newline)))
(if scm-repl-verbose
(repl-report))
(force-output)))))
- (-quit (lambda ()
+ (-quit (lambda (args)
(if scm-repl-verbose
(begin
(display ";;; QUIT executed, repl exitting")
(newline)
(repl-report)))
- #t))
+ args))
(-abort (lambda ()
(if scm-repl-verbose
@@ -2297,19 +2409,21 @@
(repl-report)))
(repl -read -eval -print))))
- (error-catching-repl -read
- -eval
- -print)))
+ (let ((status (error-catching-repl -read
+ -eval
+ -print)))
+ (-quit status))))
+
-(define (stand-alone-repl)
- (let ((oport (current-input-port)))
- (set-current-input-port *stdin*)
- (scm-style-repl)
- (set-current-input-port oport)))
+;(define (stand-alone-repl)
+; (let ((oport (current-input-port)))
+; (set-current-input-port *stdin*)
+; (scm-style-repl)
+; (set-current-input-port oport)))
-
+;;; {IOTA functions: generating lists of numbers}
(define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
(define (iota n) (list-reverse! (reverse-iota n)))
@@ -2364,6 +2478,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 +2546,13 @@
-(define try-load-with-path try-load-module-with-path)
-(define try-load try-load-module)
-(define load-with-path load-module-with-path)
(define load load-module)
+;(define (load . args)
+; (start-stack 'load-stack (apply load-module args)))
+;;; {I/O functions for Tcl channels (disabled)}
;; (define in-ch (get-standard-channel TCL_STDIN))
;; (define out-ch (get-standard-channel TCL_STDOUT))
@@ -2467,13 +2587,18 @@
;; (set-current-output-port outp)
;; (set-current-error-port errp)
-(define (top-repl) (scm-style-repl))
+(define (top-repl)
+ (scm-style-repl))
+
+(defmacro false-if-exception (expr)
+ `(catch #t (lambda () ,expr)
+ (lambda args #f)))
+;;; {Calling Conventions}
(define-module (ice-9 calling))
;;;;
-;;; {Calling Conventions}
;;;
;;; This file contains a number of macros that support
;;; common calling conventions.
@@ -2771,6 +2896,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 +2919,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 +3077,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 +3116,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 +3140,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 +3166,6 @@
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;
-
;;;;
;;; Q: Based on the interface to
;;;
@@ -3044,7 +3173,6 @@
;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
;;;
-
;;;;
;;; {Q}
;;;
@@ -3156,12 +3284,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 +3306,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 +3524,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 +3658,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 +3667,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 +3676,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 +3686,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 +3704,7 @@
(define-public string-prefix=? (string-prefix-predicate string=?))
-;;;;
-;;; {Strippers}
+;;; {String Fun: Strippers}
;;;
;;; <stripper> = sans-<removable-part>
;;;
@@ -3639,8 +3757,7 @@
(else str)))
-;;;;
-;;; {has-trailing-newline?}
+;;; {String Fun: has-trailing-newline?}
;;;
(define-public (has-trailing-newline? str)
@@ -3649,7 +3766,7 @@
-
+;;; {String Fun: with-regexp-parts}
(define-public (with-regexp-parts regexp fields str return fail)
(let ((parts (regexec regexp str fields)))
@@ -3658,6 +3775,44 @@
(apply return parts))))
+;;; {Load debug extension code if debug extensions present.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (memq 'debug-extensions *features*)
+ (define-module (guile) :use-module (ice-9 debug)))
+
+
+;;; {Load session support if present.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (%search-load-path "ice-9/session.scm")
+ (define-module (guile) :use-module (ice-9 session)))
+
+
+;;; {Load thread code if threads are present.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (memq 'threads *features*)
+ (define-module (guile) :use-module (ice-9 threads)))
+
+
+;;; {Load emacs interface support if emacs option is given.}
+;;;
+;;; *fixme* This is a temporary solution.
+;;;
+
+(if (and (module-defined? the-root-module 'use-emacs-interface)
+ use-emacs-interface)
+ (define-module (guile) :use-module (ice-9 emacs)))
+
+
(define-module (guile))
+(append! %load-path (cons "." ()))
diff --git a/ice-9/configure b/ice-9/configure
index 25b98d1a0..e69de29bb 100755
--- a/ice-9/configure
+++ b/ice-9/configure
@@ -1,722 +0,0 @@
-#! /bin/sh
-
-# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.9
-# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
-#
-# This configure script is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-
-# Defaults:
-ac_help=
-ac_default_prefix=/usr/local
-# Any additions from configure.in:
-
-# Initialize some variables set by options.
-# The variables have the same names as the options, with
-# dashes changed to underlines.
-build=NONE
-cache_file=./config.cache
-exec_prefix=NONE
-host=NONE
-no_create=
-nonopt=NONE
-no_recursion=
-prefix=NONE
-program_prefix=NONE
-program_suffix=NONE
-program_transform_name=s,x,x,
-silent=
-site=
-srcdir=
-target=NONE
-verbose=
-x_includes=NONE
-x_libraries=NONE
-bindir='${exec_prefix}/bin'
-sbindir='${exec_prefix}/sbin'
-libexecdir='${exec_prefix}/libexec'
-datadir='${prefix}/share'
-sysconfdir='${prefix}/etc'
-sharedstatedir='${prefix}/com'
-localstatedir='${prefix}/var'
-libdir='${exec_prefix}/lib'
-includedir='${prefix}/include'
-oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
-
-# Initialize some other variables.
-subdirs=
-MFLAGS= MAKEFLAGS=
-
-ac_prev=
-for ac_option
-do
-
- # If the previous option needs an argument, assign it.
- if test -n "$ac_prev"; then
- eval "$ac_prev=\$ac_option"
- ac_prev=
- continue
- fi
-
- case "$ac_option" in
- -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
- *) ac_optarg= ;;
- esac
-
- # Accept the important Cygnus configure options, so we can diagnose typos.
-
- case "$ac_option" in
-
- -bindir | --bindir | --bindi | --bind | --bin | --bi)
- ac_prev=bindir ;;
- -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
- bindir="$ac_optarg" ;;
-
- -build | --build | --buil | --bui | --bu)
- ac_prev=build ;;
- -build=* | --build=* | --buil=* | --bui=* | --bu=*)
- build="$ac_optarg" ;;
-
- -cache-file | --cache-file | --cache-fil | --cache-fi \
- | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
- ac_prev=cache_file ;;
- -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
- | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
- cache_file="$ac_optarg" ;;
-
- -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
- ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
- | --da=*)
- datadir="$ac_optarg" ;;
-
- -disable-* | --disable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- eval "enable_${ac_feature}=no" ;;
-
- -enable-* | --enable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "enable_${ac_feature}='$ac_optarg'" ;;
-
- -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
- | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
- | --exec | --exe | --ex)
- ac_prev=exec_prefix ;;
- -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
- | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
- | --exec=* | --exe=* | --ex=*)
- exec_prefix="$ac_optarg" ;;
-
- -gas | --gas | --ga | --g)
- # Obsolete; use --with-gas.
- with_gas=yes ;;
-
- -help | --help | --hel | --he)
- # Omit some internal or obsolete options to make the list less imposing.
- # This message is too long to be a string in the A/UX 3.1 sh.
- cat << EOF
-Usage: configure [options] [host]
-Options: [defaults in brackets after descriptions]
-Configuration:
- --cache-file=FILE cache test results in FILE
- --help print this message
- --no-create do not create output files
- --quiet, --silent do not print \`checking...' messages
- --version print the version of autoconf that created configure
-Directory and file names:
- --prefix=PREFIX install architecture-independent files in PREFIX
- [$ac_default_prefix]
- --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [same as prefix]
- --bindir=DIR user executables in DIR [EPREFIX/bin]
- --sbindir=DIR system admin executables in DIR [EPREFIX/sbin]
- --libexecdir=DIR program executables in DIR [EPREFIX/libexec]
- --datadir=DIR read-only architecture-independent data in DIR
- [PREFIX/share]
- --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc]
- --sharedstatedir=DIR modifiable architecture-independent data in DIR
- [PREFIX/com]
- --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var]
- --libdir=DIR object code libraries in DIR [EPREFIX/lib]
- --includedir=DIR C header files in DIR [PREFIX/include]
- --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include]
- --infodir=DIR info documentation in DIR [PREFIX/info]
- --mandir=DIR man documentation in DIR [PREFIX/man]
- --srcdir=DIR find the sources in DIR [configure dir or ..]
- --program-prefix=PREFIX prepend PREFIX to installed program names
- --program-suffix=SUFFIX append SUFFIX to installed program names
- --program-transform-name=PROGRAM
- run sed PROGRAM on installed program names
-EOF
- cat << EOF
-Host type:
- --build=BUILD configure for building on BUILD [BUILD=HOST]
- --host=HOST configure for HOST [guessed]
- --target=TARGET configure for TARGET [TARGET=HOST]
-Features and packages:
- --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
- --enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --x-includes=DIR X include files are in DIR
- --x-libraries=DIR X library files are in DIR
-EOF
- if test -n "$ac_help"; then
- echo "--enable and --with options recognized:$ac_help"
- fi
- exit 0 ;;
-
- -host | --host | --hos | --ho)
- ac_prev=host ;;
- -host=* | --host=* | --hos=* | --ho=*)
- host="$ac_optarg" ;;
-
- -includedir | --includedir | --includedi | --included | --include \
- | --includ | --inclu | --incl | --inc)
- ac_prev=includedir ;;
- -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
- | --includ=* | --inclu=* | --incl=* | --inc=*)
- includedir="$ac_optarg" ;;
-
- -infodir | --infodir | --infodi | --infod | --info | --inf)
- ac_prev=infodir ;;
- -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
- infodir="$ac_optarg" ;;
-
- -libdir | --libdir | --libdi | --libd)
- ac_prev=libdir ;;
- -libdir=* | --libdir=* | --libdi=* | --libd=*)
- libdir="$ac_optarg" ;;
-
- -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
- | --libexe | --libex | --libe)
- ac_prev=libexecdir ;;
- -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
- | --libexe=* | --libex=* | --libe=*)
- libexecdir="$ac_optarg" ;;
-
- -localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst \
- | --locals | --local | --loca | --loc | --lo)
- ac_prev=localstatedir ;;
- -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* \
- | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
- localstatedir="$ac_optarg" ;;
-
- -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
- ac_prev=mandir ;;
- -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
- mandir="$ac_optarg" ;;
-
- -nfp | --nfp | --nf)
- # Obsolete; use --without-fp.
- with_fp=no ;;
-
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c)
- no_create=yes ;;
-
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
- no_recursion=yes ;;
-
- -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
- | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
- | --oldin | --oldi | --old | --ol | --o)
- ac_prev=oldincludedir ;;
- -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
- | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
- | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
- oldincludedir="$ac_optarg" ;;
-
- -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
- ac_prev=prefix ;;
- -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
- prefix="$ac_optarg" ;;
-
- -program-prefix | --program-prefix | --program-prefi | --program-pref \
- | --program-pre | --program-pr | --program-p)
- ac_prev=program_prefix ;;
- -program-prefix=* | --program-prefix=* | --program-prefi=* \
- | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
- program_prefix="$ac_optarg" ;;
-
- -program-suffix | --program-suffix | --program-suffi | --program-suff \
- | --program-suf | --program-su | --program-s)
- ac_prev=program_suffix ;;
- -program-suffix=* | --program-suffix=* | --program-suffi=* \
- | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
- program_suffix="$ac_optarg" ;;
-
- -program-transform-name | --program-transform-name \
- | --program-transform-nam | --program-transform-na \
- | --program-transform-n | --program-transform- \
- | --program-transform | --program-transfor \
- | --program-transfo | --program-transf \
- | --program-trans | --program-tran \
- | --progr-tra | --program-tr | --program-t)
- ac_prev=program_transform_name ;;
- -program-transform-name=* | --program-transform-name=* \
- | --program-transform-nam=* | --program-transform-na=* \
- | --program-transform-n=* | --program-transform-=* \
- | --program-transform=* | --program-transfor=* \
- | --program-transfo=* | --program-transf=* \
- | --program-trans=* | --program-tran=* \
- | --progr-tra=* | --program-tr=* | --program-t=*)
- program_transform_name="$ac_optarg" ;;
-
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- silent=yes ;;
-
- -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
- ac_prev=sbindir ;;
- -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
- | --sbi=* | --sb=*)
- sbindir="$ac_optarg" ;;
-
- -sharedstatedir | --sharedstatedir | --sharedstatedi \
- | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
- | --sharedst | --shareds | --shared | --share | --shar \
- | --sha | --sh)
- ac_prev=sharedstatedir ;;
- -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
- | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
- | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
- | --sha=* | --sh=*)
- sharedstatedir="$ac_optarg" ;;
-
- -site | --site | --sit)
- ac_prev=site ;;
- -site=* | --site=* | --sit=*)
- site="$ac_optarg" ;;
-
- -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
- ac_prev=srcdir ;;
- -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
- srcdir="$ac_optarg" ;;
-
- -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
- | --syscon | --sysco | --sysc | --sys | --sy)
- ac_prev=sysconfdir ;;
- -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
- | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
- sysconfdir="$ac_optarg" ;;
-
- -target | --target | --targe | --targ | --tar | --ta | --t)
- ac_prev=target ;;
- -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
- target="$ac_optarg" ;;
-
- -v | -verbose | --verbose | --verbos | --verbo | --verb)
- verbose=yes ;;
-
- -version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.9"
- exit 0 ;;
-
- -with-* | --with-*)
- ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "with_${ac_package}='$ac_optarg'" ;;
-
- -without-* | --without-*)
- ac_package=`echo $ac_option|sed -e 's/-*without-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- eval "with_${ac_package}=no" ;;
-
- --x)
- # Obsolete; use --with-x.
- with_x=yes ;;
-
- -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
- | --x-incl | --x-inc | --x-in | --x-i)
- ac_prev=x_includes ;;
- -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
- | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
- x_includes="$ac_optarg" ;;
-
- -x-libraries | --x-libraries | --x-librarie | --x-librari \
- | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
- ac_prev=x_libraries ;;
- -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
- | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
- x_libraries="$ac_optarg" ;;
-
- -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
- ;;
-
- *)
- if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
- echo "configure: warning: $ac_option: invalid host type" 1>&2
- fi
- if test "x$nonopt" != xNONE; then
- { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
- fi
- nonopt="$ac_option"
- ;;
-
- esac
-done
-
-if test -n "$ac_prev"; then
- { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
-fi
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-# File descriptor usage:
-# 0 standard input
-# 1 file creation
-# 2 errors and warnings
-# 3 some systems may open it to /dev/tty
-# 4 used on the Kubota Titan
-# 6 checking for... messages and results
-# 5 compiler messages saved in config.log
-if test "$silent" = yes; then
- exec 6>/dev/null
-else
- exec 6>&1
-fi
-exec 5>./config.log
-
-echo "\
-This file contains any messages produced by compilers while
-running configure, to aid debugging if configure makes a mistake.
-" 1>&5
-
-# Strip out --no-create and --no-recursion so they do not pile up.
-# Also quote any args containing shell metacharacters.
-ac_configure_args=
-for ac_arg
-do
- case "$ac_arg" in
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c) ;;
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
- ac_configure_args="$ac_configure_args '$ac_arg'" ;;
- *) ac_configure_args="$ac_configure_args $ac_arg" ;;
- esac
-done
-
-# NLS nuisances.
-# Only set LANG and LC_ALL to C if already set.
-# These must not be set unconditionally because not all systems understand
-# e.g. LANG=C (notably SCO).
-if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
-if test "${LANG+set}" = set; then LANG=C; export LANG; fi
-
-# confdefs.h avoids OS command line length limits that DEFS can exceed.
-rm -rf conftest* confdefs.h
-# AIX cpp loses on an empty file, so make sure it contains at least a newline.
-echo > confdefs.h
-
-# A filename unique to this package, relative to the directory that
-# configure is in, which we can look for to find out if srcdir is correct.
-ac_unique_file=boot-9.scm
-
-# Find the source files, if location was not specified.
-if test -z "$srcdir"; then
- ac_srcdir_defaulted=yes
- # Try the directory containing this script, then its parent.
- ac_prog=$0
- ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
- test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
- srcdir=$ac_confdir
- if test ! -r $srcdir/$ac_unique_file; then
- srcdir=..
- fi
-else
- ac_srcdir_defaulted=no
-fi
-if test ! -r $srcdir/$ac_unique_file; then
- if test "$ac_srcdir_defaulted" = yes; then
- { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
- else
- { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
- fi
-fi
-srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
-
-# Prefer explicitly selected file to automatically selected ones.
-if test -z "$CONFIG_SITE"; then
- if test "x$prefix" != xNONE; then
- CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
- else
- CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
- fi
-fi
-for ac_site_file in $CONFIG_SITE; do
- if test -r "$ac_site_file"; then
- echo "loading site script $ac_site_file"
- . "$ac_site_file"
- fi
-done
-
-if test -r "$cache_file"; then
- echo "loading cache $cache_file"
- . $cache_file
-else
- echo "creating cache $cache_file"
- > $cache_file
-fi
-
-ac_ext=c
-# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
-ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
-
-if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
- # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
- if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
- ac_n= ac_c='
-' ac_t=' '
- else
- ac_n=-n ac_c= ac_t=
- fi
-else
- ac_n= ac_c='\c' ac_t=
-fi
-
-
-
-. $srcdir/../GUILE-VERSION
-
-scm_files=""
-aux_files=""
-. $srcdir/PLUGIN/this.configure
-
-
-
-
-
-trap '' 1 2 15
-cat > confcache <<\EOF
-# This file is a shell script that caches the results of configure
-# tests run on this system so they can be shared between configure
-# scripts and configure runs. It is not useful on other systems.
-# If it contains results you don't want to keep, you may remove or edit it.
-#
-# By default, configure uses ./config.cache as the cache file,
-# creating it if it does not exist already. You can give configure
-# the --cache-file=FILE option to use a different cache file; that is
-# what configure does when it calls configure scripts in
-# subdirectories, so they share the cache.
-# Giving --cache-file=/dev/null disables caching, for debugging configure.
-# config.status only pays attention to the cache file if you give it the
-# --recheck option to rerun configure.
-#
-EOF
-# Ultrix sh set writes to stderr and can't be redirected directly,
-# and sets the high bit in the cache file unless we assign to the vars.
-(set) 2>&1 |
- sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \
- >> confcache
-if cmp -s $cache_file confcache; then
- :
-else
- if test -w $cache_file; then
- echo "updating cache $cache_file"
- cat confcache > $cache_file
- else
- echo "not updating unwritable cache $cache_file"
- fi
-fi
-rm -f confcache
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-test "x$prefix" = xNONE && prefix=$ac_default_prefix
-# Let make expand exec_prefix.
-test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
-
-# Any assignment to VPATH causes Sun make to only execute
-# the first set of double-colon rules, so remove it if not needed.
-# If there is a colon in the path, we need to keep it.
-if test "x$srcdir" = x.; then
- ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d'
-fi
-
-trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
-
-# Transform confdefs.h into DEFS.
-# Protect against shell expansion while executing Makefile rules.
-# Protect against Makefile macro expansion.
-cat > conftest.defs <<\EOF
-s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
-s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g
-s%\[%\\&%g
-s%\]%\\&%g
-s%\$%$$%g
-EOF
-DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
-rm -f conftest.defs
-
-
-# Without the "./", some shells look in PATH for config.status.
-: ${CONFIG_STATUS=./config.status}
-
-echo creating $CONFIG_STATUS
-rm -f $CONFIG_STATUS
-cat > $CONFIG_STATUS <<EOF
-#! /bin/sh
-# Generated automatically by configure.
-# Run this file to recreate the current configuration.
-# This directory was configured as follows,
-# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
-#
-# $0 $ac_configure_args
-#
-# Compiler output produced by configure, useful for debugging
-# configure, is in ./config.log if it exists.
-
-ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
-for ac_option
-do
- case "\$ac_option" in
- -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
- echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
- exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
- -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
- echo "$CONFIG_STATUS generated by autoconf version 2.9"
- exit 0 ;;
- -help | --help | --hel | --he | --h)
- echo "\$ac_cs_usage"; exit 0 ;;
- *) echo "\$ac_cs_usage"; exit 1 ;;
- esac
-done
-
-ac_given_srcdir=$srcdir
-
-trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-# Protect against being on the right side of a sed subst in config.status.
-sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
- s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
-$ac_vpsub
-$extrasub
-s%@CFLAGS@%$CFLAGS%g
-s%@CPPFLAGS@%$CPPFLAGS%g
-s%@CXXFLAGS@%$CXXFLAGS%g
-s%@DEFS@%$DEFS%g
-s%@LDFLAGS@%$LDFLAGS%g
-s%@LIBS@%$LIBS%g
-s%@exec_prefix@%$exec_prefix%g
-s%@prefix@%$prefix%g
-s%@program_transform_name@%$program_transform_name%g
-s%@bindir@%$bindir%g
-s%@sbindir@%$sbindir%g
-s%@libexecdir@%$libexecdir%g
-s%@datadir@%$datadir%g
-s%@sysconfdir@%$sysconfdir%g
-s%@sharedstatedir@%$sharedstatedir%g
-s%@localstatedir@%$localstatedir%g
-s%@libdir@%$libdir%g
-s%@includedir@%$includedir%g
-s%@oldincludedir@%$oldincludedir%g
-s%@infodir@%$infodir%g
-s%@mandir@%$mandir%g
-s%@scm_files@%$scm_files%g
-s%@aux_files@%$aux_files%g
-s%@library_name@%$library_name%g
-s%@info_files@%$info_files%g
-s%@GUILE_VERSION@%$GUILE_VERSION%g
-
-CEOF
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
-EOF
-cat >> $CONFIG_STATUS <<\EOF
-for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile]", defaulting infile="outfile.in".
- case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
- ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
- *) ac_file_in="${ac_file}.in" ;;
- esac
-
- # Adjust relative srcdir, etc. for subdirectories.
-
- # Remove last slash and all that follows it. Not all systems have dirname.
- ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
- if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
- # The file is in a subdirectory.
- test ! -d "$ac_dir" && mkdir "$ac_dir"
- ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
- # A "../" for each directory in $ac_dir_suffix.
- ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
- else
- ac_dir_suffix= ac_dots=
- fi
-
- case "$ac_given_srcdir" in
- .) srcdir=.
- if test -z "$ac_dots"; then top_srcdir=.
- else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
- /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
- *) # Relative path.
- srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
- top_srcdir="$ac_dots$ac_given_srcdir" ;;
- esac
-
- echo creating "$ac_file"
- rm -f "$ac_file"
- configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
- case "$ac_file" in
- *Makefile*) ac_comsub="1i\\
-# $configure_input" ;;
- *) ac_comsub= ;;
- esac
- sed -e "$ac_comsub
-s%@configure_input@%$configure_input%g
-s%@srcdir@%$srcdir%g
-s%@top_srcdir@%$top_srcdir%g
-" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file
-fi; done
-rm -f conftest.subs
-
-
-
-exit 0
-EOF
-chmod +x $CONFIG_STATUS
-rm -fr confdefs* $ac_clean_files
-test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
-
diff --git a/ice-9/configure.in b/ice-9/configure.in
index cb1926a87..e69de29bb 100644
--- a/ice-9/configure.in
+++ b/ice-9/configure.in
@@ -1,17 +0,0 @@
-#
-# Process this file with autoconf to produce a configure script.
-#
-
-AC_INIT(boot-9.scm)
-
-. $srcdir/../GUILE-VERSION
-
-scm_files=""
-aux_files=""
-. $srcdir/PLUGIN/this.configure
-AC_SUBST(scm_files)
-AC_SUBST(aux_files)
-AC_SUBST(library_name)
-AC_SUBST(info_files)
-AC_SUBST(GUILE_VERSION)
-AC_OUTPUT(Makefile)
diff --git a/ice-9/debug.scm b/ice-9/debug.scm
new file mode 100644
index 000000000..f5515d376
--- /dev/null
+++ b/ice-9/debug.scm
@@ -0,0 +1,195 @@
+;;;; Copyright (C) 1996 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+(define-module #/ice-9/debug)
+
+
+
+;;; {Run-time options}
+
+(define names '((debug-options-interface
+ (debug-options debug-enable debug-disable)
+ (debug-set!))
+
+ (evaluator-traps-interface
+ (traps trap-enable trap-disable)
+ (trap-set!))
+
+ (read-options-interface
+ (read-options read-enable read-disable)
+ (read-set!))
+
+ (print-options-interface
+ (print-options print-enable print-disable)
+ (print-set!))
+ ))
+
+(define option-name car)
+(define option-value cadr)
+(define option-documentation caddr)
+
+(define (print-option option)
+ (display (option-name option))
+ (if (< (string-length (symbol->string (option-name option))) 8)
+ (display #\tab))
+ (display #\tab)
+ (display (option-value option))
+ (display #\tab)
+ (display (option-documentation option))
+ (newline))
+
+;;; Below follows the macros defining the run-time option interfaces.
+;;; *fixme* These should not be macros, but need to be until module
+;;; system is improved.
+;;;
+
+(define (make-options interface)
+ `(lambda args
+ (cond ((null? args) (,interface))
+ ((pair? (car args)) (,interface (car args)) (,interface))
+ (else (for-each print-option (,interface #t))))))
+
+(define (make-enable interface)
+ `(lambda flags
+ (,interface (append flags (,interface)))
+ (,interface)))
+
+(define (make-disable interface)
+ `(lambda flags
+ (let ((options (,interface)))
+ (for-each (lambda (flag)
+ (set! options (delq! flag options)))
+ flags)
+ (,interface options)
+ (,interface))))
+
+(define (make-set! interface)
+ `((name exp)
+ (,'quasiquote
+ (begin (,interface (append (,interface)
+ (list '(,'unquote name)
+ (,'unquote exp))))
+ (,interface)))))
+
+(defmacro define-all ()
+ (cons 'begin
+ (apply append
+ (map (lambda (group)
+ (let ((interface (car group)))
+ (append (map (lambda (name constructor)
+ `(define-public ,name
+ ,(constructor interface)))
+ (cadr group)
+ (list make-options
+ make-enable
+ make-disable))
+ (map (lambda (name constructor)
+ `(defmacro-public ,name
+ ,@(constructor interface)))
+ (caddr group)
+ (list make-set!)))))
+ names))))
+
+(define-all)
+
+
+;;; {Trace}
+;;;
+;;; This code is just an experimental prototype (e. g., it is not
+;;; thread safe), but since it's at the same time useful, it's
+;;; included anyway.
+;;;
+(define traced-procedures '())
+
+(define-public (trace . args)
+ (if (null? args)
+ (nameify traced-procedures)
+ (begin
+ (for-each (lambda (proc)
+ (if (not (procedure? proc))
+ (error "trace: Wrong type argument:" proc))
+ (set-procedure-property! proc 'trace #t)
+ (if (not (memq proc traced-procedures))
+ (set! traced-procedures
+ (cons proc traced-procedures))))
+ args)
+ (set! apply-frame-handler trace-entry)
+ (set! exit-frame-handler trace-exit)
+ (set! trace-level 0)
+ (debug-enable 'trace)
+ (nameify args))))
+
+(define-public (untrace . args)
+ (if (and (null? args)
+ (not (null? traced-procedures)))
+ (apply untrace traced-procedures)
+ (begin
+ (for-each (lambda (proc)
+ (set-procedure-property! proc 'trace #f)
+ (set! traced-procedures (delq! proc traced-procedures)))
+ args)
+ (if (null? traced-procedures)
+ (debug-disable 'trace))
+ (nameify args))))
+
+(define (nameify ls)
+ (map (lambda (proc)
+ (let ((name (procedure-name proc)))
+ (or name proc)))
+ ls))
+
+(define trace-level 0)
+(add-hook! abort-hook (lambda () (set! trace-level 0)))
+
+(define (trace-entry key cont tail)
+ (if (eq? (stack-id cont) 'repl-stack)
+ (let ((cep (current-error-port))
+ (frame (last-stack-frame cont)))
+ (if (not tail)
+ (set! trace-level (+ trace-level 1)))
+ (let indent ((n trace-level))
+ (cond ((> n 1) (display "| " cep) (indent (- n 1)))))
+ (display-application frame cep)))
+ (debug-enable 'trace)
+ ;; It's not necessary to call the continuation since
+ ;; execution will continue if the handler returns
+ ;(cont #f)
+ )
+
+(define (trace-exit key cont retval)
+ (if (eq? (stack-id cont) 'repl-stack)
+ (let ((cep (current-error-port)))
+ (set! trace-level (- trace-level 1))
+ (let indent ((n trace-level))
+ (cond ((> n 0) (display "| " cep) (indent (- n 1)))))
+ (write retval cep)
+ (newline cep)))
+ (debug-enable 'trace))
+
+
+;;; A fix to get the error handling working together with the module system.
+;;;
+(variable-set! (builtin-variable 'debug-options) debug-options)
+
+
+
+(debug-enable 'debug)
+(read-enable 'positions)
diff --git a/ice-9/emacs.scm b/ice-9/emacs.scm
new file mode 100644
index 000000000..c563200cc
--- /dev/null
+++ b/ice-9/emacs.scm
@@ -0,0 +1,163 @@
+;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+;;; {Session support for Emacs}
+;;;
+
+(define-module (ice-9 emacs)
+ :use-module (ice-9 threads)
+ :use-module (ice-9 nonblocking))
+
+(define emacs-escape-character #\sub)
+
+(define emacs-output-port (current-output-port))
+
+(define (make-emacs-command char)
+ (let ((cmd (list->string (list emacs-escape-character char))))
+ (lambda ()
+ (display cmd emacs-output-port))))
+
+(define enter-input-wait (make-emacs-command #\s))
+(define exit-input-wait (make-emacs-command #\f))
+(define enter-read-character #\r)
+(define sending-error (make-emacs-command #\F))
+(define sending-backtrace (make-emacs-command #\B))
+(define sending-result (make-emacs-command #\x))
+(define end-of-text (make-emacs-command #\.))
+
+;; {Error handling}
+;;
+
+(add-hook! before-backtrace-hook sending-backtrace)
+(add-hook! after-backtrace-hook end-of-text)
+(add-hook! before-error-hook sending-error)
+(add-hook! after-error-hook end-of-text)
+
+;; {Repl}
+;;
+
+(set-current-error-port emacs-output-port)
+
+(add-hook! before-read-hook
+ (lambda ()
+ (enter-input-wait)
+ (force-output emacs-output-port)))
+
+(add-hook! after-read-hook
+ (lambda ()
+ (exit-input-wait)
+ (force-output emacs-output-port)))
+
+;;; {Misc.}
+
+(define (make-emacs-load-port orig-port)
+ (letrec ((read-char-fn (lambda args
+ (let ((c (read-char orig-port)))
+ (if (eq? c #\soh)
+ (throw 'end-of-chunk)
+ c)))))
+
+ (make-soft-port
+ (vector #f #f #f
+ read-char-fn
+ (lambda () (close-port orig-port)))
+ "r")))
+
+(set! repl-input-port (make-emacs-load-port (current-input-port)))
+(set-current-input-port repl-input-port)
+
+(define (emacs-eval-request form)
+ (let ((port (current-output-port)))
+ (sending-result port)
+ (write (eval form) port)
+ (end-of-text port)
+ (force-output port)))
+
+(define load-acknowledge (make-emacs-command #\l))
+
+(define load-port (current-input-port))
+
+(define (flush-line port)
+ (let loop ((c (read-char port)))
+ (if (not (eq? c #\nl))
+ (loop (read-char port)))))
+
+(define whitespace-chars (list #\space #\tab #\nl))
+
+(define (flush-whitespace port)
+ (catch 'end-of-chunk
+ (lambda ()
+ (let loop ((c (read-char port)))
+ (cond ((eq? c the-eof-object)
+ (error "End of file while recieving Emacs data"))
+ ((memq c whitespace-chars) (loop (read-char port)))
+ ((eq? c #\;) (flush-line port) (loop (read-char port)))
+ (else (unread-char c port))))
+ #f)
+ (lambda args
+ (read-char port) ; Read final newline
+ #t)))
+
+(define (emacs-load filename linum)
+ (set-port-filename! %%load-port filename)
+ (set-port-line! %%load-port (- linum 1))
+ (set-port-column! %%load-port 0)
+ (lazy-catch #t
+ (lambda ()
+ (let loop ((endp (flush-whitespace %%load-port)))
+ (if (not endp)
+ (begin
+ (start-stack read-and-eval! (read-and-eval! %%load-port))
+ (loop (flush-whitespace %%load-port)))
+ (begin
+ (load-acknowledge))))
+ )
+ (lambda (key . args)
+ (cond ((eq? key 'end-of-chunk)
+ (set! the-last-stack #f)
+ (set! stack-saved? #t)
+ (scm-error 'misc-error
+ 'emacs-load
+ "Incomplete expression"
+ '()
+ '()))
+ ((eq? key 'exit))
+ (else
+ (save-stack)
+ (catch 'end-of-chunk
+ (lambda ()
+ (let loop ()
+ (read-char %%load-port)
+ (loop)))
+ (lambda args
+ #f))
+ (apply throw key args))))))
+
+;;; A fix to get the emacs interface to work together with the module system.
+;;;
+(variable-set! (builtin-variable '%%load-port) load-port)
+(variable-set! (builtin-variable '%%emacs-load) emacs-load)
diff --git a/ice-9/expect.scm b/ice-9/expect.scm
new file mode 100644
index 000000000..9ac851f89
--- /dev/null
+++ b/ice-9/expect.scm
@@ -0,0 +1,124 @@
+;;; installed-scm-file
+
+;;;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+
+
+;;; Expect: a macro for selecting actions based on what it reads from a port.
+;;; The idea is from Don Libes' expect based on Tcl.
+;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
+
+
+(define expect-port #f)
+(define expect-timeout #f)
+(define expect-timeout-proc #f)
+(define expect-eof-proc #f)
+(define expect-char-proc #f)
+
+;;; expect: each test is a procedure which is applied to the accumulating
+;;; string.
+(defmacro expect clauses
+ (let ((s (gentemp))
+ (c (gentemp))
+ (port (gentemp))
+ (timeout (gentemp)))
+ `(let ((,s "")
+ (,port (or expect-port (current-input-port)))
+ (,timeout (if expect-timeout
+ (+ (* expect-timeout internal-time-units-per-second)
+ (get-internal-real-time))
+ #f)))
+ (let next-char ()
+ (if (and expect-timeout
+ (or (>= (get-internal-real-time) ,timeout)
+ (and (not (char-ready? ,port))
+ (not (expect-select ,port ,timeout)))))
+ (if expect-timeout-proc
+ (expect-timeout-proc ,s)
+ #f)
+ (let ((,c (read-char ,port)))
+ (if expect-char-proc
+ (expect-char-proc ,c))
+ (cond ((eof-object? ,c)
+ (if expect-eof-proc
+ (expect-eof-proc ,s)
+ #f))
+ (else
+ (set! ,s (string-append ,s (string ,c)))
+ (cond
+ ,@(let next-expr ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (body ()))
+ (cond
+ ((null? tests)
+ (reverse body))
+ (else
+ (next-expr
+ (cdr tests)
+ (cdr exprs)
+ (cons
+ `((,(car tests) ,s)
+ ,@(cond ((null? (car exprs))
+ ())
+ ((eq? (caar exprs) '=>)
+ (if (not (= (length (car exprs))
+ 2))
+ (scm-error 'misc-error
+ "expect"
+ "bad recipient: %S"
+ (list (car exprs))
+ #f)
+ `((apply ,(cadar exprs)
+ (,(car tests) ,s)))))
+ (else
+ (car exprs))))
+ body)))))
+ (else (next-char)))))))))))
+
+;;; the regexec front-end to expect:
+;;; each test must evaluate to a regular expression.
+(defmacro expect-strings clauses
+ `(let ,@(let next-test ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (defs ())
+ (body ()))
+ (cond ((null? tests)
+ (list (reverse defs) `(expect ,@(reverse body))))
+ (else
+ (let ((rxname (gentemp)))
+ (next-test (cdr tests)
+ (cdr exprs)
+ (cons `(,rxname (regcomp ,(car tests)
+ REG_NEWLINE))
+ defs)
+ (cons `((lambda (s)
+ (regexec ,rxname s ""))
+ ,@(car exprs))
+ body))))))))
+
+;;; simplified select: returns #t if input is waiting or #f if timed out.
+;;; timeout is absolute in terms of get-internal-real-time.
+(define (expect-select port timeout)
+ (let* ((relative (/ (- timeout (get-internal-real-time))
+ internal-time-units-per-second))
+ (relative-s (inexact->exact (floor relative)))
+ (relative-ms (inexact->exact
+ (round (* (- relative relative-s) 1000)))))
+ (and (> relative 0)
+ (pair? (car (select (list port) () ()
+ relative-s
+ relative-ms))))))
diff --git a/ice-9/gtcl.scm b/ice-9/gtcl.scm
new file mode 100644
index 000000000..bacccb043
--- /dev/null
+++ b/ice-9/gtcl.scm
@@ -0,0 +1,379 @@
+;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+(define-module (ice-9 gtcl) :use-module (ice-9 debug))
+
+(read-set! keywords 'prefix)
+
+(define-public TCL_VERSION "7.4")
+(define-public TCL_MAJOR_VERSION 7)
+(define-public TCL_MINOR_VERSION 4)
+
+;;; When a TCL command returns, the string pointer interp->result points to
+;;; a string containing return information from the command. In addition,
+;;; the command procedure returns an integer value, which is one of the
+;;; following:
+;;;
+;;; TCL_OK Command completed normally; interp->result contains
+;;; the command's result.
+;;; TCL_ERROR The command couldn't be completed successfully;
+;;; interp->result describes what went wrong.
+;;; TCL_RETURN The command requests that the current procedure
+;;; return; interp->result contains the procedure's
+;;; return value.
+;;; TCL_BREAK The command requests that the innermost loop
+;;; be exited; interp->result is meaningless.
+;;; TCL_CONTINUE Go on to the next iteration of the current loop;
+;;; interp->result is meaningless.
+;;;
+
+(define-public TCL_OK 0)
+(define-public TCL_ERROR 1)
+(define-public TCL_RETURN 2)
+(define-public TCL_BREAK 3)
+(define-public TCL_CONTINUE 4)
+
+;;; Flag values passed to variable-related procedures.
+;;;
+
+(define-public TCL_GLOBAL_ONLY 1)
+(define-public TCL_APPEND_VALUE 2)
+(define-public TCL_LIST_ELEMENT 4)
+(define-public TCL_TRACE_READS #x10)
+(define-public TCL_TRACE_WRITES #x20)
+(define-public TCL_TRACE_UNSETS #x40)
+(define-public TCL_TRACE_DESTROYED #x80)
+(define-public TCL_INTERP_DESTROYED #x100)
+(define-public TCL_LEAVE_ERR_MSG #x200)
+
+;;; Flag values to pass to TCL_DoOneEvent to disable searches
+;;; for some kinds of events:
+;;;
+
+(define-public TCL_DONT_WAIT 2)
+(define-public TCL_X_EVENTS 4)
+(define-public TCL_FILE_EVENTS 8)
+(define-public TCL_TIMER_EVENTS #x10)
+(define-public TCL_IDLE_EVENTS #x20)
+(define-public TCL_ALL_EVENTS -3)
+
+;; A convenience function for combining flag bits. Like logior, but
+;; handles the cases of 0 and 1 arguments.
+;;
+(define (flags . args)
+ (cond
+ ((null? args) 0)
+ ((null? (cdr args)) (car args))
+ (else (apply logior args))))
+
+
+;; MDJ 961023 <djurfeldt@nada.kth.se>
+(define-public (tcl-eval . strings)
+; (pk 'cmd strings)
+ (let* ((cmd (tcl-merge the-interpreter (map ->tcl-arg-string strings)))
+ (status (tcl-global-eval the-interpreter cmd)))
+ (if (zero? (car status))
+ (cdr status)
+ (error (cdr status)))))
+
+(define uniq-command
+ (let ((cnt 0))
+ (lambda (prefix)
+ (set! cnt (+ cnt 1))
+ (string-append prefix (number->string cnt)))))
+
+(define (closure->tcl-name p)
+ ;(let ((tcl-name (procedure-property p 'tcl-name)))
+ ;(or #f tcl-name
+ (let ((name (uniq-command ;(or (procedure-property p 'name)
+ "*__guile#"))
+ ;(template (procedure-property p 'tcl-calling-convention)))
+ )
+ (tcl-create-command the-interpreter name p)
+ ;(set-procedure-property! p 'tcl-name name)
+ name))
+
+(define (->tcl-arg-string v)
+ (cond
+ ((symbol? v) v)
+ ((keyword? v) (keyword-dash-symbol v))
+ ((string? v) v)
+ ((number? v) (number->string v))
+ ((eq? #f v) "0")
+ ((eq? #t v) "1")
+ ((closure? v)
+ (let ((cc (procedure-property v 'tcl-calling-convention)))
+ (if cc
+ (string-append (closure->tcl-name v) " " cc)
+ (closure->tcl-name v))))
+ (else "")))
+
+(define (tcl-args args)
+ (cond ((null? args) '())
+ ((symbol? (car args))
+ (cons (car args) (tcl-args (cdr args))))
+ ((keyword? (car args))
+ (cons (keyword-dash-symbol (car args)) (tcl-args (cdr args))))
+ ((string? (car args))
+ (cons (car args) (tcl-args (cdr args))))
+ ((number? (car args))
+ (cons (number->string (car args)) (tcl-args (cdr args))))
+ ((eq? #f (car args))
+ (cons "0" (tcl-args (cdr args))))
+ ((eq? #t (car args))
+ (cons "1" (tcl-args (cdr args))))
+ ((closure? (car args))
+ (let ((cc (procedure-property (car args) 'tcl-calling-convention)))
+ (if cc
+ (cons (string-append (closure->tcl-name (car args)) " " cc)
+ (tcl-args (cdr args)))
+ (cons (closure->tcl-name (car args))
+ (tcl-args (cdr args))))))
+ (else "")))
+
+;; MDJ 961023 <djurfeldt@nada.kth.se>
+(define-public (tcl-command interp name)
+ (let ((proc
+ (lambda args
+ (let ((status (tcl-global-eval
+ the-interpreter
+ (tcl-merge interp (map ->tcl-arg-string
+ (cons name args))))))
+ (if (zero? (car status))
+ (cdr status)
+ (throw 'tcl-error (cdr status)))))))
+ (set-procedure-property! proc 'name name)
+ proc))
+
+;; Reifying a Tcl command as a Scheme procedure.
+;;
+;(define-public (reify-tcl-command interp name)
+; (let ((command-object (tcl-command interp name)))
+; (and command-object
+; (let ((reified
+; (lambda args
+; (let ((answer
+; (tcl-apply-command command-object
+; (map (lambda (a)
+; (or (procedure-property a 'tk-command)
+; a))
+; args))))
+; (if (eq? 0 (car answer))
+; (tcl-string-> (cdr answer))
+; (throw 'tcl-error (cdr answer)))))))
+; (set-procedure-property! reified 'tk-command name)
+; reified))))
+(define-public reify-tcl-command tcl-command)
+
+(define-public (tcl-command? p)
+ (and (procedure? p) (procedure-property 'tcl-command)))
+
+;; Evaluate some code in the scope of a TCL-ERROR handler.
+;; The handler returns a conventional Tcl error value (i.e. (cons 1 message))
+;; Some type conversion is automaticly done on the return value to put it
+;; in a form Tcl will like.
+;;
+(defmacro-public with-tcl-error-handling body
+ `(catch 'tcl-error
+ (lambda () (->tcl-string (begin ,@body)))
+ (lambda (tag . message)
+ (cons 1 (apply errcat message)))))
+
+(define (errcat . args)
+ (apply string-append
+ (map (lambda (x)
+ (call-with-output-string
+ (lambda (p)
+ ((if (string? x) display write) x p)
+ (display " " p))))
+ args)))
+
+;; If this is defined to be an unary function, it gets to extend the
+;; default type conversion rules for arguments (it is passed otherwise
+;; unhandled values).
+;;
+(define-public tcl-type-converter #f)
+
+;; Default conversions from Scheme to Tcl strings.
+;;
+(define-public (->tcl-string val)
+ (cond
+ ((string? val) val)
+ ((symbol? val) val)
+ ((number? val) (number->string val))
+ ((eq? #f val) "0")
+ ((eq? #t val) "1")
+ ((keyword? val) (keyword->symbol val))
+ (#t "")))
+
+(define (that x) x)
+
+;; Default conversions from Tcl strings to Scheme.
+;;
+(define-public (tcl-string-> val)
+ (cond
+ ((string->number val) => that)
+ ((equal? "" val) #f)
+ (#t val)))
+
+
+;;; {An Implicit Default Interpreter}
+;;;
+;;; For programs like "wish" in which there is one designated default
+;;; interpreter.
+;;;
+
+(define-public the-interpreter #f)
+
+
+;; Use defined-tcl-command to extend the global namespace
+;; with commands from the default Tcl interpreter.
+;;
+;(define-public (use-default-tcl-commands)
+; (set! *top-level-lookup-thunk* defined-tcl-command))
+
+;; If there is a defined variable called NAME, return it.
+;; If not, but there is a Tcl command in the default interpreter
+;; called NAME, create a variable an initialize it to point to the
+;; reified Tcl command.
+;;
+;; Finally, always return a variable, perhaps undefined, if DEFINING?
+;; is a true value.
+;;
+(define-public (make-tcl-binder interp)
+ (lambda (m s define?)
+ (if define?
+ (let ((b (make-undefined-variable s)))
+ (module-obarray-set! (module-obarray m) s b)
+ (if (tcl-defined? the-interpreter s)
+ (variable-set! b (tcl-command interp s)))
+ b)
+ (and (tcl-defined? interp s)
+ (let ((b (make-undefined-variable s)))
+ (module-obarray-set! (module-obarray m) s b)
+ (variable-set! b (tcl-command interp s))
+ b)))))
+
+;; Used to define Scheme procedures which are also Tcl commands.
+;; The declarations syntax is;
+;;
+;; (proc name (?<calling-convention>? ?.? <formals>) <body>)
+;;
+;; which is expanded in terms of tcl-lambda.
+;;
+(defmacro-public proc (name . spec)
+ `(begin
+ (define ,name (tcl-lambda ,@ spec))
+ (tcl-create-command the-interpreter ',name ,name)))
+
+
+;; Used to define an anonymous Scheme procedure which is suitable
+;; for use as a Tcl command.
+;;
+;; The declaration syntax is:
+;;
+;; (tcl-lambda (?<calling-convention>? ?.? <formals>) <body>)
+;;
+;; A <calling-convention> is a string that describes how the procedure
+;; should be called when it is used as a Tcl command.
+;; If the procedure hash the tcl-name PROC, and the calling convention
+;; "%x %y", then the procedure will be called as:
+;;
+;; PROC %x %y
+;;
+;; Such calling conventions are useful in cases such as binding a Scheme
+;; procedure to Tk event.
+;;
+;; Formals specifications are as usual except that non-rest parameters
+;; can have declarations. Declarations are arbitrary expressions in which
+;; the name of the formal is in the second position. The expressions are
+;; evaluated in the scope of the formals, and may modify the formals by
+;; side effect. Declarations should return a false value to cause an error
+;; to be thrown, a true value otherwise.
+;;
+(defmacro-public tcl-lambda (formals . body)
+ (let* ((calling-convention (if (and (pair? formals)
+ (string? (car formals)))
+ (let ((a (car formals)))
+ (set! formals (cdr formals))
+ a)
+ #f))
+ (args (tcl-formals-vars formals))
+ (full-body `(begin
+ ,@(tcl-type-checks formals 1)
+ ,@body)))
+ `(let ((proc (lambda ,args
+ (with-tcl-error-handling ,full-body))))
+ ,@(if calling-convention
+ `((set-procedure-property! proc
+ 'tcl-calling-convention
+ ,calling-convention)
+ proc)
+ `(proc)))))
+
+
+;; From a list of formals, perhaps with declarations, return the
+;; formals <<e.g. (a (tcl->int b) . c) => (a b . c) >>
+;;
+(define-public (tcl-formals-vars formals)
+ (if (not (pair? formals))
+ formals
+ (cons (if (pair? (car formals))
+ (cadar formals)
+ (car formals))
+ (tcl-formals-vars (cdr formals)))))
+
+(define-public (tcl-error . args)
+ (apply throw (cons 'tcl-error args)))
+
+
+(define-public (tcl-type-checks formals pos)
+ (cond
+ ((not (pair? formals)) '())
+ ((not (pair? (car formals)))
+ (tcl-type-checks (cdr formals) (+ 1 pos)))
+ (#t (cons (tcl-type-check (car formals))
+ (tcl-type-checks (cdr formals) (+ 1 pos))))))
+
+(define-public tcl-type-converters
+ `( (number . ,(lambda (x) (tcl->number x))) ))
+
+(define (tcl-type-check x)
+ (let ((a (assoc (car x) tcl-type-converters)))
+ (if (not a)
+ (error "Unsupported declaration" x)
+ (list 'set! (cadr x) (cons (cdr a) (cdr x))))))
+
+(define-public (tcl->number x)
+ (cond ((string? x) (string->number x))
+ ((integer? x) x)
+ (#t (tcl-error "Expected integer but got" x))))
+
+;;; To support stack handling:
+
+(define v (builtin-variable 'tk-stack-mark))
+
+(variable-set! v ->tcl-string)
diff --git a/ice-9/gwish.scm b/ice-9/gwish.scm
new file mode 100644
index 000000000..8efff185d
--- /dev/null
+++ b/ice-9/gwish.scm
@@ -0,0 +1,90 @@
+;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+(define-module (ice-9 gwish)
+ :use-module (guile)
+ :use-module (ice-9 threads)
+ :use-module (ice-9 nonblocking)
+ :use-module (ice-9 gtcl))
+
+
+;;; {The Interpreter}
+;;;
+
+(set! the-interpreter (tcl-create-interp))
+
+(define gtcl-module (local-ref '(app modules ice-9 gtcl)))
+(define tcl-binder (make-tcl-binder the-interpreter))
+
+(set-module-binder! (module-public-interface gtcl-module) tcl-binder)
+
+;;; {Namespace cleaning}
+;;;
+
+;; These are the names of procedures already defined
+;; in Scheme but which, in this context, ought to refer
+;; to Tcl/Tk commands.
+
+(define override-scheme-list '(bind raise))
+
+(for-each
+ (lambda (name)
+ (eval `(set! ,name (reify-tcl-command the-interpreter ',name))))
+ override-scheme-list)
+
+;;; {Non-blocking ports}
+
+(define stdin-avail #t)
+
+(proc set-stdin-flag args (set! stdin-avail #t) "")
+
+(define wait TCL_ALL_EVENTS)
+(define dont-wait (+ wait TCL_DONT_WAIT))
+
+(set! handle-input-events
+ (lambda ()
+ (cond ((single-active-thread?) (tcl-do-one-event wait))
+ ((zero? (tcl-do-one-event dont-wait))
+ (yield)
+ ))
+ (if stdin-avail
+ (begin
+ (set! stdin-avail #f)
+ (signal-condition-variable repl-input-port-condvar)))))
+
+(fileevent 'stdin 'readable 'set-stdin-flag)
+
+(activate-non-blocking-input)
+
+;;; {The application window}
+
+(let ((init-status (tk-init-main-window the-interpreter
+ (or (getenv "DISPLAY") ":0")
+ "gwish"
+ "Gwish")))
+ (if (not (eq? #t init-status))
+ (error init-status)))
diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm
index ffde88608..28e4a6515 100644
--- a/ice-9/lineio.scm
+++ b/ice-9/lineio.scm
@@ -95,15 +95,14 @@
(read-string (lambda ()
(cond
- (buffers (let ((answer (car buffers)))
- (set! buffers (cdr buffers))
- answer))
-
- ((ungetc-char-ready? self) (read-line self 'include-newline))
-
- (else (read-line underlying-port 'include-newline)))))
-
- )
+ ((not (null? buffers))
+ (let ((answer (car buffers)))
+ (set! buffers (cdr buffers))
+ answer))
+ ((ungetc-char-ready? self)
+ (read-line self 'include-newline))
+ (else
+ (read-line underlying-port 'include-newline))))))
(set-object-property! self 'unread-string unread-string)
(set-object-property! self 'read-string read-string)
diff --git a/ice-9/mapping.scm b/ice-9/mapping.scm
index 9d9bb7aa6..ceb3a1b38 100644
--- a/ice-9/mapping.scm
+++ b/ice-9/mapping.scm
@@ -112,7 +112,8 @@
(else (error 'hash-table-mapping
"Hash-procedure specified with no known delete function."
hash-proc)))))
- (table-constructor (or (kw-arg-ref options :table-constructor) make-vector)))
+ (table-constructor (or (kw-arg-ref options :table-constructor)
+ (lambda (len) (make-vector len '())))))
(make-hash-table-mapping (table-constructor size)
hash-proc
assoc-proc
diff --git a/ice-9/nonblocking.scm b/ice-9/nonblocking.scm
new file mode 100644
index 000000000..926a40c85
--- /dev/null
+++ b/ice-9/nonblocking.scm
@@ -0,0 +1,82 @@
+;;;; Copyright (C) 1996 Mikael Djurfeldt
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+
+
+;;; *******************************
+;;; * Experimental hack *
+;;; * Shouldn't go into snapshots *
+;;; * Don't distribute! *
+;;; *******************************
+
+;;; {Non-blocking ports}
+;;;
+
+(define-module (ice-9 nonblocking)
+ :use-module (ice-9 threads))
+
+(define mu (make-mutex))
+(define-public repl-input-port-condvar (make-condition-variable))
+
+(define non-blocking-input #f)
+
+(define-public (make-non-blocking-port wait-port read-port)
+ (letrec ((read-char-fn (lambda args
+ (if (char-ready? wait-port)
+ (read-char read-port)
+ (begin
+ (wait-condition-variable repl-input-port-condvar
+ mu)
+ (unlock-mutex mu)
+ (read-char-fn))))))
+ (make-soft-port
+ (vector #f #f #f
+ read-char-fn
+ (lambda () (close-port orig-port)))
+ "r")))
+
+(define-public repl-input-port (current-input-port))
+(define-public basic-repl-input-port repl-input-port)
+
+(define-public handle-input-events
+ (lambda ()
+ (if (single-active-thread?)
+ (select (list basic-repl-input-port) '() '()))
+ (if (char-ready? basic-repl-input-port)
+ (signal-condition-variable repl-input-port-condvar)
+ (yield))))
+
+(define (kick)
+ (call-with-new-thread
+ (lambda ()
+ (error-catching-loop
+ (lambda ()
+ (let loop ()
+ (handle-input-events)
+ (loop)))))
+ (lambda args args)))
+
+(define-public (activate-non-blocking-input)
+ (if (not non-blocking-input)
+ (begin
+ (set! repl-input-port (make-non-blocking-port basic-repl-input-port
+ (current-input-port)))
+ (set-current-input-port repl-input-port)
+ (kick)
+ (set! non-blocking-input #t))))
diff --git a/ice-9/oldprint.scm b/ice-9/oldprint.scm
new file mode 100644
index 000000000..bec6d0358
--- /dev/null
+++ b/ice-9/oldprint.scm
@@ -0,0 +1,122 @@
+;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+
+
+;;; {Print}
+;;;
+;;; This code was removed from boot-9.scm by MDJ 970301
+;;; <djurfeldt@nada.kth.se>. It is placed here for archival
+;;; purposes.
+
+(define (print obj . args)
+ (let ((default-args (list (current-output-port) 0 0 default-print-style #f)))
+ (apply-to-args (append args (list-cdr-ref default-args (length args)))
+ (lambda (port depth length style table)
+ (cond
+ ((and table (print-table-ref table obj))
+ ((print-style-tag-hook style 'eq-val)
+ obj port depth length style table))
+ (else
+ (and table (print-table-add! table obj))
+ (cond
+ ((print-style-max-depth? style depth)
+ ((print-style-excess-depth-hook style)))
+ ((print-style-max-length? style length)
+ ((print-style-excess-length-hook style)))
+ (else
+ ((print-style-hook style obj)
+ obj port depth length style table)))))))))
+
+(define (make-print-style) (make-vector 59 '()))
+
+(define (extend-print-style! style utag printer)
+ (hashq-set! style utag printer))
+
+(define (print-style-hook style obj)
+ (let ((type-tag (tag obj)))
+ (or (hashq-ref style type-tag)
+ (hashq-ref style (logand type-tag 255))
+ print-obj)))
+
+(define (print-style-tag-hook style type-tag)
+ (or (hashq-ref style type-tag)
+ print-obj))
+
+(define (print-style-max-depth? style d) #f)
+(define (print-style-max-length? style l) #f)
+(define (print-style-excess-length-hook style)
+ (hashq-ref style 'excess-length-hook))
+(define (print-style-excess-depth-hook style)
+ (hashq-ref style 'excess-depth-hook))
+
+(define (make-print-table) (make-vector 59 '()))
+(define (print-table-ref table obj) (hashq-ref table obj))
+(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref)))
+
+(define (print-obj obj port depth length style table) (write obj port))
+
+(define (print-pair pair port depth length style table)
+ (if (= 0 length)
+ (display #\( port))
+
+ (print (car pair) port (+ 1 depth) 0 style table)
+
+ (cond
+ ((and (pair? (cdr pair))
+ (or (not table)
+ (not (print-table-ref table (cdr pair)))))
+
+ (display #\space port)
+ (print (cdr pair) port depth (+ 1 length) style table))
+
+ ((null? (cdr pair)) (display #\) port))
+
+ (else (display " . " port)
+ (print (cdr pair) port (+ 1 depth) 0
+ style table)
+ (display #\) port))))
+
+(define (print-vector obj port depth length style table)
+ (if (= 0 length)
+ (cond
+ ((weak-key-hash-table? obj) (display "#wh(" port))
+ ((weak-value-hash-table? obj) (display "#whv(" port))
+ ((doubly-weak-hash-table? obj) (display "#whd(" port))
+ (else (display "#(" port))))
+
+ (if (< length (vector-length obj))
+ (print (vector-ref obj length) port (+ 1 depth) 0 style table))
+
+ (cond
+ ((>= (+ 1 length) (vector-length obj)) (display #\) port))
+ (else (display #\space port)
+ (print obj port depth
+ (+ 1 length)
+ style table))))
+
+(define default-print-style (make-print-style))
+
+(extend-print-style! default-print-style utag_vector print-vector)
+(extend-print-style! default-print-style utag_wvect print-vector)
+(extend-print-style! default-print-style utag_pair print-pair)
+(extend-print-style! default-print-style 'eq-val
+ (lambda (obj port depth length style table)
+ (if (symbol? obj)
+ (display obj)
+ (begin
+ (display "##" port)
+ (display (print-table-ref table obj))))))
diff --git a/ice-9/poe.scm b/ice-9/poe.scm
index b594ebe13..eb3a13fca 100644
--- a/ice-9/poe.scm
+++ b/ice-9/poe.scm
@@ -45,7 +45,7 @@
;;;
-(define funcq-memo (make-weak-hash-table 523)) ; !!! randomly selected values
+(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
(define funcq-buffer (make-gc-buffer 256))
(define (funcq-hash arg-list n)
diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm
new file mode 100644
index 000000000..c1ab627cb
--- /dev/null
+++ b/ice-9/r4rs.scm
@@ -0,0 +1,145 @@
+;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
+;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
+
+;;;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;;; apply and call-with-current-continuation
+
+;;; We want these to be tail-recursive, so instead of using primitive
+;;; procedures, we define them as closures in terms of the primitive
+;;; macros @apply and @call-with-current-continuation.
+(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
+(define (call-with-current-continuation proc)
+ (@call-with-current-continuation proc))
+
+
+;;;; Basic Port Code
+
+;;; Specifically, the parts of the low-level port code that are written in
+;;; Scheme rather than C.
+;;;
+;;; WARNING: the parts of this interface that refer to file ports
+;;; are going away. It would be gone already except that it is used
+;;; "internally" in a few places.
+
+
+;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
+;; mode to open files in. MSDOS does carraige return - newline
+;; translation if not opened in `b' mode.
+;;
+(define OPEN_READ (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "rb")
+ (else "r")))
+(define OPEN_WRITE (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "wb")
+ (else "w")))
+(define OPEN_BOTH (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "r+b")
+ (else "r+")))
+
+(define *null-device* "/dev/null")
+
+(define (open-input-file str)
+ (open-file str OPEN_READ))
+
+(define (open-output-file str)
+ (open-file str OPEN_WRITE))
+
+(define (open-io-file str) (open-file str OPEN_BOTH))
+(define close-input-port close-port)
+(define close-output-port close-port)
+(define close-io-port close-port)
+
+(define (call-with-input-file str proc)
+ (let* ((file (open-input-file str))
+ (ans (proc file)))
+ (close-input-port file)
+ ans))
+
+(define (call-with-output-file str proc)
+ (let* ((file (open-output-file str))
+ (ans (proc file)))
+ (close-output-port file)
+ ans))
+
+(define (with-input-from-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-output-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-error-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-input-from-file file thunk)
+ (let* ((nport (open-input-file file))
+ (ans (with-input-from-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-output-to-file file thunk)
+ (let* ((nport (open-output-file file))
+ (ans (with-output-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-error-to-file file thunk)
+ (let* ((nport (open-output-file file))
+ (ans (with-error-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-input-from-string string thunk)
+ (call-with-input-string string
+ (lambda (p) (with-input-from-port p thunk))))
+
+(define (with-output-to-string thunk)
+ (call-with-output-string
+ (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-string thunk)
+ (call-with-output-string
+ (lambda (p) (with-error-to-port p thunk))))
+
+(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
+
+
+;;;; Loading
+
+(if (not (defined? '%load-verbosely))
+ (define %load-verbosely #f))
+(define (assert-load-verbosity v) (set! %load-verbosely v))
+
+(define (%load-announce file)
+ (if %load-verbosely
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (display ";;; ")
+ (display "loading ")
+ (display file)
+ (newline)
+ (force-output)))))
+
+(set! %load-hook %load-announce)
+
+(define (load name)
+ (start-stack 'load-stack
+ (primitive-load name)))
diff --git a/ice-9/slib.scm b/ice-9/slib.scm
index 3178598fd..1ef5c5a87 100644
--- a/ice-9/slib.scm
+++ b/ice-9/slib.scm
@@ -10,7 +10,7 @@
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <filename>)
- (do ((o (read port #t read-sharp) (read port #t read-sharp)))
+ (do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
@@ -35,6 +35,11 @@
(define slib:tab #\tab)
(define slib:form-feed #\page)
+(define slib-module (current-module))
+
+(define (defined? symbol)
+ (module-defined? slib-module symbol))
+
(define slib:features
(append '(source
eval
@@ -56,27 +61,27 @@
string-port
with-file)
- (if (defined? getenv)
+ (if (defined? 'getenv)
'(getenv)
'())
- (if (defined? current-time)
+ (if (defined? 'current-time)
'(current-time)
'())
- (if (defined? system)
+ (if (defined? 'system)
'(system)
'())
- (if (defined? array?)
+ (if (defined? 'array?)
'(array)
'())
- (if (defined? char-ready?)
+ (if (defined? 'char-ready?)
'(char-ready?)
'())
- (if (defined? array-for-each)
+ (if (defined? 'array-for-each)
'(array-for-each)
'())
@@ -102,25 +107,43 @@
'()))))
-(define slib-module (current-module))
-
(define (slib:load name)
(save-module-excursion
(lambda ()
(set-current-module slib-module)
- (load name))))
+ (let* ((errinfo (catch 'system-error
+ (lambda ()
+ (basic-load name)
+ #f)
+ (lambda args args)))
+ (errinfo (and errinfo
+ (catch 'system-error
+ (lambda ()
+ (basic-load (string-append name ".scm"))
+ #f)
+ (lambda args args)))))
+ (if errinfo
+ (apply throw errinfo))))))
(define slib:load-source slib:load)
(define defmacro:load slib:load)
-(define (library-vicinity) (string-append (implementation-vicinity) "slib/"))
+(define slib-parent-dir
+ (let* ((path (%search-load-path "slib/require.scm")))
+ (if path
+ (make-shared-substring path 0 (- (string-length path) 17))
+ (error "Could not find slib/require.scm in " %load-path))))
+
+(define-public (implementation-vicinity)
+ (string-append slib-parent-dir "/"))
+(define (library-vicinity)
+ (string-append (implementation-vicinity) "slib/"))
(define (scheme-implementation-type) 'guile)
(define (scheme-implementation-version) "")
(define (output-port-width . arg) 80)
(define (output-port-height . arg) 24)
-
;;; {Time}
;;;
@@ -139,6 +162,30 @@
(define (software-type) 'UNIX)
-(slib:load "require.scm")
+(slib:load (in-vicinity (library-vicinity) "require.scm"))
(define-public require require:require)
+
+;; {Extensions to the require system so that the user can add new
+;; require modules easily.}
+
+(define *vicinity-table*
+ (list
+ (cons 'implementation (implementation-vicinity))
+ (cons 'library (library-vicinity))))
+
+(define (install-require-vicinity name vicinity)
+ (let ((entry (assq name *vicinity-table*)))
+ (if entry
+ (set-cdr! entry vicinity)
+ (set! *vicinity-table*
+ (acons name vicinity *vicinity-table*)))))
+
+(define (install-require-module name vicinity-name file-name)
+ (let ((entry (assq name *catalog*))
+ (vicinity (cdr (assq vicinity-name *vicinity-table*))))
+ (let ((path-name (in-vicinity vicinity file-name)))
+ (if entry
+ (set-cdr! entry path-name)
+ (set! *catalog*
+ (acons name path-name *catalog*))))))
diff --git a/ice-9/source.scm b/ice-9/source.scm
new file mode 100644
index 000000000..3d3a960a4
--- /dev/null
+++ b/ice-9/source.scm
@@ -0,0 +1,161 @@
+;;;; source.scm --- finding lines of source code for the debugger to display
+;;;; Jim Blandy <jimb@cyclic.com> --- February 1997
+;;;;
+;;;; Copyright (C) 1997 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; This module retrieves selected lines from files of source code.
+;;; It's meant for use by source-level debuggers, to display regions
+;;; of code to the user.
+;;;
+
+;;; We don't keep the text in memory. However, we do cache the
+;;; starting positions of each line in the file, so once the file has
+;;; been scanned, we can extract any line we want pretty quickly. We
+;;; also only scan as far as we need, i.e., up to the latest line
+;;; we've been asked for. This is fast enough for interactive use,
+;;; but doesn't take up much memory.
+
+;(define-module '(ice-9 source))
+
+
+;;;; public interface
+
+;;; (get-source-line FILE LINE)
+;;; Return the text of the LINE'th line from the file FILE, as a
+;;; string.
+(define-public (get-source-line file line)
+ ...)
+
+;;; (check-source-cache FILE)
+;;; The source access routines in this module cache some information
+;;; about the contents of the files they examine. If we have cached
+;;; any information about FILE, check its modification time, and forget
+;;; our cached information if it is out of date.
+;;;
+;;; Try to call this function periodically before retrieving lines
+;;; from FILE; however, it does perform a file system access, so don't
+;;; call it too often.
+
+
+;;;; trivia
+
+(define (throw-out-of-range op index)
+ (throw 'out-of-range op "Argument out of range: %S" (list index) #f))
+
+
+;;;; stretchy vectors
+
+;;; A stretchy vector is one that you can append new entries onto
+;;; efficiently.
+
+;;; (make-svect) => a new, zero-length stretchy vector
+(define (make-svect)
+ (cons 0 (make-vector 20 '-)))
+
+;;; (svect-ref SVECT K) => the K'th element of SVECT
+(define (svect-ref svect k)
+ (vector-ref (cdr svect) k))
+
+;;; (svect-add! SVECT ELT) => append ELT to the end of SVECT
+(define (svect-add! svect elt)
+
+ ;; If we don't have room in the current vector, create a new, larger one.
+ (if (>= (car svect) (vector-length (cdr svect)))
+ (let* ((old-vect (cdr svect))
+ (new-vect (make-vector (* 2 (vector-length old-vect)) '-)))
+ (vector-move-left! old-vect 0 (vector-length old-vect)
+ new-vect 0)
+ (set-cdr! svect new-vect)))
+
+ (vector-set! (cdr svect) (car svect) elt)
+ (set-car! svect (+ 1 (car svect))))
+
+;;; (svect-length SVECT) => the length of SVECT
+(define svect-length car)
+
+
+;;;; source files
+
+;;; We keep a limited number of source files open at any given time.
+;;; A source file structure looks like:
+;;;
+;;; (PORT LINESTARTS)
+;;;
+;;; PORT is a seekable input port looking at a text file.
+;;; LINESTARTS is a stretchy vector, whose Ith element is the seek
+;;; position of the start of line I (assuming lines are numbered
+;;; starting with zero). The file may have more lines than this
+;;; array records; this occurs when we haven't completely scanned
+;;; the file.
+(define (make-source file)
+ (let ((port (open-input-file file)))
+ (let ((linestarts (make-svect)))
+ (svect-add! linestarts 0) ; We know where the first line starts.
+ (list port linestarts))))
+
+;;; Return the text of the LINE'th line of SOURCE. Return the EOF
+;;; object if SOURCE doesn't have that many lines.
+(define (get-line source line)
+ (let* ((port (car source))
+ (linestarts (cadr source))
+ (known (svect-length linestarts)))
+
+ ;; Starting at the last line whose position is known, scan SOURCE for
+ ;; new line positions, until we've found the start of the LINE'th
+ ;; line. Assume that LINE is not one whose position we already know.
+ ;; Record all line positions in SOURCE. Return the text of
+ ;; the LINE'th line (without a newline), or the EOF object if the
+ ;; file doesn't have that many lines.
+ (define (scan line)
+ (fseek port (svect-ref linestarts (- known 1)) SEEK_SET)
+ (let loop ((known known))
+ (let ((text (read-line port)))
+ (if (eof-object? text) text
+ (begin
+ (svect-add! linestarts (ftell port))
+ (if (>= line known) (loop (+ known 1))
+ text))))))
+
+ ;; Return the text of the line that starts at POS.
+ (define (get pos)
+ (fseek port pos SEEK_SET)
+ (read-line port))
+
+ (if (< line known)
+ (get (svect-ref linestarts line))
+ (scan line))))
+
+
+;;;; cache of files
+
+;;; The cache is an alist mapping filenames onto source objects. We
+;;; put a fixed limit on the number of files it contains; new files replace
+;;; the least recently used file.
+
+(define (cache-add! cache max file source)
+ (let* ((cache (cons (cons file source) cache))
+ (
+ (set-cdr!
+
+(define (cache-ref file)
+
+
+
+
+(define the-file-cache '())
+(define file-cache-max 10)
+
diff --git a/ice-9/test.scm b/ice-9/test.scm
new file mode 100644
index 000000000..aeb28ee59
--- /dev/null
+++ b/ice-9/test.scm
@@ -0,0 +1,1032 @@
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "test.scm" Test correctness of scheme implementations.
+;;; Author: Aubrey Jaffer
+;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
+;;; won't pass. Made the the tests (test-cont), (test-sc4), and
+;;; (test-delay) start to run automatically.
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named
+;;; "test.scm", so you'll have to run it from the ice-9 source
+;;; directory, or copy this file elsewhere
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests. You may need to delete them in order to run
+;;; "test.scm" more than once.
+
+;;; There are three optional tests:
+;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
+;;;
+;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
+;;;
+;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
+;;; either standard.
+
+;;; If you are testing a R3RS version which does not have `list?' do:
+;;; (define list? #f)
+
+;;; send corrections or additions to jaffer@ai.mit.edu or
+;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
+
+(define cur-section '())(define errs '())
+(define SECTION (lambda args
+ (display "SECTION") (write args) (newline)
+ (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(define test
+ (lambda (expect fun . args)
+ (write (cons fun args))
+ (display " ==> ")
+ ((lambda (res)
+ (write res)
+ (newline)
+ (cond ((not (equal? expect res))
+ (record-error (list res expect (cons fun args)))
+ (display " BUT EXPECTED ")
+ (write expect)
+ (newline)
+ #f)
+ (else #t)))
+ (if (procedure? fun) (apply fun args) (car args)))))
+(define (report-errs)
+ (newline)
+ (if (null? errs) (display "Passed all tests")
+ (begin
+ (display "errors were:")
+ (newline)
+ (display "(SECTION (got expected (call)))")
+ (newline)
+ (for-each (lambda (l) (write l) (newline))
+ errs)))
+ (newline))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+ (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+ (list
+ #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\ ))
+ (set! i (+ 3 i))
+ (write x)
+ (newline))
+ disjoint-type-functions)
+(define type-matrix
+ (map (lambda (x)
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ (write t)
+ (write x)
+ (newline)
+ t))
+ type-examples))
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+(test 'composite 'case (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+ (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+ (odd?
+ (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+ (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x 5) (+ x 1)))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((negative? (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg)))))
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+ 'quasiquote
+ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it.
+(define (sqt x)
+ (do ((i 0 (+ i 1)))
+ ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+ (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(SECTION 5 2 2)
+(test 45 'define
+ (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+;;; Not for Guile
+;(test #f not '())
+;(test #f not (list))
+(test #f not 'nil)
+
+(test #t boolean? #f)
+(test #f boolean? 0)
+;;; Not for Guile
+;(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+ (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+(test #t pair? '(a . b))
+(test #t pair? '(a . 1))
+(test #t pair? '(a b c))
+(test #f pair? '())
+(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+(test #f symbol? "bar")
+(test #t symbol? 'nil)
+(test #f symbol? '())
+(test #f symbol? #f)
+;;; But first, what case are symbols in? Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+ (set! char-standard-case char-downcase))
+;;; Not for Guile
+;(test #t 'standard-case
+; (string=? (symbol->string 'a) (symbol->string 'A)))
+;(test #t 'standard-case
+; (or (string=? (symbol->string 'a) "A")
+; (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+ (let ((v (make-string (string-length s))))
+ (do ((i (- (string-length v) 1) (- i 1)))
+ ((< i 0) v)
+ (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+ (set! s (str-copy s))
+ (do ((i 0 (+ 1 i))
+ (sl (string-length s)))
+ ((>= i sl) s)
+ (string-set! s i (char-standard-case (string-ref s i)))))
+;;; Not for Guile
+;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+;(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+;;; Not for Guile
+;(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+;;; Not for Guile
+;(test #t eq? 'mISSISSIppi 'mississippi)
+;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3 5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(define (divtest n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+ (define f3.9 (string->number "3.9"))
+ (define f4.0 (string->number "4.0"))
+ (define f-3.25 (string->number "-3.25"))
+ (define f.25 (string->number ".25"))
+ (define f4.5 (string->number "4.5"))
+ (define f3.5 (string->number "3.5"))
+ (define f0.0 (string->number "0.0"))
+ (define f0.8 (string->number "0.8"))
+ (define f1.0 (string->number "1.0"))
+ (define wto write-test-obj)
+ (define dto display-test-obj)
+ (define lto load-test-obj)
+ (newline)
+ (display ";testing inexact numbers; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test #t inexact? f3.9)
+ (test #t 'inexact? (inexact? (max f3.9 4)))
+ (test f4.0 'max (max f3.9 4))
+ (test f4.0 'exact->inexact (exact->inexact 4))
+ (test (- f4.0) round (- f4.5))
+ (test (- f4.0) round (- f3.5))
+ (test (- f4.0) round (- f3.9))
+ (test f0.0 round f0.0)
+ (test f0.0 round f.25)
+ (test f1.0 round f0.8)
+ (test f4.0 round f3.5)
+ (test f4.0 round f4.5)
+ (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+ (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+ (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+ (test #t call-with-output-file
+ "tmp3"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+ (check-test-file "tmp3")
+ (set! write-test-obj wto)
+ (set! display-test-obj dto)
+ (set! load-test-obj lto)
+ (let ((x (string->number "4195835.0"))
+ (y (string->number "3145727.0")))
+ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+ (report-errs))
+
+(define (test-bignum)
+ (define tb
+ (lambda (n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2)))))
+ (newline)
+ (display ";testing bignums; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test 0 modulo -2177452800 86400)
+ (test 0 modulo 2177452800 -86400)
+ (test 0 modulo 2177452800 86400)
+ (test 0 modulo -2177452800 -86400)
+ (test #t 'remainder (tb 281474976710655 65535))
+ (test #t 'remainder (tb 281474976710654 65535))
+ (SECTION 6 5 6)
+ (test 281474976710655 string->number "281474976710655")
+ (test "281474976710655" number->string 281474976710655)
+ (report-errs))
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+
+(SECTION 6 6)
+(test #t eqv? '#\ #\Space)
+(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\ )
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '#(0 1 4 9 16) 'for-each
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+(test -3 call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x) (if (negative? x) (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+ ((pair? obj) (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation. It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures. I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.
+(define (next-leaf-generator obj eot)
+ (letrec ((return #f)
+ (cont (lambda (x)
+ (recur obj)
+ (set! cont (lambda (x) (return eot)))
+ (cont #f)))
+ (recur (lambda (obj)
+ (if (pair? obj)
+ (for-each recur obj)
+ (call-with-current-continuation
+ (lambda (c)
+ (set! cont c)
+ (return obj)))))))
+ (lambda () (call-with-current-continuation
+ (lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+ (let* ((eot (list 'eot))
+ (xf (next-leaf-generator x eot))
+ (yf (next-leaf-generator y eot)))
+ (letrec ((loop (lambda (x y)
+ (cond ((not (eq? x y)) #f)
+ ((eq? eot x) #t)
+ (else (loop (xf) (yf)))))))
+ (loop (xf) (yf)))))
+(define (test-cont)
+ (newline)
+ (display ";testing continuations; ")
+ (newline)
+ (SECTION 6 9)
+ (test #t leaf-eq? '(a (b (c))) '((a) b c))
+ (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+ (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+ (newline)
+ (display ";testing DELAY and FORCE; ")
+ (newline)
+ (SECTION 6 9)
+ (test 3 'delay (force (delay (+ 1 2))))
+ (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+ (test 2 'delay (letrec ((a-stream
+ (letrec ((next (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+ (head car)
+ (tail (lambda (stream) (force (cdr stream)))))
+ (head (tail (tail a-stream)))))
+ (letrec ((count 0)
+ (p (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (x 5))
+ (test 6 force p)
+ (set! x 10)
+ (test 6 force p))
+ (test 3 'force
+ (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+ (c #f))
+ (force p)))
+ (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file "test.scm" input-port?)
+(define this-file (open-input-file "test.scm"))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+ (define test-file (open-input-file name))
+ (test #t 'input-port?
+ (call-with-input-file
+ name
+ (lambda (test-file)
+ (test load-test-obj read test-file)
+ (test #t eof-object? (peek-char test-file))
+ (test #t eof-object? (read-char test-file))
+ (input-port? test-file))))
+ (test #\; read-char test-file)
+ (test display-test-obj read test-file)
+ (test load-test-obj read test-file)
+ (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+ '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+ '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+ (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+ "tmp1"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+(check-test-file "tmp1")
+
+(define test-file (open-output-file "tmp2"))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+(define (test-sc4)
+ (newline)
+ (display ";testing scheme 4 functions; ")
+ (newline)
+ (SECTION 6 7)
+ (test '(#\P #\space #\l) string->list "P l")
+ (test '() string->list "")
+ (test "1\\\"" list->string '(#\1 #\\ #\"))
+ (test "" list->string '())
+ (SECTION 6 8)
+ (test '(dah dah didah) vector->list '#(dah dah didah))
+ (test '() vector->list '#())
+ (test '#(dididit dah) list->vector '(dididit dah))
+ (test '#() list->vector '())
+ (SECTION 6 10 4)
+ (load "tmp1")
+ (test write-test-obj 'load foo)
+ (report-errs))
+
+(report-errs)
+(if (and (string->number "0.0") (inexact? (string->number "0.0")))
+ (test-inexact))
+
+(let ((n (string->number "281474976710655")))
+ (if (and n (exact? n))
+ (test-bignum)))
+(newline)
+(test-cont)
+(newline)
+(test-sc4)
+(newline)
+(test-delay)
+(newline)
+"last item in file"
diff --git a/ice-9/threads.scm b/ice-9/threads.scm
new file mode 100644
index 000000000..bec189009
--- /dev/null
+++ b/ice-9/threads.scm
@@ -0,0 +1,53 @@
+;;;; Copyright (C) 1996 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;;
+;;;; ----------------------------------------------------------------
+;;;; threads.scm -- User-level interface to Guile's thread system
+;;;; 4 March 1996, Anthony Green <green@cygnus.com>
+;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
+;;;; ----------------------------------------------------------------
+;;;;
+
+
+(define-module #/ice-9/threads)
+
+
+
+; --- MACROS -------------------------------------------------------
+
+(defmacro-public make-thread (fn . args)
+ `(call-with-new-thread
+ (lambda ()
+ (,fn ,@args))
+ (lambda args args)))
+
+(defmacro-public begin-thread (first . thunk)
+ `(call-with-new-thread
+ (lambda ()
+ (begin
+ ,first ,@thunk))
+ (lambda args args)))
+
+(defmacro-public with-mutex (m . thunk)
+ `(dynamic-wind
+ (lambda () (lock-mutex ,m))
+ (lambda () (begin ,@thunk))
+ (lambda () (unlock-mutex ,m))))
+
+(defmacro-public monitor (first . thunk)
+ `(with-mutex ,(make-mutex)
+ (begin
+ ,first ,@thunk)))