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