diff options
Diffstat (limited to 'ice-9')
-rw-r--r-- | ice-9/.cvsignore | 3 | ||||
-rw-r--r-- | ice-9/ChangeLog | 524 | ||||
-rw-r--r-- | ice-9/Makefile.am | 10 | ||||
-rw-r--r-- | ice-9/Makefile.in | 240 | ||||
-rw-r--r-- | ice-9/aclocal.m4 | 64 | ||||
-rw-r--r-- | ice-9/boot-9.scm | 1588 | ||||
-rwxr-xr-x | ice-9/configure | 283 | ||||
-rw-r--r-- | ice-9/configure.in | 12 | ||||
-rw-r--r-- | ice-9/debug.scm | 120 | ||||
-rw-r--r-- | ice-9/expect.scm | 125 | ||||
-rw-r--r-- | ice-9/lineio.scm | 17 | ||||
-rw-r--r-- | ice-9/mapping.scm | 3 | ||||
-rw-r--r-- | ice-9/poe.scm | 2 | ||||
-rw-r--r-- | ice-9/r4rs.scm | 149 | ||||
-rw-r--r-- | ice-9/slib.scm | 64 | ||||
-rw-r--r-- | ice-9/test.scm | 1032 | ||||
-rw-r--r-- | ice-9/threads.scm | 53 |
17 files changed, 3424 insertions, 865 deletions
diff --git a/ice-9/.cvsignore b/ice-9/.cvsignore new file mode 100644 index 000000000..16b8c4510 --- /dev/null +++ b/ice-9/.cvsignore @@ -0,0 +1,3 @@ +Makefile +config.log +config.status diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index fe69f1e0b..6f3002e31 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,527 @@ +Mon Feb 10 03:01:48 1997 Mikael Djurfeldt <mdj@kenneth> + + * boot-9.scm (backtrace): Removed. (A C version now exists in + backtrace.c.) + +Fri Jan 24 06:05:36 1997 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (read-line!, read-delimited!, read-delimited, + read-line): new procedures, see libguile/ChangeLog. + +Thu Jan 16 17:07:03 1997 Marius Vollmer <mvo@zagadka.ping.de> + + Added dynamic linking of modules. See libguile/DYNAMIC-LINKING. + + * boot-9.scm (split-c-module-name, convert-c-registered-modules, + init-dynamic-module, dynamic-maybe-call, + find-and-link-dynamic-module, link-dynamic-module, + try-module-dynamic-link, registered-modules): New definitions for + dynamic linking of modules. + (resolve-module): Try to dynamically link the requested module + after failing to load it as Scheme code. + +Wed Jan 8 05:50:14 1997 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (getservbyport, getservbyname): remove stray %. + +Tue Jan 7 20:02:24 1997 Jim Blandy <jimb@floss.cyclic.com> + + * boot-9.scm (and=>): Rename THUNK argument to PROCEDURE, 'cos + that's what it is. + + * lineio.scm (make-line-buffering-input-port): Properly test for + the case of an empty buffer list. The old code assumed that '() + was false. + +Mon Jan 6 01:13:53 1997 Mikael Djurfeldt <mdj@kenneth> + +* * boot-9.scm (use-modules): New macro (from Marius Vollmer). + (use-modules <module name> ...) Put the the modules named by + <module name> ... on the use list of the current module. + +Sun Jan 5 15:52:59 1997 Jim Blandy <jimb@floss.cyclic.com> + + * boot-9.scm (error-catching-loop): Remove message saying that + typing "$" will put you in the debugger. This isn't implemented + yet. + +Sun Dec 22 23:27:25 1996 Jim Blandy <jimb@floss.cyclic.com> + + * boot-9.scm (delq-all!): Function deleted; delq!'s semantics have + been fixed, so this function is superfluous. + (transform-usage-lambda): Use delq!, not delq-all!. + +Tue Dec 17 20:36:45 1996 Marius Vollmer <mvo@zagadka.ping.de> + + * boot-9.scm (resolve-module): New optional parameter that + controls whether autoloading is attempted or not. Default is #t. + (process-define-module): Don't autoload the defined module. + (try-module-autoload): Don't autoload the directory modules. + + * boot-9.scm (process-define-module): Ensure that the-scm-module + is last in the `uses' list to allow shadowing builtin + bindings. All :use-module options are added in the order they + appear in the arguments but before anything already on the list + (such as the-scm-module). + +Wed Dec 11 21:06:05 1996 Gary Houston <ghouston@actrix.gen.nz> + + * slib.scm (slib-parent-dir): throw error if #f returned from + %search-load-path. + +Sat Nov 30 23:57:28 1996 Tom Tromey <tromey@cygnus.com> + + * PLUGIN/greet, PLUGIN/split.sed, PLUGIN/this.configure: Removed. + * Makefile.am, aclocal.m4: New files. + * configure.in: Updated for Automake. + +Wed Nov 27 14:16:14 1996 Marius Vollmer <mvo@zagadka.ping.de> + + * boot-9.scm (macroexpand-1, macroexpand), slib.scm + (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a + function, use it accordingly. + +Thu Nov 21 11:12:10 1996 Jim Blandy <jimb@floss.cyclic.com> + + It's an "eval closure", not an "eval thunk." A thunk is a + function of no arguments. + * boot-9.scm (module-type): Rename module field. + (make-module, eval-in-module, make-root-module, + set-current-module): Uses changed. + (module-eval-closure, set-module-eval-closure!, + root-module-closure): Renamed from module-eval-thunk, + set-module-eval-thunk!, root-module-thunk. + (set-current-module): Change uses of *top-level-lookup-thunk* to + *top-level-eval-closure*. + +Wed Nov 20 14:45:27 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * slib.scm (slib-parent-dir): Use string-length, not length. + (Thanks to Bernard Urban.) + +Sat Nov 2 20:00:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se> + + * boot-9.scm: The debugging evaluator and recording of positions + aren't enabled by default any longer (they are switched on in + debug.scm). But during development we want to have them also + *inside* boot-9.scm. Therefore, two lines are added at the + beginning of boot-9.scm to enable these. + + Call `provide' so that `records' are included among the + `*features*'. + + The scheme for saving the stack has been adjusted: save-stack is + now commonly available for saving the stack. Calling `save-stack' + sets a flag `stack-saved?' which prevents overwriting the stack. + `stack-saved?' is reset at `abort'. + + Spelling correction: seperate --> separate. + + Removed `:'s that had creeped into some comments. + + The repl now doesn't print #<unspecified> results any longer + If the user wants to see this, he can do + (assert-repl-print-unspecified #t) in his startup file. + + The user now gets a friendly message instead of a backtrace at + error. + + Added `before-read-hook'. + + Load module (ice-9 emacs) if option `-e' was specified. + + (provide): New function. + + (error): Save stack at entry, so that Guile entrails won't show up + in backtraces. + + (backtrace): New function. + + (save-stack): Can now take arbitrary number of stack narrowing + specifier pairs. The first specifier in a pair controls inner + border, the second the outer border. A number means cut that + number of frames, a procedure object means cut until that object + is found in operator position in a frame. + + * debug.scm: Enable debugging evaluator and recording of positions + by default. + + * slib.scm (slib:load): Adapt to the new behavior of + primitive-load: It doesn't any longer try both with and without + ".scm" extension. (We don't want to use %search-load-path here.) + + (implementation-vicinity): New function. slib requires it + + (library-vicinity): Updated. + + Load "require.scm" in the library-vicinity. + + (install-require-vicinity, install-require-module): New functions. + +Mon Oct 28 17:56:29 1996 Jim Blandy <jimb@floss.cyclic.com> + + * boot-9.scm (load-from-path): New function. + + * boot-9.scm (try-load, basic-try-load, try-load-module, + try-load): Deleted. I don't think they're being used. + + * Makefile.in (scm_files): Add r4rs.scm and test.scm to this list, + so they'll get distributed. + + Get Guile to be a little less chatty by default. The new user + should see as little clutter as possible. + * r4rs.scm (%load-verbosely): Make this #f by default. + * boot-9.scm (scm-repl-verbose): Make this #f by default. + (scm-style-repl): Don't run 'pk' on the value passed to quit. + + * r4rs.scm: New file. + * boot-9.scm: Load r4rs.scm, first thing. + (OPEN_READ, OPEN_WRITE, OPEN_BOTH, *null-device*, open-input-file, + open-output-file, open-io-file, close-input-port, + close-output-port, close-io-port, call-with-input-file, + call-with-output-file, with-input-from-port, with-output-to-port, + with-error-to-port, with-input-from-file, with-output-to-file, + with-error-to-file, with-input-from-string, with-output-to-string, + with-error-to-string, the-eof-object): Definitions moved to + r4rs.scm. Not all of them are R4RS, but those that are use those + that are not. + (load, %load-verbosely, %load-announce): Moved, along with code to + set %load-hook, to r4rs.scm. + + * test.scm: New file. + + * boot-9.scm (integer?): Definition deleted, in favor of the one + present in libguile (which used to be called int?). I have no + idea why integer? didn't just call int? to begin with. + + * boot-9.scm (<, <=, =, >, >=): Definitions in terms of <?, <=?, + =?, >?, and >=? deleted; they're defined that way by libguile now. + + * boot-9.scm (load): Simplified; primitive-load does most of this + work now. + (%load-announce-win): Removed; no longer used. Set %load-hook to + call %load-announce. + +Sun Oct 27 07:47:03 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (stat:dev, stat:ino, stat:mode, stat:nlink, stat:uid, + stat:gid, stat:rdev, stat:size, stat:atime, stat:mtime, + stat:ctime, stat:blksize, stat:blocks) accessor functions for stat + components. + (file-is-directory?): use stat:type. + +Fri Oct 25 03:34:47 1996 Jim Blandy <jimb@floss.cyclic.com> + + * boot-9.scm (%read-sharp): Don't recognize the `#!' syntax here; + that's now taken care of in libguile, and in a way compatible with + SCSH (which this isn't). + +Mon Oct 21 18:52:36 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * boot-9.scm: Formatting tweaks. + +Fri Oct 18 01:03:08 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se> + + * boot-9.scm (handle-system-error): Added hooks before-error-hook, + after-error-hook, before-backtrace-hook and after-backtrace-hook + to the error handler. E.g.: fancy emacs support could plug into + these. + (save-stack): New function. The stack is now made differently + depending on the stack id. (The motivation is to make a better + choice regarding what stack frames to present to the user.) + (error-catching-loop): Stack handling code moved outside into + save-stack. + +Thu Oct 17 20:33:08 1996 Gary Houston <ghouston@actrix.gen.nz> + + * Makefile.in (scm_files): add expect.scm. + + * expect.scm: new file ported from guile-iii. + + * boot-9.scm: remove handle-system-error, after moving the code into + error-catching-loop. + Don't set 'throw-handler-default property on error keys. + Just interpret (almost) any throw with 4 args as an error throw. + Delete some try-load stuff that was already commented out. + + Second thoughts, keep handle-system-error but call it from + error-catching-loop. + +Tue Oct 15 17:07:20 1996 Jim Blandy <jimb@floss.cyclic.com> + + * boot-9.scm: Doc fixes. + (make-module): Rework for readability. + (make-root-module, make-scm-module): USES argument to make-module + should be '(), not #f. + + * boot-9.scm (try-load): %sys-load-path has been renamed to + primitive-load-path; adjust call here. + +Tue Oct 15 14:25:01 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * boot-9.scm (signal-handler): Bugfix: Moved the recording of + the stack to the correct place: when it is decided to generate an + error-signal. + +Mon Oct 14 22:20:30 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * boot-9.scm (error-catching-loop, signal-handler, + handle-system-error): Backtracing now works for signals aswell; + Backtracing mechanism can now identify the stack root created by + start-stack so that the user isn't exposed to system stack frames. + +Mon Oct 14 06:05:42 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * Makefile.in: Added threads.scm. + +Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * debug.scm (make-enable, make-disable): Simplified. + + * boot-9.scm: Renamed %%throw-handler-default --> + throw-handler-default. + ((handle-system-error key . arg-list)): Changed the way errors are + reported. + ((scm-style-repl)): Wrap up the call to eval in a start-stack + acro. + ((error-catching-loop thunk)): Introduce a lazy-catch into + error-catching-loop so that the stack can be captured. + +Thu Oct 10 22:27:32 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * mapping.scm (hash-table-mapping): Explicitly request that + make-vector fill new vectors with '(); this will make it easier to + port Guile Scheme code to other Schemes. + * boot-9.scm (make-print-style, make-print-table): Same. + +Sun Oct 6 03:54:59 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (load): rewritten again. + Append "." to the default %load-path. + (feature?): new function: checks for a symbol in the features list. + (module-local-variable): remove apparently useless (caddr (list m v + ...)) + (%load-announce): minor formatting change. + (file-exists?): use access? if posix is featured. + (file-is-directory?): use stat if i/o-extensions is featured. + (try-module-autoload module-name): use file-exists? before + file-is-directory? + +Sat Oct 5 18:54:03 1996 Mikael Djurfeldt <mdj@kenneth> + + * boot-9.scm: Added conditional loading of threads.scm. + + * threads.scm: New file. Modified from the Cygnus-r0.3 + distribution. + + * boot-9.scm (error-catching-loop): Added handling of key + `switch-repl'. + + * boot-9.scm: Name change %%bad-throw --> bad-throw. + +Wed Oct 2 23:38:44 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * boot-9.scm (make-record-type, record-constructor): Don't assume + the empty list is false when parsing the argument list. + +Mon Sep 30 22:15:50 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * boot-9.scm (signal-handler): Clean up logic. + + * boot-9.scm (load): Assume %load-path is always bound. + +Sat Sep 28 00:15:37 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (error): replace another throw with scm-error. Throw + to 'misc-error instead of 'error (no need to distinguish these.) + Don't set up 'error as a key. + Set up regex-error as a key, if regex is available. + (signal-handler): use scm-error, not throw. + + (%try-load, try-load-with-path, %load, load-with-path, + basic-try-load-with-path, basic-load-with-path, + try-load-module-with-path,load-module-with-path): deleted, since + they seem redundant. + (try-load): define using %try-load, not try-load-with-path. + (load): rewritten. load tries to open the file directly and + with a .scm extension before searching the library directories + (should "." be added to %load-path? then load could still open + directly files starting with "/"). + (try-module-autoload): use load, not load-with-path. + (%load-indent): deleted, -2 was causing errors. + + (%read-sharp): use port-line, not line-number. + +Fri Sep 27 16:23:51 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * boot-9.scm (%%bad-throw): Delete definition. 1) It's very + straightforward to provide the equivalent functionality using + (catch #t ...), so there's no need for the extra complexity. 2) + Outside the context of a read-eval-print loop (which Guile should + not require) it's not clear we should do anything more complicated + than print an error and exit; the user or REPL can establish + something better if it wants. 3) In that case, it's much more + robust to just do it in the C code. + +Tue Sep 24 06:53:04 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (%try-load): define using primitive-load. Previously + %try-load itself was the primitive. + (load-with-path): use scm-error instead of %load-announce-lossage. + Errors are thrown to 'misc-error instead of 'could-not-load. + (%load-announce-lossage): deleted. + +Mon Sep 23 00:16:31 1996 Mikael Djurfeldt <mdj@kenneth> + + * boot-9.scm (warn, scm-style-repl): Use C printer instead of `print'. + (make-record-type type-name fields): Temporarily remove support + for printing of records (not possible yet with C printer). + +Fri Sep 20 00:24:27 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (file-exists?, file-is-directory): catch only + system-error, not every kind of error. + (scm-error): new procedure. + +Thu Sep 19 16:02:46 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * boot-9.scm: Formatting tweaks. + +Wed Sep 18 09:07:37 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (%%handle-system-error key): remove the code for + SCM-style errors. handle the case that an unexpected number + of args are supplied. + (%%system-errors): removed. + (error): redefine using a throw with key and 4 args. + ('error): associate 'error, 'error-signal keys with + %%handle-system-error. + (%%default-error-handler): removed. + (signal-handler): throw with 4 args and use the error-signal key. + Create an error message instead of using numerical codes. + (%%bad-throw): call error instead of throw if key not found. + +Tue Sep 17 04:11:28 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm: initialize new error keys (see libguile/ChangeLog). + (%%handle-system-error key): check subr is not #f before printing. + Recognize %s (embed an argument using "display") and + %S (embed an argument using "write"). + +Sun Sep 15 03:55:35 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (%%handle-system-error key): set args and rest to + the empty list if they are #f. + Initialize out-of-range as an error key. + +Sat Sep 14 03:41:15 1996 Gary Houston <ghouston@actrix.gen.nz> + + * PLUGIN/REQ: remove the "ice-9 lgh" line which causes a cycle. + + * boot-9.scm: remove leading %% from references to '%%system-error. + (%%handle-system-error): don't pass all the thrown arguments when + aborting, just the key and subr. + Remove the code to "Install default handlers for built-in errors." + Remove the definition of the syserror procedure. + Associate 'numerical-overflow with default handler. + +Fri Sep 13 04:58:11 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * boot-9.scm: Name change: value-ref --> local-ref + resolved-ref --> nested-ref Motivation: conformance to the other + dictionary operators: list-ref operates on list, vector-ref + operates on vector, nested-ref operates on nested namespace, + local-ref operates on the local nested namespace. + +Sat Sep 7 06:44:47 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (%%handle-system-error): recognise errors thrown + by lgh-error (fill-message etc.) + (fill-message): check first whether args is null. + (fill-message): bug fix and check that args is a list. + +Thu Sep 5 11:33:41 1996 Jim Blandy <jimb@floss.cyclic.com> + + * boot-9.scm: %load-path is initialized in C code now. + (implementation-vicinity, parse-path): Deleted, along with code to + initialize %load-path. + + * boot-9.scm (in-vicinity): If the vicinity doesn't end with a + "/", use one to separate it from the file. + +Thu Aug 29 23:05:11 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu> + + * boot-9.scm (%load-path): Add the site directory. + Add the directory named after the version number. + Prepend the version number to the other directories in the path. + Simplify by mapping the common prefix onto each item. + * Makefile.in (datadir, pkgdatadir, pkgverdatadir, subpkgdatadir, + sitedatadir): New definitions. + (libparent, libdir, install_path): Replaced by above. + (install): Create the above directories. + Put the source files into subpkgdatadir. + (uninstall): Remove the above directories. + +Thu Aug 29 21:48:47 1996 Jim Blandy <jimb@floss.cyclic.com> + + Don't use the PLUGIN system to gather information for the + Makefile's distribution and installation targets; just put it all + in the Makefile directly. + * PLUGIN/this.configure (scm_files, aux_files): Remove sections + for these. + * configure.in: Remove code that gets and substitutes scm_files and + aux_files. + * Makefile.in (scm_files, aux_files): Write out the list of files + here, where people expect to find them. + +Fri Aug 23 06:44:36 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * boot-9.scm: Preliminary solution: optionally load the debug + module. Changed "gls" to "guile1.0b3". + + * debug.scm: New file: debug extensions. + +Wed Aug 21 13:06:56 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * boot-9.scm (print-vector): Renamed weak-hash-table? --> + weak-key-hash-table?. (Again!) + +Tue Aug 20 07:31:39 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> + + * boot-9.scm (print-vector, macro-table, xformer-table): + Renamed weak-hash-table --> weak-key-hash-table. + + * poe.scm (funcq-memo): Renamed weak-hash-table --> + weak-key-hash-table. + +Sat Aug 3 06:16:35 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (*null-device*): global constant from goonix. + (move->fdes): adjusted for boolean primitive-move->fdes. return + the modified port, always set revealed count to 1 (SCSH compatible). + (release-port-handle port): from goonix (SCSH compatible). + (%open-file): removed. + (open-input-file, open-output-file, file-exists?, file-is-directory?): + modified for open-file change (does not return #f). + +Thu Aug 1 02:52:42 1996 Jim Blandy <jimb@totoro.cyclic.com> + + * Makefile.in (dist-dir): New target for new dist system. + (manifest): Deleted. + * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a + directory, and needs special treatment in the dist-dir target. + +Thu Aug 1 09:00:21 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm: remove the wrappers for '%' system primitives, + now that they throw errors directly. + remove make-simple-wrapper and similar functions. + protect a call to getenv which may now throw an exception. + +Wed Jul 31 23:44:42 1996 Gary Houston <ghouston@actrix.gen.nz> + + * boot-9.scm (false-if-exception): new macro. + Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive> * The more things change... diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am new file mode 100644 index 000000000..1647cffcc --- /dev/null +++ b/ice-9/Makefile.am @@ -0,0 +1,10 @@ +## Process this file with automake to produce Makefile.in. + +AUTOMAKE_OPTIONS = foreign + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@ +subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \ +mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm + +## test.scm is not currently installed. +EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in index 318dc4a56..c8fd1686b 100644 --- a/ice-9/Makefile.in +++ b/ice-9/Makefile.in @@ -1,71 +1,207 @@ -# Copyright (C) 1995 Free Software Foundation, Inc. -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2, or (at your option) -# any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this software; see the file COPYING. If not, write to -# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -# - - +# Makefile.in generated automatically by automake 1.1l from Makefile.am + +# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + SHELL = /bin/sh srcdir = @srcdir@ +top_srcdir = @top_srcdir@ VPATH = @srcdir@ prefix = @prefix@ +exec_prefix = @exec_prefix@ + +bindir = @bindir@ +sbindir = @sbindir@ +libexecdir = @libexecdir@ +datadir = @datadir@ +sysconfdir = @sysconfdir@ +sharedstatedir = @sharedstatedir@ +localstatedir = @localstatedir@ +libdir = @libdir@ +infodir = @infodir@ +mandir = @mandir@ +includedir = @includedir@ +oldincludedir = /usr/include + +pkgdatadir = $(datadir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ + +top_builddir = . + +INSTALL = @INSTALL@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +transform = @program_transform_name@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +PACKAGE = @PACKAGE@ +VERSION = @VERSION@ +module = @module@ + +AUTOMAKE_OPTIONS = foreign + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@ +subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \ +mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm + +EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm +ACLOCAL = $(top_srcdir)/aclocal.m4 +mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs +CONFIG_CLEAN_FILES = +DATA = $(subpkgdata_DATA) + +DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in aclocal.m4 \ +configure configure.in + + +DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ + $(TEXINFOS) $(MANS) $(EXTRA_DIST) + +TAR = tar +default: all + +.SUFFIXES: +$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) + cd $(top_srcdir) && automake --foreign Makefile + +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) + cd $(top_builddir) \ + && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status + +$(srcdir)/aclocal.m4: configure.in + cd $(srcdir) && aclocal + +config.status: configure + $(SHELL) ./config.status --recheck +$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES) + cd $(srcdir) && autoconf + +install-subpkgdataDATA: $(subpkgdata_DATA) + $(NORMAL_INSTALL) + $(mkinstalldirs) $(subpkgdatadir) + @list="$(subpkgdata_DATA)"; for p in $$list; do \ + if test -f $(srcdir)/$$p; then \ + echo "$(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p"; \ + $(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p; \ + else if test -f $$p; then \ + echo "$(INSTALL_DATA) $$p $(subpkgdatadir)/$$p"; \ + $(INSTALL_DATA) $$p $(subpkgdatadir)/$$p; \ + fi; fi; \ + done -VERSION=@GUILE_VERSION@ +uninstall-subpkgdataDATA: + list="$(subpkgdata_DATA)"; for p in $$list; do \ + rm -f $(subpkgdatadir)/$$p; \ + done +tags: TAGS +TAGS: + + +distdir = $(PACKAGE)-$(VERSION) +# This target untars the dist file and tries a VPATH configuration. Then +# it guarantees that the distribution is self-contained by making another +# tarfile. +distcheck: dist + rm -rf $(distdir) + $(TAR) zxf $(distdir).tar.gz + mkdir $(distdir)/=build + mkdir $(distdir)/=inst + dc_install_base=`cd $(distdir)/=inst && pwd`; \ + cd $(distdir)/=build \ + && ../configure --srcdir=.. --prefix=$$dc_install_base \ + && $(MAKE) \ + && $(MAKE) dvi \ + && $(MAKE) check \ + && $(MAKE) install \ + && $(MAKE) installcheck \ + && $(MAKE) dist + rm -rf $(distdir) + @echo "========================"; \ + echo "$(distdir).tar.gz is ready for distribution"; \ + echo "========================" +dist: distdir + -chmod -R a+r $(distdir) + $(TAR) chozf $(distdir).tar.gz $(distdir) + rm -rf $(distdir) +dist-all: distdir + -chmod -R a+r $(distdir) + $(TAR) chozf $(distdir).tar.gz $(distdir) + rm -rf $(distdir) +distdir: $(DISTFILES) + rm -rf $(distdir) + mkdir $(distdir) + -chmod 755 $(distdir) + here=`pwd`; distdir=`cd $(distdir) && pwd` \ + && cd $(srcdir) \ + && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign + $(mkinstalldirs) $(distdir)/PLUGIN + @for file in $(DISTFILES); do \ + d=$(srcdir); \ + test -f $(distdir)/$$file \ + || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ + || cp -p $$d/$$file $(distdir)/$$file; \ + done +info: +dvi: +check: all + $(MAKE) +installcheck: +install-exec: + $(NORMAL_INSTALL) -libparent=$(prefix)/lib -libdir=$(libparent)/guile$(VERSION) -install_path=$(libdir)/@library_name@ +install-data: install-subpkgdataDATA + $(NORMAL_INSTALL) -INSTALL = $(srcdir)/../install-sh -c -INSTALL_DATA = $(INSTALL) -m 644 +install: install-exec install-data all + @: -scm_files= @scm_files@ -aux_files = @aux_files@ +uninstall: uninstall-subpkgdataDATA -all: +all: $(DATA) Makefile -install: all - test -d $(libparent) || mkdir $(libparent) - test -d $(libdir) || mkdir $(libdir) - test -d $(install_path) || mkdir $(install_path) - cd $(srcdir); \ - for file in $(scm_files); do \ - $(INSTALL_DATA) $$file $(install_path); \ - done +install-strip: + $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install +installdirs: + $(mkinstalldirs) $(subpkgdatadir) -uninstall: - for file in $(scm_files) ; do \ - rm -f $(install_path)/$$file; \ - done; - -rmdir $(install_path) - -rmdir $(libdir) +mostlyclean-generic: + test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) -SUBDIR=. -manifest: - srcdir=./$(SUBDIR) ; \ - . $(SUBDIR)/PLUGIN/this.configure; \ - for file in $$scm_files $$aux_files ; \ - do echo $(SUBDIR)/$$file ; \ - done +clean-generic: + test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) + +distclean-generic: + rm -f Makefile $(DISTCLEANFILES) + rm -f config.cache config.log stamp-h + test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + +maintainer-clean-generic: + test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) + test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) +mostlyclean: mostlyclean-generic + +clean: clean-generic mostlyclean + +distclean: distclean-generic clean + rm -f config.status -clean: +maintainer-clean: maintainer-clean-generic distclean + @echo "This command is intended for maintainers to use;" + @echo "it deletes files that may require special tools to rebuild." + rm -f config.status -distclean: - -rm -f config.log config.status Makefile +.PHONY: default uninstall-subpkgdataDATA install-subpkgdataDATA tags \ +distdir info dvi installcheck install-exec install-data install \ +uninstall all installdirs mostlyclean-generic distclean-generic \ +clean-generic maintainer-clean-generic clean mostlyclean distclean \ +maintainer-clean -realclean: +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/ice-9/aclocal.m4 b/ice-9/aclocal.m4 new file mode 100644 index 000000000..ace866913 --- /dev/null +++ b/ice-9/aclocal.m4 @@ -0,0 +1,64 @@ +dnl aclocal.m4 generated automatically by aclocal 1.1l + + +dnl Usage: AM_INIT_GUILE_MODULE(module-name) +dnl This macro will automatically get the guile version from the +dnl top-level srcdir, and will initialize automake. It also +dnl defines the `module' variable. +AC_DEFUN([AM_INIT_GUILE_MODULE],[ +. $srcdir/../GUILE-VERSION +AM_INIT_AUTOMAKE($PACKAGE, $VERSION) +AC_CONFIG_AUX_DIR(..) +module=[$1] +AC_SUBST(module)]) + +# Do all the work for Automake. This macro actually does too much -- +# some checks are only needed if your package does certain things. +# But this isn't really a big deal. + +# serial 1 + +dnl Usage: +dnl AM_INIT_AUTOMAKE(package,version) + +AC_DEFUN(AM_INIT_AUTOMAKE, +[AC_REQUIRE([AM_PROG_INSTALL]) +PACKAGE=[$1] +AC_SUBST(PACKAGE) +AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE") +VERSION=[$2] +AC_SUBST(VERSION) +AC_DEFINE_UNQUOTED(VERSION, "$VERSION") +AM_SANITY_CHECK +AC_ARG_PROGRAM +AC_PROG_MAKE_SET]) + + +# serial 1 + +AC_DEFUN(AM_PROG_INSTALL, +[AC_REQUIRE([AC_PROG_INSTALL]) +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' +AC_SUBST(INSTALL_SCRIPT)dnl +]) + +# +# Check to make sure that the build environment is sane. +# + +AC_DEFUN(AM_SANITY_CHECK, +[AC_MSG_CHECKING([whether build environment is sane]) +echo timestamp > conftestfile +# Do this in a subshell so we don't clobber the current shell's +# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? +if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile) +then + # Ok. + : +else + AC_MSG_ERROR([newly created file is older than distributed files! +Check your system clock]) +fi +rm -f conftest* +AC_MSG_RESULT(yes)]) + diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index fa55e9a1d..5a695f967 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -26,8 +26,27 @@ ;;; +;;; During Guile development, we want to use debugging evaluator and record +;;; positions of source expressions in boot-9.scm by default. -;; {Simple Debugging Tools} +(debug-options-interface (cons 'debug (debug-options-interface))) +(read-options-interface (cons 'positions (read-options-interface))) + + +;;; {Features} +;; + +(define (provide sym) + (if (not (memq sym *features*)) + (set! *features* (cons sym *features*)))) + + +;;; {R4RS compliance} + +(primitive-load-path "ice-9/r4rs.scm") + + +;;; {Simple Debugging Tools} ;; @@ -54,7 +73,7 @@ (lambda () (newline) (display ";;; WARNING ") - (print stuff) + (display stuff) (newline) (car (last-pair stuff))))) @@ -66,12 +85,22 @@ ;;; (set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) -(define (call-with-current-continuation proc) (@call-with-current-continuation proc)) +(define (call-with-current-continuation proc) + (@call-with-current-continuation proc)) -;;; {apply-to-args} +;;; {Trivial Functions} ;;; + +(define (id x) x) +(define (1+ n) (+ n 1)) +(define (-1+ n) (+ n -1)) +(define 1- -1+) +(define return-it noop) +(define (and=> value procedure) (and value (procedure value))) +(define (make-hash-table k) (make-vector k '())) + ;;; apply-to-args is functionally redunant with apply and, worse, ;;; is less general than apply since it only takes two arguments. ;;; @@ -87,28 +116,9 @@ (define (apply-to-args args fn) (apply fn args)) -;;; {Silly Naming Cleanups and Trivial Functions} -;;; - -(define %open-file open-file) -(define (id x) x) -(define < <?) -(define <= <=?) -(define = =?) -(define > >?) -(define >= >=?) -(define (1+ n) (+ n 1)) -(define (-1+ n) (+ n -1)) -(define 1- -1+) -(define return-it noop) -(define (and=> value thunk) (and value (thunk value))) -(define (make-hash-table k) (make-vector k '())) - ;;; {Integer Math} ;;; -(define (integer? x) (and (number? x) (= x (inexact->exact x)))) - (define (ipow-by-squaring x k acc proc) (cond ((zero? k) acc) ((= 1 k) (proc acc x)) @@ -131,102 +141,6 @@ (else (apply logior args)))) -;;; {Basic Port Code} -;;; -;;; Specificly, the parts of the low-level port code that are written in -;;; Scheme rather than C. -;;; -;;; WARNING: the parts of this interface that refer to file ports -;;; is going away. It would be gone already except that it is used -;;; "internally" in a few places. -;;; - - -;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper -;; mode to open files in. MSDOS does carraige return - newline -;; translation if not opened in `b' mode. -;; -(define OPEN_READ (case (software-type) - ((MS-DOS WINDOWS ATARIST) "rb") - (else "r"))) -(define OPEN_WRITE (case (software-type) - ((MS-DOS WINDOWS ATARIST) "wb") - (else "w"))) -(define OPEN_BOTH (case (software-type) - ((MS-DOS WINDOWS ATARIST) "r+b") - (else "r+"))) - -(define (open-input-file str) - (or (open-file str OPEN_READ) - (error "OPEN-INPUT-FILE couldn't find file " str))) - -(define (open-output-file str) - (or (open-file str OPEN_WRITE) - (error "OPEN-OUTPUT-FILE couldn't find file " str))) - -(define (open-io-file str) (open-file str OPEN_BOTH)) -(define close-input-port close-port) -(define close-output-port close-port) -(define close-io-port close-port) - -(define (call-with-input-file str proc) - (let* ((file (open-input-file str)) - (ans (proc file))) - (close-input-port file) - ans)) - -(define (call-with-output-file str proc) - (let* ((file (open-output-file str)) - (ans (proc file))) - (close-output-port file) - ans)) - -(define (with-input-from-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-input-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-output-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-output-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-error-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-error-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-input-from-file file thunk) - (let* ((nport (open-input-file file)) - (ans (with-input-from-port nport thunk))) - (close-port nport) - ans)) - -(define (with-output-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-output-to-port nport thunk))) - (close-port nport) - ans)) - -(define (with-error-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-error-to-port nport thunk))) - (close-port nport) - ans)) - -(define (with-input-from-string string thunk) - (call-with-input-string string - (lambda (p) (with-input-from-port p thunk)))) - -(define (with-output-to-string thunk) - (call-with-output-string - (lambda (p) (with-output-to-port p thunk)))) - -(define (with-error-to-string thunk) - (call-with-output-string - (lambda (p) (with-error-to-port p thunk)))) - -(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - - - ;;; {Symbol Properties} ;;; @@ -246,6 +160,122 @@ (symbol-pset! sym (delq! pair (symbol-pref sym)))))) + +;;; {Line and Delimited I/O} + +;;; corresponds to SCM_LINE_INCREMENTORS in libguile. +(define scm-line-incrementors "\n") + +(define (read-line! string . maybe-port) + (let* ((port (if (pair? maybe-port) + (car maybe-port) + (current-input-port)))) + (let* ((rv (%read-delimited! scm-line-incrementors + string + #t + port)) + (terminator (car rv)) + (nchars (cdr rv))) + (cond ((and (= nchars 0) + (eof-object? terminator)) + terminator) + ((not terminator) #f) + (else nchars))))) + +(define (read-delimited! delims buf . args) + (let* ((num-args (length args)) + (port (if (> num-args 0) + (car args) + (current-input-port))) + (handle-delim (if (> num-args 1) + (cadr args) + 'trim)) + (start (if (> num-args 2) + (caddr args) + 0)) + (end (if (> num-args 3) + (cadddr args) + (string-length buf)))) + (let* ((rv (%read-delimited! delims + buf + (not (eq? handle-delim 'peek)) + port + start + end)) + (terminator (car rv)) + (nchars (cdr rv))) + (cond ((or (not terminator) ; buffer filled + (eof-object? terminator)) + (if (zero? nchars) + (if (eq? handle-delim 'split) + (cons terminator terminator) + terminator) + (if (eq? handle-delim 'split) + (cons nchars terminator) + nchars))) + (else + (case handle-delim + ((trim peek) nchars) + ((concat) (string-set! buf nchars terminator) + (+ nchars 1)) + ((split) (cons nchars terminator)) + (else (error "unexpected handle-delim value: " + handle-delim)))))))) + +(define (read-delimited delims . args) + (let* ((port (if (pair? args) + (let ((pt (car args))) + (set! args (cdr args)) + pt) + (current-input-port))) + (handle-delim (if (pair? args) + (car args) + 'trim))) + (let loop ((substrings ()) + (total-chars 0) + (buf-size 100)) ; doubled each time through. + (let* ((buf (make-string buf-size)) + (rv (%read-delimited! delims + buf + (not (eq? handle-delim 'peek)) + port)) + (terminator (car rv)) + (nchars (cdr rv)) + (join-substrings + (lambda () + (apply string-append + (reverse + (cons (if (and (eq? handle-delim 'concat) + (not (eof-object? terminator))) + (string terminator) + "") + (cons (make-shared-substring buf 0 nchars) + substrings)))))) + (new-total (+ total-chars nchars))) + (cond ((not terminator) + ;; buffer filled. + (loop (cons (substring buf 0 nchars) substrings) + new-total + (* buf-size 2))) + ((eof-object? terminator) + (if (zero? new-total) + (if (eq? handle-delim 'split) + (cons terminator terminator) + terminator) + (if (eq? handle-delim 'split) + (cons (join-substrings) terminator) + (join-substrings)))) + (else + (case handle-delim + ((trim peek concat) (join-substrings)) + ((split) (cons (join-substrings) terminator)) + (else (error "unexpected handle-delim value: " + handle-delim))))))))) + +(define (read-line . args) + (apply read-delimited scm-line-incrementors args)) + + ;;; {Arrays} ;;; @@ -287,28 +317,34 @@ (and rem (pair? (cdr rem)) (cadr rem)))) - ;;; {Print} -;;; +;;; MDJ 960919 <djurfeldt@nada.kth.se>: This code will probably be +;;; removed before the first release of Guile. Later releases may +;;; contain more fancy printing code. (define (print obj . args) (let ((default-args (list (current-output-port) 0 0 default-print-style #f))) (apply-to-args (append args (list-cdr-ref default-args (length args))) (lambda (port depth length style table) (cond - ((and table (print-table-ref table obj)) ((print-style-tag-hook style 'eq-val) - obj port depth length style table)) + ((and table (print-table-ref table obj)) + ((print-style-tag-hook style 'eq-val) + obj port depth length style table)) (else (and table (print-table-add! table obj)) (cond - ((print-style-max-depth? style depth) ((print-style-excess-depth-hook style))) - ((print-style-max-length? style length) ((print-style-excess-length-hook style))) - (else ((print-style-hook style obj) - obj port depth length style table))))))))) + ((print-style-max-depth? style depth) + ((print-style-excess-depth-hook style))) + ((print-style-max-length? style length) + ((print-style-excess-length-hook style))) + (else + ((print-style-hook style obj) + obj port depth length style table))))))))) -(define (make-print-style) (make-vector 59)) +(define (make-print-style) (make-vector 59 '())) -(define (extend-print-style! style utag printer) (hashq-set! style utag printer)) +(define (extend-print-style! style utag printer) + (hashq-set! style utag printer)) (define (print-style-hook style obj) (let ((type-tag (tag obj))) @@ -322,10 +358,12 @@ (define (print-style-max-depth? style d) #f) (define (print-style-max-length? style l) #f) -(define (print-style-excess-length-hook style) (hashq-ref style 'excess-length-hook)) -(define (print-style-excess-depth-hook style) (hashq-ref style 'excess-depth-hook)) +(define (print-style-excess-length-hook style) + (hashq-ref style 'excess-length-hook)) +(define (print-style-excess-depth-hook style) + (hashq-ref style 'excess-depth-hook)) -(define (make-print-table) (make-vector 59)) +(define (make-print-table) (make-vector 59 '())) (define (print-table-ref table obj) (hashq-ref table obj)) (define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref))) @@ -348,13 +386,14 @@ ((null? (cdr pair)) (display #\) port)) (else (display " . " port) - (print (cdr pair) port (+ 1 depth) 0 style table) + (print (cdr pair) port (+ 1 depth) 0 + style table) (display #\) port)))) (define (print-vector obj port depth length style table) (if (= 0 length) (cond - ((weak-hash-table? obj) (display "#wh(" port)) + ((weak-key-hash-table? obj) (display "#wh(" port)) ((weak-value-hash-table? obj) (display "#whv(" port)) ((doubly-weak-hash-table? obj) (display "#whd(" port)) (else (display "#(" port)))) @@ -365,7 +404,9 @@ (cond ((>= (+ 1 length) (vector-length obj)) (display #\) port)) (else (display #\space port) - (print obj port depth (+ 1 length) style table)))) + (print obj port depth + (+ 1 length) + style table)))) (define default-print-style (make-print-style)) @@ -390,16 +431,20 @@ (and (struct? obj) (eq? record-type-vtable (struct-vtable obj)))) (define (make-record-type type-name fields . opt) - (let ((printer-fn (and opt (car opt)))) + (let ((printer-fn (and (pair? opt) (car opt)))) (let ((struct (make-struct record-type-vtable 0 - (make-struct-layout (apply symbol-append (map (lambda (f) "pw") fields))) + (make-struct-layout + (apply symbol-append + (map (lambda (f) "pw") fields))) type-name (copy-tree fields)))) ;; !!! leaks printer functions - (if printer-fn - (extend-print-style! default-print-style - (logior utag_struct_base (ash (struct-vtable-tag struct) 8)) - printer-fn)) + ;; MDJ 960919 <djurfeldt@nada.kth.se>: *fixme* need to make it + ;; possible to print records nicely. + ;(if printer-fn +; (extend-print-style! default-print-style +; (logior utag_struct_base (ash (struct-vtable-tag struct) 8)) +; printer-fn)) struct))) (define (record-type-name obj) @@ -413,7 +458,7 @@ (error 'not-a-record-type obj))) (define (record-constructor rtd . opt) - (let ((field-names (if opt (car opt) (record-type-fields rtd)))) + (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) (eval `(lambda ,field-names (make-struct ',rtd 0 ,@(map (lambda (f) (if (memq f field-names) @@ -449,6 +494,8 @@ (struct-vtable obj) (error 'not-a-record obj))) +(provide 'record) + ;;; {Booleans} ;;; @@ -552,15 +599,52 @@ ;;; !!!! these should be implemented using Tcl commands, not fports. ;;; -(define (file-exists? str) - (let ((port (open-file str OPEN_READ))) - (if port (begin (close-port port) #t) - #f))) - -(define (file-is-directory? str) - (let ((port (open-file (string-append str "/.") OPEN_READ))) - (if port (begin (close-port port) #t) - #f))) +(define (feature? feature) + (and (memq feature *features*) #t)) + +;; Using the vector returned by stat directly is probably not a good +;; idea (it could just as well be a record). Hence some accessors. +(define (stat:dev f) (vector-ref f 0)) +(define (stat:ino f) (vector-ref f 1)) +(define (stat:mode f) (vector-ref f 2)) +(define (stat:nlink f) (vector-ref f 3)) +(define (stat:uid f) (vector-ref f 4)) +(define (stat:gid f) (vector-ref f 5)) +(define (stat:rdev f) (vector-ref f 6)) +(define (stat:size f) (vector-ref f 7)) +(define (stat:atime f) (vector-ref f 8)) +(define (stat:mtime f) (vector-ref f 9)) +(define (stat:ctime f) (vector-ref f 10)) +(define (stat:blksize f) (vector-ref f 11)) +(define (stat:blocks f) (vector-ref f 12)) + +;; derived from stat mode. +(define (stat:type f) (vector-ref f 13)) +(define (stat:perms f) (vector-ref f 14)) + +(define file-exists? + (if (feature? 'posix) + (lambda (str) + (access? str F_OK)) + (lambda (str) + (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ)) + (lambda args #f)))) + (if port (begin (close-port port) #t) + #f))))) + +(define file-is-directory? + (if (feature? 'i/o-extensions) + (lambda (str) + (eq? (stat:type (stat str)) 'directory)) + (lambda (str) + (display str) + (newline) + (let ((port (catch 'system-error + (lambda () (open-file (string-append str "/.") + OPEN_READ)) + (lambda args #f)))) + (if port (begin (close-port port) #t) + #f))))) (define (has-suffix? str suffix) (let ((sufl (string-length suffix)) @@ -568,89 +652,64 @@ (and (> sl sufl) (string=? (substring str (- sl sufl) sl) suffix)))) - - ;;; {Error Handling} ;;; - -;; (error . args) is short for (throw (quote error) . args) -;; (define (error . args) - (apply throw 'error args)) - - - - -;; Error handling a la SCM. -;; -(define (%%default-error-handler tag . args) - (define cep (current-error-port)) - (perror "ERROR") - (errno 0) - (display "ERROR: " cep) - (if (not (null? args)) - (begin (display (car args) cep) - (for-each (lambda (x) (display #\ cep) (write x cep)) - (cdr args)))) - (newline cep) - (force-output cep) - (apply throw 'abort tag args)) - - - -;; Install SCM error handling as the default. -;; -(set-symbol-property! 'error - 'throw-handler-default - %%default-error-handler) - - - - - -;; %%bad-throw is the hook that is called upon a throw to a an unhandled -;; key. If the key has a default handler (a throw-handler-default property), + (save-stack) + (if (null? args) + (scm-error 'misc-error #f "?" #f #f) + (let loop ((msg "%s") + (rest (cdr args))) + (if (not (null? rest)) + (loop (string-append msg " %S") + (cdr rest)) + (scm-error 'misc-error #f msg args #f))))) + +(define (scm-error key subr message args rest) + (throw key subr message args rest)) + +;; bad-throw is the hook that is called upon a throw to a an unhandled +;; key (unless the throw has four arguments, in which case +;; it's usually interpreted as an error throw.) +;; If the key has a default handler (a throw-handler-default property), ;; it is applied to the throw. ;; -(define (%%bad-throw key . args) +(define (bad-throw key . args) (let ((default (symbol-property key 'throw-handler-default))) (or (and default (apply default key args)) - (throw 'error 'unhandled-exception key args)))) - - - - + (apply error "unhandled-exception:" key args)))) -;; A number of internally defined error types are represented +;; mostly obsolete. +;; A number of internally defined error types were represented ;; as integers. Here is the mapping to symbolic names ;; and error messages. ;; -(define %%system-errors - '((-1 UNKNOWN "Unknown error") - (0 ARGn "Wrong type argument to ") - (1 ARG1 "Wrong type argument in position 1 to ") - (2 ARG2 "Wrong type argument in position 2 to ") - (3 ARG3 "Wrong type argument in position 3 to ") - (4 ARG4 "Wrong type argument in position 4 to ") - (5 ARG5 "Wrong type argument in position 5 to ") - (6 ARG5 "Wrong type argument in position 5 to ") - (7 ARG5 "Wrong type argument in position 5 to ") - (8 WNA "Wrong number of arguments to ") - (9 OVFLOW "Numerical overflow to ") - (10 OUTOFRANGE "Argument out of range to ") - (11 NALLOC "Could not allocate to ") - (12 STACK_OVFLOW "Stack overflow") - (13 EXIT "Exit (internal error?).") - (14 HUP_SIGNAL "hang-up") - (15 INT_SIGNAL "user interrupt") - (16 FPE_SIGNAL "arithmetic error") - (17 BUS_SIGNAL "bus error") - (18 SEGV_SIGNAL "segmentation violation") - (19 ALRM_SIGNAL "alarm") - (20 GC_SIGNAL "gc") - (21 TICK_SIGNAL "tick"))) +;(define %%system-errors +; '((-1 UNKNOWN "Unknown error") +; (0 ARGn "Wrong type argument to ") +; (1 ARG1 "Wrong type argument in position 1 to ") +; (2 ARG2 "Wrong type argument in position 2 to ") +; (3 ARG3 "Wrong type argument in position 3 to ") +; (4 ARG4 "Wrong type argument in position 4 to ") +; (5 ARG5 "Wrong type argument in position 5 to ") +; (6 ARG5 "Wrong type argument in position 5 to ") +; (7 ARG5 "Wrong type argument in position 5 to ") +; (8 WNA "Wrong number of arguments to ") +; (9 OVFLOW "Numerical overflow to ") +; (10 OUTOFRANGE "Argument out of range to ") +; (11 NALLOC "Could not allocate to ") +; (12 STACK_OVFLOW "Stack overflow") +; (13 EXIT "Exit (internal error?).") +; (14 HUP_SIGNAL "hang-up") +; (15 INT_SIGNAL "user interrupt") +; (16 FPE_SIGNAL "arithmetic error") +; (17 BUS_SIGNAL "bus error") +; (18 SEGV_SIGNAL "segmentation violation") +; (19 ALRM_SIGNAL "alarm") +; (20 GC_SIGNAL "gc") +; (21 TICK_SIGNAL "tick"))) (define (timer-thunk) #t) @@ -658,94 +717,57 @@ (define (alarm-thunk) #t) (define (signal-handler n) - (cond - ((= n 21) (unmask-signals) (timer-thunk)) - ((= n 20) (unmask-signals) (gc-thunk)) - ((= n 19) (unmask-signals) (alarm-thunk)) - (else (unmask-signals) (throw '%%system-error n #f)))) - - -;; The default handler for built-in error types when -;; thrown by their symbolic name. The action is to -;; convert the error into a generic error, building -;; a descriptive message for the error. -;; -(define (%%handle-system-error ignored desc proc . args) - (let* ((b (assoc desc %%system-errors)) - (msghead (cond - (b (caddr b)) - ((or (symbol? desc) (string? desc)) - (string-append desc " ")) - (#t "Unknown error"))) - (msg (if (symbol? proc) - (string-append msghead proc ":") - msghead)) - (rest (if (and proc (not (symbol? proc))) - (cons proc args) - args)) - (fixed-args (cons msg rest))) - (apply error fixed-args))) - - -(set-symbol-property! '%%system-error - 'throw-handler-default - %%handle-system-error) - - -;; Install default handlers for built-in errors. -;; -(map (lambda (err) - (set-symbol-property! (cadr err) - 'throw-handler-default - %%handle-system-error)) - (cdr %%system-errors)) - - - - -(define ((make-simple-wrapper func) . args) - (or (apply func args) - (apply throw 'syserror func (errno) args))) - -(define ((make-eof-wrapper func) . args) - (let ((rv (apply func args))) - (if (eof-object? rv) - (apply throw 'syserror func (errno) args) - rv))) - -(define ((make-errno-wrapper func) . args) - (let ((rv (apply func args))) - (if (number? rv) - (apply throw 'syserror func rv args) - rv))) - -(define ((make-errpair-wrapper func) . args) - (let ((rv (apply func args))) - (if (and (pair? rv) - (number? (car rv)) - (null? (cdr rv))) - (apply throw 'syserror func (car rv) args) - rv))) - -(begin - (define (syserror key fn err . args) - (errno err) - (apply error (cons fn args))) - (set-symbol-property! 'syserror 'throw-handler-default syserror)) - - -(define (%getgrnam name) (%getgr name)) -(define (%getgrgid id) (%getgr id)) -(define (%gethostbyaddr addr) (%gethost addr)) -(define (%gethostbyname name) (%gethost name)) -(define (%getnetbyaddr addr) (%getnet addr)) -(define (%getnetbyname name) (%getnet name)) -(define (%getprotobyname name) (%getproto name)) -(define (%getprotobynumber addr) (%getproto addr)) -(define (%getpwnam name) (%getpw name)) -(define (%getpwuid uid) (%getpw uid)) -(define (%getservbyname name proto) (%getserv name proto)) -(define (%getservbyport port proto) (%getserv port proto)) + (let* ( + ;; these numbers are set in libguile, not the same as those + ;; interned in posix.c for SIGSEGV etc. + ;; + (signal-messages `((14 . "hang-up") + (15 . "user interrupt") + (16 . "arithmetic error") + (17 . "bus error") + (18 . "segmentation violation")))) + (cond + ((= n 21) (unmask-signals) (timer-thunk)) + ((= n 20) (unmask-signals) (gc-thunk)) + ((= n 19) (unmask-signals) (alarm-thunk)) + (else (set! the-last-stack + (make-stack #t + (list-ref (list %hup-thunk + %int-thunk + %fpe-thunk + %bus-thunk + %segv-thunk) + (- n 14)) + 1)) + (set! stack-saved? #t) + (if (not (and (memq 'debug (debug-options-interface)) + (eq? (stack-id the-last-stack) 'repl-stack))) + (set! the-last-stack #f)) + (unmask-signals) + (let ((sig-pair (assoc n signal-messages))) + (scm-error 'error-signal #f + (cdr (or sig-pair + (cons n "Unknown signal: %s"))) + (if sig-pair + #f + (list n)) + (list n))))))) + + +;;; {Non-polymorphic versions of POSIX functions} + +(define (getgrnam name) (getgr name)) +(define (getgrgid id) (getgr id)) +(define (gethostbyaddr addr) (gethost addr)) +(define (gethostbyname name) (gethost name)) +(define (getnetbyaddr addr) (getnet addr)) +(define (getnetbyname name) (getnet name)) +(define (getprotobyname name) (getproto name)) +(define (getprotobynumber addr) (getproto addr)) +(define (getpwnam name) (getpw name)) +(define (getpwuid uid) (getpw uid)) +(define (getservbyname name proto) (getserv name proto)) +(define (getservbyport port proto) (getserv port proto)) (define (endgrent) (setgr)) (define (endhostent) (sethost)) (define (endnetent) (setnet)) @@ -754,12 +776,12 @@ (define (endservent) (setserv)) (define (file-position . args) (apply ftell args)) (define (file-set-position . args) (apply fseek args)) -(define (getgrent) (%getgr)) -(define (gethostent) (%gethost)) -(define (getnetent) (%getnet)) -(define (getprotoent) (%getproto)) -(define (getpwent) (%getpw)) -(define (getservent) (%getserv)) +(define (getgrent) (getgr)) +(define (gethostent) (gethost)) +(define (getnetent) (getnet)) +(define (getprotoent) (getproto)) +(define (getpwent) (getpw)) +(define (getservent) (getserv)) (define (reopen-file . args) (apply freopen args)) (define (setgrent arg) (setgr arg)) (define (sethostent arg) (sethost arg)) @@ -767,224 +789,42 @@ (define (setprotoent arg) (setproto arg)) (define (setpwent arg) (setpw arg)) (define (setservent arg) (setserv arg)) -(define (%move->fdes port fd) - (if (= 1 (primitive-move->fdes port fd)) - (set-port-revealed! port 1) - #t)) - -(define accept (make-errno-wrapper %accept)) -(define bind (make-errno-wrapper %bind)) -(define chdir (make-errno-wrapper %chdir)) -(define chmod (make-errno-wrapper %chmod)) -(define chown (make-errno-wrapper %chown)) -(define close (make-errno-wrapper %close)) -(define closedir (make-errno-wrapper %closedir)) -(define connect (make-errno-wrapper %connect)) -(define copy-file (make-simple-wrapper %copy-file)) -(define ctermid (make-simple-wrapper %ctermid)) -(define delete-file (make-errno-wrapper %delete-file)) -(define duplicate-port (make-simple-wrapper %duplicate-port)) -(define execl (make-errno-wrapper %execl)) -(define execlp (make-errno-wrapper %execlp)) -(define fdopen (make-errno-wrapper %fdopen)) -(define fileno (make-simple-wrapper %fileno)) -(define fork (make-simple-wrapper %fork)) -(define freopen (make-errno-wrapper %freopen)) -(define fseek (make-errno-wrapper %fseek)) -(define ftell (make-errno-wrapper %ftell)) -(define getcwd (make-errno-wrapper %getcwd)) -(define getenv (make-simple-wrapper %getenv)) -(define getgrgid (make-errno-wrapper %getgrgid)) -(define getgrnam (make-errno-wrapper %getgrnam)) -(define getgroups (make-errno-wrapper %getgroups)) -(define gethostbyaddr (make-simple-wrapper %gethostbyaddr)) -(define gethost (make-simple-wrapper %gethost)) -(define gethostbyname (make-simple-wrapper %gethostbyname)) -(define getnetbyaddr (make-simple-wrapper %getnetbyaddr)) -(define getnetbyname (make-simple-wrapper %getnetbyname)) -(define getpeername (make-errno-wrapper %getpeername)) -(define getprotobyname (make-simple-wrapper %getprotobyname)) -(define getprotobynumber (make-simple-wrapper %getprotobynumber)) -(define getpwnam (make-simple-wrapper %getpwnam)) -(define getpwuid (make-simple-wrapper %getpwuid)) -(define getservbyname (make-simple-wrapper %getservbyname)) -(define getservbyport (make-simple-wrapper %getservbyport)) -(define getsockname (make-errno-wrapper %getsockname)) -(define getsockopt (make-errpair-wrapper %getsockopt)) -(define inet-aton (make-simple-wrapper %inet-aton)) -(define isatty? (make-errno-wrapper %isatty?)) -(define kill (make-errno-wrapper %kill)) -(define link (make-errno-wrapper %link)) -(define listen (make-errno-wrapper %listen)) -(define lstat (make-errno-wrapper %lstat)) -(define mkdir (make-errno-wrapper %mkdir)) -(define mknod (make-errno-wrapper %mknod)) -(define nice (make-errno-wrapper %nice)) -(define opendir (make-errno-wrapper %opendir)) -(define pipe (make-errno-wrapper %pipe)) -(define primitive-move->fdes (make-simple-wrapper %primitive-move->fdes)) -(define putenv (make-errno-wrapper %putenv)) -(define read-fd (make-errpair-wrapper %read-fd)) -(define readdir (make-errno-wrapper %readdir)) -(define readlink (make-errno-wrapper %readlink)) -(define recv (make-errno-wrapper %recv)) -(define recvfrom (make-errno-wrapper %recvfrom)) -(define redirect-port (make-errno-wrapper %redirect-port)) -(define rename-file (make-errno-wrapper %rename-file)) -(define rmdir (make-errno-wrapper %rmdir)) -(define select (make-errno-wrapper %select)) -(define send (make-errpair-wrapper %send)) -(define sendto (make-errpair-wrapper %sendto)) -(define setegid (make-errno-wrapper %setegid)) -(define seteuid (make-errno-wrapper %seteuid)) -(define setgid (make-errno-wrapper %setgid)) -(define setlocale (make-errno-wrapper %setlocale)) -(define setpgid (make-errno-wrapper %setpgid)) -(define setsid (make-simple-wrapper %setsid)) -(define setsockopt (make-errno-wrapper %setsockopt)) -(define setuid (make-errno-wrapper %setuid)) -(define shutdown (make-errno-wrapper %shutdown)) -(define socket (make-errno-wrapper %socket)) -(define socketpair (make-errno-wrapper %socketpair)) -(define stat (make-errno-wrapper %stat)) -(define strptime (make-simple-wrapper %strptime)) -(define symlink (make-simple-wrapper %symlink)) -(define tcgetpgrp (make-simple-wrapper %tcgetpgrp)) -(define tcsetpgrp (make-simple-wrapper %tcsetpgrp)) -(define ttyname (make-errno-wrapper %ttyname)) -(define uname (make-errno-wrapper %uname)) -(define utime (make-errno-wrapper %utime)) -(define waitpid (make-errno-wrapper %waitpid)) -(define write-fd (make-errpair-wrapper %write-fd)) -(define move->fdes (make-simple-wrapper %move->fdes)) + +(define (move->fdes port fd) + (primitive-move->fdes port fd) + (set-port-revealed! port 1) + port) + +(define (release-port-handle port) + (let ((revealed (port-revealed port))) + (if (> revealed 0) + (set-port-revealed! port (- revealed 1))))) ;;; {Load Paths} ;;; -(define implementation-vicinity compiled-library-path) - ;;; Here for backward compatability ;; (define scheme-file-suffix (lambda () ".scm")) -(define in-vicinity string-append) - -(define (parse-path env_path) - (cond ((string? env_path) - (let loop ((curdir "") (env env_path) (path '())) - (cond ((= (string-length env) 0) - (if (> (string-length curdir) 0) - (append path (list curdir)) - path)) - ((char=? (string-ref env 0) #\:) - (loop "" - (substring env 1 (string-length env)) - (append path (list curdir)))) - (#t - (loop (string-append curdir (substring env 0 1)) - (substring env 1 (string-length env)) - path))))) - (#t '()))) - -(define %load-path (append (parse-path (%getenv "SCHEME_LOAD_PATH")) - (list "" - (in-vicinity (implementation-vicinity) "gls/guile/") - (in-vicinity (implementation-vicinity) "gls/") - (in-vicinity (implementation-vicinity) "slib/")))) - -;;; {try-load} -;;; - -(define (try-load-with-path file-name path) - (or-map (lambda (d) - (let ((f (in-vicinity d file-name))) - (and (not (file-is-directory? f)) - (%try-load f #t read-sharp)))) - path)) +(define (in-vicinity vicinity file) + (let ((tail (let ((len (string-length vicinity))) + (if (zero? len) #f + (string-ref vicinity (- len 1)))))) + (string-append vicinity + (if (eq? tail #\/) "" "/") + file))) -(define (try-load name) - (if (eval '(defined? %load-path)) - (try-load-with-path name (eval '%load-path)) - (%try-load name #t read-sharp))) -;;; {Load} -;;; - -(define %load-verbosely #t) -(define (assert-load-verbosity v) (set! %load-verbosely v)) -(define %load-indent -2) - -(define (%load f) - (current-module) - (or (and (not (file-is-directory? f)) - (%try-load f #t read-sharp)) - (and (not (has-suffix? f (scheme-file-suffix))) - (%try-load (string-append f (scheme-file-suffix)) #t read-sharp)))) - -(define (%load-announce file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display (make-string %load-indent #\ )) - (display "loading ") - (display file) - (display "...") - (newline) - (force-output))))) - -(define (%load-announce-win file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display (make-string %load-indent #\ )) - (display "...loaded ") - (display file) - (display ".") - (newline) - (force-output))))) - -(define (%load-announce-lossage file path) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display (make-string %load-indent #\ )) - (display "...COULD NOT LOAD ") - (display file) - (display " from ") - (write path) - (newline) - (force-output)))) - (throw 'could-not-load file path)) - - -(define (load-with-path name path) - (define (do-load) - (%load-announce name) - (if (not (or-map (lambda (d) - (if (%load (in-vicinity d name)) - (begin - (%load-announce-win (in-vicinity d name)) - #t) - #f)) - path)) - (%load-announce-lossage name path))) - - (let ((indent %load-indent)) - (dynamic-wind - (lambda () (set! %load-indent (modulo (+ indent 2) 16))) - do-load - (lambda () (set! %load-indent indent)))) - #t) - +;;; {Loading by paths} -(define (load name) - (if (eval '(defined? %load-path)) - (load-with-path name (eval '%load-path)) - (load-with-path name '()))) +;;; Load a Scheme source file named NAME, searching for it in the +;;; directories listed in %load-path, and applying each of the file +;;; name extensions listed in %load-extensions. +(define (load-from-path name) + (start-stack 'load-stack + (primitive-load-path name #t read-sharp))) @@ -1111,7 +951,7 @@ ;;; (define (parse-path-symbol s) - (define (seperate-fields-discarding-char ch str ret) + (define (separate-fields-discarding-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -1119,7 +959,7 @@ => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields) (make-shared-substring str 0 pos)))) (else (ret (cons str fields)))))) - (seperate-fields-discarding-char #\/ + (separate-fields-discarding-char #\/ s (lambda (fields) (map string->symbol fields)))) @@ -1148,11 +988,6 @@ ((#\c) (read:uniform-vector 0+i port)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read:array c port)) - ((#\!) (if (= 1 (line-number)) - (let skip () (if (eq? #\newline (peek-char port)) - (read port #t read-sharp) - (begin (read-char port) (skip)))) - (barf))) (else (barf)))) (define (read:array digit port) @@ -1284,15 +1119,6 @@ -(define (delq-all! obj l) - (let ((answer (cons '() l))) - (let loop ((pos answer)) - (cond - ((null? (cdr pos)) (cdr answer)) - ((eq? (cadr pos) obj) (set-cdr! pos (cddr pos)) - (loop pos)) - (else (loop (cdr pos))))))) - (define (transform-usage-lambda cases) (let* ((raw-usage (delq! 'else (map car cases))) (usage-sans-specials (map (lambda (x) @@ -1301,7 +1127,7 @@ (and (boolean? (car x)) #t) x)) raw-usage)) - (usage-desc (delq-all! #t usage-sans-specials)) + (usage-desc (delq! #t usage-sans-specials)) (kw-desc (map car usage-desc)) (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc))) (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc))) @@ -1359,8 +1185,8 @@ ;;; -;; This is how modules are printed. -;; You can re-define it. +;;; {Printing Modules} +;; This is how modules are printed. You can re-define it. ;; (define (%print-module mod port depth length style table) (display "#<" port) @@ -1379,85 +1205,74 @@ ;; A module is characterized by an obarray in which local symbols ;; are interned, a list of modules, "uses", from which non-local ;; bindings can be inherited, and an optional lazy-binder which -;; is a (THUNK module symbol) which, as a last resort, can provide +;; is a (CLOSURE module symbol) which, as a last resort, can provide ;; bindings that would otherwise not be found locally in the module. ;; (define module-type - (make-record-type 'module '(obarray uses binder eval-thunk name kind) %print-module)) + (make-record-type 'module '(obarray uses binder eval-closure name kind) + %print-module)) -;; make-module &opt size uses +;; make-module &opt size uses binder ;; -;; Create a new module, perhaps with a particular size of obarray -;; or initial uses list. +;; Create a new module, perhaps with a particular size of obarray, +;; initial uses list, or binding procedure. ;; -(define module-constructor (record-constructor module-type)) - (define make-module (lambda args - (let* ((size 1021) - (uses '()) - (binder #f) - (answer #f) - (eval-thunk - (lambda (symbol define?) - (if define? - (module-make-local-var! answer symbol) - (module-variable answer symbol))))) - - (if (> (length args) 0) - (begin - (set! size (or (car args) size)) - (set! args (cdr args)))) - - (if (> (length args) 0) - (begin - (set! uses (or (car args) uses)) - (set! args (cdr args)))) - - (if (> (length args) 0) - (begin - (set! binder (or (car args) binder)) - (set! args (cdr args)))) - - (if (not (null? args)) - (error "Too many args to make-module." args)) - (if (not (integer? size)) - (error "Illegal size to make-module." size)) + (define (parse-arg index default) + (if (> (length args) index) + (list-ref args index) + default)) + + (if (> (length args) 3) + (error "Too many args to make-module." args)) - (and (list? uses) - (or (and-map module? uses) - (error "Incorrect use list." uses))) + (let ((size (parse-arg 0 1021)) + (uses (parse-arg 1 '())) + (binder (parse-arg 2 #f))) + (if (not (integer? size)) + (error "Illegal size to make-module." size)) + (if (not (and (list? uses) + (and-map module? uses))) + (error "Incorrect use list." uses)) (if (and binder (not (procedure? binder))) (error "Lazy-binder expected to be a procedure or #f." binder)) - (set! answer - (module-constructor (make-vector size '()) - uses - binder - eval-thunk - #f - #f)) - answer))) + (let ((module (module-constructor (make-vector size '()) + uses binder #f #f #f))) + + ;; We can't pass this as an argument to module-constructor, + ;; because we need it to close over a pointer to the module + ;; itself. + (set-module-eval-closure! module + (lambda (symbol define?) + (if define? + (module-make-local-var! module symbol) + (module-variable module symbol)))) + + module)))) +(define module-constructor (record-constructor module-type)) (define module-obarray (record-accessor module-type 'obarray)) (define set-module-obarray! (record-modifier module-type 'obarray)) (define module-uses (record-accessor module-type 'uses)) (define set-module-uses! (record-modifier module-type 'uses)) (define module-binder (record-accessor module-type 'binder)) (define set-module-binder! (record-modifier module-type 'binder)) -(define module-eval-thunk (record-accessor module-type 'eval-thunk)) -(define set-module-eval-thunk! (record-modifier module-type 'eval-thunk)) +(define module-eval-closure (record-accessor module-type 'eval-closure)) +(define set-module-eval-closure! (record-modifier module-type 'eval-closure)) (define module-name (record-accessor module-type 'name)) (define set-module-name! (record-modifier module-type 'name)) (define module-kind (record-accessor module-type 'kind)) (define set-module-kind! (record-modifier module-type 'kind)) (define module? (record-predicate module-type)) + (define (eval-in-module exp module) - (eval2 exp (module-eval-thunk module))) + (eval2 exp (module-eval-closure module))) ;;; {Module Searching in General} @@ -1581,12 +1396,13 @@ ;;; If the symbol is not found at all, return #f. ;;; (define (module-local-variable m v) - (caddr - (list m v +; (caddr +; (list m v (let ((b (module-obarray-ref (module-obarray m) v))) (or (and (variable? b) b) (and (module-binder m) - ((module-binder m) m v #f))))))) + ((module-binder m) m v #f))))) +;)) ;; module-variable module symbol ;; @@ -1711,13 +1527,13 @@ ;; make-root-module -:; A root module uses the symhash table (the system's privileged +;; A root module uses the symhash table (the system's privileged ;; obarray). Being inside a root module is like using SCM without ;; any module system. ;; -(define (root-module-thunk m s define?) +(define (root-module-closure m s define?) (let ((bi (and (symbol-interned? #f s) (builtin-variable s)))) (and bi @@ -1727,7 +1543,7 @@ bi)))) (define (make-root-module) - (make-module 1019 #f root-module-thunk)) + (make-module 1019 '() root-module-closure)) ;; make-scm-module @@ -1740,7 +1556,7 @@ ;; (define (make-scm-module) - (make-module 1019 #f + (make-module 1019 '() (lambda (m s define?) (let ((bi (and (symbol-interned? #f s) (builtin-variable s)))) @@ -1764,8 +1580,8 @@ (define (set-current-module m) (set! the-module m) (if m - (set! *top-level-lookup-thunk* (module-eval-thunk the-module)) - (set! *top-level-lookup-thunk* #f))) + (set! *top-level-lookup-closure* (module-eval-closure the-module)) + (set! *top-level-lookup-closure* #f))) ;; current-module @@ -1790,28 +1606,14 @@ (set-current-module outer-module) (set! outer-module #f))))) -(define basic-try-load-with-path try-load-with-path) -(define basic-try-load try-load) -(define basic-load-with-path load-with-path) (define basic-load load) - -(define (try-load-module-with-path . args) - (save-module-excursion (lambda () (apply basic-try-load-with-path args)))) - -(define (try-load-module . args) - (save-module-excursion (lambda () (apply basic-try-load args)))) - -(define (load-module-with-path . args) - (save-module-excursion (lambda () (apply basic-load-with-path args)))) - (define (load-module . args) (save-module-excursion (lambda () (apply basic-load args)))) - -;; MODULE-REF -- exported +;;; {MODULE-REF -- exported} ;; ;; Returns the value of a variable called NAME in MODULE or any of its ;; used modules. If there is no such variable, then if the optional third @@ -1857,9 +1659,6 @@ (cons interface (delq! interface (module-uses module))))) - - -;;;; ;;; {Recursive Namespaces} ;;; ;;; @@ -1870,7 +1669,7 @@ ;;; Each variable name is a list of elements, looked up in successively nested ;;; modules. ;;; -;;; (resolved-ref some-root-module '(foo bar baz)) +;;; (nested-ref some-root-module '(foo bar baz)) ;;; => <value of a variable named baz in the module bound to bar in ;;; the module bound to foo in some-root-module> ;;; @@ -1880,23 +1679,23 @@ ;;; ;; a-root is a module ;;; ;; name is a list of symbols ;;; -;;; resolved-ref a-root name -;;; resolved-set! a-root name val -;;; resolved-define! a-root name val -;;; resolved-remove! a-root name +;;; nested-ref a-root name +;;; nested-set! a-root name val +;;; nested-define! a-root name val +;;; nested-remove! a-root name ;;; ;;; ;;; (current-module) is a natural choice for a-root so for convenience there are ;;; also: ;;; -;;; value-ref name == resolved-ref (current-module) name -;;; value-set! name val == resolved-set! (current-module) name val -;;; value-define! name val == resolved-define! (current-module) name val -;;; value-remove! name == resolved-remove! (current-module) name +;;; local-ref name == nested-ref (current-module) name +;;; local-set! name val == nested-set! (current-module) name val +;;; local-define! name val == nested-define! (current-module) name val +;;; local-remove! name == nested-remove! (current-module) name ;;; -(define (resolved-ref root names) +(define (nested-ref root names) (let loop ((cur root) (elts names)) (cond @@ -1904,37 +1703,35 @@ ((not (module? cur)) #f) (else (loop (module-ref cur (car elts) #f) (cdr elts)))))) -(define (resolved-set! root names val) +(define (nested-set! root names val) (let loop ((cur root) (elts names)) (if (null? (cdr elts)) (module-set! cur (car elts) val) (loop (module-ref cur (car elts)) (cdr elts))))) -(define (resolved-define! root names val) +(define (nested-define! root names val) (let loop ((cur root) (elts names)) (if (null? (cdr elts)) (module-define! cur (car elts) val) (loop (module-ref cur (car elts)) (cdr elts))))) -(define (resolved-remove! root names) +(define (nested-remove! root names) (let loop ((cur root) (elts names)) (if (null? (cdr elts)) (module-remove! cur (car elts)) (loop (module-ref cur (car elts)) (cdr elts))))) -(define (value-ref names) (resolved-ref (current-module) names)) -(define (value-set! names val) (resolved-set! (current-module) names val)) -(define (value-define names val) (resolved-define! (current-module) names val)) -(define (value-remove names) (resolved-remove! (current-module) names)) +(define (local-ref names) (nested-ref (current-module) names)) +(define (local-set! names val) (nested-set! (current-module) names val)) +(define (local-define names val) (nested-define! (current-module) names val)) +(define (local-remove names) (nested-remove! (current-module) names)) - -;;;; -;;; #/app +;;; {#/app} ;;; ;;; The root of conventionally named objects not directly in the top level. ;;; @@ -1955,17 +1752,19 @@ (set-current-module the-root-module) (define app (make-module 31)) -(value-define '(app modules) (make-module 31)) -(value-define '(app modules guile) the-root-module) +(local-define '(app modules) (make-module 31)) +(local-define '(app modules guile) the-root-module) ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) -(define (resolve-module name) +(define (resolve-module name . maybe-autoload) (let ((full-name (append '(app modules) name))) - (let ((already (value-ref full-name))) + (let ((already (local-ref full-name))) (or already (begin - (try-module-autoload name) + (if (or (null? maybe-autoload) (car maybe-autoload)) + (or (try-module-autoload name) + (try-module-dynamic-link name))) (make-modules-in (current-module) full-name)))))) (define (beautify-user-module! module) @@ -1997,43 +1796,46 @@ (define (process-define-module args) (let* ((module-id (car args)) - (module (resolve-module module-id)) + (module (resolve-module module-id #f)) (kws (cdr args))) (beautify-user-module! module) - (let loop ((kws kws)) - (and (not (null? kws)) - (case (car kws) - ((:use-module) - (if (not (pair? (cdr kws))) - (error "unrecognized defmodule argument" kws)) - (let* ((used-name (cadr kws)) - (used-module (resolve-module used-name))) - (if (not (module-ref used-module '%module-public-interface #f)) - (begin - ((if %autoloader-developer-mode warn error) "no code for module" used-module) - (beautify-user-module! used-module))) - (let ((interface (module-ref used-module '%module-public-interface #f))) - (if (not interface) - (error "missing interface for use-module" used-module)) - (set-module-uses! module - (append! (delq! interface (module-uses module)) - (list interface))))) - (loop (cddr kws))) - - (else (error "unrecognized defmodule argument" kws))))) + (let loop ((kws kws) + (reversed-interfaces '())) + (if (null? kws) + (for-each (lambda (interface) + (module-use! module interface)) + reversed-interfaces) + (case (car kws) + ((:use-module) + (if (not (pair? (cdr kws))) + (error "unrecognized defmodule argument" kws)) + (let* ((used-name (cadr kws)) + (used-module (resolve-module used-name))) + (if (not (module-ref used-module '%module-public-interface #f)) + (begin + ((if %autoloader-developer-mode warn error) + "no code for module" (module-name used-module)) + (beautify-user-module! used-module))) + (let ((interface (module-public-interface used-module))) + (if (not interface) + (error "missing interface for use-module" used-module)) + (loop (cddr kws) (cons interface reversed-interfaces))))) + (else + (error "unrecognized defmodule argument" kws))))) module)) +;;; {Autoloading modules} (define autoloads-in-progress '()) (define (try-module-autoload module-name) - + (define (sfx name) (string-append name (scheme-file-suffix))) (let* ((reverse-name (reverse module-name)) (name (car reverse-name)) (dir-hint-module-name (reverse (cdr reverse-name))) (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name)))) - (resolve-module dir-hint-module-name) + (resolve-module dir-hint-module-name #f) (and (not (autoload-done-or-in-progress? dir-hint name)) (let ((didit #f)) (dynamic-wind @@ -2051,13 +1853,13 @@ (and (or-map (lambda (f) (let ((full (in-vicinity d f))) full - (and (not (file-is-directory? full)) - (file-exists? full) + (and (file-exists? full) + (not (file-is-directory? full)) (begin (save-module-excursion (lambda () - (list f d) - (load-with-path f (list d)))) + (load (string-append + d "/" f)))) #t)))) trys) (begin @@ -2067,6 +1869,143 @@ (lambda () (set-autoloaded! dir-hint name didit))) didit)))) +;;; Dynamic linking of modules + +;; Initializing a module that is written in C is a two step process. +;; First the module's `module init' function is called. This function +;; is expected to call `scm_register_module_xxx' to register the `real +;; init' function. Later, when the module is referenced for the first +;; time, this real init function is called in the right context. See +;; gtcltk-lib/gtcltk-module.c for an example. +;; +;; The code for the module can be in a regular shared library (so that +;; the `module init' function will be called when libguile is +;; initialized). Or it can be dynamically linked. +;; +;; You can safely call `scm_register_module_xxx' before libguile +;; itself is initialized. You could call it from an C++ constructor +;; of a static object, for example. +;; +;; To make your Guile extension into a dynamic linkable module, follow +;; these easy steps: +;; +;; - Find a name for your module, like #/ice-9/gtcltk +;; - Write a function with a name like +;; +;; scm_init_ice_9_gtcltk_module +;; +;; This is your `module init' function. It should call +;; +;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk); +;; +;; "ice-9 gtcltk" is the C version of the module name. Slashes are +;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is +;; the real init function that executes the usual initilizations +;; like making new smobs, etc. +;; +;; - Make a shared library with your code and a name like +;; +;; ice-9/libgtcltk.so +;; +;; and put it somewhere in %load-path. +;; +;; - Then you can simply write `:use-module #/ice-9/gtcltk' and it +;; will be linked automatically. +;; +;; This is all very experimental. + +(define (split-c-module-name str) + (let loop ((rev '()) + (start 0) + (pos 0) + (end (string-length str))) + (cond + ((= pos end) + (reverse (cons (string->symbol (substring str start pos)) rev))) + ((eq? (string-ref str pos) #\space) + (loop (cons (string->symbol (substring str start pos)) rev) + (+ pos 1) + (+ pos 1) + end)) + (else + (loop rev start (+ pos 1) end))))) + +(define (convert-c-registered-modules dynobj) + (let ((res (map (lambda (c) + (list (split-c-module-name (car c)) (cdr c) dynobj)) + (c-registered-modules)))) + (c-clear-registered-modules) + res)) + +(define registered-modules (convert-c-registered-modules #f)) + +(define (init-dynamic-module modname) + (or-map (lambda (modinfo) + (if (equal? (car modinfo) modname) + (let ((mod (resolve-module modname #f))) + (save-module-excursion + (lambda () + (set-current-module mod) + (dynamic-call (cadr modinfo) (caddr modinfo)) + (set-module-public-interface! mod mod))) + (set! registered-modules (delq! modinfo registered-modules)) + #t) + #f)) + registered-modules)) + +(define (dynamic-maybe-call name dynobj) + (catch #t ; could use false-if-exception here + (lambda () + (dynamic-call name dynobj)) + (lambda args + #f))) + +(define (find-and-link-dynamic-module module-name) + (define (make-init-name mod-name) + (string-append 'scm_init + (list->string (map (lambda (c) + (if (or (char-alphabetic? c) + (char-numeric? c)) + c + #\_)) + (string->list mod-name))) + '_module)) + (let ((libname + (let loop ((dirs "") + (syms module-name)) + (cond + ((null? (cdr syms)) + (string-append dirs "lib" (car syms) ".so")) + (else + (loop (string-append dirs (car syms) "/") (cdr syms)))))) + (init (make-init-name (apply string-append + (map (lambda (s) + (string-append "_" s)) + module-name))))) + ;; (pk 'libname libname 'init init) + (or-map + (lambda (dir) + (let ((full (in-vicinity dir libname))) + ;; (pk 'trying full) + (if (file-exists? full) + (begin + (link-dynamic-module full init) + #t) + #f))) + %load-path))) + +(define (link-dynamic-module filename initname) + (let ((dynobj (dynamic-link filename))) + (if (dynamic-maybe-call initname dynobj) + (set! registered-modules (append! (convert-c-registered-modules dynobj) + registered-modules)) + (dynamic-unlink dynobj)))) + +(define (try-module-dynamic-link module-name) + (or (init-dynamic-module module-name) + (and (find-and-link-dynamic-module module-name) + (init-dynamic-module module-name)))) + (define autoloads-done '((guile . guile))) (define (autoload-done-or-in-progress? p m) @@ -2101,8 +2040,8 @@ ;;; {Macros} ;;; -(define macro-table (make-weak-hash-table 523)) -(define xformer-table (make-weak-hash-table 523)) +(define macro-table (make-weak-key-hash-table 523)) +(define xformer-table (make-weak-key-hash-table 523)) (define (defmacro? m) (hashq-ref macro-table m)) (define (assert-defmacro?! m) (hashq-set! macro-table m #t)) @@ -2138,7 +2077,7 @@ (define (macroexpand-1 e) (cond ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (eval `(defined? ,a)) (eval a)))) + (val (and (symbol? a) (defined? a) (eval a)))) (if (defmacro? val) (apply (defmacro-transformer val) (cdr e)) e))) @@ -2147,7 +2086,7 @@ (define (macroexpand e) (cond ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (eval `(defined? ,a)) (eval a)))) + (val (and (symbol? a) (defined? a) (eval a)))) (if (defmacro? val) (macroexpand (apply (defmacro-transformer val) (cdr e))) e))) @@ -2176,7 +2115,13 @@ (define scm-repl-silent #f) (define (assert-repl-silence v) (set! scm-repl-silent v)) -(define scm-repl-verbose #t) +(define *unspecified* (if #f #f)) +(define (unspecified? v) (eq? v *unspecified*)) + +(define scm-repl-print-unspecified #f) +(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v)) + +(define scm-repl-verbose #f) (define (assert-repl-verbosity v) (set! scm-repl-verbose v)) (define scm-repl-prompt #t) @@ -2188,51 +2133,140 @@ (define (loop first) (let ((next (catch #t + (lambda () + (lazy-catch #t + (lambda () + (dynamic-wind + (lambda () (unmask-signals)) + (lambda () + (first) + + ;; This line is needed because mark doesn't do closures quite right. + ;; Unreferenced locals should be collected. + ;; + (set! first #f) + (let loop ((v (thunk))) + (loop (thunk))) + #f) + (lambda () (mask-signals)))) + + (lambda args + (save-stack 1) + (apply throw args)))) + + (lambda (key . args) + (case key + ((quit) + (force-output) + #f) + + ((switch-repl) + (apply throw 'switch-repl args)) + + ((abort) + ;; This is one of the closures that require + ;; (set! first #f) above + ;; + (lambda () + (force-output) + (display "ABORT: " (current-error-port)) + (write args (current-error-port)) + (newline (current-error-port)) + (if (and (not has-shown-debugger-hint?) + (not (memq 'backtrace (debug-options-interface))) + (stack? the-last-stack)) + (begin + (newline (current-error-port)) + (display "Type \"(backtrace)\" to get more information.\n" (current-error-port)) + (set! has-shown-debugger-hint? #t))) + (set! stack-saved? #f))) + + (else + ;; This is the other cons-leak closure... (lambda () - (dynamic-wind - (lambda () (unmask-signals)) - (lambda () - (first) - - ;; This line is needed because mark doesn't do closures quite right. - ;; Unreferenced locals should be collected. - ;; - (set! first #f) - (let loop ((v (thunk))) - (loop (thunk))) - #f) - (lambda () (mask-signals)))) - - (lambda (key . args) - (case key - ((quit) (force-output) - (pk 'quit args) - #f) - - ((abort) ;; This is one of the closures that require (set! first #f) - ;; above - ;; - (lambda () - (force-output) - (display "ABORT: " (current-error-port)) - (write args (current-error-port)) - (newline (current-error-port)))) - - (else ;; This is the other cons-leak closure... - (lambda () - (apply %%bad-throw key args)))))))) + (cond ((= (length args) 4) + (apply handle-system-error key args)) + (else + (apply bad-throw key args)))))))))) (and next (loop next)))) (loop (lambda () #t))) +;;(define the-last-stack #f) Defined by scm_init_backtrace () +(define stack-saved? #f) + +(define (save-stack . narrowing) + (cond (stack-saved?) + ((not (memq 'debug (debug-options-interface))) + (set! the-last-stack #f) + (set! stack-saved? #t)) + (else + (set! the-last-stack + (case (stack-id #t) + ((repl-stack) + (apply make-stack #t save-stack eval narrowing)) + ((load-stack) + (apply make-stack #t save-stack gsubr-apply narrowing)) + ((tk-stack) + (apply make-stack #t save-stack tk-stack-mark narrowing)) + ((#t) + (apply make-stack #t save-stack narrowing)) + (else (let ((id (stack-id #t))) + (and (procedure? id) + (apply make-stack #t save-stack id narrowing)))))) + (set! stack-saved? #t)))) + +(define before-error-hook #f) +(define after-error-hook #f) +(define before-backtrace-hook #f) +(define after-backtrace-hook #f) + +(define has-shown-debugger-hint? #f) + +(define (handle-system-error key . args) + (let ((cep (current-error-port))) + (cond ((not (stack? the-last-stack))) + ((memq 'backtrace (debug-options-interface)) + (and before-backtrace-hook (before-backtrace-hook)) + (newline cep) + (display-backtrace the-last-stack cep) + (newline cep) + (and after-backtrace-hook (after-backtrace-hook)))) + (and before-error-hook (before-error-hook)) + (apply display-error the-last-stack cep args) + (and after-error-hook (after-error-hook)) + (force-output cep) + (throw 'abort key))) + (define (quit . args) (apply throw 'quit args)) +;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace () + +;; Replaced by C code: +;;(define (backtrace) +;; (if the-last-stack +;; (begin +;; (newline) +;; (display-backtrace the-last-stack (current-output-port)) +;; (newline) +;; (if (and (not has-shown-backtrace-hint?) +;; (not (memq 'backtrace (debug-options-interface)))) +;; (begin +;; (display +;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace +;;automatically if an error occurs in the future.\n") +;; (set! has-shown-backtrace-hint? #t)))) +;; (display "No backtrace available.\n"))) + (define (error-catching-repl r e p) (error-catching-loop (lambda () (p (e (r)))))) (define (gc-run-time) (cdr (assq 'gc-time-taken (gc-stats)))) +(define before-read-hook #f) +(define after-read-hook #f) + (define (scm-style-repl) (letrec ( (start-gc-rt #f) @@ -2257,7 +2291,9 @@ (display the-prompt-string) (force-output) (repl-report-reset))) + (and before-read-hook (before-read-hook)) (let ((val (read (current-input-port) #t read-sharp))) + (and after-read-hook (after-read-hook)) (if (eof-object? val) (begin (if scm-repl-verbose @@ -2270,13 +2306,16 @@ (-eval (lambda (sourc) (repl-report-start-timing) - (eval sourc))) + (start-stack 'repl-stack (eval sourc)))) (-print (lambda (result) (if (not scm-repl-silent) (begin - (print result) - (newline) + (if (or scm-repl-print-unspecified + (not (unspecified? result))) + (begin + (write result) + (newline))) (if scm-repl-verbose (repl-report)) (force-output))))) @@ -2309,7 +2348,7 @@ - +;;; {IOTA functions: generating lists of numbers} (define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '())) (define (iota n) (list-reverse! (reverse-iota n))) @@ -2364,6 +2403,12 @@ (set-current-module module) module)) +(defmacro use-modules modules + `(for-each (lambda (module) + (module-use! (current-module) + (resolve-interface module))) + (reverse ',modules))) + (define define-private define) (defmacro define-public args @@ -2426,13 +2471,13 @@ -(define try-load-with-path try-load-module-with-path) -(define try-load try-load-module) -(define load-with-path load-module-with-path) (define load load-module) +;(define (load . args) +; (start-stack 'load-stack (apply load-module args))) +;;; {I/O functions for Tcl channels (disabled)} ;; (define in-ch (get-standard-channel TCL_STDIN)) ;; (define out-ch (get-standard-channel TCL_STDOUT)) @@ -2469,11 +2514,15 @@ (define (top-repl) (scm-style-repl)) +(defmacro false-if-exception (expr) + `(catch #t (lambda () ,expr) + (lambda args #f))) + +;;; {Calling Conventions} (define-module (ice-9 calling)) ;;;; -;;; {Calling Conventions} ;;; ;;; This file contains a number of macros that support ;;; common calling conventions. @@ -2771,6 +2820,8 @@ +;;; {Implementation of COMMON LISP list functions for Scheme} + (define-module (ice-9 common-list)) ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme @@ -2792,9 +2843,6 @@ ;promotional, or sales literature without prior written consent in ;each case. - - - ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) (define-public (make-list k . init) (set! init (if (pair? init) (car init))) @@ -2953,35 +3001,38 @@ (cons (car l) u))))) +;;; {Functions for browsing modules} + (define-module (ice-9 ls) :use-module (ice-9 common-list)) - - ;;;; ;;; local-definitions-in root name -;;; Returns a list of names defined locally in the named subdirectory of root. +;;; Returns a list of names defined locally in the named +;;; subdirectory of root. ;;; definitions-in root name -;;; Returns a list of all names defined in the named subdirectory of root. -;;; The list includes alll locally defined names as well as all names inherited -;;; from a member of a use-list. +;;; Returns a list of all names defined in the named +;;; subdirectory of root. The list includes alll locally +;;; defined names as well as all names inherited from a +;;; member of a use-list. ;;; ;;; A convenient interface for examining the nature of things: ;;; ;;; ls . various-names ;;; -;;; With just one argument, interpret that argument as the name of a subdirectory -;;; of the current module and return a list of names defined there. +;;; With just one argument, interpret that argument as the +;;; name of a subdirectory of the current module and +;;; return a list of names defined there. ;;; -;;; With more than one argument, still compute subdirectory lists, but -;;; return a list: +;;; With more than one argument, still compute +;;; subdirectory lists, but return a list: ;;; ((<subdir-name> . <names-defined-there>) ;;; (<subdir-name> . <names-defined-there>) ;;; ...) ;;; (define-public (local-definitions-in root names) - (let ((m (resolved-ref root names)) + (let ((m (nested-ref root names)) (answer '())) (if (not (module? m)) (set! answer m) @@ -2989,12 +3040,13 @@ answer)) (define-public (definitions-in root names) - (let ((m (resolved-ref root names))) + (let ((m (nested-ref root names))) (if (not (module? m)) m (reduce union (cons (local-definitions-in m '()) - (map (lambda (m2) (definitions-in m2 '())) (module-uses m))))))) + (map (lambda (m2) (definitions-in m2 '())) + (module-uses m))))))) (define-public (ls . various-refs) (and various-refs @@ -3012,11 +3064,13 @@ various-refs) (local-definitions-in (current-module) (car various-refs))))) -(define-public (recursive-value-define name value) +(define-public (recursive-local-define name value) (let ((parent (reverse! (cdr (reverse name))))) (and parent (make-modules-in (current-module) parent)) - (value-define name value))) + (local-define name value))) +;;; {Queues} + (define-module (ice-9 q)) ;;;; Copyright (C) 1995 Free Software Foundation, Inc. @@ -3036,7 +3090,6 @@ ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; - ;;;; ;;; Q: Based on the interface to ;;; @@ -3044,7 +3097,6 @@ ;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. ;;; - ;;;; ;;; {Q} ;;; @@ -3156,12 +3208,11 @@ -;;; installed-scm-file +;;; {The runq data structure} + (define-module (ice-9 runq) :use-module (ice-9 q)) - - ;;;; Copyright (C) 1996 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -3179,10 +3230,7 @@ ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; - - ;;;; -;;; {The runq data structure} ;;; ;;; One way to schedule parallel computations in a serial environment is ;;; to explicitly divide each task up into small, finite execution time, @@ -3400,21 +3448,17 @@ st)) +;;; {String Fun} -;;; installed-scm-file - (define-module (ice-9 string-fun)) - ;;;; -;;; {String Fun} ;;; ;;; Various string funcitons, particularly those that take ;;; advantage of the "shared substring" capability. ;;; -;;;; -;;; {Dividing Strings Into Fields} +;;; {String Fun: Dividing Strings Into Fields} ;;; ;;; The names of these functions are very regular. ;;; Here is a grammar of a call to one of these: @@ -3538,7 +3582,7 @@ (else (ret (make-shared-substring str 0 n) (make-shared-substring str (1+ n))))))) -(define-public (seperate-fields-discarding-char ch str ret) +(define-public (separate-fields-discarding-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -3547,7 +3591,7 @@ (make-shared-substring str 0 w)))) (else (ret (cons str fields)))))) -(define-public (seperate-fields-after-char ch str ret) +(define-public (separate-fields-after-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -3556,7 +3600,7 @@ (make-shared-substring str 0 (+ 1 w))))) (else (ret (cons str fields)))))) -(define-public (seperate-fields-before-char ch str ret) +(define-public (separate-fields-before-char ch str ret) (let loop ((fields '()) (str str)) (cond @@ -3566,12 +3610,11 @@ (else (ret (cons str fields)))))) -;;;; -;;; {String Prefix Predicates} +;;; {String Fun: String Prefix Predicates} ;;; ;;; Very simple: ;;; -:;; (define-public ((string-prefix-predicate pred?) prefix str) +;;; (define-public ((string-prefix-predicate pred?) prefix str) ;;; (and (<= (length prefix) (length str)) ;;; (pred? prefix (make-shared-substring str 0 (length prefix))))) ;;; @@ -3585,8 +3628,7 @@ (define-public string-prefix=? (string-prefix-predicate string=?)) -;;;; -;;; {Strippers} +;;; {String Fun: Strippers} ;;; ;;; <stripper> = sans-<removable-part> ;;; @@ -3639,8 +3681,7 @@ (else str))) -;;;; -;;; {has-trailing-newline?} +;;; {String Fun: has-trailing-newline?} ;;; (define-public (has-trailing-newline? str) @@ -3649,7 +3690,7 @@ - +;;; {String Fun: with-regexp-parts} (define-public (with-regexp-parts regexp fields str return fail) (let ((parts (regexec regexp str fields))) @@ -3658,6 +3699,35 @@ (apply return parts)))) +;;; {Load debug extension code if debug extensions present.} +;;; +;;; *fixme* This is a temporary solution. +;;; + +(if (memq 'debug-extensions *features*) + (define-module (guile) :use-module (ice-9 debug))) + + +;;; {Load thread code if threads are present.} +;;; +;;; *fixme* This is a temporary solution. +;;; + +(if (memq 'threads *features*) + (define-module (guile) :use-module (ice-9 threads))) + + +;;; {Load emacs interface support if emacs option is given.} +;;; +;;; *fixme* This is a temporary solution. +;;; + +(if (or (member "-e" (cdr (program-arguments))) + (member "--emacs" (cdr (program-arguments)))) + (define-module (guile) :use-module (ice-9 emacs))) + + (define-module (guile)) +(append! %load-path (cons "." ())) diff --git a/ice-9/configure b/ice-9/configure index 25b98d1a0..4676147d1 100755 --- a/ice-9/configure +++ b/ice-9/configure @@ -1,7 +1,7 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.9 +# Generated automatically using autoconf version 2.12 # Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. # # This configure script is free software; the Free Software Foundation @@ -49,6 +49,8 @@ mandir='${prefix}/man' # Initialize some other variables. subdirs= MFLAGS= MAKEFLAGS= +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 ac_prev= for ac_option @@ -330,7 +332,7 @@ EOF verbose=yes ;; -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.9" + echo "configure generated by autoconf version 2.12" exit 0 ;; -with-* | --with-*) @@ -432,11 +434,14 @@ do done # NLS nuisances. -# Only set LANG and LC_ALL to C if already set. -# These must not be set unconditionally because not all systems understand -# e.g. LANG=C (notably SCO). -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -rf conftest* confdefs.h @@ -498,6 +503,7 @@ ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. @@ -512,16 +518,184 @@ else fi +ac_aux_dir= +for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# ./install, which can be erroneously created by make from ./install.sh. +echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 +echo "configure:552: checking for a BSD compatible install" >&5 +if test -z "$INSTALL"; then +if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + # Account for people who put trailing slashes in PATH elements. + case "$ac_dir/" in + /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + for ac_prog in ginstall installbsd scoinst install; do + if test -f $ac_dir/$ac_prog; then + if test $ac_prog = install && + grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + # OSF/1 installbsd also uses dspmsg, but is usable. + : + else + ac_cv_path_install="$ac_dir/$ac_prog -c" + break 2 + fi + fi + done + ;; + esac + done + IFS="$ac_save_IFS" + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL="$ac_cv_path_install" + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL="$ac_install_sh" + fi +fi +echo "$ac_t""$INSTALL" 1>&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' + . $srcdir/../GUILE-VERSION -scm_files="" -aux_files="" -. $srcdir/PLUGIN/this.configure +PACKAGE=$PACKAGE +cat >> confdefs.h <<EOF +#define PACKAGE "$PACKAGE" +EOF +VERSION=$VERSION +cat >> confdefs.h <<EOF +#define VERSION "$VERSION" +EOF +echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6 +echo "configure:620: checking whether build environment is sane" >&5 +echo timestamp > conftestfile +# Do this in a subshell so we don't clobber the current shell's +# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? +if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile) +then + # Ok. + : +else + { echo "configure: error: newly created file is older than distributed files! +Check your system clock" 1>&2; exit 1; } +fi +rm -f conftest* +echo "$ac_t""yes" 1>&6 +if test "$program_transform_name" = s,x,x,; then + program_transform_name= +else + # Double any \ or $. echo might interpret backslashes. + cat <<\EOF_SED > conftestsed +s,\\,\\\\,g; s,\$,$$,g +EOF_SED + program_transform_name="`echo $program_transform_name|sed -f conftestsed`" + rm -f conftestsed +fi +test "$program_prefix" != NONE && + program_transform_name="s,^,${program_prefix},; $program_transform_name" +# Use a double $ so make ignores it. +test "$program_suffix" != NONE && + program_transform_name="s,\$\$,${program_suffix},; $program_transform_name" + +# sed with no file args requires a program. +test "$program_transform_name" = "" && program_transform_name="s,x,x," + +echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 +echo "configure:654: checking whether ${MAKE-make} sets \${MAKE}" >&5 +set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftestmake <<\EOF +all: + @echo 'ac_maketemp="${MAKE}"' +EOF +# GNU make sometimes prints "make[1]: Entering...", which would confuse us. +eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` +if test -n "$ac_maketemp"; then + eval ac_cv_prog_make_${ac_make}_set=yes +else + eval ac_cv_prog_make_${ac_make}_set=no +fi +rm -f conftestmake +fi +if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then + echo "$ac_t""yes" 1>&6 + SET_MAKE= +else + echo "$ac_t""no" 1>&6 + SET_MAKE="MAKE=${MAKE-make}" +fi + +ac_aux_dir= +for ac_dir in .. $srcdir/..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + +module=ice-9 trap '' 1 2 15 cat > confcache <<\EOF @@ -540,11 +714,25 @@ cat > confcache <<\EOF # --recheck option to rerun configure. # EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. (set) 2>&1 | - sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \ - >> confcache + case `(ac_space=' '; set) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache if cmp -s $cache_file confcache; then : else @@ -611,7 +799,7 @@ do echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.9" + echo "$CONFIG_STATUS generated by autoconf version 2.12" exit 0 ;; -help | --help | --hel | --he | --h) echo "\$ac_cs_usage"; exit 0 ;; @@ -620,6 +808,7 @@ do done ac_given_srcdir=$srcdir +ac_given_INSTALL="$INSTALL" trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 EOF @@ -651,28 +840,66 @@ s%@includedir@%$includedir%g s%@oldincludedir@%$oldincludedir%g s%@infodir@%$infodir%g s%@mandir@%$mandir%g -s%@scm_files@%$scm_files%g -s%@aux_files@%$aux_files%g -s%@library_name@%$library_name%g -s%@info_files@%$info_files%g -s%@GUILE_VERSION@%$GUILE_VERSION%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g +s%@PACKAGE@%$PACKAGE%g +s%@VERSION@%$VERSION%g +s%@SET_MAKE@%$SET_MAKE%g +s%@module@%$module%g CEOF EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + cat >> $CONFIG_STATUS <<EOF CONFIG_FILES=\${CONFIG_FILES-"Makefile"} EOF cat >> $CONFIG_STATUS <<\EOF for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile]", defaulting infile="outfile.in". + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'` + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; *) ac_file_in="${ac_file}.in" ;; esac - # Adjust relative srcdir, etc. for subdirectories. + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. # Remove last slash and all that follows it. Not all systems have dirname. ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` @@ -696,6 +923,11 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then top_srcdir="$ac_dots$ac_given_srcdir" ;; esac + case "$ac_given_INSTALL" in + [/$]*) INSTALL="$ac_given_INSTALL" ;; + *) INSTALL="$ac_dots$ac_given_INSTALL" ;; + esac + echo creating "$ac_file" rm -f "$ac_file" configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." @@ -704,15 +936,22 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then # $configure_input" ;; *) ac_comsub= ;; esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` sed -e "$ac_comsub s%@configure_input@%$configure_input%g s%@srcdir@%$srcdir%g s%@top_srcdir@%$top_srcdir%g -" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file +s%@INSTALL@%$INSTALL%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file fi; done -rm -f conftest.subs +rm -f conftest.s* +EOF +cat >> $CONFIG_STATUS <<EOF +EOF +cat >> $CONFIG_STATUS <<\EOF exit 0 EOF diff --git a/ice-9/configure.in b/ice-9/configure.in index cb1926a87..b2d4c334b 100644 --- a/ice-9/configure.in +++ b/ice-9/configure.in @@ -3,15 +3,5 @@ # AC_INIT(boot-9.scm) - -. $srcdir/../GUILE-VERSION - -scm_files="" -aux_files="" -. $srcdir/PLUGIN/this.configure -AC_SUBST(scm_files) -AC_SUBST(aux_files) -AC_SUBST(library_name) -AC_SUBST(info_files) -AC_SUBST(GUILE_VERSION) +AM_INIT_GUILE_MODULE(ice-9) AC_OUTPUT(Makefile) diff --git a/ice-9/debug.scm b/ice-9/debug.scm new file mode 100644 index 000000000..20e67f9cf --- /dev/null +++ b/ice-9/debug.scm @@ -0,0 +1,120 @@ +;;;; Copyright (C) 1996 Mikael Djurfeldt +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;;; +;;;; The author can be reached at djurfeldt@nada.kth.se +;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN +;;;; + + +(define-module #/ice-9/debug) + + + +;;; {Run-time options} + +(define names '((debug-options-interface + (debug-options debug-enable debug-disable) + (debug-set!)) + + (evaluator-traps-interface + (traps trap-enable trap-disable) + (trap-set!)) + + (read-options-interface + (read-options read-enable read-disable) + (read-set!)) + + (print-options-interface + (print-options print-enable print-disable) + (print-set!)) + )) + +(define option-name car) +(define option-value cadr) +(define option-documentation caddr) + +(define (print-option option) + (display (option-name option)) + (if (< (string-length (symbol->string (option-name option))) 8) + (display #\tab)) + (display #\tab) + (display (option-value option)) + (display #\tab) + (display (option-documentation option)) + (newline)) + +;;; Below follows the macros defining the run-time option interfaces. +;;; *fixme* These should not be macros, but need to be until module +;;; system is improved. +;;; + +(define (make-options interface) + `(lambda args + (cond ((null? args) (,interface)) + ((pair? (car args)) (,interface (car args)) (,interface)) + (else (for-each print-option (,interface #t)))))) + +(define (make-enable interface) + `(lambda flags + (,interface (append flags (,interface))) + (,interface))) + +(define (make-disable interface) + `(lambda flags + (let ((options (,interface))) + (for-each (lambda (flag) + (set! options (delq! flag options))) + flags) + (,interface options) + (,interface)))) + +(define (make-set! interface) + `((name exp) + (,'quasiquote + (begin (,interface (append (,interface) + (list '(,'unquote name) + (,'unquote exp)))) + (,interface))))) + +(defmacro define-all () + (cons 'begin + (apply append + (map (lambda (group) + (let ((interface (car group))) + (append (map (lambda (name constructor) + `(define-public ,name + ,(constructor interface))) + (cadr group) + (list make-options + make-enable + make-disable)) + (map (lambda (name constructor) + `(defmacro-public ,name + ,@(constructor interface))) + (caddr group) + (list make-set!))))) + names)))) + +(define-all) + + + +;;; A fix to get the error handling working together with the module system. +;;; +(variable-set! (builtin-variable 'debug-options) debug-options) + +(debug-enable 'debug) +(read-enable 'positions) diff --git a/ice-9/expect.scm b/ice-9/expect.scm new file mode 100644 index 000000000..6d25c8ba3 --- /dev/null +++ b/ice-9/expect.scm @@ -0,0 +1,125 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1996 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;;; + + +;;; Expect: a macro for selecting actions based on what it reads from a port. +;;; The idea is from Don Libes' expect based on Tcl. +;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer. + + +(define expect-port #f) +(define expect-timeout #f) +(define expect-timeout-proc #f) +(define expect-eof-proc #f) +(define expect-char-proc #f) + +;;; expect: each test is a procedure which is applied to the accumulating +;;; string. +(defmacro expect clauses + (let ((s (gentemp)) + (c (gentemp)) + (port (gentemp)) + (timeout (gentemp))) + `(let ((,s "") + (,port (or expect-port (current-input-port))) + (,timeout (if expect-timeout + (+ (* expect-timeout internal-time-units-per-second) + (get-internal-real-time)) + #f))) + (let next-char () + (if (and expect-timeout + (or (>= (get-internal-real-time) ,timeout) + (and (not (char-ready? ,port)) + (not (expect-select ,port ,timeout))))) + (if expect-timeout-proc + (expect-timeout-proc ,s) + #f) + (let ((,c (read-char ,port))) + (if expect-char-proc + (expect-char-proc ,c)) + (cond ((eof-object? ,c) + (if expect-eof-proc + (expect-eof-proc ,s) + #f)) + (else + (set! ,s (string-append ,s (string ,c))) + (cond + ,@(let next-expr ((tests (map car clauses)) + (exprs (map cdr clauses)) + (body ())) + (cond + ((null? tests) + (reverse body)) + (else + (next-expr + (cdr tests) + (cdr exprs) + (cons + `((,(car tests) ,s) + ,@(cond ((null? (car exprs)) + ()) + ((eq? (caar exprs) '=>) + (if (not (= (length (car exprs)) + 2)) + (scm-error 'misc-error + "expect" + "bad recipient: %S" + (list (car exprs)) + #f) + `((apply ,(cadar exprs) + (,(car tests) ,s))))) + (else + (car exprs)))) + body))))) + (else (next-char))))))))))) + +;;; the regexec front-end to expect: +;;; each test must evaluate to a regular expression. +(defmacro expect-strings clauses + `(let ,@(let next-test ((tests (map car clauses)) + (exprs (map cdr clauses)) + (defs ()) + (body ())) + (cond ((null? tests) + (list (reverse defs) `(expect ,@(reverse body)))) + (else + (let ((rxname (gentemp))) + (next-test (cdr tests) + (cdr exprs) + (cons `(,rxname (regcomp ,(car tests) + REG_NEWLINE)) + defs) + (cons `((lambda (s) + (regexec ,rxname s "")) + ,@(car exprs)) + body)))))))) + +;;; simplified select: returns #t if input is waiting or #f if timed out. +;;; timeout is absolute in terms of get-internal-real-time. +(define (expect-select port timeout) + (let* ((relative (- timeout (get-internal-real-time))) + (relative-s (inexact->exact + (floor (/ relative internal-time-units-per-second)))) + (relative-ms (inexact->exact + (round (/ (* (- relative relative-s) 1000) + internal-time-units-per-second))))) + (and (> relative 0) + (pair? (car (select (list port) () () + relative-s + relative-ms)))))) diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm index ffde88608..28e4a6515 100644 --- a/ice-9/lineio.scm +++ b/ice-9/lineio.scm @@ -95,15 +95,14 @@ (read-string (lambda () (cond - (buffers (let ((answer (car buffers))) - (set! buffers (cdr buffers)) - answer)) - - ((ungetc-char-ready? self) (read-line self 'include-newline)) - - (else (read-line underlying-port 'include-newline))))) - - ) + ((not (null? buffers)) + (let ((answer (car buffers))) + (set! buffers (cdr buffers)) + answer)) + ((ungetc-char-ready? self) + (read-line self 'include-newline)) + (else + (read-line underlying-port 'include-newline)))))) (set-object-property! self 'unread-string unread-string) (set-object-property! self 'read-string read-string) diff --git a/ice-9/mapping.scm b/ice-9/mapping.scm index 9d9bb7aa6..ceb3a1b38 100644 --- a/ice-9/mapping.scm +++ b/ice-9/mapping.scm @@ -112,7 +112,8 @@ (else (error 'hash-table-mapping "Hash-procedure specified with no known delete function." hash-proc))))) - (table-constructor (or (kw-arg-ref options :table-constructor) make-vector))) + (table-constructor (or (kw-arg-ref options :table-constructor) + (lambda (len) (make-vector len '()))))) (make-hash-table-mapping (table-constructor size) hash-proc assoc-proc diff --git a/ice-9/poe.scm b/ice-9/poe.scm index b594ebe13..eb3a13fca 100644 --- a/ice-9/poe.scm +++ b/ice-9/poe.scm @@ -45,7 +45,7 @@ ;;; -(define funcq-memo (make-weak-hash-table 523)) ; !!! randomly selected values +(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values (define funcq-buffer (make-gc-buffer 256)) (define (funcq-hash arg-list n) diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm new file mode 100644 index 000000000..696ba4059 --- /dev/null +++ b/ice-9/r4rs.scm @@ -0,0 +1,149 @@ +;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant +;;;; Jim Blandy <jimb@cyclic.com> --- October 1996 + +;;;; Copyright (C) 1996 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; apply and call-with-current-continuation + +;;; These turn syntax, @apply and @call-with-current-continuation, +;;; into procedures. If someone knows why they have to be syntax to +;;; begin with, please fix this comment. +(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) +(define (call-with-current-continuation proc) + (@call-with-current-continuation proc)) + + +;;;; Basic Port Code + +;;; Specifically, the parts of the low-level port code that are written in +;;; Scheme rather than C. +;;; +;;; WARNING: the parts of this interface that refer to file ports +;;; are going away. It would be gone already except that it is used +;;; "internally" in a few places. + + +;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper +;; mode to open files in. MSDOS does carraige return - newline +;; translation if not opened in `b' mode. +;; +(define OPEN_READ (case (software-type) + ((MS-DOS WINDOWS ATARIST) "rb") + (else "r"))) +(define OPEN_WRITE (case (software-type) + ((MS-DOS WINDOWS ATARIST) "wb") + (else "w"))) +(define OPEN_BOTH (case (software-type) + ((MS-DOS WINDOWS ATARIST) "r+b") + (else "r+"))) + +(define *null-device* "/dev/null") + +(define (open-input-file str) + (open-file str OPEN_READ)) + +(define (open-output-file str) + (open-file str OPEN_WRITE)) + +(define (open-io-file str) (open-file str OPEN_BOTH)) +(define close-input-port close-port) +(define close-output-port close-port) +(define close-io-port close-port) + +(define (call-with-input-file str proc) + (let* ((file (open-input-file str)) + (ans (proc file))) + (close-input-port file) + ans)) + +(define (call-with-output-file str proc) + (let* ((file (open-output-file str)) + (ans (proc file))) + (close-output-port file) + ans)) + +(define (with-input-from-port port thunk) + (let* ((swaports (lambda () (set! port (set-current-input-port port))))) + (dynamic-wind swaports thunk swaports))) + +(define (with-output-to-port port thunk) + (let* ((swaports (lambda () (set! port (set-current-output-port port))))) + (dynamic-wind swaports thunk swaports))) + +(define (with-error-to-port port thunk) + (let* ((swaports (lambda () (set! port (set-current-error-port port))))) + (dynamic-wind swaports thunk swaports))) + +(define (with-input-from-file file thunk) + (let* ((nport (open-input-file file)) + (ans (with-input-from-port nport thunk))) + (close-port nport) + ans)) + +(define (with-output-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-output-to-port nport thunk))) + (close-port nport) + ans)) + +(define (with-error-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-error-to-port nport thunk))) + (close-port nport) + ans)) + +(define (with-input-from-string string thunk) + (call-with-input-string string + (lambda (p) (with-input-from-port p thunk)))) + +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (p) (with-output-to-port p thunk)))) + +(define (with-error-to-string thunk) + (call-with-output-string + (lambda (p) (with-error-to-port p thunk)))) + +(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) + + +;;;; Loading + +(if (not (defined? '%load-verbosely)) + (define %load-verbosely #f)) +(define (assert-load-verbosity v) (set! %load-verbosely v)) + +(define (%load-announce file) + (if %load-verbosely + (with-output-to-port (current-error-port) + (lambda () + (display ";;; ") + (display "loading ") + (display file) + (newline) + (force-output))))) + +(set! %load-hook %load-announce) + +;;; If we load boot-9.scm, it provides a definition for this which is +;;; more sophisticated. +(define read-sharp #f) + +(define (load name) + (start-stack 'load-stack + (primitive-load name #t read-sharp))) diff --git a/ice-9/slib.scm b/ice-9/slib.scm index 3178598fd..0e717db71 100644 --- a/ice-9/slib.scm +++ b/ice-9/slib.scm @@ -56,27 +56,27 @@ string-port with-file) - (if (defined? getenv) + (if (defined? 'getenv) '(getenv) '()) - (if (defined? current-time) + (if (defined? 'current-time) '(current-time) '()) - (if (defined? system) + (if (defined? 'system) '(system) '()) - (if (defined? array?) + (if (defined? 'array?) '(array) '()) - (if (defined? char-ready?) + (if (defined? 'char-ready?) '(char-ready?) '()) - (if (defined? array-for-each) + (if (defined? 'array-for-each) '(array-for-each) '()) @@ -108,19 +108,39 @@ (save-module-excursion (lambda () (set-current-module slib-module) - (load name)))) + (let* ((errinfo (catch 'system-error + (lambda () + (basic-load name) + #f) + (lambda args args))) + (errinfo (and errinfo + (catch 'system-error + (lambda () + (basic-load (string-append name ".scm")) + #f) + (lambda args args))))) + (if errinfo + (apply throw errinfo)))))) (define slib:load-source slib:load) (define defmacro:load slib:load) -(define (library-vicinity) (string-append (implementation-vicinity) "slib/")) +(define slib-parent-dir + (let* ((path (%search-load-path "slib/require.scm"))) + (if path + (make-shared-substring path 0 (- (string-length path) 17)) + (error "Could not find slib/require.scm in " %load-path)))) + +(define-public (implementation-vicinity) + (string-append slib-parent-dir "/")) +(define (library-vicinity) + (string-append (implementation-vicinity) "slib/")) (define (scheme-implementation-type) 'guile) (define (scheme-implementation-version) "") (define (output-port-width . arg) 80) (define (output-port-height . arg) 24) - ;;; {Time} ;;; @@ -139,6 +159,30 @@ (define (software-type) 'UNIX) -(slib:load "require.scm") +(slib:load (in-vicinity (library-vicinity) "require.scm")) (define-public require require:require) + +;; {Extensions to the require system so that the user can add new +;; require modules easily.} + +(define *vicinity-table* + (list + (cons 'implementation (implementation-vicinity)) + (cons 'library (library-vicinity)))) + +(define (install-require-vicinity name vicinity) + (let ((entry (assq name *vicinity-table*))) + (if entry + (set-cdr! entry vicinity) + (set! *vicinity-table* + (acons name vicinity *vicinity-table*))))) + +(define (install-require-module name vicinity-name file-name) + (let ((entry (assq name *catalog*)) + (vicinity (cdr (assq vicinity-name *vicinity-table*)))) + (let ((path-name (in-vicinity vicinity file-name))) + (if entry + (set-cdr! entry path-name) + (set! *catalog* + (acons name path-name *catalog*)))))) diff --git a/ice-9/test.scm b/ice-9/test.scm new file mode 100644 index 000000000..aeb28ee59 --- /dev/null +++ b/ice-9/test.scm @@ -0,0 +1,1032 @@ +;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "test.scm" Test correctness of scheme implementations. +;;; Author: Aubrey Jaffer +;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately +;;; won't pass. Made the the tests (test-cont), (test-sc4), and +;;; (test-delay) start to run automatically. + +;;; This includes examples from +;;; William Clinger and Jonathan Rees, editors. +;;; Revised^4 Report on the Algorithmic Language Scheme +;;; and the IEEE specification. + +;;; The input tests read this file expecting it to be named +;;; "test.scm", so you'll have to run it from the ice-9 source +;;; directory, or copy this file elsewhere +;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running +;;; these tests. You may need to delete them in order to run +;;; "test.scm" more than once. + +;;; There are three optional tests: +;;; (TEST-CONT) tests multiple returns from call-with-current-continuation +;;; +;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE +;;; +;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by +;;; either standard. + +;;; If you are testing a R3RS version which does not have `list?' do: +;;; (define list? #f) + +;;; send corrections or additions to jaffer@ai.mit.edu or +;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA + +(define cur-section '())(define errs '()) +(define SECTION (lambda args + (display "SECTION") (write args) (newline) + (set! cur-section args) #t)) +(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) + +(define test + (lambda (expect fun . args) + (write (cons fun args)) + (display " ==> ") + ((lambda (res) + (write res) + (newline) + (cond ((not (equal? expect res)) + (record-error (list res expect (cons fun args))) + (display " BUT EXPECTED ") + (write expect) + (newline) + #f) + (else #t))) + (if (procedure? fun) (apply fun args) (car args))))) +(define (report-errs) + (newline) + (if (null? errs) (display "Passed all tests") + (begin + (display "errors were:") + (newline) + (display "(SECTION (got expected (call)))") + (newline) + (for-each (lambda (l) (write l) (newline)) + errs))) + (newline)) + +(SECTION 2 1);; test that all symbol characters are supported. +'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) + +(SECTION 3 4) +(define disjoint-type-functions + (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) +(define type-examples + (list + #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) +(define i 1) +(for-each (lambda (x) (display (make-string i #\ )) + (set! i (+ 3 i)) + (write x) + (newline)) + disjoint-type-functions) +(define type-matrix + (map (lambda (x) + (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) + (write t) + (write x) + (newline) + t)) + type-examples)) +(SECTION 4 1 2) +(test '(quote a) 'quote (quote 'a)) +(test '(quote a) 'quote ''a) +(SECTION 4 1 3) +(test 12 (if #f + *) 3 4) +(SECTION 4 1 4) +(test 8 (lambda (x) (+ x x)) 4) +(define reverse-subtract + (lambda (x y) (- y x))) +(test 3 reverse-subtract 7 10) +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(test 10 add4 6) +(test '(3 4 5 6) (lambda x x) 3 4 5 6) +(test '(5 6) (lambda (x y . z) z) 3 4 5 6) +(SECTION 4 1 5) +(test 'yes 'if (if (> 3 2) 'yes 'no)) +(test 'no 'if (if (> 2 3) 'yes 'no)) +(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) +(SECTION 4 1 6) +(define x 2) +(test 3 'define (+ x 1)) +(set! x 4) +(test 5 'set! (+ x 1)) +(SECTION 4 2 1) +(test 'greater 'cond (cond ((> 3 2) 'greater) + ((< 3 2) 'less))) +(test 'equal 'cond (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal))) +(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f))) +(test 'composite 'case (case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite))) +(test 'consonant 'case (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) +(test #t 'and (and (= 2 2) (> 2 1))) +(test #f 'and (and (= 2 2) (< 2 1))) +(test '(f g) 'and (and 1 2 'c '(f g))) +(test #t 'and (and)) +(test #t 'or (or (= 2 2) (> 2 1))) +(test #t 'or (or (= 2 2) (< 2 1))) +(test #f 'or (or #f #f #f)) +(test #f 'or (or)) +(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) +(SECTION 4 2 2) +(test 6 'let (let ((x 2) (y 3)) (* x y))) +(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) +(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) +(test #t 'letrec (letrec ((even? + (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? + (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (even? 88))) +(define x 34) +(test 5 'let (let ((x 3)) (define x 5) x)) +(test 34 'let x) +(test 6 'let (let () (define x 6) x)) +(test 34 'let x) +(test 7 'let* (let* ((x 3)) (define x 7) x)) +(test 34 'let* x) +(test 8 'let* (let* () (define x 8) x)) +(test 34 'let* x) +(test 9 'letrec (letrec () (define x 9) x)) +(test 34 'letrec x) +(test 10 'letrec (letrec ((x 3)) (define x 10) x)) +(test 34 'letrec x) +(SECTION 4 2 3) +(define x 0) +(test 6 'begin (begin (set! x 5) (+ x 1))) +(SECTION 4 2 4) +(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) +(test 25 'do (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum)))) +(test 1 'let (let foo () 1)) +(test '((6 1 3) (-5 -2)) 'let + (let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((negative? (car numbers)) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg))) + (else + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg))))) +(SECTION 4 2 6) +(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) +(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) +(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) +(test '((foo 7) . cons) + 'quasiquote + `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) + +;;; sqt is defined here because not all implementations are required to +;;; support it. +(define (sqt x) + (do ((i 0 (+ i 1))) + ((> (* i i) x) (- i 1)))) + +(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) +(test 5 'quasiquote `,(+ 2 3)) +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) +(test '(a `(b ,x ,'y d) e) 'quasiquote + (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) +(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) +(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) +(SECTION 5 2 1) +(define add3 (lambda (x) (+ x 3))) +(test 6 'define (add3 3)) +(define first car) +(test 1 'define (first '(1 2))) +(SECTION 5 2 2) +(test 45 'define + (let ((x 5)) + (define foo (lambda (y) (bar x y))) + (define bar (lambda (a b) (+ (* a b) a))) + (foo (+ x 3)))) +(define x 34) +(define (foo) (define x 5) x) +(test 5 foo) +(test 34 'define x) +(define foo (lambda () (define x 5) x)) +(test 5 foo) +(test 34 'define x) +(define (foo x) ((lambda () (define x 5) x)) x) +(test 88 foo 88) +(test 4 foo 4) +(test 34 'define x) +(SECTION 6 1) +(test #f not #t) +(test #f not 3) +(test #f not (list 3)) +(test #t not #f) +;;; Not for Guile +;(test #f not '()) +;(test #f not (list)) +(test #f not 'nil) + +(test #t boolean? #f) +(test #f boolean? 0) +;;; Not for Guile +;(test #f boolean? '()) +(SECTION 6 2) +(test #t eqv? 'a 'a) +(test #f eqv? 'a 'b) +(test #t eqv? 2 2) +(test #t eqv? '() '()) +(test #t eqv? '10000 '10000) +(test #f eqv? (cons 1 2)(cons 1 2)) +(test #f eqv? (lambda () 1) (lambda () 2)) +(test #f eqv? #f 'nil) +(let ((p (lambda (x) x))) + (test #t eqv? p p)) +(define gen-counter + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) n)))) +(let ((g (gen-counter))) (test #t eqv? g g)) +(test #f eqv? (gen-counter) (gen-counter)) +(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) + (g (lambda () (if (eqv? f g) 'g 'both)))) + (test #f eqv? f g)) + +(test #t eq? 'a 'a) +(test #f eq? (list 'a) (list 'a)) +(test #t eq? '() '()) +(test #t eq? car car) +(let ((x '(a))) (test #t eq? x x)) +(let ((x '#())) (test #t eq? x x)) +(let ((x (lambda (x) x))) (test #t eq? x x)) + +(test #t equal? 'a 'a) +(test #t equal? '(a) '(a)) +(test #t equal? '(a (b) c) '(a (b) c)) +(test #t equal? "abc" "abc") +(test #t equal? 2 2) +(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) +(SECTION 6 3) +(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) +(define x (list 'a 'b 'c)) +(define y x) +(and list? (test #t list? y)) +(set-cdr! x 4) +(test '(a . 4) 'set-cdr! x) +(test #t eqv? x y) +(test '(a b c . d) 'dot '(a . (b . (c . d)))) +(and list? (test #f list? y)) +(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) + +(test #t pair? '(a . b)) +(test #t pair? '(a . 1)) +(test #t pair? '(a b c)) +(test #f pair? '()) +(test #f pair? '#(a b)) + +(test '(a) cons 'a '()) +(test '((a) b c d) cons '(a) '(b c d)) +(test '("a" b c) cons "a" '(b c)) +(test '(a . 3) cons 'a 3) +(test '((a b) . c) cons '(a b) 'c) + +(test 'a car '(a b c)) +(test '(a) car '((a) b c d)) +(test 1 car '(1 . 2)) + +(test '(b c d) cdr '((a) b c d)) +(test 2 cdr '(1 . 2)) + +(test '(a 7 c) list 'a (+ 3 4) 'c) +(test '() list) + +(test 3 length '(a b c)) +(test 3 length '(a (b) (c d e))) +(test 0 length '()) + +(test '(x y) append '(x) '(y)) +(test '(a b c d) append '(a) '(b c d)) +(test '(a (b) (c)) append '(a (b)) '((c))) +(test '() append) +(test '(a b c . d) append '(a b) '(c . d)) +(test 'a append '() 'a) + +(test '(c b a) reverse '(a b c)) +(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) + +(test 'c list-ref '(a b c d) 2) + +(test '(a b c) memq 'a '(a b c)) +(test '(b c) memq 'b '(a b c)) +(test '#f memq 'a '(b c d)) +(test '#f memq (list 'a) '(b (a) c)) +(test '((a) c) member (list 'a) '(b (a) c)) +(test '(101 102) memv 101 '(100 101 102)) + +(define e '((a 1) (b 2) (c 3))) +(test '(a 1) assq 'a e) +(test '(b 2) assq 'b e) +(test #f assq 'd e) +(test #f assq (list 'a) '(((a)) ((b)) ((c)))) +(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) +(test '(5 7) assv 5 '((2 3) (5 7) (11 13))) +(SECTION 6 4) +(test #t symbol? 'foo) +(test #t symbol? (car '(a b))) +(test #f symbol? "bar") +(test #t symbol? 'nil) +(test #f symbol? '()) +(test #f symbol? #f) +;;; But first, what case are symbols in? Determine the standard case: +(define char-standard-case char-upcase) +(if (string=? (symbol->string 'A) "a") + (set! char-standard-case char-downcase)) +;;; Not for Guile +;(test #t 'standard-case +; (string=? (symbol->string 'a) (symbol->string 'A))) +;(test #t 'standard-case +; (or (string=? (symbol->string 'a) "A") +; (string=? (symbol->string 'A) "a"))) +(define (str-copy s) + (let ((v (make-string (string-length s)))) + (do ((i (- (string-length v) 1) (- i 1))) + ((< i 0) v) + (string-set! v i (string-ref s i))))) +(define (string-standard-case s) + (set! s (str-copy s)) + (do ((i 0 (+ 1 i)) + (sl (string-length s))) + ((>= i sl) s) + (string-set! s i (char-standard-case (string-ref s i))))) +;;; Not for Guile +;(test (string-standard-case "flying-fish") symbol->string 'flying-fish) +;(test (string-standard-case "martin") symbol->string 'Martin) +(test "Malvina" symbol->string (string->symbol "Malvina")) +;;; Not for Guile +;(test #t 'standard-case (eq? 'a 'A)) + +(define x (string #\a #\b)) +(define y (string->symbol x)) +(string-set! x 0 #\c) +(test "cb" 'string-set! x) +(test "ab" symbol->string y) +(test y string->symbol "ab") + +;;; Not for Guile +;(test #t eq? 'mISSISSIppi 'mississippi) +;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) +(test 'JollyWog string->symbol (symbol->string 'JollyWog)) + +(SECTION 6 5 5) +(test #t number? 3) +(test #t complex? 3) +(test #t real? 3) +(test #t rational? 3) +(test #t integer? 3) + +(test #t exact? 3) +(test #f inexact? 3) + +(test #t = 22 22 22) +(test #t = 22 22) +(test #f = 34 34 35) +(test #f = 34 35) +(test #t > 3 -6246) +(test #f > 9 9 -2424) +(test #t >= 3 -4 -6246) +(test #t >= 9 9) +(test #f >= 8 9) +(test #t < -1 2 3 4 5 6 7 8) +(test #f < -1 2 3 4 4 5 6 7) +(test #t <= -1 2 3 4 5 6 7 8) +(test #t <= -1 2 3 4 4 5 6 7) +(test #f < 1 3 2) +(test #f >= 1 3 2) + +(test #t zero? 0) +(test #f zero? 1) +(test #f zero? -1) +(test #f zero? -100) +(test #t positive? 4) +(test #f positive? -4) +(test #f positive? 0) +(test #f negative? 4) +(test #t negative? -4) +(test #f negative? 0) +(test #t odd? 3) +(test #f odd? 2) +(test #f odd? -4) +(test #t odd? -1) +(test #f even? 3) +(test #t even? 2) +(test #t even? -4) +(test #f even? -1) + +(test 38 max 34 5 7 38 6) +(test -24 min 3 5 5 330 4 -24) + +(test 7 + 3 4) +(test '3 + 3) +(test 0 +) +(test 4 * 4) +(test 1 *) + +(test -1 - 3 4) +(test -3 - 3) +(test 7 abs -7) +(test 7 abs 7) +(test 0 abs 0) + +(test 5 quotient 35 7) +(test -5 quotient -35 7) +(test -5 quotient 35 -7) +(test 5 quotient -35 -7) +(test 1 modulo 13 4) +(test 1 remainder 13 4) +(test 3 modulo -13 4) +(test -1 remainder -13 4) +(test -3 modulo 13 -4) +(test 1 remainder 13 -4) +(test -1 modulo -13 -4) +(test -1 remainder -13 -4) +(define (divtest n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2)))) +(test #t divtest 238 9) +(test #t divtest -238 9) +(test #t divtest 238 -9) +(test #t divtest -238 -9) + +(test 4 gcd 0 4) +(test 4 gcd -4 0) +(test 4 gcd 32 -36) +(test 0 gcd) +(test 288 lcm 32 -36) +(test 1 lcm) + +;;;;From: fred@sce.carleton.ca (Fred J Kaudel) +;;; Modified by jaffer. +(define (test-inexact) + (define f3.9 (string->number "3.9")) + (define f4.0 (string->number "4.0")) + (define f-3.25 (string->number "-3.25")) + (define f.25 (string->number ".25")) + (define f4.5 (string->number "4.5")) + (define f3.5 (string->number "3.5")) + (define f0.0 (string->number "0.0")) + (define f0.8 (string->number "0.8")) + (define f1.0 (string->number "1.0")) + (define wto write-test-obj) + (define dto display-test-obj) + (define lto load-test-obj) + (newline) + (display ";testing inexact numbers; ") + (newline) + (SECTION 6 5 5) + (test #t inexact? f3.9) + (test #t 'inexact? (inexact? (max f3.9 4))) + (test f4.0 'max (max f3.9 4)) + (test f4.0 'exact->inexact (exact->inexact 4)) + (test (- f4.0) round (- f4.5)) + (test (- f4.0) round (- f3.5)) + (test (- f4.0) round (- f3.9)) + (test f0.0 round f0.0) + (test f0.0 round f.25) + (test f1.0 round f0.8) + (test f4.0 round f3.5) + (test f4.0 round f4.5) + (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. + (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) + (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) + (test #t call-with-output-file + "tmp3" + (lambda (test-file) + (write-char #\; test-file) + (display write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))) + (check-test-file "tmp3") + (set! write-test-obj wto) + (set! display-test-obj dto) + (set! load-test-obj lto) + (let ((x (string->number "4195835.0")) + (y (string->number "3145727.0"))) + (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) + (report-errs)) + +(define (test-bignum) + (define tb + (lambda (n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2))))) + (newline) + (display ";testing bignums; ") + (newline) + (SECTION 6 5 5) + (test 0 modulo -2177452800 86400) + (test 0 modulo 2177452800 -86400) + (test 0 modulo 2177452800 86400) + (test 0 modulo -2177452800 -86400) + (test #t 'remainder (tb 281474976710655 65535)) + (test #t 'remainder (tb 281474976710654 65535)) + (SECTION 6 5 6) + (test 281474976710655 string->number "281474976710655") + (test "281474976710655" number->string 281474976710655) + (report-errs)) + +(SECTION 6 5 6) +(test "0" number->string 0) +(test "100" number->string 100) +(test "100" number->string 256 16) +(test 100 string->number "100") +(test 256 string->number "100" 16) +(test #f string->number "") +(test #f string->number ".") +(test #f string->number "d") +(test #f string->number "D") +(test #f string->number "i") +(test #f string->number "I") +(test #f string->number "3i") +(test #f string->number "3I") +(test #f string->number "33i") +(test #f string->number "33I") +(test #f string->number "3.3i") +(test #f string->number "3.3I") +(test #f string->number "-") +(test #f string->number "+") + +(SECTION 6 6) +(test #t eqv? '#\ #\Space) +(test #t eqv? #\space '#\Space) +(test #t char? #\a) +(test #t char? #\() +(test #t char? #\ ) +(test #t char? '#\newline) + +(test #f char=? #\A #\B) +(test #f char=? #\a #\b) +(test #f char=? #\9 #\0) +(test #t char=? #\A #\A) + +(test #t char<? #\A #\B) +(test #t char<? #\a #\b) +(test #f char<? #\9 #\0) +(test #f char<? #\A #\A) + +(test #f char>? #\A #\B) +(test #f char>? #\a #\b) +(test #t char>? #\9 #\0) +(test #f char>? #\A #\A) + +(test #t char<=? #\A #\B) +(test #t char<=? #\a #\b) +(test #f char<=? #\9 #\0) +(test #t char<=? #\A #\A) + +(test #f char>=? #\A #\B) +(test #f char>=? #\a #\b) +(test #t char>=? #\9 #\0) +(test #t char>=? #\A #\A) + +(test #f char-ci=? #\A #\B) +(test #f char-ci=? #\a #\B) +(test #f char-ci=? #\A #\b) +(test #f char-ci=? #\a #\b) +(test #f char-ci=? #\9 #\0) +(test #t char-ci=? #\A #\A) +(test #t char-ci=? #\A #\a) + +(test #t char-ci<? #\A #\B) +(test #t char-ci<? #\a #\B) +(test #t char-ci<? #\A #\b) +(test #t char-ci<? #\a #\b) +(test #f char-ci<? #\9 #\0) +(test #f char-ci<? #\A #\A) +(test #f char-ci<? #\A #\a) + +(test #f char-ci>? #\A #\B) +(test #f char-ci>? #\a #\B) +(test #f char-ci>? #\A #\b) +(test #f char-ci>? #\a #\b) +(test #t char-ci>? #\9 #\0) +(test #f char-ci>? #\A #\A) +(test #f char-ci>? #\A #\a) + +(test #t char-ci<=? #\A #\B) +(test #t char-ci<=? #\a #\B) +(test #t char-ci<=? #\A #\b) +(test #t char-ci<=? #\a #\b) +(test #f char-ci<=? #\9 #\0) +(test #t char-ci<=? #\A #\A) +(test #t char-ci<=? #\A #\a) + +(test #f char-ci>=? #\A #\B) +(test #f char-ci>=? #\a #\B) +(test #f char-ci>=? #\A #\b) +(test #f char-ci>=? #\a #\b) +(test #t char-ci>=? #\9 #\0) +(test #t char-ci>=? #\A #\A) +(test #t char-ci>=? #\A #\a) + +(test #t char-alphabetic? #\a) +(test #t char-alphabetic? #\A) +(test #t char-alphabetic? #\z) +(test #t char-alphabetic? #\Z) +(test #f char-alphabetic? #\0) +(test #f char-alphabetic? #\9) +(test #f char-alphabetic? #\space) +(test #f char-alphabetic? #\;) + +(test #f char-numeric? #\a) +(test #f char-numeric? #\A) +(test #f char-numeric? #\z) +(test #f char-numeric? #\Z) +(test #t char-numeric? #\0) +(test #t char-numeric? #\9) +(test #f char-numeric? #\space) +(test #f char-numeric? #\;) + +(test #f char-whitespace? #\a) +(test #f char-whitespace? #\A) +(test #f char-whitespace? #\z) +(test #f char-whitespace? #\Z) +(test #f char-whitespace? #\0) +(test #f char-whitespace? #\9) +(test #t char-whitespace? #\space) +(test #f char-whitespace? #\;) + +(test #f char-upper-case? #\0) +(test #f char-upper-case? #\9) +(test #f char-upper-case? #\space) +(test #f char-upper-case? #\;) + +(test #f char-lower-case? #\0) +(test #f char-lower-case? #\9) +(test #f char-lower-case? #\space) +(test #f char-lower-case? #\;) + +(test #\. integer->char (char->integer #\.)) +(test #\A integer->char (char->integer #\A)) +(test #\a integer->char (char->integer #\a)) +(test #\A char-upcase #\A) +(test #\A char-upcase #\a) +(test #\a char-downcase #\A) +(test #\a char-downcase #\a) +(SECTION 6 7) +(test #t string? "The word \"recursion\\\" has many meanings.") +(test #t string? "") +(define f (make-string 3 #\*)) +(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) +(test "abc" string #\a #\b #\c) +(test "" string) +(test 3 string-length "abc") +(test #\a string-ref "abc" 0) +(test #\c string-ref "abc" 2) +(test 0 string-length "") +(test "" substring "ab" 0 0) +(test "" substring "ab" 1 1) +(test "" substring "ab" 2 2) +(test "a" substring "ab" 0 1) +(test "b" substring "ab" 1 2) +(test "ab" substring "ab" 0 2) +(test "foobar" string-append "foo" "bar") +(test "foo" string-append "foo") +(test "foo" string-append "foo" "") +(test "foo" string-append "" "foo") +(test "" string-append) +(test "" make-string 0) +(test #t string=? "" "") +(test #f string<? "" "") +(test #f string>? "" "") +(test #t string<=? "" "") +(test #t string>=? "" "") +(test #t string-ci=? "" "") +(test #f string-ci<? "" "") +(test #f string-ci>? "" "") +(test #t string-ci<=? "" "") +(test #t string-ci>=? "" "") + +(test #f string=? "A" "B") +(test #f string=? "a" "b") +(test #f string=? "9" "0") +(test #t string=? "A" "A") + +(test #t string<? "A" "B") +(test #t string<? "a" "b") +(test #f string<? "9" "0") +(test #f string<? "A" "A") + +(test #f string>? "A" "B") +(test #f string>? "a" "b") +(test #t string>? "9" "0") +(test #f string>? "A" "A") + +(test #t string<=? "A" "B") +(test #t string<=? "a" "b") +(test #f string<=? "9" "0") +(test #t string<=? "A" "A") + +(test #f string>=? "A" "B") +(test #f string>=? "a" "b") +(test #t string>=? "9" "0") +(test #t string>=? "A" "A") + +(test #f string-ci=? "A" "B") +(test #f string-ci=? "a" "B") +(test #f string-ci=? "A" "b") +(test #f string-ci=? "a" "b") +(test #f string-ci=? "9" "0") +(test #t string-ci=? "A" "A") +(test #t string-ci=? "A" "a") + +(test #t string-ci<? "A" "B") +(test #t string-ci<? "a" "B") +(test #t string-ci<? "A" "b") +(test #t string-ci<? "a" "b") +(test #f string-ci<? "9" "0") +(test #f string-ci<? "A" "A") +(test #f string-ci<? "A" "a") + +(test #f string-ci>? "A" "B") +(test #f string-ci>? "a" "B") +(test #f string-ci>? "A" "b") +(test #f string-ci>? "a" "b") +(test #t string-ci>? "9" "0") +(test #f string-ci>? "A" "A") +(test #f string-ci>? "A" "a") + +(test #t string-ci<=? "A" "B") +(test #t string-ci<=? "a" "B") +(test #t string-ci<=? "A" "b") +(test #t string-ci<=? "a" "b") +(test #f string-ci<=? "9" "0") +(test #t string-ci<=? "A" "A") +(test #t string-ci<=? "A" "a") + +(test #f string-ci>=? "A" "B") +(test #f string-ci>=? "a" "B") +(test #f string-ci>=? "A" "b") +(test #f string-ci>=? "a" "b") +(test #t string-ci>=? "9" "0") +(test #t string-ci>=? "A" "A") +(test #t string-ci>=? "A" "a") +(SECTION 6 8) +(test #t vector? '#(0 (2 2 2 2) "Anna")) +(test #t vector? '#()) +(test '#(a b c) vector 'a 'b 'c) +(test '#() vector) +(test 3 vector-length '#(0 (2 2 2 2) "Anna")) +(test 0 vector-length '#()) +(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) +(test '#(0 ("Sue" "Sue") "Anna") 'vector-set + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) +(test '#(hi hi) make-vector 2 'hi) +(test '#() make-vector 0) +(test '#() make-vector 0 'a) +(SECTION 6 9) +(test #t procedure? car) +(test #f procedure? 'car) +(test #t procedure? (lambda (x) (* x x))) +(test #f procedure? '(lambda (x) (* x x))) +(test #t call-with-current-continuation procedure?) +(test 7 apply + (list 3 4)) +(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) +(test 17 apply + 10 (list 3 4)) +(test '() apply list '()) +(define compose (lambda (f g) (lambda args (f (apply g args))))) +(test 30 (compose sqt *) 12 75) + +(test '(b e h) map cadr '((a b) (d e) (g h))) +(test '(5 7 9) map + '(1 2 3) '(4 5 6)) +(test '#(0 1 4 9 16) 'for-each + (let ((v (make-vector 5))) + (for-each (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) +(test -3 call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) (if (negative? x) (exit x))) + '(54 0 37 -3 245 19)) + #t)) +(define list-length + (lambda (obj) + (call-with-current-continuation + (lambda (return) + (letrec ((r (lambda (obj) (cond ((null? obj) 0) + ((pair? obj) (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) +(test 4 list-length '(1 2 3 4)) +(test #f list-length '(a b . c)) +(test '() map cadr '()) + +;;; This tests full conformance of call-with-current-continuation. It +;;; is a separate test because some schemes do not support call/cc +;;; other than escape procedures. I am indebted to +;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this +;;; code. The function leaf-eq? compares the leaves of 2 arbitrary +;;; trees constructed of conses. +(define (next-leaf-generator obj eot) + (letrec ((return #f) + (cont (lambda (x) + (recur obj) + (set! cont (lambda (x) (return eot))) + (cont #f))) + (recur (lambda (obj) + (if (pair? obj) + (for-each recur obj) + (call-with-current-continuation + (lambda (c) + (set! cont c) + (return obj))))))) + (lambda () (call-with-current-continuation + (lambda (ret) (set! return ret) (cont #f)))))) +(define (leaf-eq? x y) + (let* ((eot (list 'eot)) + (xf (next-leaf-generator x eot)) + (yf (next-leaf-generator y eot))) + (letrec ((loop (lambda (x y) + (cond ((not (eq? x y)) #f) + ((eq? eot x) #t) + (else (loop (xf) (yf))))))) + (loop (xf) (yf))))) +(define (test-cont) + (newline) + (display ";testing continuations; ") + (newline) + (SECTION 6 9) + (test #t leaf-eq? '(a (b (c))) '((a) b c)) + (test #f leaf-eq? '(a (b (c))) '((a) b c d)) + (report-errs)) + +;;; Test Optional R4RS DELAY syntax and FORCE procedure +(define (test-delay) + (newline) + (display ";testing DELAY and FORCE; ") + (newline) + (SECTION 6 9) + (test 3 'delay (force (delay (+ 1 2)))) + (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) + (list (force p) (force p)))) + (test 2 'delay (letrec ((a-stream + (letrec ((next (lambda (n) + (cons n (delay (next (+ n 1))))))) + (next 0))) + (head car) + (tail (lambda (stream) (force (cdr stream))))) + (head (tail (tail a-stream))))) + (letrec ((count 0) + (p (delay (begin (set! count (+ count 1)) + (if (> count x) + count + (force p))))) + (x 5)) + (test 6 force p) + (set! x 10) + (test 6 force p)) + (test 3 'force + (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) + (c #f)) + (force p))) + (report-errs)) + +(SECTION 6 10 1) +(test #t input-port? (current-input-port)) +(test #t output-port? (current-output-port)) +(test #t call-with-input-file "test.scm" input-port?) +(define this-file (open-input-file "test.scm")) +(test #t input-port? this-file) +(SECTION 6 10 2) +(test #\; peek-char this-file) +(test #\; read-char this-file) +(test '(define cur-section '()) read this-file) +(test #\( peek-char this-file) +(test '(define errs '()) read this-file) +(close-input-port this-file) +(close-input-port this-file) +(define (check-test-file name) + (define test-file (open-input-file name)) + (test #t 'input-port? + (call-with-input-file + name + (lambda (test-file) + (test load-test-obj read test-file) + (test #t eof-object? (peek-char test-file)) + (test #t eof-object? (read-char test-file)) + (input-port? test-file)))) + (test #\; read-char test-file) + (test display-test-obj read test-file) + (test load-test-obj read test-file) + (close-input-port test-file)) +(SECTION 6 10 3) +(define write-test-obj + '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) +(define display-test-obj + '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) +(define load-test-obj + (list 'define 'foo (list 'quote write-test-obj))) +(test #t call-with-output-file + "tmp1" + (lambda (test-file) + (write-char #\; test-file) + (display write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))) +(check-test-file "tmp1") + +(define test-file (open-output-file "tmp2")) +(write-char #\; test-file) +(display write-test-obj test-file) +(newline test-file) +(write load-test-obj test-file) +(test #t output-port? test-file) +(close-output-port test-file) +(check-test-file "tmp2") +(define (test-sc4) + (newline) + (display ";testing scheme 4 functions; ") + (newline) + (SECTION 6 7) + (test '(#\P #\space #\l) string->list "P l") + (test '() string->list "") + (test "1\\\"" list->string '(#\1 #\\ #\")) + (test "" list->string '()) + (SECTION 6 8) + (test '(dah dah didah) vector->list '#(dah dah didah)) + (test '() vector->list '#()) + (test '#(dididit dah) list->vector '(dididit dah)) + (test '#() list->vector '()) + (SECTION 6 10 4) + (load "tmp1") + (test write-test-obj 'load foo) + (report-errs)) + +(report-errs) +(if (and (string->number "0.0") (inexact? (string->number "0.0"))) + (test-inexact)) + +(let ((n (string->number "281474976710655"))) + (if (and n (exact? n)) + (test-bignum))) +(newline) +(test-cont) +(newline) +(test-sc4) +(newline) +(test-delay) +(newline) +"last item in file" diff --git a/ice-9/threads.scm b/ice-9/threads.scm new file mode 100644 index 000000000..bec189009 --- /dev/null +++ b/ice-9/threads.scm @@ -0,0 +1,53 @@ +;;;; Copyright (C) 1996 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;;; +;;;; ---------------------------------------------------------------- +;;;; threads.scm -- User-level interface to Guile's thread system +;;;; 4 March 1996, Anthony Green <green@cygnus.com> +;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se> +;;;; ---------------------------------------------------------------- +;;;; + + +(define-module #/ice-9/threads) + + + +; --- MACROS ------------------------------------------------------- + +(defmacro-public make-thread (fn . args) + `(call-with-new-thread + (lambda () + (,fn ,@args)) + (lambda args args))) + +(defmacro-public begin-thread (first . thunk) + `(call-with-new-thread + (lambda () + (begin + ,first ,@thunk)) + (lambda args args))) + +(defmacro-public with-mutex (m . thunk) + `(dynamic-wind + (lambda () (lock-mutex ,m)) + (lambda () (begin ,@thunk)) + (lambda () (unlock-mutex ,m)))) + +(defmacro-public monitor (first . thunk) + `(with-mutex ,(make-mutex) + (begin + ,first ,@thunk))) |