pkg://guile-scsh-19980806-2.src.rpm:106511/guile-scsh-19980806.tar.gz
info downloads
guile-scsh/ 755 521 17 0 6560306315 11443 5 ustar guile users guile-scsh/CVS/ 755 521 17 0 6560306315 12076 5 ustar guile users guile-scsh/CVS/Root 644 521 17 53 6560306302 12756 0 ustar guile users :ext:egcs.cygnus.com:/egcs/carton/cvsfiles
guile-scsh/CVS/Repository 644 521 17 47 6560306302 14215 0 ustar guile users /egcs/carton/cvsfiles/guile/guile-scsh
guile-scsh/CVS/Entries 644 521 17 4456 6560306315 13523 0 ustar guile users /.cvsignore/1.2/Fri Jul 31 09:22:10 1998//
/COPYING/1.1/Fri Jul 31 09:22:10 1998//
/ChangeLog/1.36/Fri Jul 31 09:22:11 1998//
/INCOMPAT/1.14/Fri Jul 31 09:22:11 1998//
/INSTALL/1.1/Fri Jul 31 09:22:11 1998//
/Makefile.am/1.17/Fri Jul 31 09:22:12 1998//
/Makefile.in/1.22/Fri Jul 31 09:22:12 1998//
/README/1.4/Fri Jul 31 09:22:12 1998//
/THANKS/1.2/Fri Jul 31 09:22:12 1998//
/aclocal.m4/1.8/Fri Jul 31 09:22:12 1998//
/alt-syntax.scm/1.1/Fri Jul 31 09:22:12 1998//
/awk.scm/1.1/Fri Jul 31 09:22:12 1998//
/bitwise.scm/1.1/Fri Jul 31 09:22:12 1998//
/char-set.scm/1.1/Fri Jul 31 09:22:12 1998//
/condition.scm/1.1/Fri Jul 31 09:22:12 1998//
/configure/1.10/Fri Jul 31 09:22:13 1998//
/configure.in/1.5/Fri Jul 31 09:22:13 1998//
/defrec.scm/1.1/Fri Jul 31 09:22:13 1998//
/ekko.scm/1.1/Fri Jul 31 09:22:13 1998//
/enumconst.scm/1.1/Fri Jul 31 09:22:13 1998//
/errno.scm/1.2/Fri Jul 31 09:22:13 1998//
/fileinfo.scm/1.1/Fri Jul 31 09:22:13 1998//
/filemtch.scm/1.1/Fri Jul 31 09:22:13 1998//
/filesys.scm/1.1/Fri Jul 31 09:22:13 1998//
/fluid.scm/1.1/Fri Jul 31 09:22:13 1998//
/fname.scm/1.1/Fri Jul 31 09:22:13 1998//
/fr.scm/1.1/Fri Jul 31 09:22:14 1998//
/glob.scm/1.1/Fri Jul 31 09:22:14 1998//
/here.scm/1.1/Fri Jul 31 09:22:14 1998//
/init.scm/1.28/Fri Jul 31 09:22:14 1998//
/install-sh/1.1/Fri Jul 31 09:22:14 1998//
/let-opt.scm/1.3/Fri Jul 31 09:22:14 1998//
/missing/1.1/Fri Jul 31 09:22:14 1998//
/mkinstalldirs/1.1/Fri Jul 31 09:22:14 1998//
/netconst.scm/1.3/Fri Jul 31 09:22:14 1998//
/network.scm/1.8/Fri Jul 31 09:22:15 1998//
/newports.scm/1.1/Fri Jul 31 09:22:15 1998//
/population.scm/1.1/Fri Jul 31 09:22:15 1998//
/procobj.scm/1.1/Fri Jul 31 09:22:16 1998//
/rdelim.scm/1.3/Fri Jul 31 09:22:16 1998//
/re.scm/1.3/Fri Jul 31 09:22:16 1998//
/receive.scm/1.1/Fri Jul 31 09:22:17 1998//
/rw.scm/1.5/Fri Jul 31 09:22:17 1998//
/scsh-condition.scm/1.2/Fri Jul 31 09:22:17 1998//
/scsh-version.scm/1.1/Fri Jul 31 09:22:17 1998//
/scsh.scm/1.8/Fri Jul 31 09:22:17 1998//
/sighandlers.scm/1.1/Fri Jul 31 09:22:18 1998//
/stringcoll.scm/1.1/Fri Jul 31 09:22:18 1998//
/syntax-helpers.scm/1.1/Fri Jul 31 09:22:18 1998//
/syntax.scm/1.2/Fri Jul 31 09:22:18 1998//
/syscalls.scm/1.9/Fri Jul 31 09:22:20 1998//
/time.scm/1.5/Fri Jul 31 09:22:21 1998//
/utilities.scm/1.4/Fri Jul 31 09:22:21 1998//
/weak.scm/1.1/Fri Jul 31 09:22:21 1998//
D
guile-scsh/.cvsignore 644 521 17 57 6560306302 13461 0 ustar guile users Makefile
config.cache
config.log
config.status
guile-scsh/COPYING 644 521 17 3130 6560306302 12547 0 ustar guile users Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
Copyright (c) 1994, 1995 by Olin Shivers and Brian D. Carlstrom.
Use of this program for non-commercial purposes is permitted provided
that such use is acknowledged both in the software itself and in
accompanying documentation.
Use of this program for commercial purposes is also permitted, but
only if, in addition to the acknowledgement required for
non-commercial users, written notification of such use is provided by
the commercial user to the authors prior to the fabrication and
distribution of the resulting software.
This software is provided ``as is'' without express or implied warranty.
Distributing Autoconf Output
****************************
[excerpt from autoconf documentation]
The configuration scripts that Autoconf produces are covered by the
GNU General Public License. This is because they consist almost
entirely of parts of Autoconf itself, rearranged somewhat, and Autoconf
is distributed under the terms of the GPL. As applied to Autoconf, the
GPL just means that you need to distribute `configure.in' along with
`configure'.
Programs that use Autoconf scripts to configure themselves do not
automatically come under the GPL. Distributing an Autoconf
configuration script as part of a program is considered to be *mere
aggregation* of that work with the Autoconf script. Such programs are
not derivative works based on Autoconf; only their configuration scripts
are. We still encourage software authors to distribute their work under
terms like those of the GPL, but doing so is not required to use
Autoconf.
guile-scsh/ChangeLog 644 521 17 36736 6560306303 13331 0 ustar guile users 1998-04-05 Mikael Djurfeldt <mdj@nada.kth.se>
* init.scm (rindex): Bugfix: start is an optional argument.
(Thanks to David Lutterkort.)
Sat Oct 11 03:30:45 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm, Makefile.am: add scsh-version.scm.
* scsh-version.scm (scsh-major-version): new file from scsh.
Fri Oct 10 22:48:52 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm (reading-error): defined.
Thu Oct 9 02:32:41 1997 Gary Houston <ghouston@actrix.gen.nz>
* here.scm (#\<): don't read-char from port. use read-hash-extend.
(make-immutable!, immutable, unspecific): defined.
* Makefile.am, init.scm: add here.scm
* here.scm: new file from scsh.
Wed Oct 8 03:50:13 1997 Gary Houston <ghouston@actrix.gen.nz>
* Makefile.am: add awk.scm, ekko.scm, enumconst.scm
* init.scm: load awk.scm, enumconst.scm
* enumconst.scm: new file from scsh.
* ekko.scm: new file from scsh. change interpreter to guile.
* awk.scm: new file from scsh. define awk at the end.
* init.scm (batch-mode?, set-batch-mode?!): deleted, now in
boot-9.scm.
Sat Aug 30 19:31:05 1997 Gary Houston <ghouston@actrix.gen.nz>
* filemtch.scm (split-pat): bug fix: would fail if pattern
contained a slash.
(file-match): use catch, not with-handler.
* init.scm (rindex): bug fix: scsh's start argument is
string-rindex's end.
* init.scm, Makefile.am: add new files.
* glob.scm, filemtch.scm, filesys.scm: new files from scsh 0.5.1.
(constant-glob? pattern): bug fix: last "if" had unused third
branch.
* syscalls.scm (open-fdes): removed, primitive in Guile.
(close-fdes): defined.
* scsh.scm (call/temp-file, create-temp-file, *temp-file-template*,
temp-file-iterate, temp-file-channel, open-string-source): defined.
(run/collecting*, ..., string-filter): defined.
(suspend): defined.
(y-or-n?, *y-or-n-eof-count*): uncommented, since used in
filesys.scm.
* init.scm, Makefile.am: add fluid.scm, stringcoll.scm
and alt-syntax.scm.
* syntax.scm: new file from scsh 0.5.1.
* alt-syntax.scm: renamed from syntax.scm.
* fluid.scm: new file, implements Scheme48 fluid variables.
* stringcoll.scm: new file from scsh 0.5.1.
Sat Aug 23 19:17:19 1997 Gary Houston <ghouston@actrix.gen.nz>
* scsh.scm (exec-path-search, exec/env, exec-path/env, exec-path,
exec, fork, %fork, really-fork): defined.
(fork/pipe, %fork/pipe, really-fork/pipe, %fork/pipe+, fork/pipe+,
really-fork/pipe+, tail-pipe, tail-pipe+, pipe*): defined.
* init.scm (set-batch-mode?!, batch-mode?): dummy definitions.
* Makefile.am, init.scm: add bitwise.scm.
* bitwise.scm: new file from scsh-0.5.1/alt/.
(biwise-not, bitwise-and, bitwise-or, bitwise-ior, bitwise-xor):
moved from init.scm.
(count-bits): shift -1, not 1. Commented out, seems unused.
* scsh-condition.scm (errno-error, with-errno-handler): modified
to use Guile primitives.
Don't define syscall-error condition type.
* syscalls.scm (errno-msg): defined.
* errno.scm: include all errnos from cpp_err_symbols.in (libguile).
Sat Aug 16 08:10:24 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: load fileinfo.scm, condition.scm, scsh-condition.scm.
* Makefile.am: add fileinfo.scm, condition.scm, scsh-condition.scm.
* scsh-condition.scm: new file from scsh-0.5.1.
* condition.scm: new file from scsh-0.5.1/rts/.
* fileinfo.scm: new file from scsh-0.5.1.
* init.scm: initialize command-line-arguments.
* scsh.scm (arg*, arg, argv): defined.
(stringify): defined.
* syscalls.scm (define-errno-syscall): moved from init.scm.
(%exec, %%fork): defined.
(user-gid, user-effective-gid, set-gid, user-supplementary-gids,
user-uid, user-effective-uid, set-uid, user-login-name, pid,
parent-pid, process-group, set-process-group, become-session-leader):
defined.
(set-file-mode, set-file-owner, set-file-group, read-symlink,
delete-directory, set-file-times): defined.
(file-info, sync-file, sync-file-system, seek): defined.
(process-times, cpu-ticks/sec): defined.
(%filter-C-strings!): update regexp usage.
(directory-files): defined.
(fdes-flags, set-fdes-flags, fdes-status, set-fdes-status,
open/read etc.): defined.
Sat Aug 9 08:34:09 1997 Gary Houston <ghouston@actrix.gen.nz>
* syscalls.scm: signals: signal-process, signal-process-group,
pause-until-interrupt.
miscellaneous: sleep, sleep-until, system-name.
* Makefile.am (scsh_DATA): add weak.scm, population.scm, procobj.scm,
sighandlers.scm.
* init.scm: load weak.scm, population.scm, procobj.scm,
sighandlers.scm.
* sighandlers.scm: new file from scsh-0.5.1, partially reimplemented
using Guile's sigaction.
* procobj.scm: new file from scsh-0.5.1, modified for Guile.
* population.scm: new file from scsh-0.5.1/scheme48.
* weak.scm: new file, implements scheme48-style weak pointers.
Tue Jul 29 01:39:40 1997 Gary Houston <ghouston@actrix.gen.nz>
* Makefile.am (scsh_DATA): add newports.scm.
* scsh.scm (exit): defined here instead of in syscalls.scm.
* init.scm: load newports.scm.
* newports.scm: new file, excerpts from scsh's version modified
for Guile.
* scsh.scm: include stdio/stdport sync procedures.
Sat Jul 26 06:22:36 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: load syntax-helpers.scm.
* Makefile.am (scsh_DATA): add syntax-helpers.scm.
* syntax-helpers.scm: new file from scsh 0.5.1.
(name?): make it the same as symbol?
* scsh.scm: define call-terminally.
define with-env*, with-total-env*, with-cwd*, with-umask* and
the macro versions.
* syscalls.scm: redefine exit, pipe (ugh).
Define cwd, set-umask.
Include environment stuff, gives only alist->env and env->alist.
Fri Jul 18 07:31:03 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: load re.scm.
* re.scm: delete everything except regexp-num-submatches.
Wed Jul 16 14:40:40 1997 Jim Blandy <jimb@floss.red-bean.com>
* Makefile.am: Install SCSH files in $(datadir)/guile, not in the
version-specific directory. I think SCSH shouldn't be tied to a
specific version of Guile.
* Makefile.in: Regenerated.
Sun Jun 15 06:06:58 1997 Gary Houston <ghouston@actrix.gen.nz>
* configure.in: change the version to 1.2a so it will install
in the right place (maybe).
* README: now it's a port of scsh 0.5.1.
* init.scm: don't include re.scm until Guile's interface is stable.
* match:start, match:end, match:substring updated from scsh 0.5.1.
regexp-substitute, regexp-substitute/global, regexp-num-submatches:
new from scsh 0.5.1.
* syscalls.scm (%filter-C-strings!): moved from re.scm, following
scsh 0.5.1.
* utilities.scm: new version from scsh 0.5.1, adds string-replace!,
substring-replace!, string-reduce.
* time.scm: minor changes for scsh 0.4.4 -> 0.5.1
* rw.scm: delete y-or-n? and *y-or-n-eof-count* which have moved
in scsh 0.5.1 (to scsh.scm, but we don't need them).
Tue May 13 11:59:28 1997 Jim Blandy <jimb@floss.cyclic.com>
* Makefile.in, aclocal.m4, configure: Regenerated using automake
1.1p.
Lie to automake in a different way, to get it to install things in
the right place.
* configure.in (AM_INIT_AUTOMAKE): Call the package guile-scsh,
not guile; this determines the name of the disty.
* Makefile.am (scshdir): Renamed from subpkgdatadir. Use
$(datadir)/guile instead of $(pkgdatadir), since the latter's
value uses the package name given to AM_INIT_AUTOMAKE.
(scsh_DATA): Renamed from subpkgdata_DATA.
(EXTRA_DIST): Fix reference.
* Makefile.in, configure: Regenerated.
Make SCSH into a separate distribution.
* README: Renamed from README.PORT.
* configure.in: Use AM_INIT_AUTOMAKE, not AM_INIT_GUILE_MODULE.
* Makefile.am: Don't use @module@ to decide where to install
things. No need to mention README.PORT; automake will grab it
automatically now, since it's named README. Don't try to
distribute the PLUGIN stuff.
* INSTALL: New file; stock text.
* install-sh, missing, mkinstalldirs: New files, used by
automake-generated makefiles.
* configure, Makefile.in, aclocal.m4: Regenerated.
Sat Apr 26 03:16:18 1997 Gary Houston <ghouston@actrix.gen.nz>
* time.scm (format-date): Uncommented and rewritten.
Fri Apr 11 08:15:40 1997 Gary Houston <ghouston@actrix.gen.nz>
* rdelim.scm: uncomment skip-char-set.
* Makefile.am (subpkgdata_DATA): add fr.scm.
* init.scm: load fr.scm.
* fr.scm: copied from scsh.
Mon Apr 7 08:23:03 1997 Gary Houston <ghouston@actrix.gen.nz>
* time.scm (date, time): fixed and uncommented.
Sat Apr 5 06:44:32 1997 Gary Houston <ghouston@actrix.gen.nz>
* time.scm (ticks/sec): define, always 1000000.
(time+ticks): use gettimeofday.
* Makefile.am (subpkgdata_DATA): add time.scm.
* init.scm: load time.scm. require 'format from slib.
Tue Apr 1 23:19:08 1997 Gary Houston <ghouston@actrix.gen.nz>
* time.scm: copied from scsh and modified to use Guile primitives.
Mon Mar 31 02:24:25 1997 Gary Houston <ghouston@actrix.gen.nz>
* rdelim.scm: uncomment read-paragraph.
* Makefile.am (subpkgdata_DATA): add re.scm.
* init.scm: load re.scm.
* re.scm: copied from scsh and modified to use Guile regular
expressions.
Tue Mar 25 04:28:51 1997 Gary Houston <ghouston@actrix.gen.nz>
* syscalls.scm (name->user-info, uid->user-info): defined, needed
by fname.scm.
* Makefile.am (subpkgdata_DATA): add fname.scm, syscalls.scm, scsh.scm.
* init.scm: load fname.scm, scsh.scm and call init-scsh-vars.
* scsh.scm: new file, list manipulation and global variable init
parts from scsh.
* fname.scm: copied from scsh.
* init.scm (wait/poll, wait/stopped-children): defined, all that's
needed from waitcodes.scm.
Wed Mar 19 04:55:51 1997 Gary Houston <ghouston@actrix.gen.nz>
* syscalls.scm: define user-info record and procedures user-info,
->uid, ->username, %homedir.
define group-info record and procedures group-info, ->gid, ->groupname.
Mon Mar 17 19:40:45 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: load syscalls.scm.
* syscalls.scm: new file. Will not include all of the contents
of scsh's syscalls.scm.
Tue Mar 11 04:09:55 1997 Gary Houston <ghouston@actrix.gen.nz>
* (let-opt.scm, utilities.scm): revert to scsh's versions, no longer
renaming :optional.
(rw.scm, network.scm): change optional back to :optional.
Mon Feb 24 21:47:59 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* configure.in: Added AM_MAINTAINER_MODE
Fri Jan 31 04:36:42 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: use use-modules instead of define-module to access slib.
Sat Jan 25 01:03:03 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: load char-set.scm and rdelim.scm.
* Makefile.am (subpkgdata_DATA): add char-set.scm and rdelim.scm.
* rdelim.scm: new file from scsh. Some procedures have been
implemented in libguile/ice-9 (based on the scsh interfaces), so
the versions here just modify them to use scsh char-sets and
multiple values.
* rw.scm (generic-read-string!/partial, generic-read-string!,
generic-write-string/partial, generic-write-string: adapt
to change in uniform-array-read/write arguments.
* network.scm (generic-receive-message!,
generic-receive-message!/partial): adapt to changes in recvfrom!
primitive.
* char-set.scm: new file from scsh.
Mon Jan 20 01:12:38 1997 Gary Houston <ghouston@actrix.gen.nz>
* Makefile.am, Makefile.in, PLUGIN/OPT, README.PORT, configure.in,
configure, aclocal.m4: new files.
* network.scm (generic-receive-message!/partial): catch sytem-error
and check for errno/wouldblock or errno/again.
Sat Jan 18 00:52:14 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm (index, rindex): replace versions in utilities.scm with
primitives.
load errno.scm.
* rw.scm: globally replace :optional with optional.
comment out y-or-n? and *y-or-n-eof-count*.
(read-string!/partial, generic-read-string!/partial,
generic-read-string!, read-string!, generic-write-string/partial,
write-string/partial, generic-write-string, write-string):
use guile primitives.
* netconst.scm: undefine maybe-define and maybe-define-so after use.
* errno.scm: new file.
Wed Jan 8 02:32:56 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm (ascii->char, char->ascii) defined.
* netconst.scm (maybe-define-so): new macro. use it to define
socket option constants.
remove a few SO_ types which don't appear in scsh's netconst.scm.
define variables options/boolean etc.
* network.scm: socket-address->list: new procedure.
(generic-send-message, generic-send-message/partial, socket-option,
set-socket-option, address->host-info, name->host-info,
address->network-info, name->network-info, port->service-info,
name->service-info, number->protocol-info, name->protocol-info):
use guile primitives.
(send-message, send-message/partial): minor modifications.
comment out C-long-vec->Scheme, integer->string, string->integer.
Mon Jan 6 05:00:19 1997 Gary Houston <ghouston@actrix.gen.nz>
* network.scm (generic-receive-message!): use guile primitives.
(receive-message!): minor change.
(receive-message): use the scsh definition.
(generic-receive-mesage/partial, receive-message/partial,
receive-message!/partial): similar.
* init.scm: load rw.scm
* rw.scm: copied from scsh.
Sat Jan 4 02:48:02 1997 Gary Houston <ghouston@actrix.gen.nz>
* init.scm (define-structure): simple substitute.
Sun Dec 29 08:12:10 1996 Gary Houston <ghouston@actrix.gen.nz>
* let-opt.scm: new copy from scsh. replace :optional with optional.
Fri Dec 27 06:06:50 1996 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: remove integer->string.
Sat Dec 21 01:49:23 1996 Gary Houston <ghouston@actrix.gen.nz>
* network.scm: (close-socket, bind-socket, create-socket,
connect-socket, listen-socket, accept-connection,
socket-remote-address, socket-local-address, shutdown-socket,
create-socket-pair, receive-message: use Guile network primitives.
(socket-address->list family address): new procedure.
(make-addr): comment out.
(address-vector->socket-address): new procedure.
Thu Dec 19 05:29:30 1996 Gary Houston <ghouston@actrix.gen.nz>
* network.scm (internet-address->socket-address): store the
address/port in a pair instead of packing them into a string.
(socket-address->internet-address): equal and opposite change.
(throughout): replace :optional with optional.
(socket->port sock): replaces socket->fdes.
* init.scm: define integer->string, load netconst.scm.
define define-foreign, define-errno-syscall,
define-record-dicloser (do nothing.)
load network.scm.
Wed Dec 18 22:44:02 1996 Gary Houston <ghouston@actrix.gen.nz>
* netconst.scm: new file, defines network constants.
Tue Dec 17 06:24:39 1996 Gary Houston <ghouston@actrix.gen.nz>
* network.scm: copied from scsh
* init.scm: define foreign-source, does nothing.
* init.scm: load syntax.scm instead of slib's macro-by-example.
load defrec.scm.
* defrec.scm: copied from scsh.
* syntax.scm: copied from scsh.
Redefine define-syntax and define syntax-error. By some miracle
it seems to work.
Mon Dec 16 05:53:43 1996 Gary Houston <ghouston@actrix.gen.nz>
* receive.scm: copied from scsh.
Fri Dec 13 04:53:50 1996 Gary Houston <ghouston@actrix.gen.nz>
* utilities.scm (compose): uncomment.
* init.scm (values): get call-with-values from slib.
Wed Dec 11 22:15:18 1996 Gary Houston <ghouston@actrix.gen.nz>
* init.scm: define bitwise-not, bitwise-and, bitwise-ior, bitwise-xor.
use slib's macro-by-example for define-syntax for now.
load let-opt.scm and utilities.scm.
* utilities.scm: replace usage of :optional with optional.
comment out compose, haven't decided what to do with call-with-values.
* let-opt.scm: comment out everything but the `optional'
macro, renamed from :optional.
* COPYING, let-opt.scm, utilities.scm: from scsh 0.4.4.
* ChangeLog, INCOMPAT, init.scm: new files.
* new directory.
guile-scsh/INCOMPAT 644 521 17 3226 6560306303 12660 0 ustar guile users Incompatibilities with scsh 0.4.4:
everything is defined at the top level, no modules.
generic-receive-message! always returns 2 values: the number of
bytes read and the address received from. Likewise for receive-message!
and receive-message (bug in scsh?)
network-info works when its argument is a socket address (bug in scsh?)
%read-delimited! takes a string for its "set of delimiters" parameter.
If the buffer fills, it doesn't peek ahead to check whether the next
character is a delimiter or EOF, since this a) seems to require extra
code or comparisons, b) makes read-delimted! and read-line! more complex
c) doesn't gain much anyway.
set-enabled-interrupts and with-interrupts have not been
implemented. Within a with-enabled-interrupts form, all interrupts are
disabled.
set-command-line-args! is not implemented.
command-line returns the same list every time, not a copy.
itimer is not implemented.
Several scsh procedures are incompatible with Guile procedures.
In these cases the procedures are redefined when init.scm is
loaded. This isn't a very good solution: hopefully use of the
module system will help. The following procedures are
affected: read-delimited read-delimited! pipe sleep exit make-fluid
and probably open-file.
The close-on-exec flag is not currently set on unrevealed ports.
the NDBM interface hasn't been implemented.
the flock interface hasn't been implemented.
net-to-host-32 etc., haven't been defined.
the files jcontrol.scm and jcontrol2.scm haven't been ported.
pty and tty support hasn't been implemented (pty.scm, tty.scm).
select! hasn't been implemented.
display and write don't accept file descriptors in place of ports.
guile-scsh/INSTALL 644 521 17 16447 6560306303 12605 0 ustar guile users Basic Installation
==================
These are generic installation instructions.
The `configure' shell script attempts to guess correct values for
various system-dependent variables used during compilation. It uses
those values to create a `Makefile' in each directory of the package.
It may also create one or more `.h' files containing system-dependent
definitions. Finally, it creates a shell script `config.status' that
you can run in the future to recreate the current configuration, a file
`config.cache' that saves the results of its tests to speed up
reconfiguring, and a file `config.log' containing compiler output
(useful mainly for debugging `configure').
If you need to do unusual things to compile the package, please try
to figure out how `configure' could check whether to do them, and mail
diffs or instructions to the address given in the `README' so they can
be considered for the next release. If at some point `config.cache'
contains results you don't want to keep, you may remove or edit it.
The file `configure.in' is used to create `configure' by a program
called `autoconf'. You only need `configure.in' if you want to change
it or regenerate `configure' using a newer version of `autoconf'.
The simplest way to compile this package is:
1. `cd' to the directory containing the package's source code and type
`./configure' to configure the package for your system. If you're
using `csh' on an old version of System V, you might need to type
`sh ./configure' instead to prevent `csh' from trying to execute
`configure' itself.
Running `configure' takes a while. While running, it prints some
messages telling which features it is checking for.
2. Type `make' to compile the package.
3. Optionally, type `make check' to run any self-tests that come with
the package.
4. Type `make install' to install the programs and any data files and
documentation.
5. You can remove the program binaries and object files from the
source code directory by typing `make clean'. To also remove the
files that `configure' created (so you can compile the package for
a different kind of computer), type `make distclean'. There is
also a `make maintainer-clean' target, but that is intended mainly
for the package's developers. If you use it, you may have to get
all sorts of other programs in order to regenerate files that came
with the distribution.
Compilers and Options
=====================
Some systems require unusual options for compilation or linking that
the `configure' script does not know about. You can give `configure'
initial values for variables by setting them in the environment. Using
a Bourne-compatible shell, you can do that on the command line like
this:
CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure
Or on systems that have the `env' program, you can do it like this:
env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure
Compiling For Multiple Architectures
====================================
You can compile the package for more than one kind of computer at the
same time, by placing the object files for each architecture in their
own directory. To do this, you must use a version of `make' that
supports the `VPATH' variable, such as GNU `make'. `cd' to the
directory where you want the object files and executables to go and run
the `configure' script. `configure' automatically checks for the
source code in the directory that `configure' is in and in `..'.
If you have to use a `make' that does not supports the `VPATH'
variable, you have to compile the package for one architecture at a time
in the source code directory. After you have installed the package for
one architecture, use `make distclean' before reconfiguring for another
architecture.
Installation Names
==================
By default, `make install' will install the package's files in
`/usr/local/bin', `/usr/local/man', etc. You can specify an
installation prefix other than `/usr/local' by giving `configure' the
option `--prefix=PATH'.
You can specify separate installation prefixes for
architecture-specific files and architecture-independent files. If you
give `configure' the option `--exec-prefix=PATH', the package will use
PATH as the prefix for installing programs and libraries.
Documentation and other data files will still use the regular prefix.
If the package supports it, you can cause programs to be installed
with an extra prefix or suffix on their names by giving `configure' the
option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
Optional Features
=================
Some packages pay attention to `--enable-FEATURE' options to
`configure', where FEATURE indicates an optional part of the package.
They may also pay attention to `--with-PACKAGE' options, where PACKAGE
is something like `gnu-as' or `x' (for the X Window System). The
`README' should mention any `--enable-' and `--with-' options that the
package recognizes.
For packages that use the X Window System, `configure' can usually
find the X include and library files automatically, but if it doesn't,
you can use the `configure' options `--x-includes=DIR' and
`--x-libraries=DIR' to specify their locations.
Specifying the System Type
==========================
There may be some features `configure' can not figure out
automatically, but needs to determine by the type of host the package
will run on. Usually `configure' can figure that out, but if it prints
a message saying it can not guess the host type, give it the
`--host=TYPE' option. TYPE can either be a short name for the system
type, such as `sun4', or a canonical name with three fields:
CPU-COMPANY-SYSTEM
See the file `config.sub' for the possible values of each field. If
`config.sub' isn't included in this package, then this package doesn't
need to know the host type.
If you are building compiler tools for cross-compiling, you can also
use the `--target=TYPE' option to select the type of system they will
produce code for and the `--build=TYPE' option to select the type of
system on which you are compiling the package.
Sharing Defaults
================
If you want to set default values for `configure' scripts to share,
you can create a site shell script called `config.site' that gives
default values for variables like `CC', `cache_file', and `prefix'.
`configure' looks for `PREFIX/share/config.site' if it exists, then
`PREFIX/etc/config.site' if it exists. Or, you can set the
`CONFIG_SITE' environment variable to the location of the site script.
A warning: not all `configure' scripts look for a site script.
Operation Controls
==================
`configure' recognizes the following options to control how it
operates.
`--cache-file=FILE'
Use and save the results of the tests in FILE instead of
`./config.cache'. Set FILE to `/dev/null' to disable caching, for
debugging `configure'.
`--help'
Print a summary of the options to `configure', and exit.
`--quiet'
`--silent'
`-q'
Do not print messages saying which checks are being made.
`--srcdir=DIR'
Look for the package's source code in directory DIR. Usually
`configure' can determine that directory automatically.
`--version'
Print the version of Autoconf used to generate the `configure'
script, and exit.
`configure' also accepts some other, not widely useful, options.
guile-scsh/Makefile.am 644 521 17 1225 6560306304 13555 0 ustar guile users ## Process this file with automake to produce Makefile.in.
AUTOMAKE_OPTIONS = foreign
scshdir = $(datadir)/guile/scsh
scsh_DATA = alt-syntax.scm awk.scm bitwise.scm char-set.scm condition.scm \
defrec.scm ekko.scm enumconst.scm \
errno.scm fileinfo.scm filemtch.scm filesys.scm \
fluid.scm fname.scm fr.scm glob.scm here.scm \
init.scm let-opt.scm netconst.scm \
network.scm newports.scm population.scm procobj.scm \
rdelim.scm re.scm receive.scm rw.scm \
scsh.scm scsh-condition.scm scsh-version.scm \
sighandlers.scm stringcoll.scm \
syntax.scm syntax-helpers.scm syscalls.scm \
time.scm utilities.scm weak.scm
EXTRA_DIST = $(scsh_DATA) INCOMPAT
guile-scsh/Makefile.in 644 521 17 14577 6560306304 13624 0 ustar guile users # Makefile.in generated automatically by automake 1.1p 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
ACLOCAL = @ACLOCAL@
AUTOCONF = @AUTOCONF@
AUTOHEADER = @AUTOHEADER@
AUTOMAKE = @AUTOMAKE@
MAINT = @MAINT@
MAKEINFO = @MAKEINFO@
PACKAGE = @PACKAGE@
VERSION = @VERSION@
AUTOMAKE_OPTIONS = foreign
scshdir = $(datadir)/guile/scsh
scsh_DATA = alt-syntax.scm awk.scm bitwise.scm char-set.scm condition.scm \
defrec.scm ekko.scm enumconst.scm \
errno.scm fileinfo.scm filemtch.scm filesys.scm \
fluid.scm fname.scm fr.scm glob.scm here.scm \
init.scm let-opt.scm netconst.scm \
network.scm newports.scm population.scm procobj.scm \
rdelim.scm re.scm receive.scm rw.scm \
scsh.scm scsh-condition.scm scsh-version.scm \
sighandlers.scm stringcoll.scm \
syntax.scm syntax-helpers.scm syscalls.scm \
time.scm utilities.scm weak.scm
EXTRA_DIST = $(scsh_DATA) INCOMPAT
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs
CONFIG_CLEAN_FILES =
DATA = $(scsh_DATA)
DIST_COMMON = README COPYING ChangeLog INSTALL Makefile.am Makefile.in \
THANKS aclocal.m4 configure configure.in install-sh missing \
mkinstalldirs
DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
TAR = tar
GZIP = --best
default: all
.SUFFIXES:
$(srcdir)/Makefile.in: @MAINT@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4)
cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile
Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
cd $(top_builddir) \
&& CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
$(ACLOCAL_M4): @MAINT@ configure.in
cd $(srcdir) && $(ACLOCAL)
config.status: $(srcdir)/configure
$(SHELL) ./config.status --recheck
$(srcdir)/configure: @MAINT@$(srcdir)/configure.in $(ACLOCAL_M4) $(CONFIGURE_DEPENDENCIES)
cd $(srcdir) && $(AUTOCONF)
install-scshDATA: $(scsh_DATA)
@$(NORMAL_INSTALL)
$(mkinstalldirs) $(scshdir)
@list='$(scsh_DATA)'; for p in $$list; do \
if test -f $(srcdir)/$$p; then \
echo " $(INSTALL_DATA) $(srcdir)/$$p $(scshdir)/$$p"; \
$(INSTALL_DATA) $(srcdir)/$$p $(scshdir)/$$p; \
else if test -f $$p; then \
echo " $(INSTALL_DATA) $$p $(scshdir)/$$p"; \
$(INSTALL_DATA) $$p $(scshdir)/$$p; \
fi; fi; \
done
uninstall-scshDATA:
$(NORMAL_UNINSTALL)
list='$(scsh_DATA)'; for p in $$list; do \
rm -f $(scshdir)/$$p; \
done
tags: TAGS
TAGS:
distdir = $(PACKAGE)-$(VERSION)
top_distdir = $(distdir)
# 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 777 $(distdir)
here=`cd $(top_builddir) && pwd`; \
top_distdir=`cd $(top_distdir) && pwd`; \
cd $(top_srcdir) \
&& $(AUTOMAKE) --include-deps --build-dir=$$here --srcdir-name=$(top_srcdir) --output-dir=$$top_distdir --foreign Makefile
@for file in $(DISTFILES); do \
d=$(srcdir); \
test -f $(distdir)/$$file \
|| ln $$d/$$file $(distdir)/$$file 2> /dev/null \
|| cp -p $$d/$$file $(distdir)/$$file; \
done
info:
dvi:
check: all
$(MAKE)
installcheck:
install-exec:
@$(NORMAL_INSTALL)
install-data: install-scshDATA
@$(NORMAL_INSTALL)
install: install-exec install-data all
@:
uninstall: uninstall-scshDATA
all: Makefile $(DATA)
install-strip:
$(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
installdirs:
$(mkinstalldirs) $(scshdir)
mostlyclean-generic:
test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
clean-generic:
test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
distclean-generic:
rm -f Makefile $(DISTCLEANFILES)
rm -f config.cache config.log stamp-h stamp-h[0-9]*
test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
maintainer-clean-generic:
test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
mostlyclean: mostlyclean-generic
clean: clean-generic mostlyclean
distclean: distclean-generic clean
rm -f config.status
maintainer-clean: maintainer-clean-generic distclean
@echo "This command is intended for maintainers to use;"
@echo "it deletes files that may require special tools to rebuild."
rm -f config.status
.PHONY: default uninstall-scshDATA install-scshDATA tags distdir info \
dvi installcheck install-exec install-data install uninstall all \
installdirs mostlyclean-generic distclean-generic clean-generic \
maintainer-clean-generic clean mostlyclean distclean maintainer-clean
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:
guile-scsh/README 644 521 17 3663 6560306304 12411 0 ustar guile users This is an incomplete port of the scheme shell (scsh) 0.5.1 to Guile.
The original scsh is available by ftp from
swiss-ftp.ai.mit.edu:/pub/su, which is also the place to go for scsh
documentation.
The Guile port uses a record type to represent the multiple values
returned by many scsh procedures. The values can be retrieved
using call-with-values or receive.
The Guile module system is not currently being used. Initialization
can be done by:
(load-from-path "scsh/init")
Note that SLIB must be found in %load-path, e.g., it can be unpacked
in the "site" directory. SLIB can be obtained by ftp from
prep.ai.mit.edu in the pub/gnu/jacal directory.
The Guile reference manual also has information about installing
and using SLIB and scsh.
Hacking It Yourself ==================================================
As distributed, the Guile SCSH port needs only a Unix system to build
and install. However, its makefiles, configuration scripts, and a few
other files are automatically generated, not written by hand. If you
want to make changes to the system (which we encourage!) you will find
it helpful to have the tools we use to develop it. They are the
following:
Autoconf 2.12 --- a system for automatically generating `configure'
scripts from templates which list the non-portable features a
program would like to use. Available in
"ftp://prep.ai.mit.edu/pub/gnu".
Automake 1.1p --- a system for automatically generating Makefiles that
conform to the (rather Byzantine) GNU coding standards. The
nice thing is that it takes care of hairy targets like 'make
dist' and 'make distclean', and automatically generates
Makefile dependencies. Available in
"ftp://ftp.cygnus.com/pub/tromey".
libtool 0.9d --- a system for managing the zillion hairy options needed
on various systems to produce shared libraries. Available in
"ftp://alpha.gnu.ai.mit.edu/gnu".
You are lost in a little maze of automatically generated files, all
different.
>
guile-scsh/THANKS 644 521 17 257 6560306304 12420 0 ustar guile users The Guile SCSH port is the work of volunteer Gary Houston, as well as
the Guile core system call support upon which SCSH rests.
Bug reports and fixes from:
David Lutterkort
guile-scsh/aclocal.m4 644 521 17 6274 6560306304 13372 0 ustar guile users dnl aclocal.m4 generated automatically by aclocal 1.1p
# Do all the work for Automake. This macro actually does too much --
# some checks are only needed if your package does certain things.
# But this isn't really a big deal.
# serial 1
dnl Usage:
dnl AM_INIT_AUTOMAKE(package,version, [no-define])
AC_DEFUN(AM_INIT_AUTOMAKE,
[AC_REQUIRE([AM_PROG_INSTALL])
PACKAGE=[$1]
AC_SUBST(PACKAGE)
VERSION=[$2]
AC_SUBST(VERSION)
dnl test to see if srcdir already configured
if test "`cd $srcdir && pwd`" != "`pwd`" && test -f $srcdir/config.status; then
AC_MSG_ERROR([source directory already configured; run "make distclean" there first])
fi
ifelse([$3],,
AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE")
AC_DEFINE_UNQUOTED(VERSION, "$VERSION"))
AM_SANITY_CHECK
AC_ARG_PROGRAM
dnl FIXME This is truly gross.
missing_dir=`cd $ac_aux_dir && pwd`
AM_MISSING_PROG(ACLOCAL, aclocal, $missing_dir)
AM_MISSING_PROG(AUTOCONF, autoconf, $missing_dir)
AM_MISSING_PROG(AUTOMAKE, automake, $missing_dir)
AM_MISSING_PROG(AUTOHEADER, autoheader, $missing_dir)
AM_MISSING_PROG(MAKEINFO, makeinfo, $missing_dir)
AC_PROG_MAKE_SET])
# serial 1
AC_DEFUN(AM_PROG_INSTALL,
[AC_REQUIRE([AC_PROG_INSTALL])
test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
AC_SUBST(INSTALL_SCRIPT)dnl
])
#
# Check to make sure that the build environment is sane.
#
AC_DEFUN(AM_SANITY_CHECK,
[AC_MSG_CHECKING([whether build environment is sane])
# Just in case
sleep 1
echo timestamp > conftestfile
# Do `set' in a subshell so we don't clobber the current shell's
# arguments. Must try -L first in case configure is actually a
# symlink; some systems play weird games with the mod time of symlinks
# (eg FreeBSD returns the mod time of the symlink's containing
# directory).
if (
set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
if test "$@" = "X"; then
# -L didn't work.
set X `ls -t $srcdir/configure conftestfile`
fi
test "[$]2" = conftestfile
)
then
# Ok.
:
else
AC_MSG_ERROR([newly created file is older than distributed files!
Check your system clock])
fi
rm -f conftest*
AC_MSG_RESULT(yes)])
dnl AM_MISSING_PROG(NAME, PROGRAM, DIRECTORY)
dnl The program must properly implement --version.
AC_DEFUN(AM_MISSING_PROG,
[AC_MSG_CHECKING(for working $2)
# Run test in a subshell; some versions of sh will print an error if
# an executable is not found, even if stderr is redirected.
# Redirect stdin to placate older versions of autoconf. Sigh.
if ($2 --version) < /dev/null > /dev/null 2>&1; then
$1=$2
AC_MSG_RESULT(found)
else
$1="$3/missing $2"
AC_MSG_RESULT(missing)
fi
AC_SUBST($1)])
# Add --enable-maintainer-mode option to configure.
# From Jim Meyering
# serial 1
AC_DEFUN(AM_MAINTAINER_MODE,
[AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles])
dnl maintainer-mode is disabled by default
AC_ARG_ENABLE(maintainer-mode,
[ --enable-maintainer-mode enable make rules and dependencies not useful
(and sometimes confusing) to the casual installer],
USE_MAINTAINER_MODE=$enableval,
USE_MAINTAINER_MODE=no)
AC_MSG_RESULT($USE_MAINTAINER_MODE)
if test $USE_MAINTAINER_MODE = yes; then
MAINT=
else
MAINT='#M#'
fi
AC_SUBST(MAINT)dnl
]
)
guile-scsh/alt-syntax.scm 644 521 17 14131 6560306304 14351 0 ustar guile users ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; for Guile: redefined define-syntax, added syntax-error definition.
; This definition of define-syntax is appropriate for Scheme-to-C.
;(define-macro define-syntax
; (lambda (form expander)
; (expander `(define-macro ,(cadr form)
; (let ((transformer ,(caddr form)))
; (lambda (form expander)
; (expander (transformer form
; (lambda (x) x)
; eq?)
; expander))))
; expander)))
; This is the version for Guile.
(defmacro define-syntax (name expander)
`(define ,name (defmacro:transformer (lambda form
(,expander (cons ,name
form)
(lambda (x) x)
eq?)))))
(define syntax-error error)
; Rewrite-rule compiler (a.k.a. "extend-syntax")
; Example:
;
; (define-syntax or
; (syntax-rules ()
; ((or) #f)
; ((or e) e)
; ((or e1 e ...) (let ((temp e1))
; (if temp temp (or e ...))))))
(define-syntax syntax-rules
(let ()
(define name? symbol?)
(define (segment-pattern? pattern)
(and (segment-template? pattern)
(or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern))))
(define (segment-template? pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more)))
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
(lambda (exp r c)
(define %input (r '%input)) ;Gensym these, if you like.
(define %compare (r '%compare))
(define %rename (r '%rename))
(define %tail (r '%tail))
(define %temp (r '%temp))
(define rules (cddr exp))
(define subkeywords (cadr exp))
(define (make-transformer rules)
`(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input)))
(cond ,@(map process-rule rules)
(else
(syntax-error
"use of macro doesn't match definition"
,%input))))))
(define (process-rule rule)
(if (and (pair? rule)
(pair? (cdr rule))
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
`((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern
%tail
(lambda (x) x))
,(process-template template
0
(meta-variables pattern 0 '())))))
(syntax-error "ill-formed syntax rule" rule)))
; Generate code to test whether input expression matches pattern
(define (process-match input pattern)
(cond ((name? pattern)
(if (member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))
`()))
((segment-pattern? pattern)
(process-segment-match input (car pattern)))
((pair? pattern)
`((let ((,%temp ,input))
(and (pair? ,%temp)
,@(process-match `(car ,%temp) (car pattern))
,@(process-match `(cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern))
`((eq? ,input ',pattern)))
(else
`((equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
(let ((conjuncts (process-match '(car l) pattern)))
(if (null? conjuncts)
`((list? ,input)) ;+++
`((let loop ((l ,input))
(or (null? l)
(and (pair? l)
,@conjuncts
(loop (cdr l)))))))))
; Generate code to take apart the input expression
; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit)
(cond ((name? pattern)
(if (memq pattern subkeywords)
'()
(list (list pattern (mapit path)))))
((segment-pattern? pattern)
(process-pattern (car pattern)
%temp
(lambda (x) ;temp is free in x
(mapit (if (eq? %temp x)
path ;+++
`(map (lambda (,%temp) ,x)
,path))))))
((pair? pattern)
(append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
(else '())))
; Generate code to compose the output expression according to template
(define (process-template template rank env)
(cond ((name? template)
(let ((probe (assq template env)))
(if probe
(if (<= (cdr probe) rank)
template
(syntax-error "template rank error (too few ...'s?)"
template))
`(,%rename ',template))))
((segment-template? template)
(let ((vars
(free-meta-variables (car template) (+ rank 1) env '())))
(if (null? vars)
(syntax-error "too many ...'s" template)
(let* ((x (process-template (car template)
(+ rank 1)
env))
(gen (if (equal? (list x) vars)
x ;+++
`(map (lambda ,vars ,x)
,@vars))))
(if (null? (cddr template))
gen ;+++
`(append ,gen ,(process-template (cddr template)
rank env)))))))
((pair? template)
`(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env)))
(else `(quote ,template))))
; Return an association list of (var . rank)
(define (meta-variables pattern rank vars)
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons (cons pattern rank) vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) (+ rank 1) vars))
((pair? pattern)
(meta-variables (car pattern) rank
(meta-variables (cdr pattern) rank vars)))
(else vars)))
; Return a list of meta-variables of given higher rank
(define (free-meta-variables template rank env free)
(cond ((name? template)
(if (and (not (memq template free))
(let ((probe (assq template env)))
(and probe (>= (cdr probe) rank))))
(cons template free)
free))
((segment-template? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cddr template)
rank env free)))
((pair? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cdr template)
rank env free)))
(else free)))
c ;ignored
;; Kludge for Scheme 48 static linker.
;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules))
(make-transformer rules))))
guile-scsh/awk.scm 644 521 17 46325 6560306304 13041 0 ustar guile users ;;; An awk loop, after the design of David Albertz and Olin Shivers.
;;; Copyright (c) 1994 by Olin Shivers.
;;; the only change for Guile is the awk definition on the last line.
;;; - Requires RECEIVE from RECEIVING package.
;;; - Would require DESTRUCTURE from DESTRUCTURING package, but it appears
;;; to be broken, so we hack it w/cars and cdrs.
;;; - Requires STRING-MATCH from SCSH package.
;;; This should be hacked to convert regexp strings into regexp structures
;;; at the top of the form, and then just refer to the structs in the
;;; tests.
;;; Examples:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ;;; Filter -- pass only lines containing my name.
;;; (awk (read-line) (line) ()
;;; ("Olin" (display line) (newline)))
;;;
;;; ;;; Count the number of non-comment lines of code in my Scheme source.
;;; (awk (read-line) (line) ((nlines 0))
;;; ("^[ \t]*;" nlines) ; A comment line.
;;; (else (+ nlines 1))) ; Not a comment line.
;;;
;;; ;;; Read numbers, counting the evens and odds.
;;; (awk (read) (val) ((evens 0) (odds 0))
;;; ((zero? val) (display "zero ") (values evens odds)) ; Tell me about
;;; ((> val 0) (display "pos ") (values evens odds)) ; sign, too.
;;; (else (display "neg ") (values evens odds))
;;;
;;; ((even? val) (values (+ evens 1) odds))
;;; (else (values evens (+ odds 1))))
;;; Syntax:
;;; (awk <reader-exp> <rec&field-vars> [<rec-counter>] <state-var-inits>
;;; <clause1>
;;; .
;;; .
;;; <clausen>)
;;; This macro is written using Clinger/Rees explicit-renaming low-level
;;; macros. So it is pretty ugly. It takes a little care to generate
;;; cosmetically attractive code, for two reasons:
;;; - It makes it easier for humans to examine the expanded code.
;;; - It helps low-tech compilers compile the code well. Some of the
;;; optimisations the expander implements would be hard for even a
;;; sophisticated compiler to perform automatically. For example, it doesn't
;;; introduce a record-counter variable unless required to do so. It's a
;;; non-trivial analysis to spot and remove an unused loop variable (I show
;;; how to do so in my dissertation; I don't know of any production
;;; compilers that do it). Same remarks apply to the variable that tracks
;;; the state bit for ELSE clauses -- we don't introduce one unless the loop
;;; actually contains ELSE clauses. The lesson here is that loop macros
;;; by definition have information about the data-flow of their bodies that
;;; compilers have to work hard to spot by analysis of their expanded forms.
;;; The macro can exploit this knowledge at the high-level.
;;;
;;; Interesting research issue: Could one design a macro system that would
;;; allow the macro to communicate this knowledge to the compiler? Could
;;; the macro's assertions be verified by the compiler, as well?
;;;
;;; In any even, there's a down-side to this cosmetic clean-up:
;;; all of this optimisation definitely makes the macro a lot more hairy
;;; than it would otherwise be. The expanded code is easier to read; the
;;; macro itself is harder to read.
;;; Simple syntax-hacking utilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Return a form that produces multiple values.
;;; () => (values)
;;; (v) => v
;;; (v1 v2 ...) => (values v1 v2 ...)
(define (mult-values vals rename)
(if (or (not (pair? vals)) (pair? (cdr vals)))
`(,(rename 'values) . ,vals)
(car vals)))
;;; () => ()
;;; (v1) => (v1)
;;; (v1 v2) => ((VALUES v1 v2))
;;;
;;; Return an expression list, not an expression. (Either 1 or 0 expressions.)
;;; Use this one when we don't care what happens if we are returning 0 vals.
;;; It pairs up with MV-LET below, which ignores the number of values
;;; returned to it when expecting zero values.
(define (sloppy-mult-values vals rename)
(if (and (pair? vals) (pair? (cdr vals)))
`((,(rename 'values) . ,vals))
vals))
;; DEBLOCK maps an expression to a list of expressions, flattening BEGINS.
;; (deblock '(begin (begin 3 4) 5 6 (begin 7 8))) => (3 4 5 6 7 8)
(define (deblock exp rename compare)
(let ((%block (rename 'begin)))
(let deblock1 ((exp exp))
(if (and (pair? exp)
; (name? (car exp))
(compare %block (car exp)))
(apply append (map deblock1 (cdr exp)))
(list exp)))))
;; BLOCKIFY maps an expression list to a BEGIN form, flattening nested BEGINS.
;; (blockify '( (begin 3 4) 5 (begin 6) )) => (begin 3 4 5 6)
(define (blockify exps rename compare)
(let ((new-exps (apply append
(map (lambda (exp) (deblock exp rename compare))
exps))))
(cond ((null? new-exps)
(error "Empty BEGIN" exps))
((null? (cdr new-exps)) ; (begin exp) => exp
(car new-exps))
(else `(,(rename 'begin) . ,new-exps)))))
(define (mv-let r c vars exp body)
(if (pair? vars)
(if (pair? (cdr vars))
`(,(r 'receive) ,vars ,exp . ,(deblock body r c))
`(,(r 'let) ((,(car vars) ,exp)) . ,(deblock body r c)))
(blockify (list exp body) r c)))
;;; Is X one of the keywords {range, :range, range:, :range:}?
(define (range-keyword? x rename compare)
(or (compare x (rename 'range))
(compare x (rename ':range))
(compare x (rename 'range:))
(compare x (rename ':range:))))
;;; Apply PRED to every element of VALS. Collect & return all the non-#f
;;; values produced.
(define (all-trues pred vals)
(let lp ((vals vals) (ans '()))
(if (pair? vals)
(lp (cdr vals)
(cond ((pred (car vals)) => (lambda (elt) (cons elt ans)))
(else ans)))
(reverse ans))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (expand-awk exp r c)
(let* ((%lambda (r 'lambda)) ; Bind a mess of keywords.
(%let (r 'let))
(%receive (r 'receive))
(%values (r 'values))
(%if (r 'if))
(%eof-object? (r 'eof-object?))
(%after (r 'after))
(%else (r 'else))
(%+ (r '+))
(%make-regexp (r 'make-regexp))
(gensym (let ((i 0))
(lambda (s)
(set! i (+ i 1))
(string->symbol (string-append s (number->string i))))))
;; Is the clause a range-test clause?
(range? (lambda (clause) (range-keyword? (car clause) r c)))
;; Make some standard vars we'll need.
(lp-var (r 'lp))
(reader (r 'read-rec))
;; If I throw in an abort-loop or abort-iteration macro,
;; I'll also need to make two vars for the continuations.
;; Rip the form apart.
(reader-exp (cadr exp))
(rec/field-vars (caddr exp))
(rec-var (car rec/field-vars)) ; The var bound to the record.
(rest (cdddr exp))) ; Stuff after the rec&field-vars.
(receive (rec-counter state-inits clauses) ; Parse out the last
(if (list? (car rest)) ; three parts of the
(values #f (car rest) (cdr rest)) ; form.
(values (car rest) (cadr rest) (cddr rest)))
;; Some analysis: what have we got?
;; Range clauses, else clauses, line num tests,...
(let* ((recnum-tests? ; Do any of the clauses test the record
(any? (lambda (clause) ; count? (I.e., any integer tests?)
(let ((test (car clause)))
(or (integer? test)
(and (range? clause)
(or (integer? (cadr clause))
(integer? (caddr clause)))))))
clauses))
;; If any ELSE clauses, bind this to the var in which we
;; will keep the else state, otherwise #f.
(else-var (and (any? (lambda (clause)
(c (car clause) %else))
clauses)
(r 'else)))
;; We compile all of the regexp patterns into regexp
;; data structures outside the AWK loop. So we need to
;; make a list of all the regexps that are used as tests.
(patterns (apply append
(map (lambda (clause)
(let ((test (car clause)))
(cond ((string? test) (list test))
((range? clause)
(let ((t1 (cadr clause))
(t2 (caddr clause)))
(append (if (string? t1)
(list t1)
'())
(if (string? t2)
(list t2)
'()))))
(else '()))))
clauses)))
;; Gratuitous optimisation: uniquify the patterns.
(patterns (let recur ((pats patterns))
(if (pair? pats)
(let ((pat (car pats))
(ans (recur (cdr pats))))
(if (member pat ans) ans (cons pat ans)))
'())))
;; An alist matching regexp patterns with the vars to which
;; we will bind their compiled regexp data structure.
(pats/vars (map (lambda (p) (cons p (r (gensym "re."))))
patterns))
;; A LET-list binding the regexp vars to their compiled regexps.
(regexp-inits (map (lambda (p/v)
`(,(cdr p/v) (,%make-regexp ,(car p/v))))
pats/vars))
;; Make a list of state vars for the range clauses.
;; For each range clause, we need a boolean var to track
;; whether or not the range is activated.
(range-vars (all-trues (lambda (clause)
(and (range? clause)
(r (gensym "r."))))
clauses))
(svars (map car state-inits)) ; The user's state variables.
;; If the user didn't declare a record-counter var,
;; but he is testing line numbers (with integer test forms),
;; go ahead and generate a record-counter of our own.
(rec-counter (or rec-counter
(and recnum-tests?
(r (gensym "record-count.")))))
;; Generate the loop vars & their inits.
;; These are: the record counter, the range vars,
;; and the user's state vars.
;; All of these different sets are optional.
(loop-vars (append (if rec-counter (list rec-counter) '())
range-vars
svars))
(loop-var-init-values (append (if rec-counter '(0) '())
(map (lambda (x) #f) range-vars)
(map cadr state-inits)))
;; A LET list initialising all the loop vars.
(loop-var-init (map list loop-vars loop-var-init-values))
;; Build the clause that computes the loop's return value.
;; If the user gave an AFTER clause, use its body. Otherwise,
;; it's (values ,@svars).
(after-clause? (lambda (clause) (c (car clause) %after)))
(after-exp (let ((after-clauses (filter after-clause? clauses)))
(cond ((null? after-clauses)
(mult-values svars r))
((null? (cdr after-clauses))
(blockify (cdar after-clauses) r c))
(else (error "Multiple AFTER clauses in awk body."
after-clauses exp)))))
(loop-body (awk-loop-body lp-var rec-var else-var
rec-counter range-vars svars
clauses pats/vars r c))
;; Variables that have to be updated per-iteration, as a LET list.
;; Note that we are careful not to increment the record counter
;; until after we've verified the new record isn't EOF.
(per-iteration-updates
(append (if else-var `((,else-var #t)) '()) ; Else state.
(if rec-counter ; Record count.
`((,rec-counter (,%+ ,rec-counter 1)))
'())))
(loop-body (if (pair? per-iteration-updates)
`(,%let ,per-iteration-updates
. ,(deblock loop-body r c))
loop-body)))
`(,%let ((,reader (,%lambda () ,reader-exp))
. ,regexp-inits)
(,%let ,lp-var ,loop-var-init
,(mv-let r c rec/field-vars `(,reader)
`(,%if (,%eof-object? ,rec-var) ,after-exp
,loop-body))))))))
;;; Expand into the body of the awk loop -- the code that tests & executes
;;; each clause, and then jumps to the top of the loop.
(define (awk-loop-body lp-var rec-var else-var rec-counter
range-vars svars clauses pats/vars r c)
(let ((clause-vars (if else-var (cons else-var svars) svars))
(loop-vars (append (if rec-counter (list rec-counter) '())
range-vars
svars))
(range-clause? (lambda (clause) (range-keyword? (car clause) r c)))
(%after (r 'after))
(%else (r 'else)))
(let expand ((clauses clauses) (range-vars range-vars))
(if (pair? clauses)
(let* ((clause (car clauses))
(test (car clause)))
(cond ((range-keyword? test r c)
(let ((tail (expand (cdr clauses) (cdr range-vars))))
(expand-range-clause clause tail (car range-vars)
rec-var else-var rec-counter svars
pats/vars
r c)))
((c test %after) ; An AFTER clause. Skip it.
(expand (cdr clauses) range-vars))
((c test %else) ; An ELSE clause.
(let ((tail (expand (cdr clauses) range-vars)))
(expand-else-clause clause tail else-var svars r c)))
(else ; A simple clause.
(let ((tail (expand (cdr clauses) range-vars)))
(expand-simple-clause clause tail
rec-var else-var rec-counter svars
pats/vars r c)))))
;; No clauses -- just jump to top of loop.
`(,lp-var . ,loop-vars)))))
;;; Make a Scheme expression out of a test form.
;;; Integer i => (= i <record-counter>)
;;; String s => (regexp-exec s <record>)
;;; Expression e => e
(define (->simple-clause-test test-form rec-var rec-counter pats/vars r)
(cond ((integer? test-form) `(,(r '=) ,rec-counter ,test-form))
((string? test-form)
(let ((re-var (cond ((assoc test-form pats/vars) => cdr)
(else (error "Impossible AWK error -- unknown regexp"
test-form pats/vars)))))
`(,(r 'regexp-exec) ,re-var ,rec-var)))
(else test-form)))
(define (expand-simple-clause clause tail
rec-var else-var rec-counter svars
pats/vars r c)
(let* ((%let (r 'let))
(%= (r '=))
(%string-match (r 'string-match))
(%arrow (r '=>))
(%if (r 'if))
(test (car clause))
(test (->simple-clause-test test rec-var rec-counter pats/vars r))
;; Is clause of the form (test => proc)
(arrow? (and (= 3 (length clause))
(c (cadr clause) %arrow)))
(null-clause-list (null-clause-action else-var svars r))
;; The core form conditionally executes the body.
;; It returns the new else var and the new state vars, if any.
(core (if arrow?
(let* ((tv (r 'tval)) ; APP is the actual
(app `(,(caddr clause) ,tv))) ; body: (proc tv).
`(,%let ((,tv ,test))
(,%if ,tv
,(clause-action (list app) else-var svars r c)
. ,null-clause-list)))
`(,%if ,test ,(clause-action (cdr clause) else-var svars r c)
. ,null-clause-list)))
(loop-vars (if else-var (cons else-var svars) svars)))
;; Do the core computation, update the iteration vars,
;; and then do the tail in the scope of the updated environment.
(core-then-tail loop-vars core tail r c)))
(define (core-then-tail loop-vars core tail r c)
(mv-let r c loop-vars core tail))
(define (expand-range-clause clause tail range-var
rec-var else-var rec-counter svars
pats/vars r c)
(let* ((start-test (cadr clause))
(stop-test (caddr clause))
(body (cdddr clause))
(%receive (r 'receive))
(%if (r 'if))
(%lambda (r 'lambda))
(keyword (car clause)) ; range or :range or range: or :range:
(tester (r (cond ((c keyword (r 'range)) 'next-range)
((c keyword (r ':range)) 'next-:range)
((c keyword (r 'range:)) 'next-range:)
((c keyword (r ':range:)) 'next-:range:)
(else (error "Unrecognised range keyword!" clause)))))
;; Convert the start and stop test forms to code.
(start-test (->simple-clause-test start-test rec-var
rec-counter pats/vars r))
(stop-test (->simple-clause-test stop-test rec-var
rec-counter pats/vars r))
(start-thunk `(,%lambda () ,start-test)) ; ...and thunkate them.
(stop-thunk `(,%lambda () ,stop-test))
(loop-vars (if else-var (cons else-var svars) svars))
(this-rec (r 'this-record?))
(core `(,%if ,this-rec
,(clause-action body else-var svars r c)
. ,(null-clause-action else-var svars r))))
`(,%receive (,this-rec ,range-var)
(,tester ,start-thunk ,stop-thunk ,range-var)
,(core-then-tail loop-vars core tail r c))))
(define (expand-else-clause clause tail else-var svars r c)
(let* ((body (cdr clause))
(tail-exps (deblock tail r c))
(%if (r 'if))
(%receive (r 'receive))
(%let (r 'let))
;; We are hard-wiring the else var to #t after this, so the core
;; expression doesn't need to return it -- just the new values
;; of the user's state vars.
(core `(,%if ,else-var
,(clause-action body #f svars r c)
. ,(sloppy-mult-values svars r))))
(mv-let r c svars core `(,%let ((,else-var #t)) . ,tail-exps))))
;;; BODY is a list of expressions from a loop clause. We want to evaluate it,
;;; under some conditions.
;;; - The body evaluates to multiple values, one for each state variable.
;;; However, if there are no state variables, we want to *ignore* the
;;; values produced by the body, and explicitly return 0 values,
;;; not blow up if the body should happen not to return exactly zero values.
;;; - If we are tracking an else-variable, then the body firing will turn
;;; it off by returning its new #f value.
(define (clause-action body else-var svars r c)
(let ((%values (r 'values))
(%receive (r 'receive)))
(blockify (if (pair? svars)
(if else-var
(if (pair? (cdr svars)) ; state vars and an else var.
`((,%receive ,svars ,(blockify body r c)
(,%values #f . ,svars)))
`((,%values #f ,(blockify body r c)))) ; Gratuitous.
body) ; State vars, but no else var.
;; No state vars -- ignore value computed by BODY forms.
`(,@body . ,(if else-var '(#f) `())))
r c)))
;;; The clause didn't execute. Return the svars unchanged, and also
;;; return the current else-value if we are tracking one. We return
;;; a 0 or 1 element expression list -- if no values are being expected
;;; this returns the empty list.
(define (null-clause-action else-var svars r)
(sloppy-mult-values (if else-var (cons else-var svars) svars)
r))
;;; These procs are for handling RANGE clauses.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; First return value tells whether this line is active;
;;; next value tells whether region is active after this line.
;;;
;;; (:range 0 4) = 0 1 2 3 This is the most useful one.
;;; (range: 0 4) = 1 2 3 4
;;; (range 0 4) = 1 2 3
;;; (:range: 0 4) = 0 1 2 3 4
;;; If these were inlined and the test thunks substituted, it would
;;; be acceptably efficient. But who writes Scheme compilers that good
;;; in the 90's?
(define (next-:range start-test stop-test state)
(let ((new-state (if state
(or (not (stop-test)) ; Stop,
(start-test)) ; but restart.
(and (start-test) ; Start,
(not (stop-test)))))) ; but stop, too.
(values new-state new-state)))
(define (next-range: start-test stop-test state)
(values state
(if state
(or (not (stop-test)) ; Stop,
(start-test)) ; but restart.
(and (start-test) ; Start,
(not (stop-test)))))) ; but stop, too.
(define (next-range start-test stop-test state)
(if state
(let ((not-stop (not (stop-test))))
(values not-stop
(or not-stop ; Stop,
(start-test)))) ; but restart.
(values #f
(and (start-test) ; Start,
(not (stop-test)))))) ; but stop, too.
(define (next-:range: start-test stop-test state)
(if state
(values #t
(or (not (stop-test)) ; Stop
(start-test))) ; but restart.
(let ((start? (start-test)))
(values start?
(and start? ; Start,
(not (stop-test))))))) ; but stop, too.
(define-syntax awk expand-awk)
guile-scsh/bitwise.scm 644 521 17 2531 6560306304 13674 0 ustar guile users ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; modified for Guile.
; Bitwise operators written in vanilla Scheme.
; Written for clarity and simplicity, not for speed.
; No need to use these in Scheme 48 since Scheme 48's virtual machine
; provides fast machine-level implementations.
;; use Guile primitives.
(define (bitwise-not a) (lognot a))
(define (bitwise-and a b) (logand a b))
(define (bitwise-ior a b) (logior a b))
(define (bitwise-xor a b) (logxor a b))
;;(define (bitwise-not i)
;; (- -1 i))
;;(define (bitwise-and x y)
;; (cond ((= x 0) 0)
;; ((= x -1) y)
;; (else
;; (+ (* (bitwise-and (arithmetic-shift x -1)
;; (arithmetic-shift y -1))
;; 2)
;; (* (modulo x 2) (modulo y 2))))))
;;(define (bitwise-ior x y)
;; (bitwise-not (bitwise-and (bitwise-not x)
;; (bitwise-not y))))
;;(define (bitwise-xor x y)
;; (bitwise-and (bitwise-not (bitwise-and x y))
;; (bitwise-ior x y)))
(define (bitwise-eqv x y)
(bitwise-not (bitwise-xor x y)))
(define (arithmetic-shift n m)
(inexact->exact (floor (* n (expt 2 m)))))
;;(define (count-bits x) ; Count 1's in the positive 2's comp rep
;; (let ((x (if (< x 0) (bitwise-not x) x)))
;; (do ((x x (arithmetic-shift x -1))
;; (result 0 (+ result (modulo x 2))))
;; ((= x 0) result))))
;(define (integer-length integer) ...) ;?
guile-scsh/char-set.scm 644 521 17 15243 6560306304 13760 0 ustar guile users ;;; -*-Scheme-*-
;;;
;;; Character Sets package
;;; ported from MIT Scheme runtime
;;; by Brian D. Carlstrom
;;; Sleazy code.
(define char:newline (ascii->char 13))
(define char:tab (ascii->char 9))
(define char:linefeed (ascii->char 13))
(define char:page (ascii->char 12))
(define char:return (ascii->char 10))
(define char:space (ascii->char 32))
(define (string-fill-range! str lower upper ch)
(do ((index lower (+ index 1)))
((>= index upper) str)
(string-set! str index ch)))
(define (char-ascii? char)
(let ((maybe-ascii (char->ascii char)))
(and (<= 0 maybe-ascii 127) maybe-ascii)))
;;;; Character Sets
(define (char-set? object)
(and (string? object)
(= (string-length object) 256)))
(define (char-set . chars)
(chars->char-set chars))
(define (chars->char-set chars)
(let ((char-set (make-string 256 (ascii->char 0))))
(for-each (lambda (char)
(string-set! char-set (char->ascii char) (ascii->char 1)))
chars)
char-set))
(define (string->char-set str)
(let ((char-set (make-string 256 (ascii->char 0))))
(do ((i (- (string-length str) 1) (- i 1)))
((< i 0) char-set)
(string-set! char-set (char->ascii (string-ref str i))
(ascii->char 1)))))
(define (ascii-range->char-set lower upper)
(let ((char-set (make-string 256 (ascii->char 0))))
(string-fill-range! char-set lower upper (ascii->char 1))
char-set))
(define (predicate->char-set predicate)
(let ((char-set (make-string 256)))
(let loop ((code 0))
(if (< code 256)
(begin (string-set! char-set code
(if (predicate (ascii->char code))
(ascii->char 1)
(ascii->char 0)))
(loop (+ 1 code)))))
char-set))
;;; {string, char, char-set, char predicate} -> char-set
(define (->char-set x)
(cond ((char-set? x) x)
((string? x) (string->char-set x))
((char? x) (char-set x))
((procedure? x) (predicate->char-set x))
(else (error "->char-set: Not a charset, string, char, or predicate."
x))))
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define (char-set-members char-set)
(define (loop code)
(cond ((>= code 256) '())
((zero? (char->ascii (string-ref char-set code))) (loop (+ 1 code)))
(else (cons (ascii->char code) (loop (+ 1 code))))))
(loop 0))
;;; De-releasing CHAR-SET-MEMBER?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; No other way to do it. MIT Scheme defines it (c-s-m? cset char); scsh 0.3
;;; defined it (c-s-m? char cset). MIT Scheme's arg order is not consistent
;;; with the MEMBER? procedure or common math notation, but they were here
;;; first, so I didn't want to just silently invert their arg order -- could
;;; break code. I ended up just choosing a new proc name that consistent with
;;; its arg order -- (CHAR-SET-CONTAINS? cset char).
(define (char-set-contains? char-set char)
(not (zero? (char->ascii (string-ref char-set (char->ascii char))))))
;;; This actually isn't exported. Just CYA.
(define (char-set-member? . args)
(error "CHAR-SET-MEMBER? is no longer provided. Use CHAR-SET-CONTAINS? instead."))
(define (char-set-invert char-set)
(predicate->char-set
(lambda (char) (not (char-set-contains? char-set char)))))
(define (char-set-union char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(or (char-set-contains? char-set-1 char)
(char-set-contains? char-set-2 char)))))
(define (char-set-intersection char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(and (char-set-contains? char-set-1 char)
(char-set-contains? char-set-2 char)))))
(define (char-set-difference char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(and (char-set-contains? char-set-1 char)
(not (char-set-contains? char-set-2 char))))))
;;;; System Character Sets
(define char-set:upper-case (ascii-range->char-set #x41 #x5B))
(define char-set:lower-case (ascii-range->char-set #x61 #x7B))
(define char-set:numeric (ascii-range->char-set #x30 #x3A))
(define char-set:graphic (ascii-range->char-set #x20 #x7F))
(define char-set:not-graphic (char-set-invert char-set:graphic))
(define char-set:whitespace
(char-set char:newline char:tab char:linefeed
char:page char:return char:space))
(define char-set:not-whitespace (char-set-invert char-set:whitespace))
(define char-set:alphabetic
(char-set-union char-set:upper-case char-set:lower-case))
(define char-set:alphanumeric
(char-set-union char-set:alphabetic char-set:numeric))
(define char-set:standard
(char-set-union char-set:graphic (char-set char:newline)))
(define (char-upper-case? char)
(char-set-contains? char-set:upper-case char))
(define (char-lower-case? char)
(char-set-contains? char-set:lower-case char))
(define (char-numeric? char)
(char-set-contains? char-set:numeric char))
(define (char-graphic? char)
(char-set-contains? char-set:graphic char))
(define (char-whitespace? char)
(char-set-contains? char-set:whitespace char))
(define (char-alphabetic? char)
(char-set-contains? char-set:alphabetic char))
(define (char-alphanumeric? char)
(char-set-contains? char-set:alphanumeric char))
(define (char-standard? char)
(char-set-contains? char-set:standard char))
;;; Bullshit legalese
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;$Header: /egcs/carton/cvsfiles/guile/guile-scsh/char-set.scm,v 1.1 1997/01/25 18:26:38 ghouston Exp $
;Copyright (c) 1988 Massachusetts Institute of Technology
;This material was developed by the Scheme project at the Massachusetts
;Institute of Technology, Department of Electrical Engineering and
;Computer Science. Permission to copy this software, to redistribute
;it, and to use it for any purpose is granted, subject to the following
;restrictions and understandings.
;1. Any copy made of this software must include this copyright notice
;in full.
;2. Users of this software agree to make their best efforts (a) to
;return to the MIT Scheme project any improvements or extensions that
;they make, so that these may be included in future releases; and (b)
;to inform MIT of noteworthy uses of this software.
;3. All materials developed as a consequence of the use of this
;software shall duly acknowledge such use, in accordance with the usual
;standards of acknowledging credit in academic research.
;4. MIT has made no warrantee or representation that the operation of
;this software will be error-free, and MIT is under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;5. In conjunction with products arising from the use of this material,
;there shall be no use of the name of the Massachusetts Institute of
;Technology nor of any adaptation thereof in any advertising,
;promotional, or sales literature without prior written consent from
;MIT in each case.
guile-scsh/condition.scm 644 521 17 3454 6560306304 14221 0 ustar guile users ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file condition.scm.
;;;; Condition hierarchy
; General design copied from gnu emacs.
(define *condition-types* '())
(define (condition-supertypes type)
(assq type *condition-types*))
(define (define-condition-type type supertypes)
(set! *condition-types*
(cons (cons type (apply append
(map (lambda (sup)
(or (condition-supertypes sup)
(error "unrecognized condition type"
sup)))
supertypes)))
*condition-types*)))
(define (condition-predicate name)
(lambda (c)
(and (pair? c)
(let ((probe (condition-supertypes (car c))))
(if probe
(if (memq name probe) #t #f)
#f)))))
(define (condition? x)
(and (pair? x)
(list? x)
(condition-supertypes (car x))))
(define condition-type car)
(define condition-stuff cdr)
; Errors
(define-condition-type 'error '())
(define error? (condition-predicate 'error))
(define-condition-type 'call-error '(error))
(define call-error? (condition-predicate 'call-error))
(define-condition-type 'read-error '(error))
(define read-error? (condition-predicate 'read-error))
; Exceptions
(define-condition-type 'exception '(error))
(define exception? (condition-predicate 'exception))
(define exception-opcode cadr)
(define exception-arguments cddr)
(define (make-exception opcode args)
(make-condition 'exception (cons opcode args)))
; Warnings
(define-condition-type 'warning '())
(define warning? (condition-predicate 'warning))
(define-condition-type 'syntax-error '(warning))
(define syntax-error? (condition-predicate 'syntax-error))
; Interrupts
(define-condition-type 'interrupt '())
(define interrupt? (condition-predicate 'interrupt))
guile-scsh/configure 755 521 17 106155 6560306305 13501 0 ustar guile users #! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated automatically using autoconf version 2.12
# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
# Defaults:
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
ac_help="$ac_help
--enable-maintainer-mode enable make rules and dependencies not useful
(and sometimes confusing) to the casual installer"
# Initialize some variables set by options.
# The variables have the same names as the options, with
# 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=
# Maximum number of lines to put in a shell here document.
ac_max_here_lines=12
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.12"
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 these to C if already set. These must not be set unconditionally
# because not all systems understand e.g. LANG=C (notably SCO).
# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
# Non-C LC_CTYPE values break the ctype check.
if test "${LANG+set}" = set; then LANG=C; export LANG; fi
if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -rf conftest* confdefs.h
# 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=network.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'
cross_compiling=$ac_cv_prog_cc_cross
if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
# Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
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
ac_aux_dir=
for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
if test -f $ac_dir/install-sh; then
ac_aux_dir=$ac_dir
ac_install_sh="$ac_aux_dir/install-sh -c"
break
elif test -f $ac_dir/install.sh; then
ac_aux_dir=$ac_dir
ac_install_sh="$ac_aux_dir/install.sh -c"
break
fi
done
if test -z "$ac_aux_dir"; then
{ echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
fi
ac_config_guess=$ac_aux_dir/config.guess
ac_config_sub=$ac_aux_dir/config.sub
ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
# Find a good install program. We prefer a C program (faster),
# so one script is as good as another. But avoid the broken or
# incompatible versions:
# SysV /etc/install, /usr/sbin/install
# SunOS /usr/etc/install
# IRIX /sbin/install
# AIX /bin/install
# AFS /usr/afsws/bin/install, which mishandles nonexistent args
# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
# ./install, which can be erroneously created by make from ./install.sh.
echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
echo "configure:555: checking for a BSD compatible install" >&5
if test -z "$INSTALL"; then
if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:"
for ac_dir in $PATH; do
# Account for people who put trailing slashes in PATH elements.
case "$ac_dir/" in
/|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
*)
# OSF1 and SCO ODT 3.0 have their own names for install.
for ac_prog in ginstall installbsd scoinst install; do
if test -f $ac_dir/$ac_prog; then
if test $ac_prog = install &&
grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
# AIX install. It has an incompatible calling convention.
# OSF/1 installbsd also uses dspmsg, but is usable.
:
else
ac_cv_path_install="$ac_dir/$ac_prog -c"
break 2
fi
fi
done
;;
esac
done
IFS="$ac_save_IFS"
fi
if test "${ac_cv_path_install+set}" = set; then
INSTALL="$ac_cv_path_install"
else
# As a last resort, use the slow shell script. We don't cache a
# path for INSTALL within a source directory, because that will
# break other packages using the cache if that directory is
# removed, or if the path is relative.
INSTALL="$ac_install_sh"
fi
fi
echo "$ac_t""$INSTALL" 1>&6
# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
# It thinks the first close brace ends the variable substitution.
test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
PACKAGE=guile-scsh
VERSION=1.2a
if test "`cd $srcdir && pwd`" != "`pwd`" && test -f $srcdir/config.status; then
{ echo "configure: error: source directory already configured; run "make distclean" there first" 1>&2; exit 1; }
fi
echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6
echo "configure:617: checking whether build environment is sane" >&5
# Just in case
sleep 1
echo timestamp > conftestfile
# Do `set' in a subshell so we don't clobber the current shell's
# arguments. Must try -L first in case configure is actually a
# symlink; some systems play weird games with the mod time of symlinks
# (eg FreeBSD returns the mod time of the symlink's containing
# directory).
if (
set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
if test "" = "X"; then
# -L didn't work.
set X `ls -t $srcdir/configure conftestfile`
fi
test "$2" = conftestfile
)
then
# Ok.
:
else
{ echo "configure: error: newly created file is older than distributed files!
Check your system clock" 1>&2; exit 1; }
fi
rm -f conftest*
echo "$ac_t""yes" 1>&6
if test "$program_transform_name" = s,x,x,; then
program_transform_name=
else
# Double any \ or $. echo might interpret backslashes.
cat <<\EOF_SED > conftestsed
s,\\,\\\\,g; s,\$,$$,g
EOF_SED
program_transform_name="`echo $program_transform_name|sed -f conftestsed`"
rm -f conftestsed
fi
test "$program_prefix" != NONE &&
program_transform_name="s,^,${program_prefix},; $program_transform_name"
# Use a double $ so make ignores it.
test "$program_suffix" != NONE &&
program_transform_name="s,\$\$,${program_suffix},; $program_transform_name"
# sed with no file args requires a program.
test "$program_transform_name" = "" && program_transform_name="s,x,x,"
missing_dir=`cd $ac_aux_dir && pwd`
echo $ac_n "checking for working aclocal""... $ac_c" 1>&6
echo "configure:664: checking for working aclocal" >&5
# Run test in a subshell; some versions of sh will print an error if
# an executable is not found, even if stderr is redirected.
# Redirect stdin to placate older versions of autoconf. Sigh.
if (aclocal --version) < /dev/null > /dev/null 2>&1; then
ACLOCAL=aclocal
echo "$ac_t""found" 1>&6
else
ACLOCAL="$missing_dir/missing aclocal"
echo "$ac_t""missing" 1>&6
fi
echo $ac_n "checking for working autoconf""... $ac_c" 1>&6
echo "configure:677: checking for working autoconf" >&5
# Run test in a subshell; some versions of sh will print an error if
# an executable is not found, even if stderr is redirected.
# Redirect stdin to placate older versions of autoconf. Sigh.
if (autoconf --version) < /dev/null > /dev/null 2>&1; then
AUTOCONF=autoconf
echo "$ac_t""found" 1>&6
else
AUTOCONF="$missing_dir/missing autoconf"
echo "$ac_t""missing" 1>&6
fi
echo $ac_n "checking for working automake""... $ac_c" 1>&6
echo "configure:690: checking for working automake" >&5
# Run test in a subshell; some versions of sh will print an error if
# an executable is not found, even if stderr is redirected.
# Redirect stdin to placate older versions of autoconf. Sigh.
if (automake --version) < /dev/null > /dev/null 2>&1; then
AUTOMAKE=automake
echo "$ac_t""found" 1>&6
else
AUTOMAKE="$missing_dir/missing automake"
echo "$ac_t""missing" 1>&6
fi
echo $ac_n "checking for working autoheader""... $ac_c" 1>&6
echo "configure:703: checking for working autoheader" >&5
# Run test in a subshell; some versions of sh will print an error if
# an executable is not found, even if stderr is redirected.
# Redirect stdin to placate older versions of autoconf. Sigh.
if (autoheader --version) < /dev/null > /dev/null 2>&1; then
AUTOHEADER=autoheader
echo "$ac_t""found" 1>&6
else
AUTOHEADER="$missing_dir/missing autoheader"
echo "$ac_t""missing" 1>&6
fi
echo $ac_n "checking for working makeinfo""... $ac_c" 1>&6
echo "configure:716: checking for working makeinfo" >&5
# Run test in a subshell; some versions of sh will print an error if
# an executable is not found, even if stderr is redirected.
# Redirect stdin to placate older versions of autoconf. Sigh.
if (makeinfo --version) < /dev/null > /dev/null 2>&1; then
MAKEINFO=makeinfo
echo "$ac_t""found" 1>&6
else
MAKEINFO="$missing_dir/missing makeinfo"
echo "$ac_t""missing" 1>&6
fi
echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
echo "configure:729: checking whether ${MAKE-make} sets \${MAKE}" >&5
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftestmake <<\EOF
all:
@echo 'ac_maketemp="${MAKE}"'
EOF
# GNU make sometimes prints "make[1]: Entering...", which would confuse us.
eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=`
if test -n "$ac_maketemp"; then
eval ac_cv_prog_make_${ac_make}_set=yes
else
eval ac_cv_prog_make_${ac_make}_set=no
fi
rm -f conftestmake
fi
if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then
echo "$ac_t""yes" 1>&6
SET_MAKE=
else
echo "$ac_t""no" 1>&6
SET_MAKE="MAKE=${MAKE-make}"
fi
echo $ac_n "checking whether to enable maintainer-specific portions of Makefiles""... $ac_c" 1>&6
echo "configure:756: checking whether to enable maintainer-specific portions of Makefiles" >&5
# Check whether --enable-maintainer-mode or --disable-maintainer-mode was given.
if test "${enable_maintainer_mode+set}" = set; then
enableval="$enable_maintainer_mode"
USE_MAINTAINER_MODE=$enableval
else
USE_MAINTAINER_MODE=no
fi
echo "$ac_t""$USE_MAINTAINER_MODE" 1>&6
if test $USE_MAINTAINER_MODE = yes; then
MAINT=
else
MAINT='#M#'
fi
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
# The following way of writing the cache mishandles newlines in values,
# but we know of no workaround that is simple, portable, and efficient.
# So, don't put newlines in cache variables' values.
# Ultrix sh set writes to stderr and can't be redirected directly,
# and sets the high bit in the cache file unless we assign to the vars.
(set) 2>&1 |
case `(ac_space=' '; set) 2>&1` in
*ac_space=\ *)
# `set' does not quote correctly, so add quotes (double-quote substitution
# turns \\\\ into \\, and sed turns \\ into \).
sed -n \
-e "s/'/'\\\\''/g" \
-e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
;;
*)
# `set' quotes correctly as required by POSIX, so do not add quotes.
sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
;;
esac >> confcache
if cmp -s $cache_file confcache; then
:
else
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.12"
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
ac_given_INSTALL="$INSTALL"
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%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
s%@INSTALL_DATA@%$INSTALL_DATA%g
s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g
s%@PACKAGE@%$PACKAGE%g
s%@VERSION@%$VERSION%g
s%@ACLOCAL@%$ACLOCAL%g
s%@AUTOCONF@%$AUTOCONF%g
s%@AUTOMAKE@%$AUTOMAKE%g
s%@AUTOHEADER@%$AUTOHEADER%g
s%@MAKEINFO@%$MAKEINFO%g
s%@SET_MAKE@%$SET_MAKE%g
s%@MAINT@%$MAINT%g
CEOF
EOF
cat >> $CONFIG_STATUS <<\EOF
# Split the substitutions into bite-sized pieces for seds with
# small command number limits, like on Digital OSF/1 and HP-UX.
ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
ac_file=1 # Number of current file.
ac_beg=1 # First line for current file.
ac_end=$ac_max_sed_cmds # Line after last line for current file.
ac_more_lines=:
ac_sed_cmds=""
while $ac_more_lines; do
if test $ac_beg -gt 1; then
sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
else
sed "${ac_end}q" conftest.subs > conftest.s$ac_file
fi
if test ! -s conftest.s$ac_file; then
ac_more_lines=false
rm -f conftest.s$ac_file
else
if test -z "$ac_sed_cmds"; then
ac_sed_cmds="sed -f conftest.s$ac_file"
else
ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
fi
ac_file=`expr $ac_file + 1`
ac_beg=$ac_end
ac_end=`expr $ac_end + $ac_max_sed_cmds`
fi
done
if test -z "$ac_sed_cmds"; then
ac_sed_cmds=cat
fi
EOF
cat >> $CONFIG_STATUS <<EOF
CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
EOF
cat >> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
# Support "outfile[:infile[: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 a relative srcdir, top_srcdir, and INSTALL for subdirectories.
# Remove last slash and all that follows it. Not all systems have dirname.
ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
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
case "$ac_given_INSTALL" in
[/$]*) INSTALL="$ac_given_INSTALL" ;;
*) INSTALL="$ac_dots$ac_given_INSTALL" ;;
esac
echo creating "$ac_file"
rm -f "$ac_file"
configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
case "$ac_file" in
*Makefile*) ac_comsub="1i\\
# $configure_input" ;;
*) ac_comsub= ;;
esac
ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
sed -e "$ac_comsub
s%@configure_input@%$configure_input%g
s%@srcdir@%$srcdir%g
s%@top_srcdir@%$top_srcdir%g
s%@INSTALL@%$INSTALL%g
" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
fi; done
rm -f conftest.s*
EOF
cat >> $CONFIG_STATUS <<EOF
EOF
cat >> $CONFIG_STATUS <<\EOF
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
guile-scsh/configure.in 644 521 17 253 6560306305 14013 0 ustar guile users # Process this file with autoconf to produce a configure script.
AC_INIT(network.scm)
AM_INIT_AUTOMAKE(guile-scsh, 1.2a, no-define)
AM_MAINTAINER_MODE
AC_OUTPUT(Makefile)
guile-scsh/defrec.scm 644 521 17 12644 6560306305 13505 0 ustar guile users ;;; Copyright (c) 1993 by Olin Shivers.
;;; Syntax for defining record types.
;;; This implementation works with the Scheme48 system --
;;; or any Scheme that uses Clinger's "explicit renaming"
;;; macro system.
;;;
;;; (define-record name . field&method-specs)
;;;
;;; A field-spec is one of the following:
;;; field ; Initialised field
;;; (field [default]) ; Defaulted field.
;;; An initialised field has its initial value passed as an argument to
;;; the the record maker procedure. A defaulted field takes its value from
;;; the the DEFAULT expression. If a DEFAULT expression is not given, then
;;; the defaulted field's initial value is undefined.
;;;
;;; Example:
;;; (define-record employee
;;; name
;;; id
;;; (salary 10000)
;;; (department) ; Initial value undefined.
;;; sex
;;; married?)
;;;
;;; Defines the following:
;;; - A maker procedure:
;;; (make-employee "John Smith" 742931 'male #f)
;;; MAKE-EMPLOYEE takes one argument for each initialised field.
;;;
;;; - Accessor procedures:
;;; (employee:name emp)
;;; (employee:id emp)
;;; (employee:salary emp)
;;; (employee:department emp)
;;; (employee:sex emp)
;;; (employee:married? emp)
;;;
;;; - Setter procedures:
;;; (set-employee:name emp "Janet Q. Random")
;;; (set-employee:id emp 8271)
;;; (set-employee:salary emp 20000)
;;; (set-employee:department emp "Vaporware")
;;; (set-employee:sex emp 'female)
;;; (set-employee:married? emp #t)
;;;
;;; - A type predicate:
;;; (employee? x)
;;;
;;; - The record type descriptor:
;;; type/employee
;;; Method specs are of the form
;;; ((method self var ...) body ...)
;;; The only supported method is DISCLOSE, which is used by the S48
;;; structure printer. E.g.,
;;; (define-record ship
;;; x
;;; y
;;; name
;;; ((disclose self) (list "ship" (ship:name self))))
;;; will cause (make-ship 10 20 "Valdez") to print as
;;; #{ship "Valdez"}
(define-syntax define-record
(lambda (form rename compare)
(receive (field-specs method-specs)
;; Partition the field and method specs by form.
(let lp ((specs (reverse (cddr form)))
(fspecs '())
(mspecs '()))
(if (pair? specs)
(let ((spec (car specs))
(specs (cdr specs)))
(if (and (pair? spec) (pair? (car spec)))
;; We only support the DISCLOSE method in S48.
(if (eq? (caar spec) 'disclose)
(lp specs fspecs (cons spec mspecs))
(error "Unsupported method in define-record." spec))
(lp specs (cons spec fspecs) mspecs)))
(values fspecs mspecs)))
(let* ((name (cadr form))
(s->s symbol->string)
(s-conc (lambda args (string->symbol (apply string-append args))))
(spec-name (lambda (s) (if (pair? s) (car s) s)))
(filter (lambda (pred lst)
(let f ((lst lst))
(if (pair? lst)
(let ((tail (f (cdr lst))))
(if (pred (car lst)) (cons (car lst) tail) tail))
'()))))
(gensym (let ((j 0))
(lambda (s) (set! j (+ j 1))
(s-conc s (number->string j)))))
(field-name (lambda (field-name)
(s-conc (s->s name) ":" (s->s field-name))))
(set-name (lambda (field-name)
(s-conc "set-" (s->s name) ":" (s->s field-name))))
(pred-name (s-conc (s->s name) "?"))
(maker-name (s-conc "make-" (s->s name)))
(type-name (s-conc "type/" (s->s name)))
(fields (map spec-name field-specs))
(param-fields (filter symbol? field-specs)) ; Args to maker proc.
(default-field-specs (filter (lambda (fs) (and (pair? fs)
(pair? (cdr fs))))
field-specs))
(default-exps (map cadr default-field-specs))
(param-vars (map (lambda (fs) (rename (gensym "field")))
param-fields))
(maker (rename 'maker))
(%make-record-type (rename 'make-record-type))
(%record-constructor (rename 'record-constructor))
(%record-predicate (rename 'record-predicate))
(%record-accessor (rename 'record-accessor))
(%record-modifier (rename 'record-modifier))
(%def-rec-discloser (rename 'define-record-discloser))
(%unspecified (rename 'unspecified))
(%define (rename 'define))
(%let (rename 'let))
(%lambda (rename 'lambda))
(%begin (rename 'begin)))
`(,%begin
(,%define ,type-name
(,%make-record-type ,(s->s name) ',fields))
;; Maker proc (MAKE-EMPLOYEE name id-number sex married?)
(,%define ,maker-name
,(if (null? default-field-specs)
;; Gratuitous optimisation:
`(,%record-constructor ,type-name ',param-fields)
;; Full-blown form.
`(,%let ((,maker (,%record-constructor
,type-name
',(append param-fields
(map spec-name
default-field-specs)))))
(,%lambda ,param-vars
(,maker ,@param-vars ,@default-exps)))))
;; Type predicate (EMPLOYEE? x)
(,%define ,pred-name (,%record-predicate ,type-name))
;; Accessors (EMPLOYEE:NAME emp), ...
,@(map (lambda (spec)
`(,%define ,(field-name (spec-name spec))
(,%record-accessor ,type-name ',(spec-name spec))))
field-specs)
;; Setters (SET-EMPLOYEE:NAME emp name), ...
,@(map (lambda (spec)
`(,%define ,(set-name (spec-name spec))
(,%record-modifier ,type-name ',(spec-name spec))))
field-specs)
;; Methods (we only handle DISCLOSE methods).
,@(map (lambda (m)
`(,%def-rec-discloser ,type-name
(,%lambda ,(cdar m) . ,(cdr m))))
method-specs)
)))))
guile-scsh/ekko.scm 644 521 17 274 6560306305 13142 0 ustar guile users #!/usr/local/bin/guile -s
!#
(define (main args)
(for-each (lambda (f) (display f) (write-char #\ ))
args)
(newline))
(define (ekko)
(main command-line-arguments)
)
(ekko)
guile-scsh/enumconst.scm 644 521 17 2240 6560306305 14237 0 ustar guile users ;;; Copyright (c) 1994 by Olin Shivers.
;;; Handy for defining random flags and constants.
;;; (define-enum-constant "errno" intr 9) => (define errno/intr 9)
;;; This is deeply bogus code. It merely serves to demonstrate what a loser
;;; I am when it comes to serious modern-tech macrology.
;;; The question: is / the best separator? Alternates: $ . |
;;; (define-enum-constant fruit apple 1) =>
;;; (define fruit/apple 1)
(define-syntax define-enum-constant
(lambda (form rename compare)
(let* ((%define (rename 'define))
(base (let ((b (cadr form)))
(cond ((string? b) b)
((symbol? b) (symbol->string b))
(else (error "Enum constant base must be symbol or string"
b )))))
(var (string->symbol (string-append base "/"
(symbol->string (caddr form)))))
(value (cadddr form)))
`(,%define ,var ,value))))
;;; (define-enum-constants fruit (apple 1) (orange 2))
;;; => (begin (define-enum-constant fruit apple 1)
;;; (define-enum-constant fruit orange 2))
(define-syntax define-enum-constants
(syntax-rules ()
((define-enum-constants set (elt val) ...)
(begin (define-enum-constant set elt val) ...))))
guile-scsh/errno.scm 644 521 17 7146 6560306305 13363 0 ustar guile users ;;; define errno/perm for EPERM etc.
(defmacro maybe-define-eno (value)
(let ((scsh-name (string->symbol
(string-append "errno/"
(string-downcase!
(let ((str (symbol->string value)))
(substring str 1
(string-length str))))))))
`(if (defined? ',value)
(define ,scsh-name ,value))))
(maybe-define-eno E2BIG)
(maybe-define-eno EACCES)
(maybe-define-eno EADDRINUSE)
(maybe-define-eno EADDRNOTAVAIL)
(maybe-define-eno EADV)
(maybe-define-eno EAFNOSUPPORT)
(maybe-define-eno EAGAIN)
(maybe-define-eno EALREADY)
(maybe-define-eno EBADE)
(maybe-define-eno EBADF)
(maybe-define-eno EBADFD)
(maybe-define-eno EBADMSG)
(maybe-define-eno EBADR)
(maybe-define-eno EBADRQC)
(maybe-define-eno EBADSLT)
(maybe-define-eno EBFONT)
(maybe-define-eno EBUSY)
(maybe-define-eno ECHILD)
(maybe-define-eno ECHRNG)
(maybe-define-eno ECOMM)
(maybe-define-eno ECONNABORTED)
(maybe-define-eno ECONNREFUSED)
(maybe-define-eno ECONNRESET)
(maybe-define-eno EDEADLK)
(maybe-define-eno EDEADLOCK)
(maybe-define-eno EDESTADDRREQ)
(maybe-define-eno EDOM)
(maybe-define-eno EDOTDOT)
(maybe-define-eno EDQUOT)
(maybe-define-eno EEXIST)
(maybe-define-eno EFAULT)
(maybe-define-eno EFBIG)
(maybe-define-eno EHOSTDOWN)
(maybe-define-eno EHOSTUNREACH)
(maybe-define-eno EIDRM)
(maybe-define-eno EILSEQ)
(maybe-define-eno EINPROGRESS)
(maybe-define-eno EINTR)
(maybe-define-eno EINVAL)
(maybe-define-eno EIO)
(maybe-define-eno EISCONN)
(maybe-define-eno EISDIR)
(maybe-define-eno EISNAM)
(maybe-define-eno EL2HLT)
(maybe-define-eno EL2NSYNC)
(maybe-define-eno EL3HLT)
(maybe-define-eno EL3RST)
(maybe-define-eno ELIBACC)
(maybe-define-eno ELIBBAD)
(maybe-define-eno ELIBEXEC)
(maybe-define-eno ELIBMAX)
(maybe-define-eno ELIBSCN)
(maybe-define-eno ELNRNG)
(maybe-define-eno ELOOP)
(maybe-define-eno EMFILE)
(maybe-define-eno EMLINK)
(maybe-define-eno EMSGSIZE)
(maybe-define-eno EMULTIHOP)
(maybe-define-eno ENAMETOOLONG)
(maybe-define-eno ENAVAIL)
(maybe-define-eno ENETDOWN)
(maybe-define-eno ENETRESET)
(maybe-define-eno ENETUNREACH)
(maybe-define-eno ENFILE)
(maybe-define-eno ENOANO)
(maybe-define-eno ENOBUFS)
(maybe-define-eno ENOCSI)
(maybe-define-eno ENODATA)
(maybe-define-eno ENODEV)
(maybe-define-eno ENOENT)
(maybe-define-eno ENOEXEC)
(maybe-define-eno ENOLCK)
(maybe-define-eno ENOLINK)
(maybe-define-eno ENOMEM)
(maybe-define-eno ENOMSG)
(maybe-define-eno ENONET)
(maybe-define-eno ENOPKG)
(maybe-define-eno ENOPROTOOPT)
(maybe-define-eno ENOSPC)
(maybe-define-eno ENOSR)
(maybe-define-eno ENOSTR)
(maybe-define-eno ENOSYS)
(maybe-define-eno ENOTBLK)
(maybe-define-eno ENOTCONN)
(maybe-define-eno ENOTDIR)
(maybe-define-eno ENOTEMPTY)
(maybe-define-eno ENOTNAM)
(maybe-define-eno ENOTSOCK)
(maybe-define-eno ENOTTY)
(maybe-define-eno ENOTUNIQ)
(maybe-define-eno ENXIO)
(maybe-define-eno EOPNOTSUPP)
(maybe-define-eno EOVERFLOW)
(maybe-define-eno EPERM)
(maybe-define-eno EPFNOSUPPORT)
(maybe-define-eno EPIPE)
(maybe-define-eno EPROTO)
(maybe-define-eno EPROTONOSUPPORT)
(maybe-define-eno EPROTOTYPE)
(maybe-define-eno ERANGE)
(maybe-define-eno EREMCHG)
(maybe-define-eno EREMOTE)
(maybe-define-eno EREMOTEIO)
(maybe-define-eno ERESTART)
(maybe-define-eno EROFS)
(maybe-define-eno ESHUTDOWN)
(maybe-define-eno ESOCKTNOSUPPORT)
(maybe-define-eno ESPIPE)
(maybe-define-eno ESRCH)
(maybe-define-eno ESRMNT)
(maybe-define-eno ESTALE)
(maybe-define-eno ESTRPIPE)
(maybe-define-eno ETIME)
(maybe-define-eno ETIMEDOUT)
(maybe-define-eno ETOOMANYREFS)
(maybe-define-eno ETXTBSY)
(maybe-define-eno EUCLEAN)
(maybe-define-eno EUNATCH)
(maybe-define-eno EUSERS)
(maybe-define-eno EWOULDBLOCK)
(maybe-define-eno EXDEV)
(maybe-define-eno EXFULL)
(undefine maybe-define-eno)
guile-scsh/fileinfo.scm 644 521 17 10440 6560306305 14040 0 ustar guile users ;;; Copyright (c) 1993, 1994 by Olin Shivers.
;;; needs to be modified for Guile.
;;; chase? true (the default) means if the file is a symlink, chase the link
;;; and report on the file it references. chase? = #f means check the actual
;;; file itself, even if it's a symlink.
;;; writeable means (1) file exists & is writeable OR (2) file doesn't exist
;;; but directory is writeable.
;;; Return values:
;;; #f Accessible
;;; search-denied Can't stat
;;; permission File exists but is protected
;;; (also for errno/rofs)
;;; no-directory Some directory doesn't exist
;;; nonexistent File itself doesn't exist
;;;
;;; Otherwise, signals an error.
(define (file-not-accessible? perms fd/port/fname . maybe-chase?)
(let ((uid (user-effective-uid)))
(and (not (zero? uid)) ; Root can do what he likes.
(with-errno-handler ((err data)
((errno/acces) 'search-denied)
((errno/noent) 'nonexistent)
((errno/notdir) 'not-directory))
(and (let* ((info (apply file-info fd/port/fname maybe-chase?))
(acc (file-info:mode info)))
(cond ((= (file-info:uid info) (user-effective-uid)) ; User
(zero? (bitwise-and acc (arithmetic-shift perms 6))))
((= (file-info:gid info) (user-effective-gid)) ; Group
(zero? (bitwise-and acc (arithmetic-shift perms 3))))
((memv (file-info:gid info) (user-supplementary-gids))
(zero? (bitwise-and acc (arithmetic-shift perms 3))))
(else ; Other
(zero? (bitwise-and acc perms)))))
'permission)))))
;;;;;;
(define (file-not-readable? fd/port/fname) (file-not-accessible? 4 fd/port/fname))
(define (file-not-writable? fd/port/fname) (file-not-accessible? 2 fd/port/fname))
(define (file-not-executable? fd/port/fname) (file-not-accessible? 1 fd/port/fname))
(define (file-readable? fd/port/fname) (not (file-not-readable? fd/port/fname)))
(define (file-writable? fd/port/fname) (not (file-not-writable? fd/port/fname)))
(define (file-executable? fd/port/fname) (not (file-not-executable? fd/port/fname)))
;;; Spelling corrected.
(define file-not-writeable?
(deprecated-proc file-not-writable? "file-not-writeable?"
"Use file-not-writable? instead"))
(define file-writeable?
(deprecated-proc file-writable? "file-writeable?"
"Use file-writable? instead"))
;;;;;;
;;; Returns
;;; #f exists
;;; #t doesn't exist
;;; 'search-denied can't stat
;;; ...or signals an error
(define (file-not-exists? fd/port/fname . maybe-chase?)
(with-errno-handler
((err data)
((errno/acces) 'search-denied)
((errno/noent errno/notdir) #t))
(apply file-info fd/port/fname maybe-chase?)
#f))
(define (file-exists? fd/port/fname . maybe-chase?)
(not (apply file-not-exists? fd/port/fname maybe-chase?)))
;;;;;;
;;; stat and derived file-{mode,size,owner,group,times,inode,...} ops.
(define-simple-syntax (define-stat-proc proc info-slot)
(define (proc fname/fd/port . maybe-chase?)
(info-slot (apply file-info fname/fd/port maybe-chase?))))
(define-stat-proc file-type file-info:type)
(define-stat-proc file-group file-info:gid)
(define-stat-proc file-inode file-info:inode)
(define-stat-proc file-last-access file-info:atime)
(define-stat-proc file-last-mod file-info:mtime)
(define-stat-proc file-last-status-change file-info:ctime)
(define-stat-proc file-mode file-info:mode)
(define-stat-proc file-nlinks file-info:nlinks)
(define-stat-proc file-owner file-info:uid)
(define-stat-proc file-size file-info:size)
(define (file-directory? fname/fd/port . maybe-chase?)
(eq? 'directory (apply file-type fname/fd/port maybe-chase?)))
(define (file-fifo? fname/fd/port . maybe-chase?)
(eq? 'fifo (apply file-type fname/fd/port maybe-chase?)))
(define (file-regular? fname/fd/port . maybe-chase?)
(eq? 'regular (apply file-type fname/fd/port maybe-chase?)))
(define (file-socket? fname/fd/port . maybe-chase?)
(eq? 'socket (apply file-type fname/fd/port maybe-chase?)))
(define (file-special? fname/fd/port . maybe-chase?)
(let ((type (apply file-type fname/fd/port maybe-chase?)))
(or (eq? 'block-special type) (eq? 'char-special type))))
(define (file-symlink? fname/fd/port) ; No MAYBE-CHASE?, of course.
(eq? 'symlink (file-type fname/fd/port #f)))
guile-scsh/filemtch.scm 644 521 17 7375 6560306305 14035 0 ustar guile users ;;; Code for processing file names with regular expressions.
;;; Copyright (c) 1994 by David Albertz (dalbertz@clark.lcs.mit.edu).
;;; Copyright (c) 1994 by Olin Shivers (shivers@clark.lcs.mit.edu).
;;; minor changes for Guile.
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; Usage: (file-match root dots? . pattern-list)
;;; root Search starts from here. Usefully "." (cwd)
;;; dots? => if true, dot files will be matched.
;;; if false, dot files will not be matched.
;;; pattern-list := a list of regular expressions or predicates
;;; Each member of the list corresponds
;;; to one or more levels in a directory.
;;; (A member with embedded "/" characters
;;; corresponds to multiple levels.)
;;; Example: ("foo" "bar" "\\.c$")
;;; means match files that end in ".c"
;;; if they reside in a directory with
;;; a name that contains "bar", which
;;; itself must reside in a directory
;;; with a name that contains "foo".
;;; If a member in the list is a predicate,
;;; the predicate must be a procedure of
;;; one argument. This procedure is applied
;;; to the file name being processed. If it
;;; returns true, then the file is considered
;;; a match.
;;; Return: list of matching file names (strings)
;;; The matcher never considers "." or "..".
;;; Subtle point:
;;; If a file-match predicate raises an error condition, it is caught by
;;; FILE-MATCH, and the file under consideration is not matched. This
;;; means that (file-match "." #f file-directory?) doesn't error out
;;; if you happen to run it in a directory containing a dangling symlink
;;; when FILE-DIRECTORY? is applied to the bogus symlink.
(define (file-match root dot-files? . patterns)
(let ((patterns (apply append (map split-pat patterns))))
(let recur ((root root)
(patterns patterns))
(if (pair? patterns)
(let* ((pattern (car patterns))
(patterns (cdr patterns))
(dir (file-name-as-directory root))
(matcher (cond ((string? pattern)
(let ((re (make-regexp pattern)))
(lambda (f) (regexp-exec re f))))
;; This arm makes a file-matcher using
;; predicate PATTERN. If PATTERN signals
;; an error condition while it is being
;; run, our matcher catches it and returns
;; #f.
((procedure? pattern)
(lambda (f)
(catch #t
(lambda ()
(pattern (string-append dir f)))
(lambda args #f))))
(else
(error "Bad file-match pattern" pattern))))
(candidates (maybe-directory-files root dot-files?))
(winners (filter matcher candidates)))
(apply append (map (lambda (fn) (recur (string-append dir fn)
patterns))
winners)))
;; All done
(cons root '())))))
;;; Split the pattern at the /'s. Slashes are assumed to *separate*
;;; subpatterns, not terminate them.
(define (split-pat pat)
(if (procedure? pat) (list pat)
(let lp ((i (string-length pat))
(ans '()))
(cond ((rindex pat #\/ i) =>
(lambda (j) (lp j (cons (substring pat (+ j 1) i) ans))))
(else
(cons (substring pat 0 i) ans))))))
guile-scsh/filesys.scm 644 521 17 7444 6560306305 13715 0 ustar guile users ;;; Ops that create objects in the file system:
;;; create-{directory,fifo,hard-link,symlink}
;;; Copyright (c) 1993 by Olin Shivers.
;;; This procedure nukes FNAME, whatever it may be: directory, file, fifo,
;;; symlink.
;;;
;;; We can't probe FNAME to find out what it is and then do the right
;;; delete operation because there's a window in-between the probe and the
;;; delete where the file system can be altered -- the probe and delete
;;; aren't atomic. In order to deliver on our contract, we have to spin
;;; in a funny loop until we win. In practice, the loop will probably never
;;; execute more than once.
(define (delete-filesys-object fname)
(let loop ()
(or (with-errno-handler ; Assume it's a file and try.
((err data)
((errno/perm) #f) ; Return #f if directory
((errno/noent) #t))
(delete-file fname)
#t)
(with-errno-handler ; Assume it's a directory and try.
((err data)
((errno/notdir) #f) ; Return #f if fname is not a directory.
((errno/noent) #t))
(delete-directory fname)
#t)
(loop)))) ; Strange things are happening. Try again.
;;; For similar reasons, all of these ops must loop.
;;; Abstract out common code for create-{directory,fifo,hard-link,symlink}:
(define (create-file-thing fname makeit override? op-name syscall)
(let ((query (lambda ()
(y-or-n? (string-append op-name ": " fname
" already exists. Delete")))))
(let loop ((override? override?))
;; MAKEIT returns #f if win, errno if lose.
(cond ((makeit fname) =>
(lambda (err)
(if (not (= err errno/exist))
(errno-error err syscall fname)
;; FNAME exists. Nuke it and retry?
(cond ((if (eq? override? 'query)
(query)
override?)
(delete-filesys-object fname)
(loop #t))
(else
(errno-error err syscall fname))))))))))
;;;;;;;
(define (create-directory dir . rest)
(let ((perms (if (null? rest) #o777 (car rest)))
(override? (if (or (null? rest) (null? (cdr rest))) #f
(cadr rest))))
(create-file-thing dir
(lambda (dir) (create-directory/errno dir perms))
override?
"create-directory"
create-directory)))
(define (create-fifo fifo . rest)
(let ((perms (if (null? rest) #o777 (car rest)))
(override? (if (or (null? rest) (null? (cdr rest))) #f
(cadr rest))))
(create-file-thing fifo
(lambda (fifo) (create-fifo/errno fifo perms))
override?
"create-fifo"
create-fifo)))
(define (create-hard-link old-fname new-fname . maybe-override?)
(create-file-thing new-fname
(lambda (new-fname)
(create-hard-link/errno old-fname new-fname))
(:optional maybe-override? #f)
"create-hard-link"
create-hard-link))
(define (create-symlink old-fname new-fname . maybe-override?)
(create-file-thing new-fname
(lambda (symlink)
(create-symlink/errno old-fname symlink))
(:optional maybe-override? #f)
"create-symlink"
create-symlink))
;;; Unix rename() works backwards from mkdir(), mkfifo(), link(), and
;;; symlink() -- it overrides by default, (though insisting on a type
;;; match between the old and new object). So we can't use create-file-thing.
;;; Note that this loop has a tiny atomicity problem -- if someone
;;; creates a file *after* we do our existence check, but *before* we
;;; do the rename, we could end up overriding it, when the user asked
;;; us not to. That's life in the food chain.
(define (rename-file old-fname new-fname . maybe-override?)
(let ((override? (:optional maybe-override? #f)))
(if (or (and override? (not (eq? override? 'query)))
(file-not-exists? new-fname)
(and override?
(y-or-n? (string-append "rename-file:" new-fname
" already exists. Delete"))))
(%rename-file old-fname new-fname))))
guile-scsh/fluid.scm 644 521 17 626 6560306305 13315 0 ustar guile users ;; implementation of scheme48 fluid variables using libguile fluids.
(if (not (defined? 'guile-make-fluid))
(define guile-make-fluid make-fluid))
(define (make-fluid value)
(let ((result (guile-make-fluid)))
(fluid-set! result value)
result))
(define set-fluid! fluid-set!)
(define fluid fluid-ref)
(define (let-fluid fluid value thunk)
(with-fluids* (list fluid) (list value) thunk))
guile-scsh/fname.scm 644 521 17 20762 6560306305 13343 0 ustar guile users ;;; Code for processing Unix file names.
;;; Copyright (c) 1992 by Olin Shivers (shivers@lcs.mit.edu).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; We adhere to Posix file name rules, plus we treat files beginning with
;;; ~ as absolute paths.
;;; Relevant bits of CScheme:
;;; pathnm sfile strnin unxcwd unxdir unxpar unxprm unxpth unxunp wrkdir
(define (file-name-directory? fname)
(or (string=? fname "") ; Note! "" is directory (cwd)
(char=? #\/ (string-ref fname (- (string-length fname) 1)))))
(define (file-name-non-directory? fname)
(or (string=? fname "") ; and file-name (root).
(not (char=? #\/ (string-ref fname (- (string-length fname) 1))))))
(define (file-name-as-directory fname)
(if (string=? fname ".") ""
(let ((len (string-length fname)))
(if (and (> len 0)
(char=? #\/ (string-ref fname (- len 1))))
fname
(string-append fname "/")))))
;;; Return #f if str doesn't contain a slash at all.
(define (last-non-slash str)
(let lp ((i (- (string-length str) 1)))
(and (>= i 0)
(if (char=? #\/ (string-ref str i))
(lp (- i 1))
i))))
(define (directory-as-file-name fname)
(let ((len (string-length fname)))
(if (zero? len) "." ; "" -> "."
;; Trim trailing slashes.
(cond ((last-non-slash fname) =>
(lambda (i)
(if (= i (- len 1)) fname ; No slash.
(substring fname 0 (+ i 1))))) ; Trim slashes.
;;; Solid slashes -- invoke weird Posix rule.
(else (if (= len 2) "//" "/"))))))
(define (ensure-file-name-is-directory fname)
(if (string=? fname "") ""
(file-name-as-directory fname)))
(define (ensure-file-name-is-nondirectory fname)
(if (string=? fname "") ""
(directory-as-file-name fname)))
(define (file-name-absolute? fname)
(or (= (string-length fname) 0)
(char=? #\/ (string-ref fname 0))
(char=? #\~ (string-ref fname 0))))
;;; Returns FNAME's directory component in *directory form.*
(define (file-name-directory fname)
(cond ((rindex fname #\/) =>
(lambda (rslash)
(if (last-non-slash fname)
(substring fname 0 (+ 1 rslash))
""))) ; Posix strangeness: solid slashes are root.
(else "")))
(define (file-name-nondirectory fname)
(cond ((rindex fname #\/) =>
(lambda (rslash)
(if (last-non-slash fname)
(substring fname (+ 1 rslash) (string-length fname))
fname))) ; Posix strangeness: solid slashes are root.
(else fname)))
(define (split-file-name fname)
(let* ((fname (ensure-file-name-is-nondirectory fname))
(len (string-length fname)))
(let split ((start 0))
(cond ((>= start len) '())
((index fname #\/ start) =>
(lambda (slash)
(cons (substring fname start slash)
(split (+ slash 1)))))
(else (list (substring fname start len)))))))
(define (path-list->file-name pathlist . maybe-dir)
(let ((root (ensure-file-name-is-nondirectory (:optional maybe-dir ".")))
;; Insert slashes *between* elts of PATHLIST.
(w/slashes (if (pair? pathlist)
(let insert-slashes ((pathlist pathlist))
(let ((elt (car pathlist))
(pathlist (cdr pathlist)))
(cons elt (if (pair? pathlist)
(cons "/" (insert-slashes pathlist))
'()))))
'(""))))
(apply string-append
(if (and (pair? pathlist)
(string=? "" (car pathlist)))
w/slashes ; Absolute path not relocated.
(cons (file-name-as-directory root) w/slashes)))))
(define (parse-file-name fname)
(let ((nd (file-name-nondirectory fname)))
(values (file-name-directory fname)
(file-name-sans-extension nd)
(file-name-extension nd))))
;;; Return the index of the . separating the extension from the rest of
;;; the file name. If no extension, returns an index pointing off the
;;; end of the string, i.e. (string-length fname). "Dot-files," such as
;;; /usr/shivers/.login are not considered extensions.
(define (file-name-extension-index fname)
(let ((dot (rindex fname #\.)))
(if (and dot
(> dot 0)
(not (char=? #\/ (string-ref fname (- dot 1)))))
dot
(string-length fname))))
(define (file-name-sans-extension fname)
(substring fname 0 (file-name-extension-index fname)))
(define (file-name-extension fname)
(substring fname (file-name-extension-index fname)
(string-length fname)))
(define (replace-extension fname ext)
(string-append (file-name-sans-extension fname) ext))
(define (resolve-tilde-file-name fname)
(let ((len (string-length fname)))
(if (and (> len 0) (char=? #\~ (string-ref fname 0)))
(let ((tilde->homedir (lambda (end)
(if (= end 1) home-directory ; Just ~
(let* ((user (substring fname 1 end))
(ui (name->user-info user)))
(user-info:home-dir ui))))))
(cond ((index fname #\/ 1) =>
(lambda (slash)
(string-append (tilde->homedir slash) "/"
(substring fname (+ slash 1) len))))
(else (tilde->homedir len))))
fname)))
(define (resolve-file-name fname . maybe-root)
(let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root ".")))
(fname (ensure-file-name-is-nondirectory fname))
(len (string-length fname)))
(if (zero? len) "/"
(let ((c (string-ref fname 0)))
(cond ((char=? #\/ c) fname) ; Absolute file name.
((char=? #\~ c) ; ~ file name
(resolve-tilde-file-name fname))
(else (string-append (file-name-as-directory root) fname)))))))
;;; - Remove leading and internal occurrences of dot. A trailing dot
;;; is left alone, in case the parent is a symlink.
;;; - Remove internal and trailing double-slashes. A leading double-slash
;;; is left alone, in accordance w/Posix. However, triple and more leading
;;; slashes are reduced to a single slash, in accordance w/Posix.
;;; - Double-dots are left alone, in case they come after symlinks.
(define (simplify-file-name fname)
;; First, we simplify leading multiple slashes:
;; 1 or >2 slashes -> /, 2 slashes -> //
(receive (slashes fname)
(let ((len (string-length fname)))
(if (and (> len 0) (char=? #\/ (string-ref fname 0)))
(let ((j (let lp ((i 1)) ; j is index of first non-slash.
(if (and (< i len)
(char=? (string-ref fname i) #\/))
(lp (+ i 1))
i))))
(if (< j 3)
(values (substring fname 0 j); One or two slashes - OK.
(substring fname j len))
(values "/" (substring fname (- j 1) len))))
(values "" fname)))
;; At this point, all leading slashes have been pulled off of FNAME.
;; Any remaining repeated slashes are fair game for removal.
(let* ((path-list (split-file-name fname))
(ans (if (pair? path-list)
(reverse (let lp ((path-list path-list)
(ans (list slashes)))
(let ((elt (car path-list))
(path-list (cdr path-list)))
(if (pair? path-list)
(lp path-list
(if (or (string=? "." elt) ; kill .
(string=? "" elt)) ; and //
ans
`("/" ,elt ,@ans)))
(cons elt ans)))))
(list slashes))))
(apply string-append ans))))
(define (expand-file-name fname . maybe-dir)
(simplify-file-name (apply resolve-file-name fname maybe-dir)))
(define (home-dir . maybe-user)
(if (pair? maybe-user)
(let ((user (car maybe-user)))
(ensure-file-name-is-nondirectory
(or (%homedir user)
(error "Cannot get user's home directory"
user))))
home-directory))
;;; (home-file [user] fname)
(define (home-file arg1 . maybe-arg2)
(receive (dir fname)
(if (pair? maybe-arg2)
(values (home-dir arg1) (car maybe-arg2))
(values home-directory arg1))
(string-append (file-name-as-directory dir) fname)))
;;; Ugh.
(define (substitute-env-vars str)
(let lp ((ans '()) (s str))
(let ((len (string-length s)))
(cond
((zero? len) (apply string-append (reverse! ans)))
((index s #\$) =>
(lambda (i)
(let ((ans (cons (substring s 0 i) ans))
(s (substring s (+ i 1) len))
(len (- len (+ i 1))))
(if (zero? len) (lp ans "")
(let ((next-char (string-ref s 0)))
(cond ((char=? #\{ next-char)
(cond ((index s #\}) =>
(lambda (i)
(lp (cons (getenv (substring s 1 i)) ans)
(substring s (+ i 1) len))))
(else (error "Unbalanced ${ delimiter in string" s))))
(else
(let ((i (or (index s #\/) len)))
(lp (cons (getenv (substring s 0 i)) ans)
(substring s i len))))))))))
(else (lp (cons s ans) ""))))))
guile-scsh/fr.scm 644 521 17 37271 6560306306 12670 0 ustar guile users ;;; Field and record parsing utilities for scsh.
;;; Copyright (c) 1994 by Olin Shivers.
;;; Notes:
;;; - Comment on the dependencies here...
;;; - Awk should deal with case-insensitivity.
;;; - Should I change the field-splitters to return lists? It's the
;;; right thing, and costs nothing in terms of efficiency.
;;; Looping primitives:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; It is nicer for loops that loop over a bunch of different things
;;; if you can encapsulate the idea of iterating over a data structure
;;; with a
;;; (next-element state) -> elt next-state
;;; (more-elements? state) -? #t/#f
;;; generator/termination-test pair. You can use the generator with REDUCE
;;; to make a list; you can stick it into a loop macro to loop over the
;;; elements. For example, if we had an extensible Yale-loop style loop macro,
;;; we could have a loop clause like
;;;
;;; (loop (for field in-infix-delimited-string ":" path)
;;; (do (display field) (newline)))
;;;
;;; and it would be simple to expand this into code using the generator.
;;; With procedural inlining, you can get pretty optimal loops over data
;;; structures this way.
;;;
;;; As of now, you are forced to parse fields into a buffer, and loop
;;; over that. This is inefficient of time and space. If I ever manage to do
;;; an extensible loop macro for Scheme 48, I'll have to come back to this
;;; package and rethink how to provide this functionality.
;;; Forward-progress guarantees and empty string matches.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A loop that pulls text off a string by matching a regexp against
;;; that string can conceivably get stuck in an infinite loop if the
;;; regexp matches the empty string. For example, the regexps
;;; ^, $, .*, foo|[^f]* can all match the empty string.
;;;
;;; The regexp-loop routines in this code are careful to handle this case.
;;; If a regexp matches the empty string, the next search starts, not from
;;; the end of the match (which in the empty string case is also the
;;; beginning -- there's the rub), but from the next character over.
;;; This is the correct behaviour. Regexps match the longest possible
;;; string at a given location, so if the regexp matched the empty string
;;; at location i, then it is guaranteed they could not have matched
;;; a longer pattern starting with character #i. So we can safely begin
;;; our search for the next match at char i+1.
;;;
;;; So every iteration through the loop makes some forward progress,
;;; and the loop is guaranteed to terminate.
;;;
;;; This has the effect you want with field parsing. For example, if you split
;;; a string with the empty pattern, you will explode the string into its
;;; individual characters:
;;; ((suffix-splitter "") "foo") -> #("" "f" "o" "o")
;;; However, even though this boundary case is handled correctly, we don't
;;; recommend using it. Say what you mean -- just use a field splitter:
;;; ((field-splitter ".") "foo") -> #("f" "o" "o")
;;; (join-strings string-list [delimiter grammar]) => string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Paste strings together using the delimiter string.
;;;
;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
;;;
;;; DELIMITER defaults to a single space " "
;;; GRAMMAR is one of the symbols {infix, suffix} and defaults to 'infix.
;;; (join-strings strings [delim grammar])
(define (join-strings strings . args)
(if (pair? strings)
(let-optionals args ((delim " ") (grammar 'infix))
(check-arg string? delim join-strings)
(let ((strings (reverse strings)))
(let lp ((strings (cdr strings))
(ans (case grammar
((infix) (list (car strings)))
((suffix) (list (car strings) delim))
(else (error "Illegal grammar" grammar)))))
(if (pair? strings)
(lp (cdr strings)
(cons (car strings) (cons delim ans)))
; All done
(apply string-append ans)))))
"")) ; Special-cased for infix grammar.
;;; FIELD PARSERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This section defines routines to split a string into fields.
;;; You can parse by specifying a pattern that *separates* fields,
;;; a pattern that *terminates* fields, or a pattern that *matches*
;;; fields.
(define (->delim-matcher x)
(if (procedure? x) x ; matcher proc
(let ((re (cond ((regexp? x) x) ; regexp pattern
((string? x) (make-regexp x)) ; regexp string
(else (error "Illegal pattern/parser" x)))))
;; The matcher proc.
(lambda (s i)
(cond ((regexp-exec re s i) =>
(lambda (m) (values (match:start m 0) (match:end m 0))))
(else (values #f #f)))))))
;;; (infix-splitter [re num-fields handle-delim]) -> parser
;;; (suffix-splitter [re num-fields handle-delim]) -> parser
;;; (sloppy-suffix-splitter [re num-fields handle-delim]) -> parser
;;; (field-splitter [re num-fields]) -> parser
;;;
;;; (parser string [start]) -> string-list
(define (make-field-parser-generator default-delim-matcher loop-proc)
;; This is the parser-generator
(lambda args
(let-optionals args ((delim-spec default-delim-matcher)
(num-fields #f)
(handle-delim 'trim))
;; Process and error-check the args
(let ((match-delim (->delim-matcher delim-spec))
(cons-field (case handle-delim ; Field is s[i,j).
((trim) ; Delimiter is s[j,k).
(lambda (s i j k fields)
(cons (substring s i j) fields)))
((split)
(lambda (s i j k fields)
(cons (substring s j k)
(cons (substring s i j) fields))))
((concat)
(lambda (s i j k fields)
(cons (substring s i k)
fields)))
(else
(error "Illegal handle-delim spec"
handle-delim)))))
(receive (num-fields nfields-exact?)
(cond ((not num-fields) (values #f #f))
((not (integer? num-fields))
(error "Illegal NUM-FIELDS value" num-fields))
((<= num-fields 0) (values (- num-fields) #f))
(else (values num-fields #t)))
;; This is the parser.
(lambda (s . maybe-start)
(reverse (loop-proc s (:optional maybe-start 0)
match-delim cons-field
num-fields nfields-exact?))))))))
(define default-field-matcher (->delim-matcher "[^ \t\n]+"))
;;; (field-splitter [field-spec num-fields])
(define (field-splitter . args)
(let-optionals args ((field-spec default-field-matcher)
(num-fields #f))
;; Process and error-check the args
(let ((match-field (->delim-matcher field-spec)))
(receive (num-fields nfields-exact?)
(cond ((not num-fields) (values #f #f))
((not (integer? num-fields))
(error "Illegal NUM-FIELDS value"
field-splitter num-fields))
((<= num-fields 0) (values (- num-fields) #f))
(else (values num-fields #t)))
;; This is the parser procedure.
(lambda (s . maybe-start)
(reverse (fieldspec-field-loop s (:optional maybe-start 0)
match-field num-fields nfields-exact?)))))))
;;; These four procedures implement the guts of each parser
;;; (field, infix, suffix, and sloppy-suffix).
;;;
;;; The CONS-FIELD argument is a procedure that parameterises the
;;; HANDLE-DELIM action for the field parser.
;;;
;;; The MATCH-DELIM argument is used to match a delimiter.
;;; (MATCH-DELIM S I) returns two integers [start, end] marking
;;; the next delimiter after index I in string S. If no delimiter is
;;; found, it returns [#f #f].
;;; In the main loop of each parser, the loop variable LAST-NULL? tells if the
;;; previous delimiter-match matched the empty string. If it did, we start our
;;; next delimiter search one character to the right of the match, so we won't
;;; loop forever. This means that an empty delimiter regexp "" simply splits
;;; the string at each character, which is the correct thing to do.
;;;
;;; These routines return the answer as a reversed list.
(define (fieldspec-field-loop s start match-field num-fields nfields-exact?)
(let ((end (string-length s)))
(let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
(let ((j (if last-null? (+ i 1) i)) ; Where to start next delim search.
;; Check to see if we made our quota before returning answer.
(finish-up (lambda ()
(if (and num-fields (< nfields num-fields))
(error "Too few fields in record." num-fields s)
fields))))
(cond ((> j end) (finish-up)) ; We are done. Finish up.
;; Read too many fields. Bomb out.
((and nfields-exact? (> nfields num-fields))
(error "Too many fields in record." num-fields s))
;; Made our lower-bound quota. Quit early.
((and num-fields (= nfields num-fields) (not nfields-exact?))
(if (= i end) fields ; Special case hackery.
(cons (substring s i end) fields)))
;; Match off another field & loop.
(else (receive (m0 m1) (match-field s j)
(if m0 (lp m1 (+ nfields 1)
(cons (substring s m0 m1) fields)
(= m0 m1))
(finish-up))))))))) ; No more matches. Finish up.
(define (infix-field-loop s start match-delim cons-field
num-fields nfields-exact?)
(let ((end (string-length s)))
(if (= start end) '() ; Specially hack empty string.
(let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
(let ((finish-up (lambda ()
;; s[i,end) is the last field. Terminate the loop.
(cond ((and num-fields (< (+ nfields 1) num-fields))
(error "Too few fields in record."
num-fields s))
((and nfields-exact?
(>= nfields num-fields))
(error "Too many fields in record."
num-fields s))
(else
(cons (substring s i end) fields)))))
(j (if last-null? (+ i 1) i))) ; Where to start next search.
(cond
;; If we've read NUM-FIELDS fields, quit early .
((and num-fields (= nfields num-fields))
(if nfields-exact?
(error "Too many fields in record." num-fields s)
(cons (substring s i end) fields)))
((<= j end) ; Match off another field.
(receive (m0 m1) (match-delim s j)
(if m0
(lp m1 (+ nfields 1)
(cons-field s i m0 m1 fields)
(= m0 m1))
(finish-up)))) ; No more delimiters - finish up.
;; We've run off the end of the string. This is a weird
;; boundary case occuring with empty-string delimiters.
(else (finish-up))))))))
;;; Match off an optional initial delimiter,
;;; then jump off to the suffix parser.
(define (sloppy-suffix-field-loop s start match-delim cons-field
num-fields nfields-exact?)
;; If sloppy-suffix, skip an initial delimiter if it's there.
(let ((start (receive (i j) (match-delim s start)
(if (and i (zero? i)) j start))))
(suffix-field-loop s start match-delim cons-field
num-fields nfields-exact?)))
(define (suffix-field-loop s start match-delim cons-field
num-fields nfields-exact?)
(let ((end (string-length s)))
(let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
(let ((j (if last-null? (+ i 1) i))) ; Where to start next delim search.
(cond ((= i end) ; We are done.
(if (and num-fields (< nfields num-fields)) ; Didn't make quota.
(error "Too few fields in record." num-fields s)
fields))
;; Read too many fields. Bomb out.
((and nfields-exact? (= nfields num-fields))
(error "Too many fields in record." num-fields s))
;; Made our lower-bound quota. Quit early.
((and num-fields (= nfields num-fields) (not nfields-exact?))
(cons (substring s i end) fields))
(else ; Match off another field.
(receive (m0 m1) (match-delim s j)
(if m0 (lp m1 (+ nfields 1)
(cons-field s i m0 m1 fields)
(= m0 m1))
(error "Missing field terminator" s)))))))))
;;; Now, build the exported procedures: {infix,suffix,sloppy-suffix}-splitter.
(define default-suffix-matcher (->delim-matcher "[ \t\n]+|$"))
(define default-infix-matcher (->delim-matcher "[ \t\n]+"))
(define infix-splitter
(make-field-parser-generator default-infix-matcher infix-field-loop))
(define suffix-splitter
(make-field-parser-generator default-suffix-matcher suffix-field-loop))
(define sloppy-suffix-splitter
(make-field-parser-generator default-suffix-matcher sloppy-suffix-field-loop))
;;; Reading records
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define default-record-delims (char-set #\newline))
;;; (record-reader [delims elide? handle-delim]) -> reader
;;; (reader [port]) -> string or eof
(define (record-reader . args)
(let-optionals args ((delims default-record-delims)
(elide? #f)
(handle-delim 'trim))
(let ((delims (->char-set delims)))
(case handle-delim
((trim) ; TRIM-delimiter reader.
(lambda maybe-port
(let ((s (apply read-delimited delims maybe-port)))
(if (and (not (eof-object? s)) elide?)
(apply skip-char-set delims maybe-port)) ; Snarf extra delims.
s)))
((concat) ; CONCAT-delimiter reader.
(let ((not-delims (char-set-invert delims)))
(lambda maybe-port
(let* ((p (:optional maybe-port (current-input-port)))
(s (read-delimited delims p 'concat)))
(if (or (not elide?) (eof-object? s)) s
(let ((extra-delims (read-delimited not-delims p 'peek)))
(if (eof-object? extra-delims) s
(string-append s extra-delims))))))))
((split) ; SPLIT-delimiter reader.
(let ((not-delims (char-set-invert delims)))
(lambda maybe-port
(let ((p (:optional maybe-port (current-input-port))))
(receive (s delim) (read-delimited delims p 'split)
(if (eof-object? s) (values s s)
(values s
(if (or (not elide?) (eof-object? delim))
delim
;; Elide: slurp in extra delims.
(let ((delim (string delim))
(extras (read-delimited not-delims
p 'peek)))
(if (eof-object? extras) delim
(string-append delim extras)))))))))))
(else
(error "Illegal delimiter-action" handle-delim))))))
;;; Reading and parsing records
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (field-reader [field-parser rec-reader]) -> reader
;;; (reader [port]) -> [raw-record parsed-record] or [eof #()]
;;;
;;; This is the field reader, which is basically just a composition of
;;; RECORD-READER and FIELD-PARSER.
(define default-field-parser (field-splitter))
(define (field-reader . args)
(let-optionals args ((parser default-field-parser)
(rec-reader read-line))
(lambda maybe-port
(let ((record (apply rec-reader maybe-port)))
(if (eof-object? record)
(values record '#())
(values record (parser record)))))))
;;; Parse fields by regexp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code parses up a record into fields by matching a regexp specifying
;;; the field against the record. The regexp describes the *field*. In the
;;; other routines, the regexp describes the *delimiters*. They are
;;; complimentary.
;;; Repeatedly do (APPLY PROC M STATE) to generate new state values,
;;; where M is a regexp match structure made from matching against STRING.
;(define (regexp-reduce string start regexp proc . state)
; (let ((end (string-length string))
; (regexp (if (string? regexp)
; (make-regexp regexp)
; regexp)))
;
; (let lp ((i start) (state state) (last-null? #f))
; (let ((j (if last-null? (+ i 1) i)))
; (cond ((and (<= j end) (regexp-exec regexp string j)) =>
; (lambda (m)
; (receive state (apply proc m state)
; (lp (match:end m) state (= (match:start m) (match:end m))))))
; (else (apply values state)))))))
;
;(define (all-regexp-matches regexp string)
; (reverse (regexp-reduce string 0 regexp
; (lambda (m ans) (cons (match:substring m 0) ans))
; '())))
guile-scsh/glob.scm 644 521 17 21661 6560306306 13200 0 ustar guile users ;;; Code for processing file names with a glob pattern.
;;; Copyright (c) 1994 by David Albertz (dalbertz@clark.lcs.mit.edu).
;;; Copyright (c) 1994 by Olin Shivers (shivers@clark.lcs.mit.edu).
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; Usage: (glob pattern-list)
;;; pattern-list := a list of glob-pattern strings
;;; Return: list of file names (strings)
;;; The files "." and ".." are never returned by glob.
;;; Dot files will only be returned if the first character
;;; of a glob pattern is a ".".
;;; The empty pattern matches nothing.
;;; A pattern beginning with / starts at root; otherwise, we start at cwd.
;;; A pattern ending with / matches only directories, e.g., "/usr/man/man?/"
(define (glob . pattern-list)
;; Expand out braces, and apply GLOB-ONE-PATTERN to all the result patterns.
(apply append
(map glob-one-pattern
(apply append (map glob-remove-braces pattern-list)))))
(define (glob-one-pattern pattern)
(let ((plen (string-length pattern)))
(if (zero? plen) '()
(let ((directories-only? (char=? #\/ (string-ref pattern (- plen 1))))
(patterns (split-file-name pattern))) ; Must be non-null.
(if (equal? "" (car patterns))
(really-glob "" (cdr patterns) directories-only?) ; root
(really-glob "." patterns directories-only?)))))) ; cwd
(define (really-glob root-file patterns directories-only?)
;; This is the heart of the matcher.
(let recur ((file root-file)
(pats patterns)
(sure? #f)) ; True if we are sure this file exists.
(if (pair? pats)
(let ((pat (car pats))
(pats (cdr pats))
(dir (file-name-as-directory file)))
(receive (winners sure?) (glob-subpat file pat)
(apply append (map (lambda (f)
(recur (string-append dir f) pats sure?))
winners))))
;; All done.
(if directories-only?
(if (maybe-isdir? file)
(list (file-name-as-directory file))
'())
(if (or sure? (file-exists? file))
(list file)
'())))))
;;; Return the elts of directory FNAME that match pattern PAT.
;;; If PAT contains no wildcards, we cheat and do not match the
;;; constant pattern against every file in FNAME/; we just
;;; immediately return FNAME/PAT. In this case, we indicate that we
;;; aren't actually sure the file exists by returning a true SURE?
;;; value. Not only does this vastly speed up the matcher, it also
;;; allows us to match the constant patterns "." and "..".
(define (glob-subpat fname pat) ; PAT doesn't contain a slash.
(cond ((string=? pat "")
